mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 06:20:23 +02:00
Code Activity

Support => within case, and improve error messages for cond and case

Browse source 
* module/ice-9/boot-9.scm (cond, case): Reimplement using syntax-case,
  with improved error messages and support for '=>' within 'case' as
  mandated by the R7RS.  Add warnings for duplicate case datums and
  case datums that cannot be meaningfully compared using 'eqv?'.

* module/system/base/message.scm (%warning-types): Add 'bad-case-datum'
  and 'duplicate-case-datum' warning types.

* test-suite/tests/syntax.test (cond, case): Update tests to reflect
  improved error reporting.  Add tests for '=>' within 'case'.

* test-suite/tests/tree-il.test (partial evaluation): Update tests to
  reflect changes in how 'case' is expanded.

* doc/ref/api-control.texi (Conditionals): Document '=>' within 'case'.
This commit is contained in:
Mark H Weaver 2012-02-07 19:40:29 -05:00
parent b131b233ff
commit e7cf0457d7
5 changed files with 234 additions and 84 deletions
Download patch file Download diff file Expand all files Collapse all files

19
doc/ref/api-control.texi
View file

@ -212,18 +212,30 @@ result of the @code{cond}-expression.
@end deffn
@deffn syntax case key clause1 clause2 @dots{}
@var{key} may be any expression, the @var{clause}s must have the form
@var{key} may be any expression, and the @var{clause}s must have the form
@lisp
((@var{datum1} @dots{}) @var{expr1} @var{expr2} @dots{})
@end lisp
or
@lisp
((@var{datum1} @dots{}) => @var{expression})
@end lisp
and the last @var{clause} may have the form
@lisp
(else @var{expr1} @var{expr2} @dots{})
@end lisp
or
@lisp
(else => @var{expression})
@end lisp
All @var{datum}s must be distinct. First, @var{key} is evaluated. The
result of this evaluation is compared against all @var{datum} values using
@code{eqv?}. When this comparison succeeds, the expression(s) following
@ -234,6 +246,11 @@ If the @var{key} matches no @var{datum} and there is an
@code{else}-clause, the expressions following the @code{else} are
evaluated. If there is no such clause, the result of the expression is
unspecified.
For the @code{=>} clause types, @var{expression} is evaluated and the
resulting procedure is applied to the value of @var{key}. The result of
this procedure application is then the result of the
@code{case}-expression.
@end deffn

192
module/ice-9/boot-9.scm
View file

