From 7f81de6dfa71242898e86b66f09f1509ae3dd823 Mon Sep 17 00:00:00 2001 From: ESL Date: Sat, 8 Jun 2024 01:40:53 -0400 Subject: [PATCH] more lib/env hacks --- src/t.scm | 155 ++++++++++++++++++++++++++++++++++++++++++++++++++---- t.c | 97 +++++++++++++++++++++++++++------- 2 files changed, 224 insertions(+), 28 deletions(-) diff --git a/src/t.scm b/src/t.scm index 381a150..c045e12 100644 --- a/src/t.scm +++ b/src/t.scm @@ -1342,13 +1342,16 @@ (if (eq? (caar env) id) (case at [(ref) (cdar env)] [else #f]) (loop (cdr env)))] - [(vector? env) ; root (can be extended) + [(vector? env) ; extendable, keeps imported? flags (let* ([n (vector-length env)] [i (immediate-hash id n)] [al (vector-ref env i)] [p (assq id al)]) - (if p (cdr p) + (if p ; p is (key loc imported?) + (case at + [(ref) (cadr p)] + [else (if (caddr p) #f (cadr p))]) ; imported can be ref-d only ; implicitly/on demand append integrables and "naked" globals (let ([loc (make-location (or (lookup-integrable id) (list 'ref id)))]) - (vector-set! env i (cons (cons id loc) al)) + (vector-set! env i (cons (list id loc #f) al)) ; not imported loc)))] [(string? env) ; module prefix = module internals: full access (and (memq at '(ref set! define define-syntax)) @@ -1365,8 +1368,8 @@ [env (make-vector n '())]) (define (put! k loc) (let* ([i (immediate-hash k n)] [al (vector-ref env i)] [p (assq k al)]) - (cond [p (set-cdr! p loc)] - [else (vector-set! env i (cons (cons k loc) al))]))) + (cond [p (set-car! (cdr p) loc)] + [else (vector-set! env i (cons (list k loc #t) al))]))) (let loop ([l (initial-transformers)]) (if (null? l) env (let ([p (car l)] [l (cdr l)]) @@ -1412,14 +1415,14 @@ (define (get-env! lib) (cond [(assoc lib *std-lib->env*) => cdr] - [else (let* ([n (if (eq? lib '(skint repl)) 101 37)] ; use prime number + [else (let* ([n (if (eq? lib '(repl)) 101 37)] ; use prime number [env (make-vector n '())]) (set! *std-lib->env* (cons (cons lib env) *std-lib->env*)) env)])) (let loop ([name (car r)] [keys (cdr r)]) (cond - [(null? keys) - (put-loc! (get-env! '(skint repl)) name (root-environment name 'ref))] + [(null? keys) ; all go to (repl) + (put-loc! (get-env! '(repl)) name (root-environment name 'ref))] [else (put-loc! (get-env! (key->lib (car keys))) name (root-environment name 'ref)) (loop name (cdr keys))]))) @@ -1482,7 +1485,7 @@ (interaction-environment p v) (null-environment v) (read r v) (scheme-report-environment v) (write w v) (current-jiffy t) (current-second t) (jiffies-per-second t) (write-shared w) (write-simple w) - ; skint extras go into (skint repl) environment only + ; skint extras go into (repl) only (box?) (box) (unbox) (set-box!) )) @@ -1503,6 +1506,140 @@ (if p (cdr p) #f)))))))] [else #f])) +(define (std-lib->alist lib) + (cond [(assoc lib *std-lib->env*) => + (lambda (p) + (define lv (cdr p)) + (let loop ([i 0] [n (vector-length lv)] [al '()]) + (if (= i n) al + (loop (+ i 1) n (append (vector-ref lv i) al)))))] + [else #f])) + +; combine explicit finite env1 with finite or infinite env2 +; env1 here is a proper alist of bindings (( . ) ...) +; env2 can be any environment -- explicit or implicit, finite or not + +(define (adjoin-env env1 env2) ;=> env12 + (if (null? env1) env2 + (let ([env2 (adjoin-env (cdr env1) env2)]) + (cond [(env-lookup (caar env1) env2 'ref) => + (lambda (loc) ; ? loc is not auto-mapped even when env2 supports it + (if (eq? (cdar env1) loc) + env2 ; repeat of same id with same binding is allowed + (c-error "multiple identifier bindings on import:" + (caar env1) (cdar env1) loc)))] + [else (cons (car env1) env2)])))) + +; this variant is used in repl; it allows shadowing of old bindings with new ones +; todo: remove duplicates by starting ; with the env1 and appending non-duplicate parts of env2 + +(define (adjoin-env/shadow env1 env2) ;=> env12 + (if (null? env1) env2 + (let ([env2 (adjoin-env/shadow (cdr env1) env2)]) + (cond [(env-lookup (caar env1) env2 'ref) => + (lambda (loc) ; ? loc is not auto-mapped even when env2 supports it + (if (eq? (cdar env1) a) + env2 ; repeat of same id with same binding is allowed + (begin + (c-warning "old identifier binding shadowed on import:" + (caar env1) 'was: a 'now: (cdar env1)) + (cons (car env1) env2))))] + [else (cons (car env1) env2)])))) + +; local environment is made for expansion of thislib library's body forms +; it is made of explicit import environment followed by a view to lib-specific +; global locations in root environment, normally prefixed with library name +; NB: import-env is expected to be explicit and limited (just an alist) + +(define (make-local-env esps thislib import-env) ;=> env (infinite) + (let loop ([esps esps] [env import-env]) + (if (null? esps) + (if (lib-public? thislib) + ; all non-exported definitions are public and in global namespace under their own names + (append env #t) ; unprefixed view into global namespace (limited use) + ; otherwise they are in global namespace under mangled names + (append env (fully-qualified-library-prefix thislib))) + (loop (cdr esps) ; just for syntax checking + (sexp-case (car esps) + [ env] + [(rename ) env] + [else (c-error "invalid export spec in export:" (car esps))]))))) + +; environment for import from thislib library into outside libs or programs + +(define (make-export-env esps thislib import-env) ;=> env (finite, alist) + (define (extend-export lid eid env) + (cond [(assq eid env) (c-error "duplicate external id in export:" eid esps)] + [(assq lid import-env) => ; re-exported imported id, keep using imported binding under eid + (lambda (b) (cons (cons eid (cdr b)) env))] + [else (cons (cons eid (fully-qualified-library-location thislib lid)) env)])) + (if (lib-public? thislib) + (if (or esps (pair? import-env)) + (c-error "module cannot be imported:" thislib) + '()) + (let loop ([esps esps] [env '()]) + (if (null? esps) + env + (loop (cdr esps) + (sexp-case (car esps) + [ (extend-export (car esps) (car esps) env)] + [(rename ) (extend-export (cadr (car esps)) (caddr (car esps)) env)] + [else (c-error "invalid export spec in export:" (car esps))])))))) + + +;--------------------------------------------------------------------------------------------- +; Library processing info cache +;--------------------------------------------------------------------------------------------- + +; we have to cache loaded libraries, so stores are not hit on repeat loads/visits +; of/to the same library + +(define *library-info-cache* '()) + +;; library info: #(used-libs import-env export-specs beg-forms) +(define (make-library-info) (make-vector 4 #f)) + +(define (library-available? lib) + (cond [(assoc lib *library-info-cache*) #t] + [(string? lib) (file-resolve-relative-to-current lib)] + [(and (pair? lib) (list? lib)) (find-library-path lib)] + [else #f])) + +(define (lookup-library-info lib) ;=> li (possibly non-inited) + (cond [(assoc lib *library-info-cache*) => cdr] + [(std-lib->alist lib) => + (lambda (al) + (define li (make-library-info)) + (set! *library-info-cache* + (cons (cons lib li) *library-info-cache*)) + (vector-set! li 0 '()) + (vector-set! li 1 al) + (vector-set! li 2 (map car al)) + (vector-set! li 3 '()) + li)] + [else + (let ([li (make-library-info)]) + (set! *library-info-cache* + (cons (cons lib li) *library-info-cache*)) + li)])) + +; main hub for library info -- calls process if library info is not inited +(define (get-library-info lib process return) ;=> (return used-libs import-env export-specs beg-forms) + (define li (lookup-library-info lib)) + (define (update-li! used-libs import-env export-specs beg-forms) + (vector-set! li 0 used-libs) + (vector-set! li 1 import-env) + (vector-set! li 2 export-specs) + (vector-set! li 3 beg-forms)) + (unless (vector-ref li 0) ; not inited? + (call-with-file/lib-sexps lib #f + (lambda (all-forms) ; need to split off header forms + (process lib all-forms update-li!)))) + (return (vector-ref li 0) + (vector-ref li 1) + (vector-ref li 2) + (vector-ref li 3))) + ;--------------------------------------------------------------------------------------------- ; Evaluation diff --git a/t.c b/t.c index 80225b1..d76de90 100644 --- a/t.c +++ b/t.c @@ -663,8 +663,8 @@ char *t_code[] = { "P", "call-with-input-file/lib", "%3${.2,@(y27:resolve-input-file/lib-name)[01},.2,.1,.5,&3{%0:0,:1,:2,&" - "3{%1:0?{${t,.3,@(y19:set-port-fold-case!)[02}}.0,:1,:2[12},:1,@(y20:ca" - "ll-with-input-file)[02},.1,@(y17:with-current-file)[42", + "3{%1:0?{t,.1P79}.0,:1,:2[12},:1,@(y20:call-with-input-file)[02},.1,@(y" + "17:with-current-file)[42", "P", "call-with-file/lib-sexps", "%3.2,&1{%2n,,#0.3,:0,.2,&3{%1${:2,@(y14:read-code-sexp)[01},.0R8?{.1A9" @@ -696,19 +696,20 @@ char *t_code[] = { "P", "env-lookup", "%3.0K0?{.2,'(l2:y3:ref;y4:set!;),.1A1?{.1,@(y7:old-den)[41}f]4}.1,,#0." "4,.3,.2,&3{%1.0p?{:1,.1aaq?{:2,'(y3:ref),.1v?{.1ad]2}f]2}.0d,:0^[11}.0" - "V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{.0d]5}:1U5,.0?{.0}{:1,'(y3:ref),l" - "2}_1b,.2,.1,:1cc,.4,.7V5.0]6}.0S0?{'(l4:y3:ref;y4:set!;y6:define;y13:d" - "efine-syntax;),:2A0?{:1X4,.1S6X5,'(y3:ref),@(y18:*root-environment*),." - "2,@(y10:env-lookup)[23}f]1}f]1}.!0.0^_1[31", + "V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{:2,'(y3:ref),.1v?{.1da]6}.1dda?{f" + "]6}.1da]6}:1U5,.0?{.0}{:1,'(y3:ref),l2}_1b,.2,f,.2,:1,l3c,.4,.7V5.0]6}" + ".0S0?{'(l4:y3:ref;y4:set!;y6:define;y13:define-syntax;),:2A0?{:1X4,.1S" + "6X5,'(y3:ref),@(y18:*root-environment*),.2,@(y10:env-lookup)[23}f]1}f]" + "1}.!0.0^_1[31", "C", 0, - "'(i101),n,.1V2,,#0.2,.2,&2{%2:1,.1H2,.0,:0V4,.0,.3A3,.0?{.4,.1sd]5}.1," - ".5,.5cc,.3,:0V5]5}.!0${U1,,#0.0,.5,.7,&3{%1.0u?{:0]1}.0d,.1a,.0d,.1a,." - "1Y0,.0?{.0}{.2N0}_1?{${.3b,.3,:1^[02}.3,:2^[51}.1p?{'(y12:syntax-rules" - "),.2aq}{f}?{,,#0#1&0{%2.1,@(y18:*root-environment*),.2,@(y10:env-looku" - "p)[23}.!0${.5da,@(y3:id?)[01}?{${.5ddd,.6dda,.7da,.5^,@(y13:syntax-rul" - "es*)[04}}{${.5dd,.6da,f,.5^,@(y13:syntax-rules*)[04}}.!1${.3^b,.5,:1^[" - "02}.5,:2^[71}f]5}.!0.0^_1[01}_1_1_1@!(y18:*root-environment*)", + "'(i101),n,.1V2,,#0.2,.2,&2{%2:1,.1H2,.0,:0V4,.0,.3A3,.0?{.4,.1dsa]5}.1" + ",t,.6,.6,l3c,.3,:0V5]5}.!0${U1,,#0.0,.5,.7,&3{%1.0u?{:0]1}.0d,.1a,.0d," + ".1a,.1Y0,.0?{.0}{.2N0}_1?{${.3b,.3,:1^[02}.3,:2^[51}.1p?{'(y12:syntax-" + "rules),.2aq}{f}?{,,#0#1&0{%2.1,@(y18:*root-environment*),.2,@(y10:env-" + "lookup)[23}.!0${.5da,@(y3:id?)[01}?{${.5ddd,.6dda,.7da,.5^,@(y13:synta" + "x-rules*)[04}}{${.5dd,.6da,f,.5^,@(y13:syntax-rules*)[04}}.!1${.3^b,.5" + ",:1^[02}.5,:2^[71}f]5}.!0.0^_1[01}_1_1_1@!(y18:*root-environment*)", "P", "root-environment", "%2.1,@(y18:*root-environment*),.2,@(y10:env-lookup)[23", @@ -859,12 +860,12 @@ char *t_code[] = { "cheme;y11:case-lambda;)]2}'(y1:x),.1v?{'(l2:y6:scheme;y3:cxr;)]2}'(y1:" "b),.1v?{'(l2:y6:scheme;y4:base;)]2}]2}.!0&0{%3.0V3,.0,.3H2,.0,.3V4,.0," ".5A3,.0?{.6,.1sd]7}.1,.7,.7cc,.3,.6V5]7}.!1&0{%1@(y14:*std-lib->env*)," - ".1A5,.0?{.0d]2}'(l2:y5:skint;y4:repl;),.2q?{'(i101)}{'(i37)},n,.1V2,@(" - "y14:*std-lib->env*),.1,.5cc@!(y14:*std-lib->env*).0]4}.!2.3d,.4a,,#0.0" - ",.5,.5,.8,&4{%2.1u?{${'(y3:ref),.3,@(y16:root-environment)[02},.1,${'(" - "l2:y5:skint;y4:repl;),:0^[01},:2^[23}${${'(y3:ref),.5,@(y16:root-envir" - "onment)[02},.3,${${.9a,:1^[01},:0^[01},:2^[03}.1d,.1,:3^[22}.!0.0^_1[4" - "2},@(y10:%25for-each1)[02}", + ".1A5,.0?{.0d]2}'(l1:y4:repl;),.2q?{'(i101)}{'(i37)},n,.1V2,@(y14:*std-" + "lib->env*),.1,.5cc@!(y14:*std-lib->env*).0]4}.!2.3d,.4a,,#0.0,.5,.5,.8" + ",&4{%2.1u?{${'(y3:ref),.3,@(y16:root-environment)[02},.1,${'(l1:y4:rep" + "l;),:0^[01},:2^[23}${${'(y3:ref),.5,@(y16:root-environment)[02},.3,${$" + "{.9a,:1^[01},:0^[01},:2^[03}.1d,.1,:3^[22}.!0.0^_1[42},@(y10:%25for-ea" + "ch1)[02}", "P", "std-lib->env", "%1@(y14:*std-lib->env*),.1A5,.0?{.0,.0d,.0V3,'(l2:y5:skint;y4:repl;),." @@ -872,6 +873,64 @@ char *t_code[] = { "1,.6cc,.4,:0V5.0]6}]5}.1,.1,&2{%2'(y3:ref),.2q?{:0,.1H2,.0,:1V4,.0,.3A" "3,.0?{.0d]5}f]5}f]2}]5}f]2", + "P", "std-lib->alist", + "%1@(y14:*std-lib->env*),.1A5,.0?{.0,,#0.1d.!0n,.1^V3,'0,,#0.4,.1,&2{%3" + ".1,.1=?{.2]3}.2,.1,:1^V4L6,.2,'1,.3+,:0^[33}.!0.0^_1[43}f]2", + + "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" + "ifier bindings on import:),@(y7:c-error)[54}.1,.3ac]4", + + "P", "adjoin-env/shadow", + "%2.0u?{.1]2}${.3,.3d,@(y17:adjoin-env/shadow)[02},${'(y3:ref),.3,.5aa," + "@(y10:env-lookup)[03},.0?{.0,@(y1:a),.4adq?{.2]5}${.5ad,'(y4:now:),@(y" + "1:a),'(y4:was:),.9aa,'(s42:old identifier binding shadowed on import:)" + ",@(y9:c-warning)[06}.2,.4ac]5}.1,.3ac]4", + + "P", "make-local-env", + "%3.2,.1,,#0.0,.5,&2{%2.0u?{${:0,@(y11:lib-public?)[01}?{t,.2L6]2}${:0," + "@(y30:fully-qualified-library-prefix)[01},.2L6]2}.0a,${.2,'(y8:),@(y11:sexp-match?)[02}?{.2}{${.2,'(l3:y6:rename;y8:;y8:;),@(y11:sexp-match?)[02}?{.2}{${.3a,'(s30:invalid export spec in " + "export:),@(y7:c-error)[02}}}_1,.1d,:1^[22}.!0.0^_1[32", + + "P", "make-export-env", + "%3,#0.3,.3,.3,&3{%3.2,.2A3?{:0,.2,'(s32:duplicate external id in expor" + "t:),@(y7:c-error)[33}:2,.1A3,.0?{.0,.4,.1d,.5cc]5}.3,${.4,:1,@(y32:ful" + "ly-qualified-library-location)[02},.4cc]4}.!0${.4,@(y11:lib-public?)[0" + "1}?{.1,.0?{.0}{.4p}_1?{.2,'(s26:module cannot be imported:),@(y7:c-err" + "or)[42}n]4}n,.2,,#0.3,.1,&2{%2.0u?{.1]2}.0a,${.2,'(y8:),@(y11:" + "sexp-match?)[02}?{${.4,.4a,.5a,:1^[03}}{${.2,'(l3:y6:rename;y8:;y8:;),@(y11:sexp-match?)[02}?{${.4,.4adda,.5ada,:1^[03}}{${." + "3a,'(s30:invalid export spec in export:),@(y7:c-error)[02}}}_1,.1d,:0^" + "[22}.!0.0^_1[42", + + "C", 0, + "n@!(y20:*library-info-cache*)", + + "P", "make-library-info", + "%0f,'4V2]0", + + "P", "library-available?", + "%1@(y20:*library-info-cache*),.1A5?{t]1}.0S0?{.0,@(y32:file-resolve-re" + "lative-to-current)[11}.0p?{.0L0}{f}?{.0,@(y17:find-library-path)[11}f]" + "1", + + "P", "lookup-library-info", + "%1@(y20:*library-info-cache*),.1A5,.0?{.0d]2}${.3,@(y14:std-lib->alist" + ")[01},.0?{.0,,#0${@(y17:make-library-info)[00}.!0@(y20:*library-info-c" + "ache*),.1^,.6cc@!(y20:*library-info-cache*)n,'0,.2^V5.1,'1,.2^V5${.3,@" + "(y3:car),@(y5:%25map1)[02},'2,.2^V5n,'3,.2^V5.0^]5}${@(y17:make-librar" + "y-info)[00},@(y20:*library-info-cache*),.1,.5cc@!(y20:*library-info-ca" + "che*).0]4", + + "P", "get-library-info", + "%3,,#0#1${.4,@(y19:lookup-library-info)[01}.!0.0,&1{%4.0,'0,:0^V5.1,'1" + ",:0^V5.2,'2,:0^V5.3,'3,:0^V5]4}.!1'0,.1^V4~?{${.3,.5,.7,&3{%1:2^,.1,:1" + ",:0[13},f,.6,@(y24:call-with-file/lib-sexps)[03}}'3,.1^V4,'2,.2^V4,'1," + ".3^V4,'0,.4^V4,.8[54", + "P", "visit-top-form", "%2.0p?{${.3,.3a,t,@(y5:xform)[03},'(y5:begin),.1q?{.1d,,#0.4,.1,&2{%1." "0p?{${:1,.3a,@(y14:visit-top-form)[02}.0d,:0^[11}]1}.!0.0^_1[31}'(y6:d"