let-values in terms of syntax-case, add make-tree-il-folder

* module/language/tree-il.scm (tree-il-fold): Fix for let-values case.
  (make-tree-il-folder): New public macro, makes a multi-valued folder
  specific to the number of seeds that the user wants.
* module/language/tree-il/optimize.scm (optimize!): Reverse the order of
  inline! and fix-letrec!, as the latter might expose opportunities for
  the former.
* module/srfi/srfi-11.scm (let-values): Reimplement in terms of
  syntax-case, so that its expressions may reference hygienically bound
  variables. See the NEWS for the rationale.
  (let*-values): An empty let*-values still introduces a local `let'
  binding contour.
* module/system/base/syntax.scm (record-case): Yukkkk. Reimplement in
  terms of syntax-case. Ug-ly, but see the NEWS again: "Lexical bindings
  introduced by hygienic macros may not be referenced by nonhygienic
  macros."

4 files changed, 194 insertions, 189 deletions

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 01d52f181..8ad7065c6 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -18,6 +18,7 @@
 
 (define-module (language tree-il)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (system base pmatch)
   #:use-module (system base syntax)
   #:export (tree-il-src
@@ -46,6 +47,7 @@
             tree-il->scheme
 
             tree-il-fold
+            make-tree-il-folder
             post-order!
             pre-order!))
 
@@ -316,11 +318,83 @@ This is an implementation of `foldts' as described by Andy Wingo in
            (up tree (loop body
                           (loop vals
                                 (down tree result)))))
-          ((<let-values> body)
-           (up tree (loop body (down tree result))))
+          ((<let-values> exp body)
+           (up tree (loop body (loop exp (down tree result)))))
           (else
            (leaf tree result))))))
 
+
+(define-syntax make-tree-il-folder
+  (syntax-rules ()
+    ((_ seed ...)
+     (lambda (tree down up leaf seed ...)
+       (define (fold-values proc exps seed ...)
+         (if (null? exps)
+             (values seed ...)
+             (let-values (((seed ...) (proc (car exps) seed ...)))
+               (fold-values proc (cdr exps) seed ...))))
+       (let foldts ((tree tree) (seed seed) ...)
+         (record-case tree
+           ((<lexical-set> exp)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (foldts exp seed ...)))
+              (up tree seed ...)))
+           ((<module-set> exp)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (foldts exp seed ...)))
+              (up tree seed ...)))
+           ((<toplevel-set> exp)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (foldts exp seed ...)))
+              (up tree seed ...)))
+           ((<toplevel-define> exp)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (foldts exp seed ...)))
+              (up tree seed ...)))
+           ((<conditional> test then else)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (foldts test seed ...))
+                          ((seed ...) (foldts then seed ...))
+                          ((seed ...) (foldts else seed ...)))
+              (up tree seed ...)))
+           ((<application> proc args)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (foldts proc seed ...))
+                          ((seed ...) (fold-values foldts args seed ...)))
+              (up tree seed ...)))
+           ((<sequence> exps)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (fold-values foldts exps seed ...)))
+              (up tree seed ...)))
+           ((<lambda> body)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (foldts body seed ...)))
+              (up tree seed ...)))
+           ((<let> vals body)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (fold-values foldts vals seed ...))
+                          ((seed ...) (foldts body seed ...)))
+              (up tree seed ...)))
+           ((<letrec> vals body)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (fold-values foldts vals seed ...))
+                          ((seed ...) (foldts body seed ...)))
+              (up tree seed ...)))
+
+           ((<fix> vals body)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (fold-values foldts vals seed ...))
+                          ((seed ...) (foldts body seed ...)))
+              (up tree seed ...)))
+           ((<let-values> exp body)
+            (let*-values (((seed ...) (down tree seed ...))
+                          ((seed ...) (fold-values foldts vals seed ...))
+                          ((seed ...) (foldts body seed ...)))
+              (up tree seed ...)))
+           (else
+            (leaf tree seed ...))))))))
+
+
 (define (post-order! f x)
   (let lp ((x x))
     (record-case x
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 23505201c..0e490a636 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -29,7 +29,7 @@
   (if e (car e) (current-module)))
 
 (define (optimize! x env opts)
-  (fix-letrec!
-   (inline!
+  (inline!
+   (fix-letrec!
     (expand-primitives! 
      (resolve-primitives! x (env-module env))))))
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index c8422eeaf..8a41d00f7 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -1,6 +1,6 @@
 ;;; srfi-11.scm --- let-values and let*-values
 
-;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -63,148 +63,55 @@
 ;;                 (q <tmp-q>))
 ;;             (baz x y z p q))))))
 
