From 9a4cafc28dc918b97102c78a19d0f0c20b068508 Mon Sep 17 00:00:00 2001 From: ESL Date: Mon, 24 Jun 2024 18:01:34 -0400 Subject: [PATCH] minor fixes preparing for library code --- src/t.scm | 29 +++++++++++++++++++++++++++-- t.c | 44 ++++++++++++++++++++++++++++++-------------- 2 files changed, 57 insertions(+), 16 deletions(-) diff --git a/src/t.scm b/src/t.scm index d7892dc..230a8f5 100644 --- a/src/t.scm +++ b/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 @@ ; -> (call ...) ; -> (integrable ...) where is an index in the integrables table ; -> (asm ) where is ig string leaving result in ac, e.g. "'2,'1+" +; -> (once ) 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 ( . )) 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 (( . ) ...) diff --git a/t.c b/t.c index eb0265c..8d30167 100644 --- a/t.c +++ b/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" - "er access),@(y6:error*)[42", + "%3${.4,.4,.4[02},.0?{.0]4}.3,${.5,@(y7:id->sym)[01},.4,l3,'(s38:transf" + "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;)," - ".1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced definition form),@(y7:c-error)[" - "12},@(y13:apply-to-list)[22}'(y16:record-case-miss)]2", + ",&0{%1n]1},@(y13:apply-to-list)[22}'(y4:once),.1aq?{.0d,.2,&1{%2:0,.2," + "@(y9:find-free)[22},@(y13:apply-to-list)[22}'(l2:y6:define;y13:define-" + "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:" - "define;y13:define-syntax;),.1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced defi" - "nition form),@(y7:c-error)[12},@(y13:apply-to-list)[22}'(y16:record-ca" - "se-miss)]2", + "ist)[22}'(y3:asm),.1aq?{.0d,&0{%1n]1},@(y13:apply-to-list)[22}'(y4:onc" + "e),.1aq?{.0d,&0{%2.1,@(y9:find-sets)[21},@(y13:apply-to-list)[22}'(l2:" + "y6:define;y13:define-syntax;),.1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced d" + "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;),." - "1aA0?{.0d,.1,&1{%!0:0,'(s25:misplaced definition form),@(y7:c-error)[1" - "2},@(y13:apply-to-list)[72}'(y16:record-case-miss)]7", + "g)[12}]1},@(y13:apply-to-list)[72}'(y4:once),.1aq?{.0d,.7,.7,.7,.7,.7," + ".7,&6{%2:5,:4,:3,:2,:1,:0,n,n,.9c,n,n,tc,'(y5:quote)cc,.9c,'(y4:set!)c" + "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" - "pend)[03}X5]2", + "%2.1,'(y1:?),.2Y0?{.2}{${.4,@(y16:listname->symbol)[01}},@(y13:symbol-" + "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"