evaluator support for case-lambda

* libguile/memoize.c (patch_case_lambda, scm_m_case_lambda)
  (scm_m_case_lambda_star): Add memoizers for case-lambda and
  case-lambda*.
  (unmemoize): Unmemoize lambdas with multiple arities.

* libguile/eval.c (prepare_boot_closure_env_for_apply):
  (prepare_boot_closure_env_for_eval): Adapt to return both body and
  env, so that case-lambda clauses can be selected appropriately.
  (eval, boot_closure_apply): Adapt callers.

* module/ice-9/eval.scm (make-general-closure): Support multiple
  arities.

libguile/eval.c

@@ -124,9 +124,11 @@ static scm_t_bits scm_tc16_boot_closure;
     inits = CAR (mx); mx = CDR (mx);                            \
     alt = CAR (mx);                                             \
   } while (0)
-static SCM prepare_boot_closure_env_for_apply (SCM proc, SCM args);
+static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
-static SCM prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
+                                                SCM *out_body, SCM *out_env);
-                                              SCM exps, SCM env);
+static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
+                                               SCM exps, SCM *out_body,
+                                               SCM *inout_env);
 
 
 #define CAR(x)   SCM_CAR(x)
@@ -270,8 +272,7 @@ eval (SCM x, SCM env)
        * ARGS is the list of arguments. */
       if (BOOT_CLOSURE_P (proc))
         {
-          x = BOOT_CLOSURE_BODY (proc);
+          prepare_boot_closure_env_for_apply (proc, args, &x, &env);
-          env = prepare_boot_closure_env_for_apply (proc, args);
           goto loop;
         }
       else
@@ -285,8 +286,7 @@ eval (SCM x, SCM env)
 
       if (BOOT_CLOSURE_P (proc))
         {
-          x = BOOT_CLOSURE_BODY (proc);
+          prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
-          env = prepare_boot_closure_env_for_eval (proc, argc, mx, env);
           goto loop;
         }
       else
@@ -900,8 +900,9 @@ scm_apply (SCM proc, SCM arg1, SCM args)
   return scm_vm_apply (scm_the_vm (), proc, args);
 }
 
-static SCM
+static void
-prepare_boot_closure_env_for_apply (SCM proc, SCM args)
+prepare_boot_closure_env_for_apply (SCM proc, SCM args,
+                                    SCM *out_body, SCM *out_env)
 {
   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
   SCM env = BOOT_CLOSURE_ENV (proc);
@@ -913,6 +914,8 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args)
         scm_wrong_num_args (proc);
       for (; scm_is_pair (args); args = CDR (args))
         env = scm_cons (CAR (args), env);
+      *out_body = BOOT_CLOSURE_BODY (proc);
+      *out_env = env;
     }
   else if (BOOT_CLOSURE_IS_REST (proc))
     {
@@ -921,26 +924,35 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args)
       for (; nreq; nreq--, args = CDR (args))
         env = scm_cons (CAR (args), env);
       env = scm_cons (args, env);
+      *out_body = BOOT_CLOSURE_BODY (proc);
+      *out_env = env;
     }
   else
     {
       int i, argc, nreq, nopt;
       SCM body, rest, kw, inits, alt;
       
+    loop:
       BOOT_CLOSURE_PARSE_FULL (proc, body, nargs, rest, nopt, kw, inits, alt);
 
       argc = scm_ilength (args);
       if (argc < nreq)
         {
           if (scm_is_true (alt))
-            abort ();
+            {
+              proc = alt;
+              goto loop;
+            }
           else
             scm_wrong_num_args (proc);
         }
       if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
         {
           if (scm_is_true (alt))
-            abort ();
+            {
+              proc = alt;
+              goto loop;
+            }
           else
             scm_wrong_num_args (proc);
         }
@@ -1035,14 +1047,15 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args)
               }
           }
         }
-    }
 
-  return env;
+      *out_body = BOOT_CLOSURE_BODY (proc);
+      *out_env = env;
+    }
 }
 
-static SCM
+static void
 prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
