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.

module/ice-9/boot-9.scm

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

module/ice-9/psyntax.scm

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