more lib/env hacks

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)]
+        (cond [p (set-car! (cdr p) loc)]
-              [else (vector-set! env i (cons (cons k loc) al))])))
+              [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)
+        [(null? keys) ; all go to (repl)
-         (put-loc! (get-env! '(skint repl)) name (root-environment name 'ref))]
+         (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 ((<id> . <location>) ...)
+; 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) 
+            [<symbol> env]
+            [(rename <symbol> <symbol>) 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) 
+                [<symbol> (extend-export (car esps) (car esps) env)]
+                [(rename <symbol> <symbol>) (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

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"
+  "3{%1:0?{t,.1P79}.0,:1,:2[12},:1,@(y20:call-with-input-file)[02},.1,@(y"
-  "ll-with-input-file)[02},.1,@(y17:with-current-file)[42",
+  "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"
+  "V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{:2,'(y3:ref),.1v?{.1da]6}.1dda?{f"
-  "2}_1b,.2,.1,:1cc,.4,.7V5.0]6}.0S0?{'(l4:y3:ref;y4:set!;y6:define;y13:d"
+  "]6}.1da]6}:1U5,.0?{.0}{:1,'(y3:ref),l2}_1b,.2,f,.2,:1,l3c,.4,.7V5.0]6}"
-  "efine-syntax;),:2A0?{:1X4,.1S6X5,'(y3:ref),@(y18:*root-environment*),."
+  ".0S0?{'(l4:y3:ref;y4:set!;y6:define;y13:define-syntax;),:2A0?{:1X4,.1S"
-  "2,@(y10:env-lookup)[23}f]1}f]1}.!0.0^_1[31",
+  "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,"
+  "'(i101),n,.1V2,,#0.2,.2,&2{%2:1,.1H2,.0,:0V4,.0,.3A3,.0?{.4,.1dsa]5}.1"
-  ".5,.5cc,.3,:0V5]5}.!0${U1,,#0.0,.5,.7,&3{%1.0u?{:0]1}.0d,.1a,.0d,.1a,."
+  ",t,.6,.6,l3c,.3,:0V5]5}.!0${U1,,#0.0,.5,.7,&3{%1.0u?{:0]1}.0d,.1a,.0d,"
-  "1Y0,.0?{.0}{.2N0}_1?{${.3b,.3,:1^[02}.3,:2^[51}.1p?{'(y12:syntax-rules"
+  ".1a,.1Y0,.0?{.0}{.2N0}_1?{${.3b,.3,:1^[02}.3,:2^[51}.1p?{'(y12:syntax-"
-  "),.2aq}{f}?{,,#0#1&0{%2.1,@(y18:*root-environment*),.2,@(y10:env-looku"
+  "rules),.2aq}{f}?{,,#0#1&0{%2.1,@(y18:*root-environment*),.2,@(y10:env-"
-  "p)[23}.!0${.5da,@(y3:id?)[01}?{${.5ddd,.6dda,.7da,.5^,@(y13:syntax-rul"
+  "lookup)[23}.!0${.5da,@(y3:id?)[01}?{${.5ddd,.6dda,.7da,.5^,@(y13:synta"
-  "es*)[04}}{${.5dd,.6da,f,.5^,@(y13:syntax-rules*)[04}}.!1${.3^b,.5,:1^["
+  "x-rules*)[04}}{${.5dd,.6da,f,.5^,@(y13:syntax-rules*)[04}}.!1${.3^b,.5"
-  "02}.5,:2^[71}f]5}.!0.0^_1[01}_1_1_1@!(y18:*root-environment*)",
+  ",: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,@("
+  ".1A5,.0?{.0d]2}'(l1:y4:repl;),.2q?{'(i101)}{'(i37)},n,.1V2,@(y14:*std-"
-  "y14:*std-lib->env*),.1,.5cc@!(y14:*std-lib->env*).0]4}.!2.3d,.4a,,#0.0"
+  "lib->env*),.1,.5cc@!(y14:*std-lib->env*).0]4}.!2.3d,.4a,,#0.0,.5,.5,.8"
-  ",.5,.5,.8,&4{%2.1u?{${'(y3:ref),.3,@(y16:root-environment)[02},.1,${'("
+  ",&4{%2.1u?{${'(y3:ref),.3,@(y16:root-environment)[02},.1,${'(l1:y4:rep"
-  "l2:y5:skint;y4:repl;),:0^[01},:2^[23}${${'(y3:ref),.5,@(y16:root-envir"
+  "l;),:0^[01},:2^[23}${${'(y3:ref),.5,@(y16:root-environment)[02},.3,${$"
-  "onment)[02},.3,${${.9a,:1^[01},:0^[01},:2^[03}.1d,.1,:3^[22}.!0.0^_1[4"
+  "{.9a,:1^[01},:0^[01},:2^[03}.1d,.1,:3^[22}.!0.0^_1[42},@(y10:%25for-ea"
-  "2},@(y10:%25for-each1)[02}",
+  "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:<symbol"
+  ">),@(y11:sexp-match?)[02}?{.2}{${.2,'(l3:y6:rename;y8:<symbol>;y8:<sym"
+  "bol>;),@(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:<symbol>),@(y11:"
+  "sexp-match?)[02}?{${.4,.4a,.5a,:1^[03}}{${.2,'(l3:y6:rename;y8:<symbol"
+  ">;y8:<symbol>;),@(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"