-                                   SCM exps, SCM env)
+                                   SCM exps, SCM *out_body, SCM *inout_env)
 {
   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
   SCM new_env = BOOT_CLOSURE_ENV (proc);
@@ -1051,40 +1064,44 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
           && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
     {
       for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
-        new_env = scm_cons (eval (CAR (exps), env), new_env);
+        new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
       if (SCM_UNLIKELY (nreq != 0))
         scm_wrong_num_args (proc);
+      *out_body = BOOT_CLOSURE_BODY (proc);
+      *inout_env = new_env;
     }
   else if (BOOT_CLOSURE_IS_REST (proc))
     {
       if (SCM_UNLIKELY (argc < nreq))
         scm_wrong_num_args (proc);
       for (; nreq; nreq--, exps = CDR (exps))
-        new_env = scm_cons (eval (CAR (exps), env), new_env);
+        new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
       {
         SCM rest = SCM_EOL;
         for (; scm_is_pair (exps); exps = CDR (exps))
-          rest = scm_cons (eval (CAR (exps), env), rest);
+          rest = scm_cons (eval (CAR (exps), *inout_env), rest);
         new_env = scm_cons (scm_reverse (rest),
                             new_env);
       }
+      *out_body = BOOT_CLOSURE_BODY (proc);
+      *inout_env = new_env;
     }
   else
     {
       SCM args = SCM_EOL;
       for (; scm_is_pair (exps); exps = CDR (exps))
-        args = scm_cons (eval (CAR (exps), env), args);
+        args = scm_cons (eval (CAR (exps), *inout_env), args);
-      scm_reverse_x (args, SCM_UNDEFINED);
+      args = scm_reverse_x (args, SCM_UNDEFINED);
-      new_env = prepare_boot_closure_env_for_apply (proc, args);
+      prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
     }
-  return new_env;
 }
 
 static SCM
 boot_closure_apply (SCM closure, SCM args)
 {
-  return eval (BOOT_CLOSURE_BODY (closure),
+  SCM body, env;
-               prepare_boot_closure_env_for_apply (closure, args));
+  prepare_boot_closure_env_for_apply (closure, args, &body, &env);
+  return eval (body, env);
 }
 
 static int
@@ -1098,6 +1115,7 @@ boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
                         scm_from_locale_symbol ("_"));
   if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
     args = scm_cons_star (scm_from_locale_symbol ("_"), args);
+  /* FIXME: optionals and rests */
   scm_display (args, port);
   scm_putc ('>', port);
   return 1;

libguile/memoize.c

@@ -273,6 +273,8 @@ static SCM scm_m_eval_when (SCM xorig, SCM env);
 static SCM scm_m_if (SCM xorig, SCM env);
 static SCM scm_m_lambda (SCM xorig, SCM env);
 static SCM scm_m_lambda_star (SCM xorig, SCM env);
+static SCM scm_m_case_lambda (SCM xorig, SCM env);
+static SCM scm_m_case_lambda_star (SCM xorig, SCM env);
 static SCM scm_m_let (SCM xorig, SCM env);
 static SCM scm_m_letrec (SCM xorig, SCM env);
 static SCM scm_m_letstar (SCM xorig, SCM env);
@@ -431,6 +433,8 @@ SCM_SYNTAX (s_letrec, "letrec", scm_m_letrec);
 SCM_SYNTAX (s_letstar, "let*", scm_m_letstar);
 SCM_SYNTAX (s_or, "or", scm_m_or);
 SCM_SYNTAX (s_lambda_star, "lambda*", scm_m_lambda_star);
+SCM_SYNTAX (s_case_lambda, "case-lambda", scm_m_case_lambda);
+SCM_SYNTAX (s_case_lambda_star, "case-lambda*", scm_m_case_lambda_star);
 
 SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
 SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
@@ -457,6 +461,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
 SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
 SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
 SCM_SYMBOL (sym_lambda_star, "lambda*");
+SCM_SYMBOL (sym_case_lambda, "case-lambda");
+SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
 SCM_SYMBOL (sym_eval, "eval");
 SCM_SYMBOL (sym_load, "load");
 
@@ -903,6 +909,83 @@ scm_m_lambda_star (SCM expr, SCM env)
                                              SCM_BOOL_F));
 }
 
+static SCM
+patch_case_lambda (SCM a, SCM b)
+{
+  SCM mx, body, rest, kw_indices, inits;
+  int nreq, nopt;
+
+  mx = SCM_SMOB_OBJECT_1 (a);
+  body = CAR (mx);
+  mx = CDR (mx);
+
+  if (scm_is_null (CDR (mx)))
+    {
+      nreq = scm_to_int16 (CAR (mx));
+      rest = SCM_BOOL_F;
+      nopt = 0;
+      kw_indices = SCM_BOOL_F;
+      inits = SCM_EOL;
+    }
+  else if (scm_is_null (CDDR (mx)))
+    {
+      nreq = scm_to_int16 (CAR (mx));
+      rest = CADR (mx);
+      nopt = 0;
+      kw_indices = SCM_BOOL_F;
+      inits = SCM_EOL;
+    }
+  else
+    {
+      nreq = scm_to_int16 (CAR (mx));
+      rest = CADR (mx);
+      nopt = scm_to_int16 (CADDR (mx));
+      kw_indices = CADDDR (mx);
+      inits = CADR (CDDDR (mx));
+    }
+
+  return MAKMEMO_LAMBDA
+    (body, FULL_ARITY (nreq, rest, nopt, kw_indices, inits, b));
+}
+
+static SCM
+scm_m_case_lambda (SCM expr, SCM env)
+{
+  SCM ret, clauses;
+
+  const long length = scm_ilength (expr);
+  ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
+  ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+  clauses = scm_reverse (CDR (expr));
+  ret = SCM_BOOL_F;
+  
+  for (; scm_is_pair (clauses); clauses = CDR (clauses))
+    ret = patch_case_lambda
+      (scm_m_lambda (scm_cons (scm_sym_lambda, CAR (clauses)), env), ret);
+  
+  return ret;
+}
+
+static SCM
+scm_m_case_lambda_star (SCM expr, SCM env)
+{
+  SCM ret, clauses;
+
+  const long length = scm_ilength (expr);
+  ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
+  ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+  clauses = scm_reverse (CDR (expr));
+  ret = SCM_BOOL_F;
+  
+  for (; scm_is_pair (clauses); clauses = CDR (clauses))
+    ret = patch_case_lambda
+      (scm_m_lambda_star (scm_cons (sym_lambda_star, CAR (clauses)), env), ret);
+  
+  return ret;
+}
+
 /* Check if the format of the bindings is ((<symbol> <init-form>) ...).  */
 static void
 check_bindings (const SCM bindings, const SCM expr)
@@ -1521,19 +1604,23 @@ unmemoize (const SCM expr)
         }
       else
         {
-          SCM body = CAR (args), spec = CDR (args), alt;
+          SCM body = CAR (args), spec = CDR (args), alt, tail;
           
           alt = CADDR (CDDDR (spec));
           if (scm_is_true (alt))
-            abort ();
+            tail = CDR (unmemoize (alt));
+          else
+            tail = SCM_EOL;
           
-          return scm_list_3 (sym_lambda_star,
+          return scm_cons
-                             scm_list_5 (CAR (spec),
+            (sym_case_lambda_star,
+             scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
                                                CADR (spec),
                                                CADDR (spec),
                                                CADDDR (spec),
                                                unmemoize_exprs (CADR (CDDDR (spec)))),
-                             unmemoize (body));
+                                   unmemoize (body)),
+                       tail));
         }
     case SCM_M_LET:
       return scm_list_3 (scm_sym_let,

module/ice-9/eval.scm

@@ -218,20 +218,26 @@
     ;; A unique marker for unbound keywords.
     (define unbound-arg (list 'unbound-arg))
 
-    ;; Procedures with rest, optional, or keyword arguments.
+    ;; Procedures with rest, optional, or keyword arguments, potentially with
+    ;; multiple arities, as with case-lambda.
     (define (make-general-closure env body nreq rest? nopt kw inits alt)
-      (lambda args
+      (define alt-proc
+        (and alt
+             (apply make-general-closure env (memoized-expression-data alt))))
+      (lambda %args
         (let lp ((env env)
-                 (nreq nreq)
+                 (nreq* nreq)
-                 (args args))
+                 (args %args))
-          (if (> nreq 0)
+          (if (> nreq* 0)
               ;; First, bind required arguments.
               (if (null? args)
+                  (if alt
+                      (apply alt-proc %args)
                       (scm-error 'wrong-number-of-args
                                  "eval" "Wrong number of arguments"
-                             '() #f)
+                                 '() #f))
                   (lp (cons (car args) env)
-                      (1- nreq)
+                      (1- nreq*)
                       (cdr args)))
               ;; Move on to optional arguments.
               (if (not kw)
@@ -245,9 +251,11 @@
                             (eval body (cons args env))
                             (if (null? args)
                                 (eval body env)
+                                (if alt
+                                    (apply alt-proc %args)
                                     (scm-error 'wrong-number-of-args
                                                "eval" "Wrong number of arguments"
-                                           '() #f)))
+                                               '() #f))))
                         (if (null? args)
                             (lp (cons (eval (car inits) env) env)
                                 (1- nopt) args (cdr inits))