mirror of
https://github.com/false-schemers/skint.git
synced 2024-11-16 07:47:54 +01:00
t.scm: eval-top-form works with root env
This commit is contained in:
ESL
parent
ebd93be256
commit
6631ac582e
4 changed files with 127 additions and 27 deletions
10
i.c
10
i.c
|
|
@ -3426,6 +3426,16 @@ define_instruction(igco) {
|
|||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(vmclo) {
|
||||
int i, n = get_fixnum(*ip++);
|
||||
if (n < 1) fail("invalid closure size");
|
||||
hp_reserve(vmclobsz(n));
|
||||
for (i = n-1; i >= 0; --i) *--hp = sref(i);
|
||||
ac = hend_vmclo(n);
|
||||
sdrop(n);
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(hshim) {
|
||||
unsigned long long v = (unsigned long long)ac, base = 0; obj b = spop();
|
||||
if (v && isaptr(v)) failtype(v, "immediate value");
|
||||
|
|
|
|||
1
i.h
1
i.h
|
|
@ -532,6 +532,7 @@ declare_instruction(iglk, "U5", 0, "lookup-integrable",
|
|||
declare_instruction(igty, "U6", 0, "integrable-type", '1', AUTOGL)
|
||||
declare_instruction(iggl, "U7", 0, "integrable-global", '1', AUTOGL)
|
||||
declare_instruction(igco, "U8", 0, "integrable-code", '2', AUTOGL)
|
||||
declare_instruction(vmclo, "U9", 1, "closure", '#', INLINED)
|
||||
declare_instruction(hshim, "H2\0f", 0, "immediate-hash", 'b', AUTOGL)
|
||||
|
||||
/* inlined integrables (no custom instructions) */
|
||||
|
|
|
|||
91
src/t.scm
91
src/t.scm
|
|
@ -439,7 +439,7 @@
|
|||
(location-set-val! (env (car ids)) (xform #t (car inits) env))
|
||||
(loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
|
||||
|
||||
(define (xform-begin tail env) ; top-level
|
||||
(define (xform-begin tail env) ; non-internal
|
||||
(if (list? tail)
|
||||
(let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)])
|
||||
(if (and (pair? xexps) (null? (cdr xexps)))
|
||||
|
|
@ -447,7 +447,7 @@
|
|||
(cons 'begin xexps)))
|
||||
(x-error "improper begin form" (cons 'begin! tail))))
|
||||
|
||||
(define (xform-define tail env) ; top-level
|
||||
(define (xform-define tail env) ; non-internal
|
||||
(cond [(and (list2? tail) (null? (car tail))) ; idless
|
||||
(xform #f (cadr tail) env)]
|
||||
[(and (list2? tail) (id? (car tail)))
|
||||
|
|
@ -459,7 +459,7 @@
|
|||
[else
|
||||
(x-error "improper define form" (cons 'define tail))]))
|
||||
|
||||
(define (xform-define-syntax tail env) ; top-level
|
||||
(define (xform-define-syntax tail env) ; non-internal
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(list 'define-syntax (id->sym (car tail)) (xform #t (cadr tail) env))
|
||||
(x-error "improper define-syntax form" (cons 'define-syntax tail))))
|
||||
|
|
@ -1078,6 +1078,11 @@
|
|||
(codegen x '() '() '() (find-free x '()) #f p)
|
||||
(get-output-string p)))
|
||||
|
||||
(define (compile-to-thunk-code x)
|
||||
(let ([p (open-output-string)])
|
||||
(codegen x '() '() '() (find-free x '()) 0 p)
|
||||
(get-output-string p)))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Code deserialization and execution
|
||||
|
|
@ -1158,23 +1163,78 @@
|
|||
(loop l))])))))))
|
||||
|
||||
(define (root-environment id)
|
||||
(env-lookup id *root-environment* #t))
|
||||
; new protocol for top-level envs
|
||||
(if (pair? id)
|
||||
(record-case id
|
||||
[define (i) i]
|
||||
[define-syntax (i) (env-lookup i *root-environment* #t)])
|
||||
(env-lookup id *root-environment* #t)))
|
||||
|
||||
|
||||
;---------------------------------------------------------------------------------------------
|
||||
; Evaluation
|
||||
;---------------------------------------------------------------------------------------------
|
||||
|
||||
(define (error* msg args)
|
||||
(apply error (cons msg args)))
|
||||
|
||||
; transformation of top-level form should process begin, define, and define-syntax
|
||||
; explicitly, so that they can produce and observe side effects on env
|
||||
|
||||
(define (eval-top-form x env)
|
||||
(if (pair? x)
|
||||
(let ([hval (xform #t (car x) env)])
|
||||
(cond
|
||||
[(eq? hval 'begin)
|
||||
(let loop ([x* (cdr x)])
|
||||
(when (pair? x*)
|
||||
(eval-top-form (car x*) env)
|
||||
(loop (cdr x*))))]
|
||||
[(eq? hval 'define)
|
||||
; new protocol for top-level envs
|
||||
(let* ([core (xform-define (cdr x) env)]
|
||||
[res (env (list 'define (cadr core)))])
|
||||
(if res ; symbol (runtime store key) or #f
|
||||
(compile-and-run-core-expr (list 'set! res (caddr core)))
|
||||
(x-error "identifier cannot be (re)defined in env"
|
||||
(cadr core) env)))]
|
||||
[(eq? hval 'define-syntax)
|
||||
; new protocol for top-level envs
|
||||
(let* ([core (xform-define-syntax (cdr x) env)]
|
||||
[res (env (list 'define-syntax (cadr core)))])
|
||||
(if res ; macro location or #f
|
||||
(location-set-val! res (caddr core))
|
||||
(x-error "identifier cannot be (re)defined as syntax in env"
|
||||
(cadr core) env)))]
|
||||
[(procedure? hval)
|
||||
(eval-top-form (hval x env) env)]
|
||||
[(integrable? hval)
|
||||
(compile-and-run-core-expr
|
||||
(xform-integrable hval (cdr x) env))]
|
||||
[else
|
||||
(compile-and-run-core-expr
|
||||
(xform #f x env))]))
|
||||
(compile-and-run-core-expr
|
||||
(xform #f x env))))
|
||||
|
||||
(define *verbose* #f)
|
||||
|
||||
(define (compile-and-run-core-expr core)
|
||||
(unless (pair? core) (x-error "unexpected transformed output" core))
|
||||
(when *verbose* (write core) (newline))
|
||||
(when (eq? (car core) 'define) (set-car! core 'set!))
|
||||
(let ([code (compile-to-thunk-code core)])
|
||||
(when *verbose* (write code) (newline))
|
||||
(let* ([cl (closure (deserialize-code code))] [r (cl)])
|
||||
(when *verbose* (write r) (newline)))))
|
||||
|
||||
#|
|
||||
(define (transform! x)
|
||||
(let ([t (xform #t x root-environment)])
|
||||
(when (and (syntax-match? '(define-syntax * *) t) (id? (cadr t))) ; (procedure? (caddr t))
|
||||
(let ([loc (env-lookup (cadr t) *root-environment* #t)])
|
||||
(let ([loc (root-environment (cadr t))])
|
||||
(when loc (location-set-val! loc (caddr t)))))
|
||||
t))
|
||||
|
||||
(define (error* msg args)
|
||||
(apply error (cons msg args)))
|
||||
|
||||
(define (visit f)
|
||||
(define p (open-input-file f))
|
||||
|
|
@ -1197,6 +1257,19 @@
|
|||
[begin x* (for-each exec x*)]
|
||||
[define (i v) (exec (list 'set! i v))]
|
||||
[define-syntax (i m)]
|
||||
[else (write (compile-to-string x)) (newline)])))
|
||||
[else (write (compile-to-thunk-code x)) (newline)])))
|
||||
(loop (read p))))
|
||||
(close-input-port p))
|
||||
|#
|
||||
|
||||
|
||||
(define (visit/x f)
|
||||
(define p (open-input-file f))
|
||||
(let loop ([x (read p)])
|
||||
(unless (eof-object? x)
|
||||
(when *verbose* (write x) (newline))
|
||||
(eval-top-form x root-environment)
|
||||
(when *verbose* (newline))
|
||||
(loop (read p))))
|
||||
(close-input-port p))
|
||||
|
||||
|
|
|
|||
52
t.c
52
t.c
|
|
@ -537,6 +537,10 @@ char *t_code[] = {
|
|||
"%1P51,${.2,f,${n,.8,@(y9:find-free)[02},n,n,n,.9,@(y7:codegen)[07}.0P9"
|
||||
"0]2",
|
||||
|
||||
"P", "compile-to-thunk-code",
|
||||
"%1P51,${.2,'0,${n,.8,@(y9:find-free)[02},n,n,n,.9,@(y7:codegen)[07}.0P"
|
||||
"90]2",
|
||||
|
||||
"P", "env-lookup",
|
||||
"%3.0K0?{.0,@(y7:old-den)[31}.1,,#0.4,.3,.2,&3{%1.0p?{:1,.1aaq?{.0ad]1}"
|
||||
".0d,:0^[11}.0V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{.0d]5}:1U5,.0?{.0}{:"
|
||||
|
|
@ -553,30 +557,42 @@ char *t_code[] = {
|
|||
"2}.5,:2^[71}f]5}.!0.0^_1[01}_1_1_1@!(y18:*root-environment*)",
|
||||
|
||||
"P", "root-environment",
|
||||
"%1t,@(y18:*root-environment*),.2,@(y10:env-lookup)[13",
|
||||
|
||||
"P", "transform!",
|
||||
"%1${@(y16:root-environment),.3,t,@(y5:xform)[03},${.2,'(l3:y13:define-"
|
||||
"syntax;y1:*;y1:*;),@(y13:syntax-match?)[02}?{${.2da,@(y3:id?)[01}}{f}?"
|
||||
"{${t,@(y18:*root-environment*),.4da,@(y10:env-lookup)[03},.0?{.1dda,.1"
|
||||
"sz}_1}.0]2",
|
||||
"%1.0p?{'(y6:define),.1aq?{.0d,&0{%1.0]1},@(y13:apply-to-list)[12}'(y13"
|
||||
":define-syntax),.1aq?{.0d,&0{%1t,@(y18:*root-environment*),.2,@(y10:en"
|
||||
"v-lookup)[13},@(y13:apply-to-list)[12}'(y16:record-case-miss)]1}t,@(y1"
|
||||
"8:*root-environment*),.2,@(y10:env-lookup)[13",
|
||||
|
||||
"P", "error*",
|
||||
"%2.1,.1c,@(y5:error),@(y13:apply-to-list)[22",
|
||||
|
||||
"P", "visit",
|
||||
"%1,#0${.3,@(y15:open-input-file)[01}.!0${${.4^,@(y4:read)[01},,#0.4,.1"
|
||||
",&2{%1.0R8~?{${.2,@(y10:transform!)[01},Po,.1W5PoW6_1${:1^,@(y4:read)["
|
||||
"01},:0^[11}]1}.!0.0^_1[01}.0^P60]2",
|
||||
"P", "eval-top-form",
|
||||
"%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"
|
||||
"fine),.1q?{${.4,.4d,@(y12:xform-define)[02},${.2da,'(y6:define),l2,.6["
|
||||
"01},.0?{.1dda,.1,'(y4:set!),l3,@(y25:compile-and-run-core-expr)[51}.4,"
|
||||
".2da,'(s39:identifier cannot be (re)defined in env),@(y7:x-error)[53}'"
|
||||
"(y13:define-syntax),.1q?{${.4,.4d,@(y19:xform-define-syntax)[02},${.2d"
|
||||
"a,'(y13:define-syntax),l2,.6[01},.0?{.1dda,.1sz]5}.4,.2da,'(s49:identi"
|
||||
"fier cannot be (re)defined as syntax in env),@(y7:x-error)[53}.0K0?{.2"
|
||||
",${.5,.5,.5[02},@(y13:eval-top-form)[32}.0U0?{${.4,.4d,.4,@(y16:xform-"
|
||||
"integrable)[03},@(y25:compile-and-run-core-expr)[31}${.4,.4,f,@(y5:xfo"
|
||||
"rm)[03},@(y25:compile-and-run-core-expr)[31}${.3,.3,f,@(y5:xform)[03},"
|
||||
"@(y25:compile-and-run-core-expr)[21",
|
||||
|
||||
"P", "visit/c",
|
||||
"C", 0,
|
||||
"f@!(y9:*verbose*)",
|
||||
|
||||
"P", "compile-and-run-core-expr",
|
||||
"%1.0p~?{${.2,'(s29:unexpected transformed output),@(y7:x-error)[02}}@("
|
||||
"y9:*verbose*)?{Po,.1W5PoW6}'(y6:define),.1aq?{'(y4:set!),.1sa}${.2,@(y"
|
||||
"21:compile-to-thunk-code)[01},@(y9:*verbose*)?{Po,.1W5PoW6}.0U4,U91,${"
|
||||
".2[00},@(y9:*verbose*)?{Po,.1W5PoW6]4}]4",
|
||||
|
||||
"P", "visit/x",
|
||||
"%1,#0${.3,@(y15:open-input-file)[01}.!0${${.4^,@(y4:read)[01},,#0.4,.1"
|
||||
",&2{%1.0R8~?{${.2,@(y10:transform!)[01},Po,.1W5PoW6${.2,,#0.0,&1{%1'(y"
|
||||
"5:begin),.1aq?{.0d,:0,&1{%!0.0,:0^,@(y10:%25for-each1)[12},@(y13:apply"
|
||||
"-to-list)[12}'(y6:define),.1aq?{.0d,:0,&1{%2.1,.1,'(y4:set!),l3,:0^[21"
|
||||
"},@(y13:apply-to-list)[12}'(y13:define-syntax),.1aq?{.0d,&0{%2]2},@(y1"
|
||||
"3:apply-to-list)[12}Po,${.3,@(y17:compile-to-string)[01}W5PoW6]1}.!0.0"
|
||||
"^_1[01}_1${:1^,@(y4:read)[01},:0^[11}]1}.!0.0^_1[01}.0^P60]2",
|
||||
",&2{%1.0R8~?{@(y9:*verbose*)?{Po,.1W5PoW6}${@(y16:root-environment),.3"
|
||||
",@(y13:eval-top-form)[02}@(y9:*verbose*)?{PoW6}${:1^,@(y4:read)[01},:0"
|
||||
"^[11}]1}.!0.0^_1[01}.0^P60]2",
|
||||
|
||||
0, 0, 0
|
||||
};
|
||||
|
|
|
|||
Loading…
Reference in a new issue