fix order of internal definitions

* 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.

module/ice-9/psyntax.scm

@@ -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)
+                                           (reverse (map syntax->datum var-ids))
-                                           vars
+                                           (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))

test-suite/tests/syntax.test

@@ -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"