-;; I originally wrote this as a define-macro, but then I found out
-;; that guile's gensym/gentemp was broken, so I tried rewriting it as
-;; a syntax-rules statement.
-;;     [make-symbol now fixes gensym/gentemp problems.]
-;;
-;; Since syntax-rules didn't seem powerful enough to implement
-;; let-values in one definition without exposing illegal syntax (or
-;; perhaps my brain's just not powerful enough :>).  I tried writing
-;; it using a private helper, but that didn't work because the
-;; let-values expands outside the scope of this module.  I wonder why
-;; syntax-rules wasn't designed to allow "private" patterns or
-;; similar...
-;;
-;; So in the end, I dumped the syntax-rules implementation, reproduced
-;; here for posterity, and went with the define-macro one below --
-;; gensym/gentemp's got to be fixed anyhow...
-;
-; (define-syntax let-values-helper
-;   (syntax-rules ()
-;     ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
-;     ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
-;     ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
-;     ;; temps you create so you can use them later...
-;     ;;
-;     ;; I really don't fully understand why the (var-1 var-1) trick
-;     ;; works below, but basically, when all those (x x) bindings show
-;     ;; up in the final "let", syntax-rules forces a renaming.
-
-;     ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
-;         body ...)
-;      (lambda lambda-tmps
-;        (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
-
-;     ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
-;         body ...)
-;      (let-values-helper "consumer"
-;                         (var-2 ...)
-;                         (lambda-tmp ... var-1)
-;                         ((var-1 var-1) . final-let-bindings)
-;                         lv-bindings
-;                         body ...))
-
-;     ((_ "cwv" () final-let-bindings body ...)
-;      (let final-let-bindings
-;          body ...))
-
-;     ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
-;         body ...)
-;      (call-with-values (lambda () binding-1)
-;        (let-values-helper "consumer"
-;                           vars-1
-;                           ()
-;                           final-let-bindings
-;                           (other-bindings ...)
-;                           body ...)))))
-;
-; (define-syntax let-values
-;   (syntax-rules ()
-;     ((let-values () body ...)
-;      (begin body ...))
-;     ((let-values (binding ...) body ...)
-;      (let-values-helper "cwv" (binding ...) () body ...))))
-;
-;
-; (define-syntax let-values
-;   (letrec-syntax ((build-consumer
-;                    ;; Take the vars from one let binding (i.e. the (x
-;                    ;; y z) from ((x y z) (values 1 2 3)) and turn it
-;                    ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
-;                    ;; <tmp-z>) ...) from above.
-;                    (syntax-rules ()
-;                      ((_ () new-tmps tmp-vars () body ...)
-;                       (lambda new-tmps
-;                         body ...))
-;                      ((_ () new-tmps tmp-vars vars body ...)
-;                       (lambda new-tmps
-;                         (lv-builder vars tmp-vars body ...)))
-;                      ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
-;                       (build-consumer (var-2 ...)
-;                                       (tmp-1 . new-tmps)
-;                                       ((var-1 tmp-1) . tmp-vars)
-;                                       bindings
-;                                       body ...))))
-;                   (lv-builder
-;                    (syntax-rules ()
-;                      ((_ () tmp-vars body ...)
-;                       (let tmp-vars
-;                           body ...))
-;                      ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
-;                          tmp-vars
-;                          body ...)
-;                       (call-with-values (lambda () binding-1)
-;                         (build-consumer vars-1
-;                                         ()
-;                                         tmp-vars
-;                                         ((vars-2 binding-2) ...)
-;                                         body ...))))))
-;
-;     (syntax-rules ()
-;       ((_ () body ...)
-;        (begin body ...))
-;       ((_ ((vars binding) ...) body ...)
-;        (lv-builder ((vars binding) ...) () body ...)))))
-
-(define-macro (let-values vars . body)
-
-  (define (map-1-dot proc elts)
-    ;; map over one optionally dotted (a b c . d) list, producing an
-    ;; optionally dotted result.
-    (cond
-     ((null? elts) '())
-     ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
-     (else (proc elts))))
-
-  (define (undot-list lst)
-    ;; produce a non-dotted list from a possibly dotted list.
-    (cond
-     ((null? lst) '())
-     ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
-     (else (list lst))))
-
-  (define (let-values-helper vars body prev-let-vars)
-    (let* ((var-binding (car vars))
-           (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
-                                (car var-binding)))
-           (let-vars (map (lambda (sym tmp) (list sym tmp))
-                          (undot-list (car var-binding))
-                          (undot-list new-tmps))))
-
-      (if (null? (cdr vars))
-          `(call-with-values (lambda () ,(cadr var-binding))
-             (lambda ,new-tmps
-               (let ,(apply append let-vars prev-let-vars)
-                 ,@body)))
-          `(call-with-values (lambda () ,(cadr var-binding))
-             (lambda ,new-tmps
-               ,(let-values-helper (cdr vars) body
-                                   (cons let-vars prev-let-vars)))))))
-
-  (if (null? vars)
-      `(begin ,@body)
-      (let-values-helper vars body '())))
+;; We could really use quasisyntax here...
+(define-syntax let-values
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (clause ...) b0 b1 ...)
+       (let lp ((clauses (syntax (clause ...)))
+                (ids '())
+                (tmps '()))
+         (if (null? clauses)
+             (with-syntax (((id ...) ids)
+                           ((tmp ...) tmps))
+               (syntax (let ((id tmp) ...)
+                         b0 b1 ...)))
+             (syntax-case (car clauses) ()
+               (((var ...) exp)
+                (with-syntax (((new-tmp ...) (generate-temporaries 
+                                              (syntax (var ...))))
+                              ((id ...) ids)
+                              ((tmp ...) tmps))
+                  (with-syntax ((inner (lp (cdr clauses)
+                                           (syntax (var ... id ...))
+                                           (syntax (new-tmp ... tmp ...)))))
+                    (syntax (call-with-values (lambda () exp)
+                              (lambda (new-tmp ...) inner))))))
+               ((vars exp)
+                (with-syntax ((((new-tmp . new-var) ...)
+                               (let lp ((vars (syntax vars)))
+                                 (syntax-case vars ()
+                                   ((id . rest)
+                                    (acons (syntax id)
+                                           (car
+                                            (generate-temporaries (syntax (id))))
+                                           (lp (syntax rest))))
+                                   (id (acons (syntax id)
+                                              (car
+                                               (generate-temporaries (syntax (id))))
+                                              '())))))
+                              ((id ...) ids)
+                              ((tmp ...) tmps))
+                  (with-syntax ((inner (lp (cdr clauses)
+                                           (syntax (new-var ... id ...))
+                                           (syntax (new-tmp ... tmp ...))))
+                                (args (let lp ((tmps (syntax (new-tmp ...))))
+                                        (syntax-case tmps ()
+                                          ((id) (syntax id))
+                                          ((id . rest) (cons (syntax id)
+                                                             (lp (syntax rest))))))))
+                    (syntax (call-with-values (lambda () exp)
+                              (lambda args inner)))))))))))))
 
 ;;;;;;;;;;;;;;
 ;; let*-values
@@ -226,28 +133,11 @@
 (define-syntax let*-values
   (syntax-rules ()
     ((let*-values () body ...)
-     (begin body ...))
+     (let () body ...))
     ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
      (call-with-values (lambda () binding-1)
        (lambda vars-1
          (let*-values ((vars-2 binding-2) ...)
            body ...))))))
 
-; Alternate define-macro implementation...
-;
-; (define-macro (let*-values vars . body)
-;   (define (let-values-helper vars body)
-;     (let ((var-binding (car vars)))
-;       (if (null? (cdr vars))
-;           `(call-with-values (lambda () ,(cadr var-binding))
-;              (lambda ,(car var-binding)
-;                ,@body))
-;           `(call-with-values (lambda () ,(cadr var-binding))
-;              (lambda ,(car var-binding)
-;                ,(let-values-helper (cdr vars) body))))))
-
-;   (if (null? vars)
-;       `(begin ,@body)
-;       (let-values-helper vars body)))
-
 ;;; srfi-11.scm ends here
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index cc73f38d1..249961d79 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM specific syntaxes and utilities
 
-;; Copyright (C) 2001 Free Software Foundation, Inc
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -174,29 +174,70 @@
 ;;   5.88      0.01      0.01  list-index
 
 
-(define-macro (record-case record . clauses)
-  (let ((r (gensym))
-        (rtd (gensym)))
-    (define (process-clause clause)
-      (if (eq? (car clause) 'else)
-          clause
-          (let ((record-type (caar clause))
-                (slots (cdar clause))
-                (body (cdr clause)))
-            (let ((stem (trim-brackets record-type)))
-              `((eq? ,rtd ,record-type)
-                (let ,(map (lambda (slot)
-                             (if (pair? slot)
-                                 `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
-                                 `(,slot (,(symbol-append stem '- slot) ,r))))
-                           slots)
-                  ,@(if (pair? body) body '((if #f #f)))))))))
-    `(let* ((,r ,record)
-            (,rtd (struct-vtable ,r)))
-       (cond ,@(let ((clauses (map process-clause clauses)))
-                 (if (assq 'else clauses)
-                     clauses
-                     (append clauses `((else (error "unhandled record" ,r))))))))))
+;;; So ugly... but I am too ignorant to know how to make it better.
+(define-syntax record-case
+  (lambda (x)
+    (syntax-case x ()
+      ((_ record clause ...)
+       (let ((r (syntax r))
+             (rtd (syntax rtd)))
+         (define (process-clause tag fields exprs)
+           (let ((infix (trim-brackets (syntax->datum tag))))
+             (with-syntax ((tag tag)
+                           (((f . accessor) ...)
+                            (let lp ((fields fields))
+                              (syntax-case fields ()
+                                (() (syntax ()))
+                                (((v0 f0) f1 ...)
+                                 (acons (syntax v0)
+                                        (datum->syntax x 
+                                                       (symbol-append infix '- (syntax->datum
+                                                                                (syntax f0))))
+                                        (lp (syntax (f1 ...)))))
+                                ((f0 f1 ...)
+                                 (acons (syntax f0)
+                                        (datum->syntax x 
+                                                       (symbol-append infix '- (syntax->datum
+                                                                                (syntax f0))))
+                                        (lp (syntax (f1 ...))))))))
+                           ((e0 e1 ...)
+                            (syntax-case exprs ()
+                              (() (syntax (#t)))
+                              ((e0 e1 ...) (syntax (e0 e1 ...))))))
+               (syntax
+                ((eq? rtd tag)
+                 (let ((f (accessor r))
+                       ...)
+                   e0 e1 ...))))))
+         (with-syntax
+             ((r r)
+              (rtd rtd)
+              ((processed ...)
+               (let lp ((clauses (syntax (clause ...)))
+                        (out '()))
+                 (syntax-case clauses (else)
+                   (()
+                    (reverse! (cons (syntax
+                                     (else (error "unhandled record" r)))
+                                    out)))
+                   (((else e0 e1 ...))
+                    (reverse! (cons (syntax (else e0 e1 ...)) out)))
+                   (((else e0 e1 ...) . rest)
+                    (syntax-violation 'record-case
+                                      "bad else clause placement"
+                                      (syntax x)
+                                      (syntax (else e0 e1 ...))))
+                   ((((<foo> f0 ...) e0 ...) . rest)
+                    (lp (syntax rest)
+                        (cons (process-clause (syntax <foo>)
+                                              (syntax (f0 ...))
+                                              (syntax (e0 ...)))
+                              out)))))))
+           (syntax
+            (let* ((r record)
+                   (rtd (struct-vtable r)))
+              (cond processed ...)))))))))
+
 
 ;; Here we take the terrorism to another level. Nasty, but the client
 ;; code looks good.