initial-transformers op, fancy define built-in, minor fixes

.gitignore

@@ -53,3 +53,6 @@ dkms.conf
 
 save/
 .vs/
+
+tests/r5rstest.ss
+tests/r7rstest.ss

i.c

@@ -888,7 +888,7 @@ define_instruction(rck) {
     obj *ks = &vmcloref(rd, 2), *ke = ks + n;
     if (ke-ks > 3 && *--ke == fixnum_obj(0) && *--ke == cx_callmv_2Dadapter_2Dclosure) {
       obj *sb = r + VM_REGC;
-      rd = *--ke; rx = fixnum_obj(0); n = ke - ks; /* cns */
+      rd = *--ke; rx = fixnum_obj(0); n = (int)(ke - ks); /* cns */
       /* arrange stack as follows: [ks..ke] [arg ...] */
       assert((cxg_rend - cxg_regs - VM_REGC) > n + c);
       if (c) objmove(sb+n, sp-c, c);
@@ -3387,6 +3387,11 @@ define_instruction(wriw) {
   gonexti();
 }
 
+define_instruction(itrs) {
+  ac = cx__2Atransformers_2A;
+  gonexti(); 
+}
+
 define_instruction(igp) {
   ac = bool_obj(isintegrable(ac));
   gonexti(); 

i.h

@@ -525,6 +525,7 @@ declare_instruction(exit,       "Z9\0t",        0,  "%exit",
 
 /* serialization and deserialization instructions */             
 declare_instruction(igp,        "U0",           0,  "integrable?",              '1', AUTOGL)
+declare_instruction(itrs,       "U1",           0,  "initial-transformers",     '0', AUTOGL)
 declare_instruction(rdsx,       "U3",           0,  "deserialize-sexp",         '1', AUTOGL)
 declare_instruction(rdsc,       "U4",           0,  "deserialize-code",         '1', AUTOGL)
 declare_instruction(iglk,       "U5",           0,  "lookup-integrable",        '1', AUTOGL)

n.c

@@ -1059,6 +1059,7 @@ static stab_t *stabfree(stab_t *p) {
 }
 static int stabnew(obj o, stab_t *p, int circ) {
   if (!o || notaptr(o) || notobjptr(o) || (circ && isaptr(objptr_from_obj(o)[-1]))) return 0;
+  else if (circ && isaptr(objptr_from_obj(o)[0])) return 0; /* opaque */ 
   else { /* v[i] is 0 or heap obj, possibly with lower bit set if it's not new */
     unsigned long h = (unsigned long)o; size_t sz = p->sz, i, j;
     for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1))
@@ -1387,7 +1388,10 @@ static void wrdatum(obj o, wenv_t *e) {
     }
     wrc('>', e);
   } else if (isprocedure(o)) {
-    char buf[60]; sprintf(buf, "#<procedure @%p>", objptr_from_obj(o)); wrs(buf, e);
+    char buf[60];
+    if (isobjptr(hblkref(o, 0))) sprintf(buf, "#<vmclosure @%p>", objptr_from_obj(o));
+    else sprintf(buf, "#<procedure @%p>", objptr_from_obj(o)); 
+    wrs(buf, e);
   } else if (isrecord(o)) {
     int i, n = recordlen(o);
     wrs("#<record ", e);

src/k.sf

@@ -357,7 +357,7 @@
                           (x-error "set& of a non-variable")))]))
       (x-error "improper set& form" (cons 'set& tail))))
 
-(define (xform-begin tail env)
+(define (xform-begin tail env) ; top-level
   (if (list? tail)
       (let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)])
         (if (and (pair? xexps) (null? (cdr xexps)))
@@ -467,20 +467,25 @@
            (let ([first (car body)] [rest (cdr body)])
              (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head env)])
                (case hval
-                 [(begin)
+                 [(begin) ; internal
                   (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)))
+                 [(define) ; internal
+                  (cond [(and (list2? tail) (null? (car tail))) ; idless
+                         (let ([init (cadr tail)])
+                           (loop env (cons #f ids) (cons init inits) (cons #f nids) rest))]
+                        [(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)
+                           (loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
+                        [(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail)))
+                         (let* ([id (caar tail)] [lambda-id (new-id (make-binding 'lambda 'lambda))] 
+                                [init (cons lambda-id (cons (cdar tail) (cdr tail)))]
+                                [nid (gensym (id->sym id))] [env (add-var id nid env)])
+                           (loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
+                        [else (x-error "improper define form" first)])]
+                 [(define-syntax) ; internal
                   (if (and (list2? tail) (id? (car tail))) 
                       (let* ([id (car tail)] [init (cadr tail)]
                              [env (add-binding id '(undefined) env)])
@@ -511,14 +516,19 @@
            (binding-set-val! (env (car ids)) (xform #t (car inits) env))
            (loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
 
-(define (xform-define tail env) ; top-level only
-  (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 tail env) ; top-level
+  (cond [(and (list2? tail) (null? (car tail))) ; idless
+         (xform #f (cadr tail) env)]
+        [(and (list2? tail) (id? (car tail)))
+         (list 'define (id->sym (car tail)) 
+           (xform #f (cadr tail) env))]
+        [(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail)))
+         (list 'define (id->sym (caar tail))
+           (xform-lambda (cons (cdar tail) (cdr tail)) env))] 
+        [else 
+         (x-error "improper define form" (cons 'define tail))]))
 
-(define (xform-define-syntax tail env) ; top-level only
+(define (xform-define-syntax tail env) ; top-level
   (if (and (list2? tail) (id? (car tail)))
       (list 'define-syntax (id->sym (car tail)) (xform #t (cadr tail) env))
       (x-error "improper define-syntax form" (cons 'define-syntax tail))))
@@ -702,18 +712,6 @@
         ; or (_ (litname ...) . rules)
         (list syntax-id (syntax-rules* env #f (cadr sexp) (cddr sexp))))))
 
-; non-recursive transformer for define relies on old definition
-
-(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)
-       (define name exp)]))))
-
 
 ;---------------------------------------------------------------------------------------------
 ; Runtime
@@ -1326,8 +1324,8 @@
                   (process-alias (cadr x) (caddr x) oport)
                   (process-syntax (cadr x) (caddr x) oport))))]
          [(eq? hval 'define)
-          (let ([xval (transform #f (caddr x))])
-            (process-define (cadr x) xval oport))]
+          (let* ([dval (transform #f x)] [xval (caddr dval)])
+            (process-define (cadr dval) xval oport))]
          [(procedure? hval)
           (process-top-form (hval x top-transformer-env) oport)]
          [else

src/n.sf

@@ -3391,6 +3391,7 @@ static stab_t *stabfree(stab_t *p) {
 }
 static int stabnew(obj o, stab_t *p, int circ) {
   if (!o || notaptr(o) || notobjptr(o) || (circ && isaptr(objptr_from_obj(o)[-1]))) return 0;
+  else if (circ && isaptr(objptr_from_obj(o)[0])) return 0; /* opaque */ 
   else { /* v[i] is 0 or heap obj, possibly with lower bit set if it's not new */
     unsigned long h = (unsigned long)o; size_t sz = p->sz, i, j;
     for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1))
@@ -3841,7 +3842,10 @@ static void wrdatum(obj o, wenv_t *e) {
     }
     wrc('>', e);
   } else if (isprocedure(o)) {
-    char buf[60]; sprintf(buf, \"#<procedure @%p>\", objptr_from_obj(o)); wrs(buf, e);
+    char buf[60];
+    if (isobjptr(hblkref(o, 0))) sprintf(buf, \"#<vmclosure @%p>\", objptr_from_obj(o));
+    else sprintf(buf, \"#<procedure @%p>\", objptr_from_obj(o)); 
+    wrs(buf, e);
   } else if (isrecord(o)) {
     int i, n = recordlen(o);
     wrs(\"#<record \", e);

src/t.scm

@@ -321,7 +321,7 @@
                           (x-error "set& of a non-variable")))]))
       (x-error "improper set& form" (cons 'set& tail))))
 
-(define (xform-begin tail env)
+(define (xform-begin tail env) ; top-level
   (if (list? tail)
       (let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)])
         (if (and (pair? xexps) (null? (cdr xexps)))
@@ -431,20 +431,25 @@
            (let ([first (car body)] [rest (cdr body)])
              (let* ([head (car first)] [tail (cdr first)] [hval (xform #t head env)])
                (case hval
-                 [(begin)
+                 [(begin) ; internal
                   (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)))
+                 [(define) ; internal
+                  (cond [(and (list2? tail) (null? (car tail))) ; idless
+                         (let ([init (cadr tail)])
+                           (loop env (cons #f ids) (cons init inits) (cons #f nids) rest))]
+                        [(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)
+                           (loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
+                        [(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail)))
+                         (let* ([id (caar tail)] [lambda-id (new-id (make-binding 'lambda 'lambda))] 
+                                [init (cons lambda-id (cons (cdar tail) (cdr tail)))]
+                                [nid (gensym (id->sym id))] [env (add-var id nid env)])
+                           (loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
+                        [else (x-error "improper define form" first)])]
+                 [(define-syntax) ; internal
                   (if (and (list2? tail) (id? (car tail))) 
                       (let* ([id (car tail)] [init (cadr tail)]
                              [env (add-binding id '(undefined) env)])
@@ -475,14 +480,19 @@
            (binding-set-val! (env (car ids)) (xform #t (car inits) env))
            (loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
 
-(define (xform-define tail env) ; top-level only
-  (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 tail env) ; top-level
+  (cond [(and (list2? tail) (null? (car tail))) ; idless
+         (xform #f (cadr tail) env)]
+        [(and (list2? tail) (id? (car tail)))
+         (list 'define (id->sym (car tail)) 
+           (xform #f (cadr tail) env))]
+        [(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail)))
+         (list 'define (id->sym (caar tail))
+           (xform-lambda (cons (cdar tail) (cdr tail)) env))] 
+        [else 
+         (x-error "improper define form" (cons 'define tail))]))
 
-(define (xform-define-syntax tail env) ; top-level only
+(define (xform-define-syntax tail env) ; top-level
   (if (and (list2? tail) (id? (car tail)))
       (list 'define-syntax (id->sym (car tail)) (xform #t (cadr tail) env))
       (x-error "improper define-syntax form" (cons 'define-syntax tail))))
@@ -666,15 +676,6 @@
         ; or (_ (litname ...) . rules)
         (list syntax-id (syntax-rules* env #f (cadr sexp) (cddr sexp))))))
 
-; non-recursive transformer for define relies on old definition
-
-(install-transformer! 'define
-  (let ([env (add-binding 'define 'define top-transformer-env)])
-    (syntax-rules* env #f '() '(
-      [(_ (name . args) . forms)
-       (define name (lambda args . forms))]
-      [(_ name exp)
-       (define name exp)]))))
 
 ; Remaining transformers are made with the help of syntax-rules*
 ; NB: order of installation is important -- each transformer can

t.c

@@ -259,13 +259,17 @@ char *t_code[] = {
   ".(i11),fc,.(i11),:0^[(i12)5}${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}"
   "}{f}?{.2a,.3da,${${.5,@(y7:id->sym)[01},@(y6:gensym)[01},${.(i11),.3,."
   "6,@(y7:add-var)[03},.9,.(i14),.3c,.(i14),.5c,.(i14),.7c,.4,:0^[(i15)5}"
-  ".4,'(s20:improper define form),@(y7:x-error)[(i11)2}'(y13:define-synta"
-  "x),.1v?{${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}}{f}?{.2a,.3da,${.(i"
-  "10),'(l1:y9:undefined;),.5,@(y11:add-binding)[03},.8,.(i13),tc,.(i13),"
-  ".4c,.(i13),.6c,.4,:0^[(i14)5}.4,'(s27:improper define-syntax form),@(y"
-  "7:x-error)[(i11)2}.1K0?{.5,${.9,.8,.6[02}c,.(i10),.(i10),.(i10),.(i10)"
-  ",:0^[(i11)5}.6,.(i11),.(i11)A8,.(i11)A8,.(i11)A8,@(y12:xform-labels)[("
-  "i11)5}.0,.5,.5A8,.5A8,.5A8,@(y12:xform-labels)[55}.!0.0^_1[25",
+  "${.4,@(y7:list2+?)[01}?{.2ap?{${.4aa,@(y3:id?)[01}?{${.4ad,@(y8:idslis"
+  "t?)[01}}{f}}{f}}{f}?{.2aa,${'(y6:lambda),'(y6:lambda)c,@(y6:new-id)[01"
+  "},.4d,.5adc,.1c,${${.6,@(y7:id->sym)[01},@(y6:gensym)[01},${.(i12),.3,"
+  ".7,@(y7:add-var)[03},.(i10),.(i15),.3c,.(i15),.5c,.(i15),.8c,.4,:0^[(i"
+  "16)5}.4,'(s20:improper define form),@(y7:x-error)[(i11)2}'(y13:define-"
+  "syntax),.1v?{${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}}{f}?{.2a,.3da,"
+  "${.(i10),'(l1:y9:undefined;),.5,@(y11:add-binding)[03},.8,.(i13),tc,.("
+  "i13),.4c,.(i13),.6c,.4,:0^[(i14)5}.4,'(s27:improper define-syntax form"
+  "),@(y7:x-error)[(i11)2}.1K0?{.5,${.9,.8,.6[02}c,.(i10),.(i10),.(i10),."
+  "(i10),:0^[(i11)5}.6,.(i11),.(i11)A8,.(i11)A8,.(i11)A8,@(y12:xform-labe"
+  "ls)[(i11)5}.0,.5,.5A8,.5A8,.5A8,@(y12:xform-labels)[55}.!0.0^_1[25",
 
   "P", "xform-labels",
   "%5n,n,.4,.4,.4,,#0.0,.(i11),.(i11),&3{%5.0u?{${:0,:1,&1{%1:0,.1,f,@(y5"
@@ -279,8 +283,10 @@ char *t_code[] = {
   "P", "xform-define",
   "%2${.2,@(y6:list2?)[01}?{.0au}{f}?{.1,.1da,f,@(y5:xform)[23}${.2,@(y6:"
   "list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xform)[03},${.3"
-  "a,@(y7:id->sym)[01},'(y6:define),l3]2}.0,'(y6:define)c,'(s20:improper "
-  "define form),@(y7:x-error)[22",
+  "a,@(y7:id->sym)[01},'(y6:define),l3]2}${.2,@(y7:list2+?)[01}?{.0ap?{${"
+  ".2aa,@(y3:id?)[01}?{${.2ad,@(y8:idslist?)[01}}{f}}{f}}{f}?{${.3,.3d,.4"
+  "adc,@(y12:xform-lambda)[02},${.3aa,@(y7:id->sym)[01},'(y6:define),l3]2"
+  "}.0,'(y6:define)c,'(s20:improper define form),@(y7:x-error)[22",
 
   "P", "xform-define-syntax",
   "%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,t,@(y5:xfo"
@@ -353,13 +359,6 @@ char *t_code[] = {
   "dd,.4da,f,.7,@(y13:syntax-rules*)[04},.1^,l2]3},'(y12:syntax-rules),@("
   "y20:install-transformer!)[02}",
 
-  "C", 0,
-  "${${@(y19:top-transformer-env),'(y6:define),'(y6:define),@(y11:add-bin"
-  "ding)[03},${'(l2:l2:py1:_;ppy4:name;y4:args;;y5:forms;;;l3:y6:define;y"
-  "4:name;py6:lambda;py4:args;y5:forms;;;;;l2:l3:y1:_;y4:name;y3:exp;;l3:"
-  "y6:define;y4:name;y3:exp;;;),n,f,.5,@(y13:syntax-rules*)[04}_1,'(y6:de"
-  "fine),@(y20:install-transformer!)[02}",
-
   "S", "install-sr-transformer!",
   "l4:y12:syntax-rules;l2:y5:quote;y12:syntax-rules;;l2:l3:y1:_;l2:y5:quo"
   "te;y4:name;;py12:syntax-rules;pl2:y3:lit;y3:...;;y5:rules;;;;l5:y26:in"