@ -411,70 +411,150 @@ If there is no handler at all, Guile prints an error and then exits."
((_ x) x)
((_ x y ...) (let ((t x)) (if t t (or y ...))))))
(include-from-path "ice-9/quasisyntax")
(define-syntax-rule (when test stmt stmt* ...)
(if test (begin stmt stmt* ...)))
(define-syntax-rule (unless test stmt stmt* ...)
(if (not test) (begin stmt stmt* ...)))
;; The "maybe-more" bits are something of a hack, so that we can support
;; SRFI-61. Rewrites into a standalone syntax-case macro would be
;; appreciated.
(define-syntax cond
(syntax-rules (=> else)
((_ "maybe-more" test consequent)
(if test consequent))
((_ "maybe-more" test consequent clause ...)
(if test consequent (cond clause ...)))
((_ (else else1 else2 ...))
(begin else1 else2 ...))
((_ (test => receiver) more-clause ...)
(let ((t test))
(cond "maybe-more" t (receiver t) more-clause ...)))
((_ (generator guard => receiver) more-clause ...)
(call-with-values (lambda () generator)
(lambda t
(cond "maybe-more"
(apply guard t) (apply receiver t) more-clause ...))))
((_ (test => receiver ...) more-clause ...)
(syntax-violation 'cond "wrong number of receiver expressions"
'(test => receiver ...)))
((_ (generator guard => receiver ...) more-clause ...)
(syntax-violation 'cond "wrong number of receiver expressions"
'(generator guard => receiver ...)))
((_ (test) more-clause ...)
(let ((t test))
(cond "maybe-more" t t more-clause ...)))
((_ (test body1 body2 ...) more-clause ...)
(cond "maybe-more"
test (begin body1 body2 ...) more-clause ...))))
(lambda (whole-expr)
(define (fold f seed xs)
(let loop ((xs xs) (seed seed))
(if (null? xs) seed
(loop (cdr xs) (f (car xs) seed)))))
(define (reverse-map f xs)
(fold (lambda (x seed) (cons (f x) seed))
'() xs))
(syntax-case whole-expr ()
((_ clause clauses ...)
#`(begin
#,@(fold (lambda (clause-builder tail)
(clause-builder tail))
#'()
(reverse-map
(lambda (clause)
(define* (bad-clause #:optional (msg "invalid clause"))
(syntax-violation 'cond msg whole-expr clause))
(syntax-case clause (=> else)
((else e e* ...)
(lambda (tail)
(if (null? tail)
#'((begin e e* ...))
(bad-clause "else must be the last clause"))))
((else . _) (bad-clause))
((test => receiver)
(lambda (tail)
#`((let ((t test))
(if t
(receiver t)
#,@tail)))))
((test => receiver ...)
(bad-clause "wrong number of receiver expressions"))
((generator guard => receiver)
(lambda (tail)
#`((call-with-values (lambda () generator)
(lambda vals
(if (apply guard vals)
(apply receiver vals)
#,@tail))))))
((generator guard => receiver ...)
(bad-clause "wrong number of receiver expressions"))
((test)
(lambda (tail)
#`((let ((t test))
(if t t #,@tail)))))
((test e e* ...)
(lambda (tail)
#`((if test
(begin e e* ...)
#,@tail))))
(_ (bad-clause))))
#'(clause clauses ...))))))))
(define-syntax case
(syntax-rules (else)
((case (key ...)
clauses ...)
(let ((atom-key (key ...)))
(case atom-key clauses ...)))
((case key
(else result1 result2 ...))
(begin result1 result2 ...))
((case key
((atoms ...) result1 result2 ...))
(if (memv key '(atoms ...))
(begin result1 result2 ...)))
((case key
((atoms ...) result1 result2 ...)
clause clauses ...)
(if (memv key '(atoms ...))
(begin result1 result2 ...)
(case key clause clauses ...)))))
(lambda (whole-expr)
(define (fold f seed xs)
(let loop ((xs xs) (seed seed))
(if (null? xs) seed
(loop (cdr xs) (f (car xs) seed)))))
(define (fold2 f a b xs)
(let loop ((xs xs) (a a) (b b))
(if (null? xs) (values a b)
(call-with-values
(lambda () (f (car xs) a b))
(lambda (a b)
(loop (cdr xs) a b))))))
(define (reverse-map-with-seed f seed xs)
(fold2 (lambda (x ys seed)
(call-with-values
(lambda () (f x seed))
(lambda (y seed)
(values (cons y ys) seed))))
'() seed xs))
(syntax-case whole-expr ()
((_ expr clause clauses ...)
(with-syntax ((key #'key))
#`(let ((key expr))
#,@(fold
(lambda (clause-builder tail)
(clause-builder tail))
#'()
(reverse-map-with-seed
(lambda (clause seen)
(define* (bad-clause #:optional (msg "invalid clause"))
(syntax-violation 'case msg whole-expr clause))
(syntax-case clause ()
((test . rest)
(with-syntax
((clause-expr
(syntax-case #'rest (=>)
((=> receiver) #'(receiver key))
((=> receiver ...)
(bad-clause
"wrong number of receiver expressions"))
((e e* ...) #'(begin e e* ...))
(_ (bad-clause)))))
(syntax-case #'test (else)
((datums ...)
(let ((seen
(fold
(lambda (datum seen)
(define (warn-datum type)
((@ (system base message)
warning)
type
(append (source-properties datum)
(source-properties
(syntax->datum #'test)))
datum
(syntax->datum clause)
(syntax->datum whole-expr)))
(if (memv datum seen)
(warn-datum 'duplicate-case-datum))
(if (or (pair? datum)
(array? datum)
(generalized-vector? datum))
(warn-datum 'bad-case-datum))
(cons datum seen))
seen
(map syntax->datum #'(datums ...)))))
(values (lambda (tail)
#`((if (memv key '(datums ...))
clause-expr
#,@tail)))
seen)))
(else (values (lambda (tail)
(if (null? tail)
#'(clause-expr)
(bad-clause
"else must be the last clause")))
seen))
(_ (bad-clause)))))
(_ (bad-clause))))
'() #'(clause clauses ...)))))))))
(define-syntax do
(syntax-rules ()
@ -502,8 +582,6 @@ If there is no handler at all, Guile prints an error and then exits."
(define-syntax-rule (delay exp)
(make-promise (lambda () exp)))
(include-from-path "ice-9/quasisyntax")
(define-syntax current-source-location
(lambda (x)
(syntax-case x ()

14
module/system/base/message.scm
View file

@ -126,6 +126,20 @@
"~A: warning: possibly wrong number of arguments to `~A'~%"
loc name))))
(duplicate-case-datum
"report a duplicate datum in a case expression"
,(lambda (port loc datum clause case-expr)
(emit port
"~A: warning: duplicate datum ~S in clause ~S of case expression ~S~%"
loc datum clause case-expr)))
(bad-case-datum
"report a case datum that cannot be meaningfully compared using `eqv?'"
,(lambda (port loc datum clause case-expr)
(emit port
"~A: warning: datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%"
loc datum clause case-expr)))
(format
"report wrong number of arguments to `format'"
,(lambda (port loc . rest)

77
test-suite/tests/syntax.test
View file

@ -648,11 +648,13 @@
(pass-if-syntax-error "missing recipient"
'(cond . "wrong number of receiver expressions")
(cond (#t identity =>)))
(eval '(cond (#t identity =>))
(interaction-environment)))
(pass-if-syntax-error "extra recipient"
'(cond . "wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(eval '(cond (#t identity => identity identity))
(interaction-environment))))
(with-test-prefix "bad or missing clauses"
@ -662,43 +664,48 @@
(interaction-environment)))
(pass-if-syntax-error "(cond #t)"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond #t)
(interaction-environment)))
(pass-if-syntax-error "(cond 1)"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond 1)
(interaction-environment)))
(pass-if-syntax-error "(cond 1 2)"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond 1 2)
(interaction-environment)))
(pass-if-syntax-error "(cond 1 2 3)"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond 1 2 3)
(interaction-environment)))
(pass-if-syntax-error "(cond 1 2 3 4)"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond 1 2 3 4)
(interaction-environment)))
(pass-if-syntax-error "(cond ())"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond ())
(interaction-environment)))
(pass-if-syntax-error "(cond () 1)"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond () 1)
(interaction-environment)))
(pass-if-syntax-error "(cond (1) 1)"
exception:generic-syncase-error
'(cond . "invalid clause")
(eval '(cond (1) 1)
(interaction-environment)))
(pass-if-syntax-error "(cond (else #f) (#t #t))"
'(cond . "else must be the last clause")
(eval '(cond (else #f) (#t #t))
(interaction-environment))))
(with-test-prefix "wrong number of arguments"
@ -712,10 +719,46 @@
(pass-if "clause with empty labels list"
(case 1 (() #f) (else #t)))
(with-test-prefix "case handles '=> correctly"
(pass-if "(1 2 3) => list"
(equal? (case 1 ((1 2 3) => list))
'(1)))
(pass-if "else => list"
(equal? (case 6
((1 2 3) 'wrong)
(else => list))
'(6)))
(with-test-prefix "bound '=> is handled correctly"
(pass-if "(1) => 'ok"
(let ((=> 'foo))
(eq? (case 1 ((1) => 'ok)) 'ok)))
(pass-if "else =>"
(let ((=> 'foo))
(eq? (case 1 (else =>)) 'foo)))
(pass-if "else => list"
(let ((=> 'foo))
(eq? (case 1 (else => identity)) identity))))
(pass-if-syntax-error "missing recipient"
'(case . "wrong number of receiver expressions")
(eval '(case 1 ((1) =>))
(interaction-environment)))
(pass-if-syntax-error "extra recipient"
'(case . "wrong number of receiver expressions")
(eval '(case 1 ((1) => identity identity))
(interaction-environment))))
(with-test-prefix "case is hygienic"
(pass-if-syntax-error "bound 'else is handled correctly"
exception:generic-syncase-error
'(case . "invalid clause")
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
@ -742,22 +785,22 @@
(interaction-environment)))
(pass-if-syntax-error "(case 1 \"foo\")"
exception:generic-syncase-error
'(case . "invalid clause")
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-syntax-error "(case 1 ())"
exception:generic-syncase-error
'(case . "invalid clause")
(eval '(case 1 ())
(interaction-environment)))
(pass-if-syntax-error "(case 1 (\"foo\"))"
exception:generic-syncase-error
'(case . "invalid clause")
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
exception:generic-syncase-error
'(case . "invalid clause")
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
@ -767,7 +810,7 @@
(interaction-environment)))
(pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
exception:generic-syncase-error
'(case . "invalid clause")
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
@ -777,7 +820,7 @@
(interaction-environment)))
(pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
exception:generic-syncase-error
'(case . "else must be the last clause")
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))

16
test-suite/tests/tree-il.test
View file

@ -1156,14 +1156,14 @@
(case foo
((3 2 1) 'a)
(else 'b))
(if (let (t) (_) ((toplevel foo))
(if (apply (primitive eqv?) (lexical t _) (const 3))
(let (key) (_) ((toplevel foo))
(if (if (apply (primitive eqv?) (lexical key _) (const 3))
(const #t)
(if (apply (primitive eqv?) (lexical t _) (const 2))
(if (apply (primitive eqv?) (lexical key _) (const 2))
(const #t)
(apply (primitive eqv?) (lexical t _) (const 1)))))
(const a)
(const b)))
(apply (primitive eqv?) (lexical key _) (const 1))))
(const a)
(const b))))
(pass-if-peval
;; Memv with non-constant key, empty list, test context. Currently
@ -1171,9 +1171,7 @@
(case foo
(() 'a)
(else 'b))
(if (begin (toplevel foo) (const #f))
(const a)
(const b)))
(begin (toplevel foo) (const b)))
;;
;; Below are cases where constant propagation should bail out.