minor fixes preparing for library code

src/t.scm

@@ -108,6 +108,9 @@
          (begin result1 result2 ...)
          (sexp-case key clause clauses ...))]))
 
+(define symbol-append
+  (lambda syms (string->symbol (apply string-append (map symbol->string syms)))))
+
 ; unique symbol generator (poor man's version)
 (define gensym
   (let ([gsc 0])
@@ -195,6 +198,7 @@
 ;  <core> -> (call <core> <core> ...) 
 ;  <core> -> (integrable <ig> <core> ...) where <ig> is an index in the integrables table
 ;  <core> -> (asm <igs>) where <igs> is ig string leaving result in ac, e.g. "'2,'1+" 
+;  <core> -> (once <gid> <core>) where gid is always resolved as global
 
 ;  NB: (begin) is legit, returns unspecified value
 ;  on top level, these two extra core forms are legal:
@@ -306,7 +310,7 @@
 
 (define (xenv-lookup env id at)
   (or (env id at)
-      (error* "transformer: invalid identifier access" (list id at))))
+      (error* "transformer: invalid identifier access" (list id (id->sym id) at))))
 
 (define (xenv-ref env id) (xenv-lookup env id 'ref))
 
@@ -885,6 +889,8 @@
        (set-union (find-free exp b) (find-free* args b))]
       [asm (cstr)
        '()]
+      [once (gid exp)
+       (find-free exp b)]
       [(define define-syntax) tail
        (c-error "misplaced definition form" x)])))
 
@@ -929,6 +935,8 @@
        (set-union (find-sets exp v) (find-sets* args v))]
       [asm (cstr)
        '()]
+      [once (gid exp)
+       (find-sets exp)]
       [(define define-syntax) tail
        (c-error "misplaced definition form" x)])))
 
