mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

fix order of internal definitions

Browse source 
* module/ice-9/psyntax.scm (chi-body): Whoops, actually render internal
  definitions into a letrec* in the right order.
* module/ice-9/psyntax-pp.scm: Regenerate.

* test-suite/tests/syntax.test: Add some letrec* tests.
This commit is contained in:
Andy Wingo 2010-06-17 14:39:32 +02:00
parent 417ee09802
commit 5f8c55ce3b
3 changed files with 7931 additions and 7829 deletions
Download patch file Download diff file Expand all files Collapse all files

15660
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

8
module/ice-9/psyntax.scm
View file

@ -23,7 +23,7 @@
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
;;; revision control logs corresponding to this file: 2009.
;;; revision control logs corresponding to this file: 2009, 2010.
;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
;;; to the ChangeLog distributed in the same directory as this file:
@ -1484,11 +1484,11 @@
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source #t
(map syntax->datum var-ids)
vars
(reverse (map syntax->datum var-ids))
(reverse vars)
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod))
vals)
(reverse vals))
(build-sequence no-source
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod))

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

@ -45,6 +45,8 @@
'(syntax-error . "bad let "))
(define exception:bad-letrec
'(syntax-error . "bad letrec "))
(define exception:bad-letrec*
'(syntax-error . "bad letrec\\* "))
(define exception:bad-set!
'(syntax-error . "bad set!"))
(define exception:bad-quote
@ -463,6 +465,96 @@
(eval '(letrec ((x 1)))
(interaction-environment)))))
(with-test-prefix "letrec*"
(with-test-prefix "bindings"
(pass-if-exception "initial bindings are undefined"
exception:used-before-defined
(begin
;; FIXME: the memoizer does initialize the var to undefined, but
;; the Scheme evaluator has no way of checking what's an
;; undefined value. Not sure how to do this.
(throw 'unresolved)
(letrec* ((x y) (y 1)) y))))
(with-test-prefix "bad bindings"
(pass-if-exception "(letrec*)"
exception:bad-letrec*
(eval '(letrec*)
(interaction-environment)))
(pass-if-exception "(letrec* 1)"
exception:bad-letrec*
(eval '(letrec* 1)
(interaction-environment)))
(pass-if-exception "(letrec* (x))"
exception:bad-letrec*
(eval '(letrec* (x))
(interaction-environment)))
(pass-if-exception "(letrec* (x) 1)"
exception:bad-letrec*
(eval '(letrec* (x) 1)
(interaction-environment)))
(pass-if-exception "(letrec* ((x)) 3)"
exception:bad-letrec*
(eval '(letrec* ((x)) 3)
(interaction-environment)))
(pass-if-exception "(letrec* ((x 1) y) x)"
exception:bad-letrec*
(eval '(letrec* ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(letrec* x ())"
exception:bad-letrec*
(eval '(letrec* x ())
(interaction-environment)))
(pass-if-exception "(letrec* x (y))"
exception:bad-letrec*
(eval '(letrec* x (y))
(interaction-environment)))
(pass-if-exception "(letrec* ((1 2)) 3)"
exception:bad-letrec*
(eval '(letrec* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "duplicate bindings"
(pass-if-exception "(letrec* ((x 1) (x 2)) x)"
exception:duplicate-binding
(eval '(letrec* ((x 1) (x 2)) x)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(letrec* ())"
exception:bad-letrec*
(eval '(letrec* ())
(interaction-environment)))
(pass-if-exception "(letrec* ((x 1)))"
exception:bad-letrec*
(eval '(letrec* ((x 1)))
(interaction-environment))))
(with-test-prefix "referencing previous values"
(pass-if (equal? (letrec ((a (cons 'foo 'bar))
(b a))
b)
'(foo . bar)))
(pass-if (equal? (let ()
(define a (cons 'foo 'bar))
(define b a)
b)
'(foo . bar)))))
(with-test-prefix "if"
(with-test-prefix "missing or extra expressions"