support for var-less define; define-values & friends

s.c

@@ -16,6 +16,11 @@ char *s_code[] = {
   "l3:y12:syntax-rules;n;l2:py1:_;pl2:l2:y3:var;y4:init;;y3:...;;y5:forms"
   ";;;py4:body;pl3:y6:define;y3:var;y4:init;;py3:...;y5:forms;;;;;",
 
+  "S", "letrec*",
+  "l3:y12:syntax-rules;n;l2:py1:_;pl2:l2:y3:var;y4:expr;;y3:...;;y5:forms"
+  ";;;l5:y3:let;l2:l2:y3:var;f;;y3:...;;l3:y4:set!;y3:var;y4:expr;;y3:..."
+  ";py4:body;y5:forms;;;;",
+
   "S", "let",
   "l4:y12:syntax-rules;n;l2:py1:_;pl2:l2:y3:var;y4:init;;y3:...;;y5:forms"
   ";;;l3:py6:lambda;pl2:y3:var;y3:...;;y5:forms;;;y4:init;y3:...;;;l2:py1"
@@ -28,6 +33,49 @@ char *s_code[] = {
   "1:_;ppy5:first;y4:more;;y5:forms;;;l3:y3:let;l1:y5:first;;py4:let*;py4"
   ":more;y5:forms;;;;;",
 
+  "S", "let*-values",
+  "l5:y12:syntax-rules;n;l2:py1:_;pn;y5:forms;;;py4:body;y5:forms;;;l2:py"
+  "1:_;ppl2:l1:y1:a;;y1:x;;y2:b*;;y5:forms;;;l3:y3:let;l1:l2:y1:a;y1:x;;;"
+  "py11:let*-values;py2:b*;y5:forms;;;;;l2:py1:_;ppl2:y2:aa;y1:x;;y2:b*;;"
+  "y5:forms;;;l3:y16:call-with-values;l3:y6:lambda;n;y1:x;;l3:y6:lambda;y"
+  "2:aa;py11:let*-values;py2:b*;y5:forms;;;;;;",
+
+  "S", "%let-values-loop",
+  "l6:y12:syntax-rules;n;l2:py1:_;pl2:y5:new-b;y3:...;;py6:new-aa;py1:x;p"
+  "y6:map-b*;pn;pn;y5:forms;;;;;;;;l3:y11:let*-values;l3:y5:new-b;y3:...;"
+  "l2:y6:new-aa;y1:x;;;py3:let;py6:map-b*;y5:forms;;;;;l2:py1:_;pl2:y5:ne"
+  "w-b;y3:...;;py6:new-aa;py5:old-x;py6:map-b*;pn;ppl2:y2:aa;y1:x;;y2:b*;"
+  ";y5:forms;;;;;;;;py16:%25let-values-loop;pl3:y5:new-b;y3:...;l2:y6:new"
+  "-aa;y5:old-x;;;pn;py1:x;py6:map-b*;py2:aa;py2:b*;y5:forms;;;;;;;;;l2:p"
+  "y1:_;py6:new-b*;pl2:y5:new-a;y3:...;;py1:x;pl2:y5:map-b;y3:...;;ppy1:a"
+  ";y2:aa;;py2:b*;y5:forms;;;;;;;;py16:%25let-values-loop;py6:new-b*;pl3:"
+  "y5:new-a;y3:...;y5:tmp-a;;py1:x;pl3:y5:map-b;y3:...;l2:y1:a;y5:tmp-a;;"
+  ";py2:aa;py2:b*;y5:forms;;;;;;;;;l2:py1:_;py6:new-b*;pl2:y5:new-a;y3:.."
+  ".;;py1:x;pl2:y5:map-b;y3:...;;py1:a;py2:b*;y5:forms;;;;;;;;py16:%25let"
+  "-values-loop;py6:new-b*;ppy5:new-a;py3:...;y5:tmp-a;;;py1:x;pl3:y5:map"
+  "-b;y3:...;l2:y1:a;y5:tmp-a;;;pn;py2:b*;y5:forms;;;;;;;;;",
+
+  "S", "let-values",
+  "l4:y12:syntax-rules;n;l2:py1:_;pn;y5:forms;;;py3:let;pn;y5:forms;;;;l2"
+  ":py1:_;ppl2:y2:aa;y1:x;;y2:b*;;y5:forms;;;py16:%25let-values-loop;pn;p"
+  "n;py1:x;pn;py2:aa;py2:b*;y5:forms;;;;;;;;;",
+
+  "S", "%define-values-loop",
+  "l5:y12:syntax-rules;n;l2:l5:y1:_;y6:new-aa;l2:l2:y1:a;y5:tmp-a;;y3:..."
+  ";;n;y1:x;;l4:y5:begin;l3:y6:define;y1:a;l1:y5:begin;;;y3:...;l3:y6:def"
+  "ine;n;l3:y16:call-with-values;l3:y6:lambda;n;y1:x;;l4:y6:lambda;y6:new"
+  "-aa;l3:y4:set!;y1:a;y5:tmp-a;;y3:...;;;;;;l2:l5:y1:_;l2:y5:new-a;y3:.."
+  ".;;l2:y5:map-a;y3:...;;py1:a;y2:aa;;y1:x;;l5:y19:%25define-values-loop"
+  ";l3:y5:new-a;y3:...;y5:tmp-a;;l3:y5:map-a;y3:...;l2:y1:a;y5:tmp-a;;;y2"
+  ":aa;y1:x;;;l2:l5:y1:_;l2:y5:new-a;y3:...;;l2:y5:map-a;y3:...;;y1:a;y1:"
+  "x;;l5:y19:%25define-values-loop;py5:new-a;py3:...;y5:tmp-a;;;l3:y5:map"
+  "-a;y3:...;l2:y1:a;y5:tmp-a;;;n;y1:x;;;",
+
+  "S", "define-values",
+  "l4:y12:syntax-rules;n;l2:l3:y1:_;n;y1:x;;l3:y6:define;n;l3:y16:call-wi"
+  "th-values;l3:y6:lambda;n;y1:x;;l2:y6:lambda;n;;;;;l2:l3:y1:_;y2:aa;y1:"
+  "x;;l5:y19:%25define-values-loop;n;n;y2:aa;y1:x;;;",
+
   "S", "and",
   "l5:y12:syntax-rules;n;l2:l1:y1:_;;t;;l2:l2:y1:_;y4:test;;y4:test;;l2:p"
   "y1:_;py4:test;y5:tests;;;l4:y2:if;y4:test;py3:and;y5:tests;;f;;;",
@@ -45,14 +93,14 @@ char *s_code[] = {
   "4:rest;;;;;l2:py1:_;ppy1:x;y4:exps;;y4:rest;;;l4:y2:if;y1:x;py5:begin;"
   "y4:exps;;py4:cond;y4:rest;;;;",
 
-  "S", "case-test",
+  "S", "%case-test",
   "l4:y12:syntax-rules;l1:y4:else;;l2:l3:y1:_;y1:k;y4:else;;t;;l2:l3:y1:_"
   ";y1:k;y5:atoms;;l3:y4:memv;y1:k;l2:y5:quote;y5:atoms;;;;",
 
   "S", "case",
   "l3:y12:syntax-rules;n;l2:l4:y1:_;y1:x;py4:test;y5:exprs;;y3:...;;l3:y3"
-  ":let;l1:l2:y3:key;y1:x;;;l3:y4:cond;pl3:y9:case-test;y3:key;y4:test;;y"
-  "5:exprs;;y3:...;;;;",
+  ":let;l1:l2:y3:key;y1:x;;;l3:y4:cond;pl3:y10:%25case-test;y3:key;y4:tes"
+  "t;;y5:exprs;;y3:...;;;;",
 
   "S", "do",
   "l3:y12:syntax-rules;n;l2:l5:y1:_;l2:py3:var;py4:init;y4:step;;;y3:...;"
@@ -83,8 +131,8 @@ char *s_code[] = {
   "4:test;;py5:begin;y4:rest;;;;",
 
   "S", "case-lambda",
-  "l3:y12:syntax-rules;n;l2:l3:y1:_;py4:args;y4:body;;y3:...;;l3:y7:lambd"
-  "a*;l2:y4:args;py6:lambda;py4:args;y4:body;;;;y3:...;;;",
+  "l3:y12:syntax-rules;n;l2:l3:y1:_;py4:args;y5:forms;;y3:...;;l3:y7:lamb"
+  "da*;l2:y4:args;py6:lambda;py4:args;y5:forms;;;;y3:...;;;",
 
   "P", "floor/",
   "%2.1,.1G4,.2,.2G3,@(y6:values)[22",

src/k.sf

@@ -439,41 +439,53 @@
       (x-error "improper withcc form" (cons 'withcc tail))))
 
 (define (xform-body tail env)
-  (if (null? tail)
-      (list 'begin)
-      (let loop ([env env] [ids '()] [inits '()] [nids '()] [body tail])
-        (if (and (pair? body) (pair? (car body)))
-            (let ([first (car body)] [rest (cdr body)])
-              (let* ([head (car first)] [hval (xform #t head env)])
-                (case hval
-                  [(begin)
-                   (loop env ids inits nids (append (cdr first) rest))]
-                  [(define)
-                   (let* ([id (cadr first)] [init (caddr first)]
-                          [nid (gensym (id->sym id))] [env (add-var id nid env)])
-                     (loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
-                  [(define-syntax)
-                   (let* ([id (cadr first)] [init (caddr first)]
-                          [env (add-binding id '(undefined) env)])
-                     (loop env (cons id ids) (cons init inits) (cons #t nids) rest))]
-                  [else
-                   (if (procedure? hval)
-                       (loop env ids inits nids (cons (hval first env) rest))
-                       (xform-labels (reverse ids) (reverse inits) (reverse nids) body env))])))
-            (xform-labels (reverse ids) (reverse inits) (reverse nids) body env)))))
+  (cond
+    [(null? tail) 
+     (list 'begin)]
+    [(not (list? tail))
+     (x-error "improper body form" (cons 'body tail))]
+    [else
+     (let loop ([env env] [ids '()] [inits '()] [nids '()] [body tail])
+       (if (and (pair? body) (pair? (car body)))
+           (let ([first (car body)] [rest (cdr body)])
+             (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head env)])
+               (case hval
+                 [(begin)
+                  (if (list? tail) 
+                      (loop env ids inits nids (append tail rest))
+                      (x-error "improper begin form" first))]
+                 [(define)
+                  (if (and (list2? tail) (null? (car tail))) 
+                      (let ([init (cadr tail)]) ; idless
+                        (loop env (cons #f ids) (cons init inits) (cons #f nids) rest))
+                      (if (and (list2? tail) (id? (car tail)))
+                          (let* ([id (car tail)] [init (cadr tail)]
+                                 [nid (gensym (id->sym id))] [env (add-var id nid env)])
+                            (loop env (cons id ids) (cons init inits) (cons nid nids) rest))
+                      (x-error "improper define form" first)))]
+                 [(define-syntax)
+                  (if (and (list2? tail) (id? (car tail))) 
+                      (let* ([id (car tail)] [init (cadr tail)]
+                             [env (add-binding id '(undefined) env)])
+                        (loop env (cons id ids) (cons init inits) (cons #t nids) rest))
+                      (x-error "improper define-syntax form" first))]
+                 [else
+                  (if (procedure? hval)
+                      (loop env ids inits nids (cons (hval first env) rest))
+                      (xform-labels (reverse ids) (reverse inits) (reverse nids) body env))])))
+           (xform-labels (reverse ids) (reverse inits) (reverse nids) body env)))]))
 
 (define (xform-labels ids inits nids body env)
   (let loop ([ids ids] [inits inits] [nids nids] [sets '()] [lids '()])
     (cond [(null? ids) 
-           (let* ([xexps (append (reverse sets)
-                           (map (lambda (sexp) (xform #f sexp env)) body))]
-                  [xexp (if (and (pair? xexps) (null? (cdr xexps)))
-                            (car xexps)
-                            (cons 'begin xexps))])
-             (if (null? lids)
-                 xexp
+           (let* ([xexps (append (reverse sets) (map (lambda (x) (xform #f x env)) body))]
+                  [xexp (if (list1? xexps) (car xexps) (cons 'begin xexps))])
+             (if (null? lids) xexp
                  (pair* 'call (list 'lambda (reverse lids) xexp)
                    (map (lambda (lid) '(begin)) lids))))]
+          [(not (car ids)) ; idless define
+           (loop (cdr ids) (cdr inits) (cdr nids)
+             (cons (xform #f (car inits) env) sets) lids)]
           [(symbol? (car nids)) ; define
            (loop (cdr ids) (cdr inits) (cdr nids)
              (cons (xform-set! (list (car ids) (car inits)) env) sets)
@@ -483,9 +495,11 @@
            (loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
 
 (define (xform-define tail env) ; top-level only
-  (if (and (list2? tail) (id? (car tail)))
-      (list 'define (id->sym (car tail)) (xform #f (cadr tail) env))
-      (x-error "improper define form" (cons 'define tail))))
+  (if (and (list2? tail) (null? (car tail))) ; idless
+      (xform #f (cadr tail) env)
+      (if (and (list2? tail) (id? (car tail)))
+          (list 'define (id->sym (car tail)) (xform #f (cadr tail) env))
+          (x-error "improper define form" (cons 'define tail)))))
 
 (define (xform-define-syntax tail env) ; top-level only
   (if (and (list2? tail) (id? (car tail)))
@@ -674,6 +688,8 @@
 (install-transformer! 'define
   (let ([env (add-binding 'define 'define top-transformer-env)])
     (syntax-rules* env #f '() '(
+      [(_ () exp) ; idless
+       (define () exp)]
       [(_ (name . args) . forms)
        (define name (lambda args . forms))]
       [(_ name exp)
@@ -813,7 +829,9 @@
       [integrable (ig . args)
        (find-free* args b)]
       [call (exp . args)
-       (set-union (find-free exp b) (find-free* args b))])))
+       (set-union (find-free exp b) (find-free* args b))]
+      [define tail
+       (c-error "misplaced define form" x)])))
 
 (define find-sets*
   (lambda (x* v)
@@ -853,7 +871,9 @@
       [integrable (ig . args)
        (find-sets* args v)]
       [call (exp . args)
-       (set-union (find-sets exp v) (find-sets* args v))])))
+       (set-union (find-sets exp v) (find-sets* args v))]
+      [define tail
+       (c-error "misplaced define form" x)])))
 
 (define codegen
   ; x: Scheme Core expression to compile
@@ -1123,7 +1143,9 @@
               (write-char #\[ port)
               (write-serialized-arg 0 port)
               (write-serialized-arg (length args) port)
-              (write-char #\} port)])])))
+              (write-char #\} port)])]
+      [define tail
+       (c-error "misplaced define form" x)])))
 
 (define (compile-to-string x)
   (let ([p (open-output-string)])

src/s.scm

@@ -13,14 +13,14 @@
 ; (quote const)
 ; (set! id expr)
 ; (set& id)
-; (letcc id expr) 
-; (withcc expr expr ...) 
 ; (if expr1 expr2)
 ; (if expr1 expr2 expr3)
 ; (begin expr ...)
-; (body expr ...) -- lexical scope for definitions
 ; (lambda args expr ...)
 ; (lambda* [arity expr] ...)
+; (body expr ...) -- lexical scope for definitions
+; (letcc id expr) 
+; (withcc expr expr ...) 
 ; (define id expr)
 ; (define (id . args) expr ...)
 ; (define-syntax kw form)
@@ -46,6 +46,14 @@
     [(_ ([var init] ...) . forms)
      (body (define var init) ... . forms)]))
 
+(define-syntax letrec*
+  (syntax-rules ()
+    [(_ ([var expr] ...) . forms)
+     (let ([var #f] ...)
+       (set! var expr)
+       ...
+       (body . forms))]))
+
 (define-syntax let
   (syntax-rules ()
     [(_ ([var init] ...) . forms)
@@ -60,6 +68,45 @@
     [(_ (first . more) . forms)
      (let (first) (let* more . forms))]))
 
+(define-syntax let*-values
+  (syntax-rules ()
+    [(_ () . forms) (body . forms)]
+    [(_ ([(a) x] . b*) . forms) (let ([a x]) (let*-values b* . forms))]
+    [(_ ([aa x] . b*) . forms) (call-with-values (lambda () x) (lambda aa (let*-values b* . forms)))]))
+
+(define-syntax %let-values-loop
+  (syntax-rules ()
+    [(_ (new-b ...) new-aa x map-b* () () . forms)
+     (let*-values (new-b ... [new-aa x]) (let map-b* . forms))]
+    [(_ (new-b ...) new-aa old-x map-b* () ([aa x] . b*) . forms)
+     (%let-values-loop (new-b ... [new-aa old-x]) () x map-b* aa b* . forms)]
+    [(_ new-b* (new-a ...) x (map-b ...) (a . aa) b* . forms)
+     (%let-values-loop new-b* (new-a ... tmp-a) x (map-b ... [a tmp-a]) aa b* . forms)]
+    [(_ new-b* (new-a ...) x (map-b ...) a b* . forms) 
+     (%let-values-loop new-b* (new-a ... . tmp-a) x (map-b ... [a tmp-a]) () b* . forms)]))
+
+(define-syntax let-values
+  (syntax-rules ()
+    [(_ () . forms) (let () . forms)]
+    [(_ ([aa x] . b*) . forms)
+     (%let-values-loop () () x () aa b* . forms)]))
+
+(define-syntax %define-values-loop
+  (syntax-rules ()
+    [(_ new-aa ([a tmp-a] ...) () x)
+     (begin
+       (define a (begin)) ...
+       (define () (call-with-values (lambda () x) (lambda new-aa (set! a tmp-a) ...))))]
+    [(_ (new-a ...) (map-a ...) (a . aa) x) 
+     (%define-values-loop (new-a ... tmp-a) (map-a ... [a tmp-a]) aa x)]
+    [(_ (new-a ...) (map-a ...) a x) 
+     (%define-values-loop (new-a ... . tmp-a) (map-a ... [a tmp-a]) () x)]))
+
+(define-syntax define-values
+  (syntax-rules ()
+    [(_ () x) (define () (call-with-values (lambda () x) (lambda ())))] ; use idless define
+    [(_ aa x) (%define-values-loop () () aa x)]))
+
 (define-syntax and
   (syntax-rules ()
     [(_) #t]
@@ -80,7 +127,7 @@
     [(_ (x => proc) . rest) (let ([tmp x]) (cond [tmp (proc tmp)] . rest))]
     [(_ (x . exps) . rest) (if x (begin . exps) (cond . rest))]))
 
-(define-syntax case-test
+(define-syntax %case-test
   (syntax-rules (else) 
     [(_ k else) #t]
     [(_ k atoms) (memv k 'atoms)]))
@@ -88,7 +135,7 @@
 (define-syntax case
   (syntax-rules ()
     [(_ x (test . exprs) ...)
-     (let ([key x]) (cond ((case-test key test) . exprs) ...))]))
+     (let ([key x]) (cond ((%case-test key test) . exprs) ...))]))
 
 (define-syntax do
   (syntax-rules ()
@@ -117,7 +164,7 @@
 
 (define-syntax case-lambda
   (syntax-rules ()
-    [(_ [args . body] ...) (lambda* [args (lambda args . body)] ...)]))
+    [(_ [args . forms] ...) (lambda* [args (lambda args . forms)] ...)]))
 
 ;cond-expand