@@ -1213,6 +1221,11 @@
       [asm (cstr)
        (write-string cstr port)
        (when k (write-char #\] port) (write-serialized-arg k port))]
+      [once (gid exp)
+       (codegen `(if (integrable ,(lookup-integrable 'eq?) (ref ,gid) (quote #t)) 
+                     (begin)
+                     (begin (set! ,gid (quote #t)) ,exp)) 
+          l f s g k port)]
       [(define define-syntax) tail
        (c-error "misplaced definition form" x)])))
 
@@ -1404,7 +1417,7 @@
 ; name prefixes
 
 (define (fully-qualified-library-prefixed-name lib id)
-  (string->symbol (string-append (symbol->string (listname->symbol lib)) "?" (symbol->string id))))
+  (symbol-append (if (symbol? lib) lib (listname->symbol lib)) '? id))
 
 
 ;---------------------------------------------------------------------------------------------
@@ -1602,6 +1615,18 @@
                  (if p (cdr p) #f)))))]
         [else #f]))
 
+; add std libraries to root env as expand time mappings of library's symbolic name
+; to an identifyer-syntax expanding into (quote (<init-code> . <eal>)) form
+(for-each
+  (let ([syntax-id (new-id 'syntax (make-location 'syntax) #f)])
+    (lambda (p) 
+      (let* ([lib (car p)] [eal (cdr p)] [sym (listname->symbol lib)])
+        (define (libid-transformer sexp env)
+          (list syntax-id (list 'quote (cons '(begin) eal))))
+        (define-in-root-environment! sym 
+          (make-location libid-transformer) #t))))
+  *std-lib->alist-env*)
+
 
 ; combine explicit finite env1 with finite or infinite env2
 ; env1 here is a proper alist of bindings ((<id> . <location>) ...)

t.c

@@ -56,6 +56,10 @@ char *t_code[] = {
   "quote;y3:pat;;y3:key;;l4:y5:begin;y7:result1;y7:result2;y3:...;;l5:y9:"
   "sexp-case;y3:key;y6:clause;y7:clauses;y3:...;;;;",
 
+  "P", "symbol-append",
+  "%!0${${.4,@(y14:symbol->string),@(y5:%25map1)[02},@(y14:%25string-appe"
+  "nd),@(y13:apply-to-list)[02}X5]1",
+
   "C", 0,
   "'0,#0.0,&1{%!0'1,:0^I+:!0.0u?{'(i10),:0^X6,'(s1:#)S6X5]1}.0aY0?{'(i10)"
   ",:0^X6,'(s1:#)S6,.1aX4S6X5]1}'0:!0]1}_1@!(y6:gensym)",
@@ -167,8 +171,8 @@ char *t_code[] = {
   "%3.2,.2,'(y3:ref),l2,.2,@(y17:extend-xenv-local)[33",
 
   "P", "xenv-lookup",
-  "%3${.4,.4,.4[02},.0?{.0]4}.3,.3,l2,'(s38:transformer: invalid identifi"
+  "%3${.4,.4,.4[02},.0?{.0]4}.3,${.5,@(y7:id->sym)[01},.4,l3,'(s38:transf"
-  "er access),@(y6:error*)[42",
+  "ormer: invalid identifier access),@(y6:error*)[42",
 
   "P", "xenv-ref",
   "%2'(y3:ref),.2,.2,@(y11:xenv-lookup)[23",
@@ -473,9 +477,10 @@ char *t_code[] = {
   ",&1{%!1:0,.1,@(y10:find-free*)[22},@(y13:apply-to-list)[22}'(y4:call),"
   ".1aq?{.0d,.2,&1{%!1${:0,.3,@(y10:find-free*)[02},${:0,.5,@(y9:find-fre"
   "e)[02},@(y9:set-union)[22},@(y13:apply-to-list)[22}'(y3:asm),.1aq?{.0d"
-  ",&0{%1n]1},@(y13:apply-to-list)[22}'(l2:y6:define;y13:define-syntax;),"
+  ",&0{%1n]1},@(y13:apply-to-list)[22}'(y4:once),.1aq?{.0d,.2,&1{%2:0,.2,"
-  ".1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced definition form),@(y7:c-error)["
+  "@(y9:find-free)[22},@(y13:apply-to-list)[22}'(l2:y6:define;y13:define-"
-  "12},@(y13:apply-to-list)[22}'(y16:record-case-miss)]2",
+  "syntax;),.1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced definition form),@(y7:"
+  "c-error)[12},@(y13:apply-to-list)[22}'(y16:record-case-miss)]2",
 
   "P", "find-sets*",
   "%2.0u?{n]2}${.3,.3d,@(y10:find-sets*)[02},${.4,.4a,@(y9:find-sets)[02}"
@@ -501,10 +506,11 @@ char *t_code[] = {
   "10:integrable),.1aq?{.0d,.2,&1{%!1:0,.1,@(y10:find-sets*)[22},@(y13:ap"
   "ply-to-list)[22}'(y4:call),.1aq?{.0d,.2,&1{%!1${:0,.3,@(y10:find-sets*"
   ")[02},${:0,.5,@(y9:find-sets)[02},@(y9:set-union)[22},@(y13:apply-to-l"
-  "ist)[22}'(y3:asm),.1aq?{.0d,&0{%1n]1},@(y13:apply-to-list)[22}'(l2:y6:"
+  "ist)[22}'(y3:asm),.1aq?{.0d,&0{%1n]1},@(y13:apply-to-list)[22}'(y4:onc"
-  "define;y13:define-syntax;),.1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced defi"
+  "e),.1aq?{.0d,&0{%2.1,@(y9:find-sets)[21},@(y13:apply-to-list)[22}'(l2:"
-  "nition form),@(y7:c-error)[12},@(y13:apply-to-list)[22}'(y16:record-ca"
+  "y6:define;y13:define-syntax;),.1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced d"
-  "se-miss)]2",
+  "efinition form),@(y7:c-error)[12},@(y13:apply-to-list)[22}'(y16:record"
+  "-case-miss)]2",
 
   "P", "codegen",
   "%7'(y5:quote),.1aq?{.0d,.6,.8,&2{%1.0,t,.1v?{:0,'(ct)W0}{f,.1v?{:0,'(c"
@@ -621,9 +627,13 @@ char *t_code[] = {
   "write-serialized-arg)[02}${:5,.3g,@(y20:write-serialized-arg)[02}:5,'("
   "c})W0]2},@(y13:apply-to-list)[72}'(y3:asm),.1aq?{.0d,.6,.8,&2{%1${:0,."
   "3,@(y12:write-string)[02}:1?{:0,'(c])W0:0,:1,@(y20:write-serialized-ar"
-  "g)[12}]1},@(y13:apply-to-list)[72}'(l2:y6:define;y13:define-syntax;),."
+  "g)[12}]1},@(y13:apply-to-list)[72}'(y4:once),.1aq?{.0d,.7,.7,.7,.7,.7,"
-  "1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced definition form),@(y7:c-error)[1"
+  ".7,&6{%2:5,:4,:3,:2,:1,:0,n,n,.9c,n,n,tc,'(y5:quote)cc,.9c,'(y4:set!)c"
-  "2},@(y13:apply-to-list)[72}'(y16:record-case-miss)]7",
+  "c,'(y5:begin)cc,n,'(y5:begin)cc,n,n,tc,'(y5:quote)cc,n,.9c,'(y3:ref)cc"
+  ",'(y3:eq?)U5c,'(y10:integrable)cc,'(y2:if)c,@(y7:codegen)[27},@(y13:ap"
+  "ply-to-list)[72}'(l2:y6:define;y13:define-syntax;),.1aA0?{.0d,.1,&1{%!"
+  "0:0,'(s25:misplaced definition form),@(y7:c-error)[12},@(y13:apply-to-"
+  "list)[72}'(y16:record-case-miss)]7",
 
   "P", "compile-to-string",
   "%1P51,${.2,f,${n,.8,@(y9:find-free)[02},n,n,n,.9,@(y7:codegen)[07}.0P9"
@@ -733,8 +743,8 @@ char *t_code[] = {
   ":0[01}:1^[10}]1}.!0.0^_1[20},.3,.3,@(y24:call-with-input-file/lib)[33",
 
   "P", "fully-qualified-library-prefixed-name",
-  "%2${.3X4,'(s1:?),${.6,@(y16:listname->symbol)[01}X4,@(y14:%25string-ap"
+  "%2.1,'(y1:?),.2Y0?{.2}{${.4,@(y16:listname->symbol)[01}},@(y13:symbol-"
-  "pend)[03}X5]2",
+  "append)[23",
 
   "P", "env-lookup",
   "%3.0K0?{.2,'(l2:y3:ref;y4:set!;),.1A1?{.1,@(y7:old-den)[41}f]4}.1,,#0."
@@ -938,6 +948,12 @@ char *t_code[] = {
   "%1${.2,@(y18:std-lib->alist-env)[01},.0?{.0,.0,&1{%2'(y3:ref),.2q?{:0,"
   ".1A3,.0?{.0d]3}f]3}f]2}]3}f]2",
 
+  "C", 0,
+  "${@(y20:*std-lib->alist-env*),${f,'(y6:syntax)b,'(y6:syntax),@(y6:new-"
+  "id)[03},.0,&1{%1.0a,.1d,${.3,@(y16:listname->symbol)[01},,#0.2,:0,&2{%"
+  "2:1,'(l1:y5:begin;)c,'(y5:quote),l2,:0,l2]2}.!0t,.1^b,.3,@(y27:define-"
+  "in-root-environment!)[53}_1,@(y10:%25for-each1)[02}",
+
   "P", "adjoin-env",
   "%2.0u?{.1]2}${.3,.3d,@(y10:adjoin-env)[02},${'(y3:ref),.3,.5aa,@(y10:e"
   "nv-lookup)[03},.0?{.0,.0,.4adq?{.2]5}.0,.4ad,.5aa,'(s39:multiple ident"