mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
residualize names into procedures. re-implement srfi-61. module naming foo.
* module/ice-9/boot-9.scm (cond): Implement srfi-61; most of the code is from the SRFI itself. Yuk. (%print-module, make-modules-in, %app, (%app modules)) (module-name): Syncase needs to get at the names of modules, even at anonymous modules. So lazily assign gensyms as module names. Name %app as (%app), but since (%app modules) is at the top of the module hierarchy, name it (). * module/ice-9/psyntax.scm: When building tree-il, try to name lambdas in definitions and in lets. (let, letrec): Give more specific errors in a couple of cases. * module/ice-9/psyntax-pp.scm: Regenerated. * test-suite/tests/syntax.test: More work. Many exceptions have different messages than they used to, many more generic; we can roll this back to be faithful to the original strings, but it doesn't seem necessary to me.
This commit is contained in:
Andy Wingo
parent
0260421208
commit
dc1eed52f7
4 changed files with 208 additions and 164 deletions
|
|
@ -222,31 +222,44 @@
|
|||
((_ x) x)
|
||||
((_ x y ...) (let ((t x)) (if t t (or y ...))))))
|
||||
|
||||
;; 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 =>)
|
||||
((cond (else result1 result2 ...))
|
||||
(begin result1 result2 ...))
|
||||
((cond (test => result))
|
||||
(let ((temp test))
|
||||
(if temp (result temp))))
|
||||
((cond (test => result) clause1 clause2 ...)
|
||||
(let ((temp test))
|
||||
(if temp
|
||||
(result temp)
|
||||
(cond clause1 clause2 ...))))
|
||||
((cond (test)) test)
|
||||
((cond (test) clause1 clause2 ...)
|
||||
(let ((temp test))
|
||||
(if temp
|
||||
temp
|
||||
(cond clause1 clause2 ...))))
|
||||
((cond (test result1 result2 ...))
|
||||
(if test (begin result1 result2 ...)))
|
||||
((cond (test result1 result2 ...)
|
||||
clause1 clause2 ...)
|
||||
(if test
|
||||
(begin result1 result2 ...)
|
||||
(cond clause1 clause2 ...)))))
|
||||
(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 ...))))
|
||||
|
||||
(define-syntax case
|
||||
(syntax-rules (else)
|
||||
|
|
@ -1233,11 +1246,8 @@
|
|||
(define (%print-module mod port) ; unused args: depth length style table)
|
||||
(display "#<" port)
|
||||
(display (or (module-kind mod) "module") port)
|
||||
(let ((name (module-name mod)))
|
||||
(if name
|
||||
(begin
|
||||
(display " " port)
|
||||
(display name port))))
|
||||
(display " " port)
|
||||
(display (module-name mod) port)
|
||||
(display " " port)
|
||||
(display (number->string (object-address mod) 16) port)
|
||||
(display ">" port))
|
||||
|
|
@ -1902,7 +1912,7 @@
|
|||
val
|
||||
(let ((m (make-module 31)))
|
||||
(set-module-kind! m 'directory)
|
||||
(set-module-name! m (append (or (module-name module) '())
|
||||
(set-module-name! m (append (module-name module)
|
||||
(list (car name))))
|
||||
(module-define! module (car name) m)
|
||||
m)))
|
||||
|
|
@ -1956,17 +1966,26 @@
|
|||
(define default-duplicate-binding-procedures #f)
|
||||
|
||||
(define %app (make-module 31))
|
||||
(set-module-name! %app '(%app))
|
||||
(define app %app) ;; for backwards compatability
|
||||
|
||||
(local-define '(%app modules) (make-module 31))
|
||||
(let ((m (make-module 31)))
|
||||
(set-module-name! m '())
|
||||
(local-define '(%app modules) m))
|
||||
(local-define '(%app modules guile) the-root-module)
|
||||
|
||||
;; This boots the module system. All bindings needed by modules.c
|
||||
;; must have been defined by now.
|
||||
;;
|
||||
(set-current-module the-root-module)
|
||||
;; definition deferred for syncase's benefit
|
||||
(define module-name (record-accessor module-type 'name))
|
||||
;; definition deferred for syncase's benefit.
|
||||
(define module-name
|
||||
(let ((accessor (record-accessor module-type 'name)))
|
||||
(lambda (mod)
|
||||
(or (accessor mod)
|
||||
(begin
|
||||
(set-module-name! mod (list (gensym)))
|
||||
(accessor mod))))))
|
||||
|
||||
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -435,10 +435,23 @@
|
|||
((c) ((@ (language tree-il) make-toplevel-set) source var exp))
|
||||
(else `(set! ,var ,exp)))))))
|
||||
|
||||
;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
|
||||
;; from working. Hack around it.
|
||||
(define (maybe-name-value! name val)
|
||||
(cond
|
||||
(((@ (language tree-il) lambda?) val)
|
||||
(let ((meta ((@ (language tree-il) lambda-meta) val)))
|
||||
(if (not (assq 'name meta))
|
||||
((setter (@ (language tree-il) lambda-meta))
|
||||
val
|
||||
(acons 'name name meta)))))))
|
||||
|
||||
(define build-global-definition
|
||||
(lambda (source var exp)
|
||||
(case (fluid-ref *mode*)
|
||||
((c) ((@ (language tree-il) make-toplevel-define) source var exp))
|
||||
((c)
|
||||
(maybe-name-value! var exp)
|
||||
((@ (language tree-il) make-toplevel-define) source var exp))
|
||||
(else `(define ,var ,exp)))))
|
||||
|
||||
(define build-lambda
|
||||
|
|
@ -480,7 +493,9 @@
|
|||
(if (null? vars)
|
||||
body-exp
|
||||
(case (fluid-ref *mode*)
|
||||
((c) ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
|
||||
((c)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
((@ (language tree-il) make-let) src ids vars val-exps body-exp))
|
||||
(else `(let ,(map list vars val-exps) ,body-exp))))))
|
||||
|
||||
(define build-named-let
|
||||
|
|
@ -490,12 +505,14 @@
|
|||
(vars (cdr vars))
|
||||
(ids (cdr ids)))
|
||||
(case (fluid-ref *mode*)
|
||||
((c) ((@ (language tree-il) make-letrec) src
|
||||
(list f-name)
|
||||
(list f)
|
||||
(list (build-lambda src ids vars #f body-exp))
|
||||
(build-application src (build-lexical-reference 'fun src f-name f)
|
||||
val-exps)))
|
||||
((c)
|
||||
(let ((proc (build-lambda src ids vars #f body-exp)))
|
||||
(maybe-name-value! f-name proc)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
((@ (language tree-il) make-letrec) src
|
||||
(list f-name) (list f) (list proc)
|
||||
(build-application src (build-lexical-reference 'fun src f-name f)
|
||||
val-exps))))
|
||||
(else `(let ,f ,(map list vars val-exps) ,body-exp))))))
|
||||
|
||||
(define build-letrec
|
||||
|
|
@ -503,7 +520,9 @@
|
|||
(if (null? vars)
|
||||
body-exp
|
||||
(case (fluid-ref *mode*)
|
||||
((c) ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
|
||||
((c)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
|
||||
(else `(letrec ,(map list vars val-exps) ,body-exp))))))
|
||||
|
||||
;; FIXME: wingo: use make-lexical ?
|
||||
|
|
@ -1819,13 +1838,14 @@
|
|||
(lambda (e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(and-map id? (syntax (id ...)))
|
||||
(chi-let e r w s mod
|
||||
build-let
|
||||
(syntax (id ...))
|
||||
(syntax (val ...))
|
||||
(syntax (e1 e2 ...))))
|
||||
((_ f ((id val) ...) e1 e2 ...)
|
||||
(id? (syntax f))
|
||||
(and (id? (syntax f)) (and-map id? (syntax (id ...))))
|
||||
(chi-let e r w s mod
|
||||
build-named-let
|
||||
(syntax (f id ...))
|
||||
|
|
@ -1838,6 +1858,7 @@
|
|||
(lambda (e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(and-map id? (syntax (id ...)))
|
||||
(let ((ids (syntax (id ...))))
|
||||
(if (not (valid-bound-ids? ids))
|
||||
(syntax-violation 'letrec "duplicate bound variable" e)
|
||||
|
|
|
|||
|
|
@ -40,16 +40,22 @@
|
|||
(define exception:illegal-empty-combination
|
||||
(cons 'syntax-error "Illegal empty combination"))
|
||||
|
||||
(define exception:bad-lambda
|
||||
'(syntax-error . "bad lambda"))
|
||||
(define exception:bad-let
|
||||
'(syntax-error . "bad let "))
|
||||
(define exception:bad-letrec
|
||||
'(syntax-error . "bad letrec "))
|
||||
(define exception:bad-bindings
|
||||
(cons 'syntax-error "Bad bindings"))
|
||||
(define exception:bad-binding
|
||||
(cons 'syntax-error "Bad binding"))
|
||||
(define exception:duplicate-binding
|
||||
(cons 'syntax-error "Duplicate binding"))
|
||||
(cons 'syntax-error "duplicate bound variable"))
|
||||
(define exception:bad-body
|
||||
(cons 'misc-error "^bad body"))
|
||||
(define exception:bad-formals
|
||||
(cons 'syntax-error "Bad formals"))
|
||||
'(syntax-error . "invalid parameter list"))
|
||||
(define exception:bad-formal
|
||||
(cons 'syntax-error "Bad formal"))
|
||||
(define exception:duplicate-formal
|
||||
|
|
@ -176,17 +182,17 @@
|
|||
(with-test-prefix "bad formals"
|
||||
|
||||
(pass-if-exception "(lambda)"
|
||||
exception:missing-expr
|
||||
exception:bad-lambda
|
||||
(eval '(lambda)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(lambda . \"foo\")"
|
||||
exception:bad-expression
|
||||
exception:bad-lambda
|
||||
(eval '(lambda . "foo")
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(lambda \"foo\")"
|
||||
exception:missing-expr
|
||||
exception:bad-lambda
|
||||
(eval '(lambda "foo")
|
||||
(interaction-environment)))
|
||||
|
||||
|
|
@ -196,22 +202,22 @@
|
|||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(lambda (x 1) 2)"
|
||||
exception:bad-formal
|
||||
exception:bad-formals
|
||||
(eval '(lambda (x 1) 2)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(lambda (1 x) 2)"
|
||||
exception:bad-formal
|
||||
exception:bad-formals
|
||||
(eval '(lambda (1 x) 2)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(lambda (x \"a\") 2)"
|
||||
exception:bad-formal
|
||||
exception:bad-formals
|
||||
(eval '(lambda (x "a") 2)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(lambda (\"a\" x) 2)"
|
||||
exception:bad-formal
|
||||
exception:bad-formals
|
||||
(eval '(lambda ("a" x) 2)
|
||||
(interaction-environment))))
|
||||
|
||||
|
|
@ -219,20 +225,20 @@
|
|||
|
||||
;; Fixed on 2001-3-3
|
||||
(pass-if-exception "(lambda (x x) 1)"
|
||||
exception:duplicate-formal
|
||||
exception:bad-formals
|
||||
(eval '(lambda (x x) 1)
|
||||
(interaction-environment)))
|
||||
|
||||
;; Fixed on 2001-3-3
|
||||
(pass-if-exception "(lambda (x x x) 1)"
|
||||
exception:duplicate-formal
|
||||
exception:bad-formals
|
||||
(eval '(lambda (x x x) 1)
|
||||
(interaction-environment))))
|
||||
|
||||
(with-test-prefix "bad body"
|
||||
|
||||
(pass-if-exception "(lambda ())"
|
||||
exception:missing-expr
|
||||
exception:bad-lambda
|
||||
(eval '(lambda ())
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -242,9 +248,8 @@
|
|||
|
||||
(pass-if "normal let"
|
||||
(let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
|
||||
(foo) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda () (let ((i 1) (j 2)) (+ i j)))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
|
||||
|
||||
(with-test-prefix "bindings"
|
||||
|
||||
|
|
@ -255,42 +260,42 @@
|
|||
(with-test-prefix "bad bindings"
|
||||
|
||||
(pass-if-exception "(let)"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let 1)"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let (x))"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let (x))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let ((x)))"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let ((x)))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let (x) 1)"
|
||||
exception:bad-binding
|
||||
exception:bad-let
|
||||
(eval '(let (x) 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let ((x)) 3)"
|
||||
exception:bad-binding
|
||||
exception:bad-let
|
||||
(eval '(let ((x)) 3)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let ((x 1) y) x)"
|
||||
exception:bad-binding
|
||||
exception:bad-let
|
||||
(eval '(let ((x 1) y) x)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let ((1 2)) 3)"
|
||||
exception:bad-variable
|
||||
exception:bad-let
|
||||
(eval '(let ((1 2)) 3)
|
||||
(interaction-environment))))
|
||||
|
||||
|
|
@ -304,12 +309,12 @@
|
|||
(with-test-prefix "bad body"
|
||||
|
||||
(pass-if-exception "(let ())"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let ((x 1)))"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let ((x 1)))
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -324,19 +329,19 @@
|
|||
(with-test-prefix "bad bindings"
|
||||
|
||||
(pass-if-exception "(let x (y))"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let x (y))
|
||||
(interaction-environment))))
|
||||
|
||||
(with-test-prefix "bad body"
|
||||
|
||||
(pass-if-exception "(let x ())"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let x ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let x ((y 1)))"
|
||||
exception:missing-expr
|
||||
exception:bad-let
|
||||
(eval '(let x ((y 1)))
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -346,19 +351,16 @@
|
|||
|
||||
(pass-if "normal let*"
|
||||
(let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
|
||||
(foo) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda () (let* ((x 1) (y 2)) (+ x y))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
|
||||
|
||||
(pass-if "let* without bindings"
|
||||
(let ((foo (lambda () (let ((x 1) (y 2))
|
||||
(let* ()
|
||||
(and (= x 1) (= y 2)))))))
|
||||
(foo) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda () (let ((x 1) (y 2))
|
||||
(let* ()
|
||||
(and (= x 1) (= y 2)))))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda () (let ((_ 1) (_ 2))
|
||||
(if (= _ 1) (= _ 2) #f)))))))
|
||||
|
||||
(with-test-prefix "bindings"
|
||||
|
||||
|
|
@ -378,59 +380,59 @@
|
|||
(with-test-prefix "bad bindings"
|
||||
|
||||
(pass-if-exception "(let*)"
|
||||
exception:missing-expr
|
||||
exception:generic-syncase-error
|
||||
(eval '(let*)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* 1)"
|
||||
exception:missing-expr
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* (x))"
|
||||
exception:missing-expr
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* (x))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* (x) 1)"
|
||||
exception:bad-binding
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* (x) 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* ((x)) 3)"
|
||||
exception:bad-binding
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* ((x)) 3)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* ((x 1) y) x)"
|
||||
exception:bad-binding
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* ((x 1) y) x)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* x ())"
|
||||
exception:bad-bindings
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* x ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* x (y))"
|
||||
exception:bad-bindings
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* x (y))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* ((1 2)) 3)"
|
||||
exception:bad-variable
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* ((1 2)) 3)
|
||||
(interaction-environment))))
|
||||
|
||||
(with-test-prefix "bad body"
|
||||
|
||||
(pass-if-exception "(let* ())"
|
||||
exception:missing-expr
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(let* ((x 1)))"
|
||||
exception:missing-expr
|
||||
exception:generic-syncase-error
|
||||
(eval '(let* ((x 1)))
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -440,9 +442,8 @@
|
|||
|
||||
(pass-if "normal letrec"
|
||||
(let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
|
||||
(foo) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
|
||||
|
||||
(with-test-prefix "bindings"
|
||||
|
||||
|
|
@ -454,47 +455,47 @@
|
|||
(with-test-prefix "bad bindings"
|
||||
|
||||
(pass-if-exception "(letrec)"
|
||||
exception:missing-expr
|
||||
exception:bad-letrec
|
||||
(eval '(letrec)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec 1)"
|
||||
exception:missing-expr
|
||||
exception:bad-letrec
|
||||
(eval '(letrec 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec (x))"
|
||||
exception:missing-expr
|
||||
exception:bad-letrec
|
||||
(eval '(letrec (x))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec (x) 1)"
|
||||
exception:bad-binding
|
||||
exception:bad-letrec
|
||||
(eval '(letrec (x) 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec ((x)) 3)"
|
||||
exception:bad-binding
|
||||
exception:bad-letrec
|
||||
(eval '(letrec ((x)) 3)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec ((x 1) y) x)"
|
||||
exception:bad-binding
|
||||
exception:bad-letrec
|
||||
(eval '(letrec ((x 1) y) x)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec x ())"
|
||||
exception:bad-bindings
|
||||
exception:bad-letrec
|
||||
(eval '(letrec x ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec x (y))"
|
||||
exception:bad-bindings
|
||||
exception:bad-letrec
|
||||
(eval '(letrec x (y))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec ((1 2)) 3)"
|
||||
exception:bad-variable
|
||||
exception:bad-letrec
|
||||
(eval '(letrec ((1 2)) 3)
|
||||
(interaction-environment))))
|
||||
|
||||
|
|
@ -508,12 +509,12 @@
|
|||
(with-test-prefix "bad body"
|
||||
|
||||
(pass-if-exception "(letrec ())"
|
||||
exception:missing-expr
|
||||
exception:bad-letrec
|
||||
(eval '(letrec ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(letrec ((x 1)))"
|
||||
exception:missing-expr
|
||||
exception:bad-letrec
|
||||
(eval '(letrec ((x 1)))
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -525,17 +526,17 @@
|
|||
(let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
|
||||
(foo #t) ; make sure, memoization has been performed
|
||||
(foo #f) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda (x) (if x (+ 1) (+ 2))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda (_) (if _ (+ 1) (+ 2))))))
|
||||
|
||||
(pass-if "if without else"
|
||||
(expect-fail "if without else"
|
||||
(let ((foo (lambda (x) (if x (+ 1)))))
|
||||
(foo #t) ; make sure, memoization has been performed
|
||||
(foo #f) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda (x) (if x (+ 1))))))
|
||||
|
||||
(pass-if "if #f without else"
|
||||
(expect-fail "if #f without else"
|
||||
(let ((foo (lambda () (if #f #f))))
|
||||
(foo) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
|
|
@ -544,12 +545,12 @@
|
|||
(with-test-prefix "missing or extra expressions"
|
||||
|
||||
(pass-if-exception "(if)"
|
||||
exception:missing/extra-expr
|
||||
exception:generic-syncase-error
|
||||
(eval '(if)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(if 1 2 3 4)"
|
||||
exception:missing/extra-expr
|
||||
exception:generic-syncase-error
|
||||
(eval '(if 1 2 3 4)
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
@ -611,78 +612,77 @@
|
|||
(eq? 'ok (cond (#t identity =>) (else #f)))))
|
||||
|
||||
(pass-if-exception "missing recipient"
|
||||
'(syntax-error . "Missing recipient")
|
||||
'(syntax-error . "cond: wrong number of receiver expressions")
|
||||
(cond (#t identity =>)))
|
||||
|
||||
(pass-if-exception "extra recipient"
|
||||
'(syntax-error . "Extra expression")
|
||||
'(syntax-error . "cond: wrong number of receiver expressions")
|
||||
(cond (#t identity => identity identity))))
|
||||
|
||||
(with-test-prefix "unmemoization"
|
||||
|
||||
;; FIXME: the (if #f #f) is a hack!
|
||||
(pass-if "normal clauses"
|
||||
(let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
|
||||
(foo 1) ; make sure, memoization has been performed
|
||||
(foo 2) ; make sure, memoization has been performed
|
||||
(let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
|
||||
'(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
|
||||
|
||||
(pass-if "else"
|
||||
(let ((foo (lambda () (cond (else 'bar)))))
|
||||
(foo) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda () (cond (else 'bar))))))
|
||||
'(lambda () 'bar))))
|
||||
|
||||
;; FIXME: the (if #f #f) is a hack!
|
||||
(pass-if "=>"
|
||||
(let ((foo (lambda () (cond (#t => identity)))))
|
||||
(foo) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda () (cond (#t => identity)))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda () (let ((_ #t))
|
||||
(if _ (identity _) (if #f #f))))))))
|
||||
|
||||
(with-test-prefix "bad or missing clauses"
|
||||
|
||||
(pass-if-exception "(cond)"
|
||||
exception:missing-clauses
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond #t)"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond #t)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond 1)"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond 1 2)"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond 1 2)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond 1 2 3)"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond 1 2 3)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond 1 2 3 4)"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond 1 2 3 4)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond ())"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond () 1)"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond () 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(cond (1) 1)"
|
||||
exception:bad-cond-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(cond (1) 1)
|
||||
(interaction-environment))))
|
||||
|
||||
|
|
@ -700,7 +700,7 @@
|
|||
(with-test-prefix "case is hygienic"
|
||||
|
||||
(pass-if-exception "bound 'else is handled correctly"
|
||||
exception:bad-case-labels
|
||||
exception:generic-syncase-error
|
||||
(eval '(let ((else #f)) (case 1 (else #f)))
|
||||
(interaction-environment))))
|
||||
|
||||
|
|
@ -708,79 +708,83 @@
|
|||
|
||||
(pass-if "normal clauses"
|
||||
(let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
|
||||
(foo 1) ; make sure, memoization has been performed
|
||||
(foo 2) ; make sure, memoization has been performed
|
||||
(foo 3) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda (_)
|
||||
(if ((@@ (guile) memv) _ '(1))
|
||||
'bar
|
||||
(if ((@@ (guile) memv) _ '(2))
|
||||
'baz
|
||||
'foobar))))))
|
||||
|
||||
(pass-if "empty labels"
|
||||
(let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
|
||||
(foo 1) ; make sure, memoization has been performed
|
||||
(foo 2) ; make sure, memoization has been performed
|
||||
(foo 3) ; make sure, memoization has been performed
|
||||
(equal? (procedure-source foo)
|
||||
'(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
|
||||
(matches? (procedure-source foo)
|
||||
(lambda (_)
|
||||
(if ((@@ (guile) memv) _ '(1))
|
||||
'bar
|
||||
(if ((@@ (guile) memv) _ '())
|
||||
'baz
|
||||
'foobar)))))))
|
||||
|
||||
(with-test-prefix "bad or missing clauses"
|
||||
|
||||
(pass-if-exception "(case)"
|
||||
exception:missing-clauses
|
||||
exception:generic-syncase-error
|
||||
(eval '(case)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case . \"foo\")"
|
||||
exception:bad-expression
|
||||
exception:generic-syncase-error
|
||||
(eval '(case . "foo")
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1)"
|
||||
exception:missing-clauses
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1)
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 . \"foo\")"
|
||||
exception:bad-expression
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 . "foo")
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 \"foo\")"
|
||||
exception:bad-case-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 "foo")
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 ())"
|
||||
exception:bad-case-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 ())
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 (\"foo\"))"
|
||||
exception:bad-case-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 ("foo"))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
|
||||
exception:bad-case-labels
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 ("foo" "bar"))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
|
||||
exception:bad-expression
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 ((2) "bar") . "foo")
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
|
||||
exception:bad-case-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 ((2) "bar") (else))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 (else #f) . \"foo\")"
|
||||
exception:bad-expression
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 (else #f) . "foo")
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-exception "(case 1 (else #f) ((1) #t))"
|
||||
exception:misplaced-else-clause
|
||||
exception:generic-syncase-error
|
||||
(eval '(case 1 (else #f) ((1) #t))
|
||||
(interaction-environment)))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue