lambda*/case-lambda: initial implementation

i.c

@@ -372,6 +372,21 @@ define_instruction(brt) { int dx = fixnum_from_obj(*ip++); if (ac) ip += dx; gon
 
 define_instruction(brnot) { int dx = fixnum_from_obj(*ip++); if (!ac) ip += dx; gonexti(); }
 
+/* define_instruction(brcne) {
+  obj v = *ip++;
+  int dx = fixnum_from_obj(*ip++);
+  ip = (ac == v) ? ip : ip + dx;
+  gonexti(); 
+}
+
+define_instruction(brclt) {
+  obj v = *ip++;
+  int dx = fixnum_from_obj(*ip++);
+  // unsigned tagged fixnums can be compared as-is
+  ip = (ac >= v) ? ip : ip + dx; 
+  gonexti(); 
+} */
+
 define_instruction(sseti) {
   int i = fixnum_from_obj(*ip++);
   boxref(sref(i)) = ac;
@@ -474,6 +489,33 @@ define_instruction(save) {
 
 define_instruction(push) { spush(ac); gonexti(); }
 
+define_instruction(jdceq) {
+  obj v = *ip++, i = *ip++;
+  if (ac == v) {
+    rd = dref(fixnum_from_obj(i)); ckx(rd); 
+    rx = obj_from_fixnum(0);
+    callsubi();
+  }
+  gonexti();
+}
+
+define_instruction(jdcge) {
+  obj v = *ip++, i = *ip++;
+  if (ac >= v) { /* unsigned tagged fixnums can be compared as-is */
+    rd = dref(fixnum_from_obj(i)); ckx(rd); 
+    rx = obj_from_fixnum(0);
+    callsubi();
+  }
+  gonexti();
+}
+
+define_instruction(jdref) {
+  int i = fixnum_from_obj(*ip++); 
+  rd = dref(i); ckx(rd); 
+  rx = obj_from_fixnum(0);
+  callsubi();
+}
+
 define_instruction(call) {
   int n = fixnum_from_obj(*ip++); 
   ckx(ac); rd = ac; rx = obj_from_fixnum(0); 
@@ -542,6 +584,11 @@ define_instruction(shrarg) {
   gonexti();
 }
 
+define_instruction(aerr) {
+  fail("argument count error on entry");
+  gonexti();
+}
+
 define_instruction(shlit) { spush(ac); ac = *ip++; gonexti(); }
 define_instruction(shi0)  { spush(ac); ac = obj_from_fixnum(0); gonexti(); }
 
@@ -3118,6 +3165,27 @@ more:
         *--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
         goto more;
       } break;
+      /* case 'c': { cases 
+        fixnum_t n;
+        ra = sref(1); hp = rds_arg(r, sp, hp);
+        if (iseof(ra)) goto out;
+        hreserve(hbsz(3)*2, sp-r);
+        *--hp = sref(0); *--hp = pbr->g;  
+        *--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
+        *--hp = sref(0); *--hp = ra;  
+        *--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
+        ra = sref(1); hp = rds_block(r, sp, hp);
+        if (iseof(ra)) goto out;
+        n = length(ra);
+        hreserve(hbsz(3)*1, sp-r); 
+        *--hp = sref(0); *--hp = obj_from_fixnum(n);
+        *--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
+        if (n > 0) {
+          obj lp = lastpair(ra); assert(ispair(lp));
+          cdr(lp) = sref(0); sref(0) = ra;
+        }
+        goto more;
+      } break; */
       case 'b': { /* branches */
         fixnum_t n; int c;
         ra = sref(1); hp = rds_block(r, sp, hp);

i.h

@@ -51,6 +51,8 @@ declare_instruction(sbox,     "#",     1, NULL, 0, NULL)
 declare_instruction(br,       NULL,  'b', NULL, 0, NULL) 
 declare_instruction(brnot,    "?",   'b', NULL, 0, NULL) 
 declare_instruction(brt,      "~?",  'b', NULL, 0, NULL)  
+/* declare_instruction(brcne,    "|",   'c', NULL, 0, NULL) */
+/* declare_instruction(brclt,    "|!",  'c', NULL, 0, NULL) */ 
 declare_instruction(sseti,    ".!",    1, NULL, 0, NULL) 
 declare_instruction(dseti,    ":!",    1, NULL, 0, NULL)
 declare_instruction(gset,     "@!",  'g', NULL, 0, NULL)
@@ -62,6 +64,9 @@ declare_instruction(rcmv,     "K5",    0, NULL, 0, NULL)
 declare_instruction(sdmv,     "K6",    0, NULL, 0, NULL)
 declare_instruction(save,     "$",   's', NULL, 0, NULL)
 declare_instruction(push,     ",",     0, NULL, 0, NULL) 
+declare_instruction(jdceq,    "|",     2, NULL, 0, NULL)  
+declare_instruction(jdcge,    "|!",    2, NULL, 0, NULL)  
+declare_instruction(jdref,    "|!0",   1, NULL, 0, NULL) 
 declare_instruction(call,     "[0",    1, NULL, 0, NULL) 
 declare_instruction(scall,    "[",     2, NULL, 0, NULL)  
 declare_instruction(return,   "]0",    0, NULL, 0, NULL) 
@@ -70,6 +75,7 @@ declare_instruction(adrop,    "_",     1, NULL, 0, NULL)
 declare_instruction(pop,      "_!",    0, NULL, 0, NULL) 
 declare_instruction(atest,    "%",     1, NULL, 0, NULL)
 declare_instruction(shrarg,   "%!",    1, NULL, 0, NULL)
+declare_instruction(aerr,     "%%",    0, NULL, 0, NULL)
 
 /* popular instruction combos */
 declare_instruction(shlit,    ",'",    1, NULL, 0, NULL)

src/k.sf

@@ -142,9 +142,10 @@
 ;  <core> -> (ref <id>)
 ;  <core> -> (set! <id> <core>)
 ;  <core> -> (lambda <ids> <core>) where <ids> -> (<id> ...) | (<id> ... . <id>) | <id>
+;  <core> -> (lambda* (<arity> <core>) ...) where <arity> -> (<cnt> <rest?>) 
 ;  <core> -> (begin <core> ...)
 ;  <core> -> (if <core> <core> <core>)
-;  <core> -> (call <core> <core> ...) 
+;  <core> -> (call <core> <core> ...)
 
 ;  NB: (begin) is legit, returns unspecified value
 ;  on top level, these two extra core forms are legal:
@@ -152,6 +153,15 @@
 ;  <core> -> (define <id> <core>)
 ;  <core> -> (define-syntax <id> <transformer>)
 
+(define normalize-arity
+  (lambda (arity)
+    (if (and (list2? arity) (fixnum? (car arity)) (boolean? (cadr arity)))
+        arity
+        (let loop ([cnt 0] [l arity])
+          (cond [(pair? l) (loop (fx+ 1 cnt) (cdr l))]
+                [(null? l) (list cnt #f)]
+                [else (list cnt #t)])))))
+
 ; convention for 'flattened' <ids> is to put rest arg if any at the front
 (define flatten-idslist
   (lambda (ilist)
@@ -166,7 +176,6 @@
         (fx+ 1 (idslist-req-count (cdr ilist)))
         0)))
 
-
 ;---------------------------------------------------------------------------------------------
 ; Macro transformer (from Scheme to Scheme Core) derived from Al Petrofsky's EIOD 1.17
 ;---------------------------------------------------------------------------------------------
@@ -234,6 +243,7 @@
                   [(begin)         (xform-begin tail env)]
                   [(if)            (xform-if tail env)]
                   [(lambda)        (xform-lambda tail env)]
+                  [(lambda*)       (xform-lambda* tail env)]
                   [(body)          (xform-body tail env)]
                   [(define)        (xform-define (car tail) (cadr tail) env)]
                   [(define-syntax) (xform-define-syntax (car tail) (cadr tail) env)]
@@ -303,6 +313,17 @@
                   (xform-body (cdr tail) ienv)))]))
       (error 'transform "improper lambda body")))
 
+(define (xform-lambda* tail env)
+  (if (list? tail)
+      (cons 'lambda*
+         (map (lambda (aexp)
+                 (if (list2? aexp)
+                     (list (normalize-arity (car aexp))
+                           (xform #f (cadr aexp) env))
+                     (error 'transform "improper lambda* clause")))
+              tail))
+      (error 'transform "improper lambda* form")))
+
 (define (xform-body tail env)
   (if (null? tail)
       (list 'begin)
@@ -373,6 +394,7 @@
     (make-binding 'begin 'begin)
     (make-binding 'if 'if)
     (make-binding 'lambda 'lambda)
+    (make-binding 'lambda* 'lambda*)
     (make-binding 'body 'body)
     denotation-of-default-ellipsis))
 
@@ -639,6 +661,10 @@
   (syntax-rules ()
     [(_ test . rest) (if (not test) (begin . rest))]))
 
+(install-sr-transformer! 'case-lambda
+  (syntax-rules ()
+    [(_ [args . body] ...) (lambda* [args (lambda args . body)] ...)]))
+
 
 ;---------------------------------------------------------------------------------------------
 ; Runtime
@@ -754,6 +780,8 @@
          (find-free exp b))]
       [lambda (idsi exp)
        (find-free exp (set-union (flatten-idslist idsi) b))]
+      [lambda* clauses
+       (find-free* (map cadr clauses) b)]
       [if (test then else)
        (set-union
          (find-free test b)
@@ -784,6 +812,8 @@
          (find-sets x v))]
       [lambda (idsi exp)
        (find-sets exp (set-minus v (flatten-idslist idsi)))]
+      [lambda* clauses
+       (find-sets* (map cadr clauses) v)]
       [begin exps
        (find-sets* exps v)]
       [if (test then else)
@@ -899,6 +929,24 @@
            g (length ids) port)
          (write-char #\} port))
        (when k (write-char #\] port) (write-serialized-arg k port))]
+      [lambda* clauses
+       (do ([clauses (reverse clauses) (cdr clauses)] [l l (cons #f l)]) 
+            [(null? clauses)]
+         (codegen (cadr (car clauses)) l f s g #f port)
+         (write-char #\, port))
+       (write-char #\& port)
+       (write-serialized-arg (length clauses) port)
+       (write-char #\{ port)
+       (do ([clauses clauses (cdr clauses)] [i 0 (fx+ i 1)]) 
+            [(null? clauses)]
+         (let* ([arity (caar clauses)] [cnt (car arity)] [rest? (cadr arity)])
+           (write-char #\| port)
+           (if rest? (write-char #\! port))
+           (write-serialized-arg cnt port)
+           (write-serialized-arg i port)))
+       (write-char #\% port) (write-char #\% port)
+       (write-char #\} port)
+       (when k (write-char #\] port) (write-serialized-arg k port))]
       [call (exp . args)
        (cond [(and (eq? (car exp) 'lambda) (list? (cadr exp))
                    (fx=? (length args) (length (cadr exp))))