psyntax, primitive expander, and memoizer support for letrec*

* libguile/expand.c (expand_letrec_helper): Factor out common code.
  (expand_letrec): Use expand_letrec_helper.
  (expand_letrec_star): New primitive syntax: letrec*.

* libguile/memoize.c (memoize): Add memoizer support for in-order letrec
  (letrec*).

* module/ice-9/psyntax.scm (build-letrec): Another arg, `in-order?'.
  (chi-body): Adapt to build-letrec change. We don't yet use letrec* for
  internal definitions.
  (letrec): Adapt to build-letrec change.
  (letrec*): New expander.

* module/ice-9/psyntax-pp.scm: Regenerated.

libguile/expand.c

@@ -163,6 +163,7 @@ SCM_SYNTAX ("set!", expand_set_x);
 SCM_SYNTAX ("and", expand_and);
 SCM_SYNTAX ("cond", expand_cond);
 SCM_SYNTAX ("letrec", expand_letrec);
+SCM_SYNTAX ("letrec*", expand_letrec_star);
 SCM_SYNTAX ("let*", expand_letstar);
 SCM_SYNTAX ("or", expand_or);
 SCM_SYNTAX ("lambda*", expand_lambda_star);
@@ -1030,7 +1031,7 @@ expand_let (SCM expr, SCM env)
 }
 
 static SCM
-expand_letrec (SCM expr, SCM env)
+expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
 {
   SCM bindings;
 
@@ -1048,12 +1049,24 @@ expand_letrec (SCM expr, SCM env)
       SCM var_names, var_syms, inits;
       transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
       env = expand_env_extend (env, var_names, var_syms);
-      return LETREC (SCM_BOOL_F, SCM_BOOL_F,
+      return LETREC (SCM_BOOL_F, in_order_p,
                      var_names, var_syms, expand_exprs (inits, env),
                      expand_sequence (CDDR (expr), env));
     }
 }
 
+static SCM
+expand_letrec (SCM expr, SCM env)
+{
+  return expand_letrec_helper (expr, env, SCM_BOOL_F);
+}
+
+static SCM
+expand_letrec_star (SCM expr, SCM env)
+{
+  return expand_letrec_helper (expr, env, SCM_BOOL_T);
+}
+
 static SCM
 expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
 {

libguile/memoize.c

@@ -374,33 +374,50 @@ memoize (SCM exp, SCM env)
 
     case SCM_EXPANDED_LETREC:
       {
-        SCM vars, exps, body, undefs, inits, sets, new_env;
+        SCM vars, exps, body, undefs, new_env;
-        int i, nvars;
+        int i, nvars, in_order_p;
         
         vars = REF (exp, LETREC, GENSYMS);
         exps = REF (exp, LETREC, VALS);
         body = REF (exp, LETREC, BODY);
+        in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
         nvars = i = scm_ilength (vars);
-        inits = undefs = sets = SCM_EOL;
+        undefs = SCM_EOL;
         new_env = env;
 
-        for (; scm_is_pair (vars); vars = CDR (vars), i--)
+        for (; scm_is_pair (vars); vars = CDR (vars))
           {
             new_env = scm_cons (CAR (vars), new_env);
             undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
-            sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
-                                              MAKMEMO_LEX_REF (i-1)),
-                             sets);
           }
 
-        for (; scm_is_pair (exps); exps = CDR (exps))
+        if (in_order_p)
-          inits = scm_cons (memoize (CAR (exps), new_env), inits);
+          {
-        inits = scm_reverse_x (inits, SCM_UNDEFINED);
+            SCM body_exps = SCM_EOL;
-
+            for (; scm_is_pair (exps); exps = CDR (exps), i--)
-        return MAKMEMO_LET
+              body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
-          (undefs,
+                                                     memoize (CAR (exps), new_env)),
-           MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
+                                    body_exps);
-                                      memoize (body, new_env))));
+            body_exps = scm_cons (memoize (body, new_env), body_exps);
+            body_exps = scm_reverse_x (body_exps, SCM_UNDEFINED);
+            return MAKMEMO_LET (undefs, MAKMEMO_BEGIN (body_exps));
+          }
+        else
+          {
+            SCM sets = SCM_EOL, inits = SCM_EOL;
+            for (; scm_is_pair (exps); exps = CDR (exps), i--)
+              {
+                sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
+                                                  MAKMEMO_LEX_REF (i-1)),
+                                 sets);
+                inits = scm_cons (memoize (CAR (exps), new_env), inits);
+              }
+            inits = scm_reverse_x (inits, SCM_UNDEFINED);
+            return MAKMEMO_LET
+              (undefs,
+               MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
+                                          memoize (body, new_env))));
+          }
       }
 
     case SCM_EXPANDED_DYNLET:

module/ice-9/psyntax.scm

@@ -526,12 +526,12 @@
                               val-exps))))))
 
   (define build-letrec
-    (lambda (src ids vars val-exps body-exp)
+    (lambda (src in-order? ids vars val-exps body-exp)
       (if (null? vars)
           body-exp
           (begin
             (for-each maybe-name-value! ids val-exps)
-            (make-letrec src #f ids vars val-exps body-exp)))))
+            (make-letrec src in-order? ids vars val-exps body-exp)))))
 
 
   ;; FIXME: use a faster gensym
@@ -1483,7 +1483,7 @@
                                            (loop (cdr bs) er r-cache))
                                          (loop (cdr bs) er-cache r-cache)))))
                              (set-cdr! r (extend-env labels bindings (cdr r)))
-                             (build-letrec no-source
+                             (build-letrec no-source #f
                                            (map syntax->datum var-ids)
                                            vars
                                            (map (lambda (x)
@@ -2103,7 +2103,7 @@
                                   (new-vars (map gen-var ids)))
                               (let ((w (make-binding-wrap ids labels w))
                                     (r (extend-var-env labels new-vars r)))
-                                (build-letrec s
+                                (build-letrec s #f
                                               (map syntax->datum ids)
                                               new-vars
                                               (map (lambda (x) (chi x r w mod)) #'(val ...))
@@ -2112,6 +2112,27 @@
                      (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
 
 
+  (global-extend 'core 'letrec*
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ ((id val) ...) e1 e2 ...)
+                      (and-map id? #'(id ...))
+                      (let ((ids #'(id ...)))
+                        (if (not (valid-bound-ids? ids))
+                            (syntax-violation 'letrec* "duplicate bound variable" e)
+                            (let ((labels (gen-labels ids))
+                                  (new-vars (map gen-var ids)))
+                              (let ((w (make-binding-wrap ids labels w))
+                                    (r (extend-var-env labels new-vars r)))
+                                (build-letrec s #t
+                                              (map syntax->datum ids)
+                                              new-vars
+                                              (map (lambda (x) (chi x r w mod)) #'(val ...))
+                                              (chi-body #'(e1 e2 ...) 
+                                                        (source-wrap e w s mod) r w mod)))))))
+                     (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
+
+
   (global-extend 'core 'set!
                  (lambda (e r w s mod)
                    (syntax-case e ()