Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2025-01-27 19:58:49 +01:00
Code Issues Projects Releases Packages Wiki Activity

visit-top-form visit/v added; minor fixes

Browse source
This commit is contained in:
ESL 2024-05-29 00:47:49 -04:00
parent 00bc579327
commit 547c29df64
2 changed files with 103 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

83
src/t.scm
View file

@ -1142,27 +1142,27 @@
; nonsymbolic ids can't be (re)defined ; nonsymbolic ids can't be (re)defined
(case at [(ref set!) (old-den id)] [else #f]) (case at [(ref set!) (old-den id)] [else #f])
(let loop ([env env]) (let loop ([env env])
(cond [(pair? env) ; imported (cond [(pair? env) ; imported: ref-only
(if (eq? (caar env) id) (if (eq? (caar env) id)
(case at [(ref set!) (cdar env)] [else #f]) (case at [(ref) (cdar env)] [else #f])
(loop (cdr env)))] (loop (cdr env)))]
[(vector? env) ; root (can be extended) [(vector? env) ; root (can be extended)
(let* ([n (vector-length env)] [i (immediate-hash id n)] (let* ([n (vector-length env)] [i (immediate-hash id n)]
[al (vector-ref env i)] [p (assq id al)]) [al (vector-ref env i)] [p (assq id al)])
(if p (cdr p) (if p (cdr p)
; implicitly append integrables and "naked" globals ; implicitly/on demand append integrables and "naked" globals
(let ([loc (make-location (or (lookup-integrable id) (list 'ref id)))]) (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 (cons id loc) al))
loc)))] loc)))]
[(string? env) ; module prefix [(string? env) ; module prefix = module internals: full access
(and (memq at '(define define-syntax)) (and (memq at '(ref set! define define-syntax))
(let ([gid (string->symbol (string-append env (symbol->string id)))]) (let ([gid (string->symbol (string-append env (symbol->string id)))])
(env-lookup gid *root-environment* 'ref)))] (env-lookup gid *root-environment* 'ref)))]
[else ; finite env [else ; finite env
#f])))) #f]))))
; make root environment from the list of initial transformers ; make root environment (a vector) from the list of initial transformers
(define *root-environment* (define *root-environment*
(let* ([n 101] ; use prime number (let* ([n 101] ; use prime number
@ -1204,40 +1204,90 @@
; transformation of top-level form should process begin, define, and define-syntax ; transformation of top-level form should process begin, define, and define-syntax
; explicitly, so that they can produce and observe side effects on env ; explicitly, so that they can produce and observe side effects on env
(define (visit-top-form x env)
(if (pair? x)
(let ([hval (xform #t (car x) env)])
(cond
[(eq? hval 'begin)
; splice
(let loop ([x* (cdr x)])
(when (pair? x*)
(visit-top-form (car x*) env)
(loop (cdr x*))))]
[(eq? hval 'define)
; use new protocol for top-level envs
(let* ([core (xform-define (cdr x) env)]
[loc (xenv-lookup env (cadr core) 'define)])
(if (and loc (syntax-match? '(ref *) (location-val loc)))
#t
(x-error "identifier cannot be (re)defined in env:"
(cadr core) env)))]
[(eq? hval 'define-syntax)
; use new protocol for top-level envs
(let* ([core (xform-define-syntax (cdr x) env)]
[loc (xenv-lookup env (cadr core) 'define-syntax)])
(if loc ; location or #f
(location-set-val! loc (caddr core)) ; modifies env!
(x-error "identifier cannot be (re)defined as syntax in env:"
(cadr core) env)))]
[(procedure? hval)
; transformer: apply and loop
(visit-top-form (hval x env) env)]
[(integrable? hval)
; no env effect possible here
#t]
[(symbol? hval)
; other specials: no env effect possible here (?? set! ??)
#t]
[else
; regular call: no env effect possible here
#t]))
; var refs and literals : xform for access check
#t))
(define (eval-top-form x env) (define (eval-top-form x env)
(if (pair? x) (if (pair? x)
(let ([hval (xform #t (car x) env)]) (let ([hval (xform #t (car x) env)])
(cond (cond
[(eq? hval 'begin) [(eq? hval 'begin)
; splice
(let loop ([x* (cdr x)]) (let loop ([x* (cdr x)])
(when (pair? x*) (when (pair? x*)
(eval-top-form (car x*) env) (eval-top-form (car x*) env)
(loop (cdr x*))))] (loop (cdr x*))))]
[(eq? hval 'define) [(eq? hval 'define)
; new protocol for top-level envs ; use new protocol for top-level envs
(let* ([core (xform-define (cdr x) env)] (let* ([core (xform-define (cdr x) env)]
[loc (xenv-lookup env (cadr core) 'define)]) [loc (xenv-lookup env (cadr core) 'define)])
(if (and loc (syntax-match? '(ref *) (location-val loc))) (if (and loc (syntax-match? '(ref *) (location-val loc)))
(compile-and-run-core-expr (compile-and-run-core-expr
(list 'set! (cadr (location-val loc)) (caddr core))) (list 'set! (cadr (location-val loc)) (caddr core)))
(x-error "identifier cannot be (re)defined in env" (x-error "identifier cannot be (re)defined in env:"
(cadr core) env)))] (cadr core) env)))]
[(eq? hval 'define-syntax) [(eq? hval 'define-syntax)
; new protocol for top-level envs ; use new protocol for top-level envs
(let* ([core (xform-define-syntax (cdr x) env)] (let* ([core (xform-define-syntax (cdr x) env)]
[loc (xenv-lookup env (cadr core) 'define-syntax)]) [loc (xenv-lookup env (cadr core) 'define-syntax)])
(if loc ; location or #f (if loc ; location or #f
(location-set-val! loc (caddr core)) (location-set-val! loc (caddr core))
(x-error "identifier cannot be (re)defined as syntax in env" (x-error "identifier cannot be (re)defined as syntax in env:"
(cadr core) env)))] (cadr core) env)))]
[(procedure? hval) [(procedure? hval)
; transformer: apply and loop
(eval-top-form (hval x env) env)] (eval-top-form (hval x env) env)]
[(integrable? hval) [(integrable? hval)
; integrable application
(compile-and-run-core-expr (compile-and-run-core-expr
(xform-integrable hval (cdr x) env))] (xform-integrable hval (cdr x) env))]
[else [(symbol? hval)
; other specials
(compile-and-run-core-expr (compile-and-run-core-expr
(xform #f x env))])) (xform #f x env))]
[else
; regular call
(compile-and-run-core-expr
(xform-call hval (cdr x) env))]))
; var refs and literals
(compile-and-run-core-expr (compile-and-run-core-expr
(xform #f x env)))) (xform #f x env))))
@ -1286,6 +1336,15 @@
(close-input-port p)) (close-input-port p))
|# |#
(define (visit/v f)
(define p (open-input-file f))
(let loop ([x (read p)])
(unless (eof-object? x)
(when *verbose* (write x) (newline))
(visit-top-form x root-environment)
(when *verbose* (newline))
(loop (read p))))
(close-input-port p))
(define (visit/x f) (define (visit/x f)
(define p (open-input-file f)) (define p (open-input-file f))

45
t.c
View file

@ -552,11 +552,11 @@ char *t_code[] = {
"P", "env-lookup", "P", "env-lookup",
"%3.0K0?{.2,'(l2:y3:ref;y4:set!;),.1A1?{.1,@(y7:old-den)[41}f]4}.1,,#0." "%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,'(l2:y3:ref;y4:set!;),.1A1?{.1ad]2}f]2}" "4,.3,.2,&3{%1.0p?{:1,.1aaq?{:2,'(y3:ref),.1v?{.1ad]2}f]2}.0d,:0^[11}.0"
".0d,:0^[11}.0V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{.0d]5}:1U5,.0?{.0}{:" "V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{.0d]5}:1U5,.0?{.0}{:1,'(y3:ref),l"
"1,'(y3:ref),l2}_1b,.2,.1,:1cc,.4,.7V5.0]6}.0S0?{'(l2:y6:define;y13:def" "2}_1b,.2,.1,:1cc,.4,.7V5.0]6}.0S0?{'(l4:y3:ref;y4:set!;y6:define;y13:d"
"ine-syntax;),:2A0?{:1X4,.1S6X5,'(y3:ref),@(y18:*root-environment*),.2," "efine-syntax;),:2A0?{:1X4,.1S6X5,'(y3:ref),@(y18:*root-environment*),."
"@(y10:env-lookup)[23}f]1}f]1}.!0.0^_1[31", "2,@(y10:env-lookup)[23}f]1}f]1}.!0.0^_1[31",
"C", 0, "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,.1sd]5}.1,"
@ -573,20 +573,33 @@ char *t_code[] = {
"P", "error*", "P", "error*",
"%2.1,.1c,@(y5:error),@(y13:apply-to-list)[22", "%2.1,.1c,@(y5:error),@(y13:apply-to-list)[22",
"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"
"efine),.1q?{${.4,.4d,@(y12:xform-define)[02},${'(y6:define),.3da,.7,@("
"y11:xenv-lookup)[03},.0?{${.2z,'(l2:y3:ref;y1:*;),@(y13:syntax-match?)"
"[02}}{f}?{t]5}.4,.2da,'(s40:identifier cannot be (re)defined in env:),"
"@(y7:x-error)[53}'(y13:define-syntax),.1q?{${.4,.4d,@(y19:xform-define"
"-syntax)[02},${'(y13:define-syntax),.3da,.7,@(y11:xenv-lookup)[03},.0?"
"{.1dda,.1sz]5}.4,.2da,'(s50:identifier cannot be (re)defined as syntax"
" in env:),@(y7:x-error)[53}.0K0?{.2,${.5,.5,.5[02},@(y14:visit-top-for"
"m)[32}.0U0?{t]3}.0Y0?{t]3}t]3}t]2",
"P", "eval-top-form", "P", "eval-top-form",
"%2.0p?{${.3,.3a,t,@(y5:xform)[03},'(y5:begin),.1q?{.1d,,#0.4,.1,&2{%1." "%2.0p?{${.3,.3a,t,@(y5:xform)[03},'(y5:begin),.1q?{.1d,,#0.4,.1,&2{%1."
"0p?{${:1,.3a,@(y13:eval-top-form)[02}.0d,:0^[11}]1}.!0.0^_1[31}'(y6:de" "0p?{${:1,.3a,@(y13:eval-top-form)[02}.0d,:0^[11}]1}.!0.0^_1[31}'(y6:de"
"fine),.1q?{${.4,.4d,@(y12:xform-define)[02},${'(y6:define),.3da,.7,@(y" "fine),.1q?{${.4,.4d,@(y12:xform-define)[02},${'(y6:define),.3da,.7,@(y"
"11:xenv-lookup)[03},.0?{${.2z,'(l2:y3:ref;y1:*;),@(y13:syntax-match?)[" "11:xenv-lookup)[03},.0?{${.2z,'(l2:y3:ref;y1:*;),@(y13:syntax-match?)["
"02}}{f}?{.1dda,.1zda,'(y4:set!),l3,@(y25:compile-and-run-core-expr)[51" "02}}{f}?{.1dda,.1zda,'(y4:set!),l3,@(y25:compile-and-run-core-expr)[51"
"}.4,.2da,'(s39:identifier cannot be (re)defined in env),@(y7:x-error)[" "}.4,.2da,'(s40:identifier cannot be (re)defined in env:),@(y7:x-error)"
"53}'(y13:define-syntax),.1q?{${.4,.4d,@(y19:xform-define-syntax)[02},$" "[53}'(y13:define-syntax),.1q?{${.4,.4d,@(y19:xform-define-syntax)[02},"
"{'(y13:define-syntax),.3da,.7,@(y11:xenv-lookup)[03},.0?{.1dda,.1sz]5}" "${'(y13:define-syntax),.3da,.7,@(y11:xenv-lookup)[03},.0?{.1dda,.1sz]5"
".4,.2da,'(s49:identifier cannot be (re)defined as syntax in env),@(y7:" "}.4,.2da,'(s50:identifier cannot be (re)defined as syntax in env:),@(y"
"x-error)[53}.0K0?{.2,${.5,.5,.5[02},@(y13:eval-top-form)[32}.0U0?{${.4" "7:x-error)[53}.0K0?{.2,${.5,.5,.5[02},@(y13:eval-top-form)[32}.0U0?{${"
",.4d,.4,@(y16:xform-integrable)[03},@(y25:compile-and-run-core-expr)[3" ".4,.4d,.4,@(y16:xform-integrable)[03},@(y25:compile-and-run-core-expr)"
"1}${.4,.4,f,@(y5:xform)[03},@(y25:compile-and-run-core-expr)[31}${.3,." "[31}.0Y0?{${.4,.4,f,@(y5:xform)[03},@(y25:compile-and-run-core-expr)[3"
"3,f,@(y5:xform)[03},@(y25:compile-and-run-core-expr)[21", "1}${.4,.4d,.4,@(y10:xform-call)[03},@(y25:compile-and-run-core-expr)[3"
"1}${.3,.3,f,@(y5:xform)[03},@(y25:compile-and-run-core-expr)[21",
"C", 0, "C", 0,
"f@!(y9:*verbose*)", "f@!(y9:*verbose*)",
@ -597,6 +610,12 @@ char *t_code[] = {
"21:compile-to-thunk-code)[01},@(y9:*verbose*)?{Po,.1W5PoW6}.0U4,U91,${" "21:compile-to-thunk-code)[01},@(y9:*verbose*)?{Po,.1W5PoW6}.0U4,U91,${"
".2[00},@(y9:*verbose*)?{Po,.1W5PoW6]4}]4", ".2[00},@(y9:*verbose*)?{Po,.1W5PoW6]4}]4",
"P", "visit/v",
"%1,#0${.3,@(y15:open-input-file)[01}.!0${${.4^,@(y4:read)[01},,#0.4,.1"
",&2{%1.0R8~?{@(y9:*verbose*)?{Po,.1W5PoW6}${@(y16:root-environment),.3"
",@(y14:visit-top-form)[02}@(y9:*verbose*)?{PoW6}${:1^,@(y4:read)[01},:"
"0^[11}]1}.!0.0^_1[01}.0^P60]2",
"P", "visit/x", "P", "visit/x",
"%1,#0${.3,@(y15:open-input-file)[01}.!0${${.4^,@(y4:read)[01},,#0.4,.1" "%1,#0${.3,@(y15:open-input-file)[01}.!0${${.4^,@(y4:read)[01},,#0.4,.1"
",&2{%1.0R8~?{@(y9:*verbose*)?{Po,.1W5PoW6}${@(y16:root-environment),.3" ",&2{%1.0R8~?{@(y9:*verbose*)?{Po,.1W5PoW6}${@(y16:root-environment),.3"