mirror of
https://github.com/false-schemers/skint.git
synced 2025-02-01 07:57:49 +01:00
procedure ids store their syms with dens
This commit is contained in:
ESL
parent
c10c65e90c
commit
3476c64553
4 changed files with 2480 additions and 2494 deletions
29
src/k.sf
29
src/k.sf
|
|
@ -224,14 +224,14 @@
|
|||
; Special forms are either a symbol naming a builtin, or a transformer procedure
|
||||
; that takes two arguments: a macro use and the environment of the macro use.
|
||||
|
||||
; <identifier> -> <symbol> | <thunk returning den>
|
||||
; <identifier> -> <symbol> | <thunk returning (sym . den)>
|
||||
; <denotation> -> <binding>
|
||||
; <binding> -> (<symbol> . <value>)
|
||||
; <value> -> <special> | <core>
|
||||
; <special> -> <builtin> | <transformer>
|
||||
; <builtin> -> syntax | quote | set! | set& | begin | if | lambda |
|
||||
; lambda* | syntax-lambda | letcc | withcc | body |
|
||||
; define | define-syntax ; top-level only
|
||||
; <builtin> -> syntax | quote | set! | set& | if | lambda | lambda* |
|
||||
; letcc | withcc | body | begin | define | define-syntax |
|
||||
; syntax-lambda | syntax-rules | syntax-length | syntax-error
|
||||
; <transformer> -> <procedure of exp and env returning exp>
|
||||
|
||||
(define-inline (val-core? val) (pair? val))
|
||||
|
|
@ -244,11 +244,11 @@
|
|||
(define-inline (binding-set-val! bnd val) (set-cdr! bnd val))
|
||||
(define-inline (find-top-binding s blist) (assq s blist))
|
||||
|
||||
(define (new-id den) (define p (list den)) (lambda () p))
|
||||
(define (old-den id) (car (id)))
|
||||
(define (new-id sym den) (define p (cons sym den)) (lambda () p))
|
||||
(define (old-sym id) (car (id)))
|
||||
(define (old-den id) (cdr (id)))
|
||||
(define (id? x) (or (symbol? x) (procedure? x)))
|
||||
(define (id->sym id) (if (symbol? id) id (den->sym (old-den id))))
|
||||
(define (den->sym den) (if (symbol? den) den (binding-sym den)))
|
||||
(define (id->sym id) (if (symbol? id) id (old-sym id)))
|
||||
|
||||
(define (extend-xenv env id bnd) (lambda (i) (if (eq? id i) bnd (env i))))
|
||||
|
||||
|
|
@ -314,8 +314,7 @@
|
|||
|
||||
(define (xform-ref id env)
|
||||
(let ([den (env id)])
|
||||
(cond [(symbol? den) (x-error "unexpected den" den)] ;(list 'ref den)
|
||||
[(eq? (binding-val den) '...) (x-error "improper use of ...")]
|
||||
(cond [(eq? (binding-val den) '...) (x-error "improper use of ...")]
|
||||
[else (binding-val den)])))
|
||||
|
||||
(define (xform-quote tail env)
|
||||
|
|
@ -326,8 +325,7 @@
|
|||
(define (xform-set! tail env)
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
|
||||
(cond [(symbol? den) (x-error "unexpected den in set!" den)] ;(list 'set! den xexp)
|
||||
[(binding-special? den) (binding-set-val! den xexp) '(begin)]
|
||||
(cond [(binding-special? den) (binding-set-val! den xexp) '(begin)]
|
||||
[else (let ([val (binding-val den)])
|
||||
(if (eq? (car val) 'ref)
|
||||
(list 'set! (cadr val) xexp)
|
||||
|
|
@ -337,8 +335,7 @@
|
|||
(define (xform-set& tail env)
|
||||
(if (list1? tail)
|
||||
(let ([den (env (car tail))])
|
||||
(cond [(symbol? den) (x-error "unexpected den in set&" den)] ;(list 'set& den)
|
||||
[(binding-special? den) (x-error "set& of a non-variable")]
|
||||
(cond [(binding-special? den) (x-error "set& of a non-variable")]
|
||||
[else (let ([val (binding-val den)])
|
||||
(if (eq? (car val) 'ref)
|
||||
(list 'set& (cadr val))
|
||||
|
|
@ -445,7 +442,7 @@
|
|||
[nid (gensym (id->sym id))] [env (add-var id nid env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
|
||||
[(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail)))
|
||||
(let* ([id (caar tail)] [lambda-id (new-id (make-binding 'lambda 'lambda))]
|
||||
(let* ([id (caar tail)] [lambda-id (new-id 'lambda (make-binding 'lambda 'lambda))]
|
||||
[init (cons lambda-id (cons (cdar tail) (cdr tail)))]
|
||||
[nid (gensym (id->sym id))] [env (add-var id nid env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
|
||||
|
|
@ -656,7 +653,7 @@
|
|||
; fresh ids, but that's okay because when we go to retrieve a
|
||||
; fresh id, assq will always retrieve the first one.
|
||||
(define new-literals
|
||||
(map (lambda (id) (cons id (new-id (mac-env id))))
|
||||
(map (lambda (id) (cons id (new-id (id->sym id) (mac-env id))))
|
||||
(list-ids tmpl #t
|
||||
(lambda (id) (not (assq id top-bindings))))))
|
||||
|
||||
|
|
|
|||
29
src/t.scm
29
src/t.scm
|
|
@ -189,14 +189,14 @@
|
|||
; Special forms are either a symbol naming a builtin, or a transformer procedure
|
||||
; that takes two arguments: a macro use and the environment of the macro use.
|
||||
|
||||
; <identifier> -> <symbol> | <thunk returning den>
|
||||
; <identifier> -> <symbol> | <thunk returning (sym . den)>
|
||||
; <denotation> -> <binding>
|
||||
; <binding> -> (<symbol> . <value>)
|
||||
; <value> -> <special> | <core>
|
||||
; <special> -> <builtin> | <transformer>
|
||||
; <builtin> -> syntax | quote | set! | set& | begin | if | lambda |
|
||||
; lambda* | syntax-lambda | letcc | withcc | body |
|
||||
; define | define-syntax ; top-level only
|
||||
; <builtin> -> syntax | quote | set! | set& | if | lambda | lambda* |
|
||||
; letcc | withcc | body | begin | define | define-syntax |
|
||||
; syntax-lambda | syntax-rules | syntax-length | syntax-error
|
||||
; <transformer> -> <procedure of exp and env returning exp>
|
||||
|
||||
(define-syntax val-core? pair?)
|
||||
|
|
@ -207,11 +207,11 @@
|
|||
(define-syntax binding-sym car)
|
||||
(define-syntax binding-set-val! set-cdr!)
|
||||
|
||||
(define (new-id den) (define p (list den)) (lambda () p))
|
||||
(define (old-den id) (car (id)))
|
||||
(define (new-id sym den) (define p (cons sym den)) (lambda () p))
|
||||
(define (old-sym id) (car (id)))
|
||||
(define (old-den id) (cdr (id)))
|
||||
(define (id? x) (or (symbol? x) (procedure? x)))
|
||||
(define (id->sym id) (if (symbol? id) id (den->sym (old-den id))))
|
||||
(define (den->sym den) (if (symbol? den) den (binding-sym den)))
|
||||
(define (id->sym id) (if (symbol? id) id (old-sym id)))
|
||||
|
||||
(define (extend-xenv env id bnd) (lambda (i) (if (eq? id i) bnd (env i))))
|
||||
|
||||
|
|
@ -279,8 +279,7 @@
|
|||
|
||||
(define (xform-ref id env)
|
||||
(let ([den (env id)])
|
||||
(cond [(symbol? den) (x-error "unexpected den" den)] ;(list 'ref den)
|
||||
[(eq? (binding-val den) '...) (x-error "improper use of ...")]
|
||||
(cond [(eq? (binding-val den) '...) (x-error "improper use of ...")]
|
||||
[else (binding-val den)])))
|
||||
|
||||
(define (xform-quote tail env)
|
||||
|
|
@ -291,8 +290,7 @@
|
|||
(define (xform-set! tail env)
|
||||
(if (and (list2? tail) (id? (car tail)))
|
||||
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
|
||||
(cond [(symbol? den) (x-error "unexpected den in set!" den)] ;(list 'set! den xexp)
|
||||
[(binding-special? den) (binding-set-val! den xexp) '(begin)]
|
||||
(cond [(binding-special? den) (binding-set-val! den xexp) '(begin)]
|
||||
[else (let ([val (binding-val den)])
|
||||
(if (eq? (car val) 'ref)
|
||||
(list 'set! (cadr val) xexp)
|
||||
|
|
@ -302,8 +300,7 @@
|
|||
(define (xform-set& tail env)
|
||||
(if (list1? tail)
|
||||
(let ([den (env (car tail))])
|
||||
(cond [(symbol? den) (x-error "unexpected den in set&" den)] ;(list 'set& den)
|
||||
[(binding-special? den) (x-error "set& of a non-variable")]
|
||||
(cond [(binding-special? den) (x-error "set& of a non-variable")]
|
||||
[else (let ([val (binding-val den)])
|
||||
(if (eq? (car val) 'ref)
|
||||
(list 'set& (cadr val))
|
||||
|
|
@ -410,7 +407,7 @@
|
|||
[nid (gensym (id->sym id))] [env (add-var id nid env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
|
||||
[(and (list2+? tail) (pair? (car tail)) (id? (caar tail)) (idslist? (cdar tail)))
|
||||
(let* ([id (caar tail)] [lambda-id (new-id (make-binding 'lambda 'lambda))]
|
||||
(let* ([id (caar tail)] [lambda-id (new-id 'lambda (make-binding 'lambda 'lambda))]
|
||||
[init (cons lambda-id (cons (cdar tail) (cdr tail)))]
|
||||
[nid (gensym (id->sym id))] [env (add-var id nid env)])
|
||||
(loop env (cons id ids) (cons init inits) (cons nid nids) rest))]
|
||||
|
|
@ -579,7 +576,7 @@
|
|||
; fresh ids, but that's okay because when we go to retrieve a
|
||||
; fresh id, assq will always retrieve the first one.
|
||||
(define new-literals
|
||||
(map (lambda (id) (cons id (new-id (mac-env id))))
|
||||
(map (lambda (id) (cons id (new-id (id->sym id) (mac-env id))))
|
||||
(list-ids tmpl #t
|
||||
(lambda (id) (not (assq id top-bindings))))))
|
||||
|
||||
|
|
|
|||
81
t.c
81
t.c
|
|
@ -97,19 +97,19 @@ char *t_code[] = {
|
|||
"A", "binding-set-val!", "set-cdr!",
|
||||
|
||||
"P", "new-id",
|
||||
"%1,#0.1,l1.!0.0,&1{%0:0^]0}]2",
|
||||
"%2,#0.2,.2c.!0.0,&1{%0:0^]0}]3",
|
||||
|
||||
"P", "old-sym",
|
||||
"%1${.2[00}a]1",
|
||||
|
||||
"P", "old-den",
|
||||
"%1${.2[00}a]1",
|
||||
"%1${.2[00}d]1",
|
||||
|
||||
"P", "id?",
|
||||
"%1.0Y0,.0?{.0]2}.1K0]2",
|
||||
|
||||
"P", "id->sym",
|
||||
"%1.0Y0?{.0]1}${.2,@(y7:old-den)[01},@(y8:den->sym)[11",
|
||||
|
||||
"P", "den->sym",
|
||||
"%1.0Y0?{.0]1}.0a]1",
|
||||
"%1.0Y0?{.0]1}.0,@(y7:old-sym)[11",
|
||||
|
||||
"P", "extend-xenv",
|
||||
"%3.0,.3,.3,&3{%1.0,:0q?{:1]1}.0,:2[11}]3",
|
||||
|
|
@ -149,8 +149,8 @@ char *t_code[] = {
|
|||
"orm-call)[73",
|
||||
|
||||
"P", "xform-ref",
|
||||
"%2${.2,.4[01},.0Y0?{.0,'(s14:unexpected den),@(y7:x-error)[32}'(y3:..."
|
||||
"),.1dq?{'(s19:improper use of ...),@(y7:x-error)[31}.0d]3",
|
||||
"%2${.2,.4[01},'(y3:...),.1dq?{'(s19:improper use of ...),@(y7:x-error)"
|
||||
"[31}.0d]3",
|
||||
|
||||
"P", "xform-quote",
|
||||
"%2${.2,@(y6:list1?)[01}?{${.2a,@(y17:xform-sexp->datum)[01},'(y5:quote"
|
||||
|
|
@ -158,18 +158,16 @@ char *t_code[] = {
|
|||
|
||||
"P", "xform-set!",
|
||||
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xfo"
|
||||
"rm)[03},${.3a,.5[01},.0Y0?{.0,'(s22:unexpected den in set!),@(y7:x-err"
|
||||
"or)[42}${.2,@(y16:binding-special?)[01}?{.1,.1sd'(l1:y5:begin;)]4}.0d,"
|
||||
"'(y3:ref),.1aq?{.2,.1da,'(y4:set!),l3]5}'(s27:set! to non-identifier f"
|
||||
"orm),@(y7:x-error)[51}.0,'(y4:set!)c,'(s18:improper set! form),@(y7:x-"
|
||||
"error)[22",
|
||||
"rm)[03},${.3a,.5[01},${.2,@(y16:binding-special?)[01}?{.1,.1sd'(l1:y5:"
|
||||
"begin;)]4}.0d,'(y3:ref),.1aq?{.2,.1da,'(y4:set!),l3]5}'(s27:set! to no"
|
||||
"n-identifier form),@(y7:x-error)[51}.0,'(y4:set!)c,'(s18:improper set!"
|
||||
" form),@(y7:x-error)[22",
|
||||
|
||||
"P", "xform-set&",
|
||||
"%2${.2,@(y6:list1?)[01}?{${.2a,.4[01},.0Y0?{.0,'(s22:unexpected den in"
|
||||
" set&),@(y7:x-error)[32}${.2,@(y16:binding-special?)[01}?{'(s22:set& o"
|
||||
"f a non-variable),@(y7:x-error)[31}.0d,'(y3:ref),.1aq?{.0da,'(y4:set&)"
|
||||
",l2]4}'(s22:set& of a non-variable),@(y7:x-error)[41}.0,'(y4:set&)c,'("
|
||||
"s18:improper set& form),@(y7:x-error)[22",
|
||||
"%2${.2,@(y6:list1?)[01}?{${.2a,.4[01},${.2,@(y16:binding-special?)[01}"
|
||||
"?{'(s22:set& of a non-variable),@(y7:x-error)[31}.0d,'(y3:ref),.1aq?{."
|
||||
"0da,'(y4:set&),l2]4}'(s22:set& of a non-variable),@(y7:x-error)[41}.0,"
|
||||
"'(y4:set&)c,'(s18:improper set& form),@(y7:x-error)[22",
|
||||
|
||||
"P", "xform-if",
|
||||
"%2.0L0?{${.2,.4,&1{%1:0,.1,f,@(y5:xform)[13},@(y5:%25map1)[02},.0g,'2,"
|
||||
|
|
@ -232,16 +230,17 @@ char *t_code[] = {
|
|||
"}{f}?{.2a,.3da,${${.5,@(y7:id->sym)[01},@(y6:gensym)[01},${.(i11),.3,."
|
||||
"6,@(y7:add-var)[03},.9,.(i14),.3c,.(i14),.5c,.(i14),.7c,.4,:0^[(i15)5}"
|
||||
"${.4,@(y7:list2+?)[01}?{.2ap?{${.4aa,@(y3:id?)[01}?{${.4ad,@(y8:idslis"
|
||||
"t?)[01}}{f}}{f}}{f}?{.2aa,${'(y6:lambda),'(y6:lambda)c,@(y6:new-id)[01"
|
||||
"},.4d,.5adc,.1c,${${.6,@(y7:id->sym)[01},@(y6:gensym)[01},${.(i12),.3,"
|
||||
".7,@(y7:add-var)[03},.(i10),.(i15),.3c,.(i15),.5c,.(i15),.8c,.4,:0^[(i"
|
||||
"16)5}.4,'(s20:improper define form),@(y7:x-error)[(i11)2}'(y13:define-"
|
||||
"syntax),.1v?{${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}}{f}?{.2a,.3da,"
|
||||
"${.(i10),'(l1:y9:undefined;),.5,@(y11:add-binding)[03},.8,.(i13),tc,.("
|
||||
"i13),.4c,.(i13),.6c,.4,:0^[(i14)5}.4,'(s27:improper define-syntax form"
|
||||
"),@(y7:x-error)[(i11)2}.1K0?{.5,${.9,.8,.6[02}c,.(i10),.(i10),.(i10),."
|
||||
"(i10),:0^[(i11)5}.6,.(i11),.(i11)A8,.(i11)A8,.(i11)A8,@(y12:xform-labe"
|
||||
"ls)[(i11)5}.0,.5,.5A8,.5A8,.5A8,@(y12:xform-labels)[55}.!0.0^_1[25",
|
||||
"t?)[01}}{f}}{f}}{f}?{.2aa,${'(y6:lambda),'(y6:lambda)c,'(y6:lambda),@("
|
||||
"y6:new-id)[02},.4d,.5adc,.1c,${${.6,@(y7:id->sym)[01},@(y6:gensym)[01}"
|
||||
",${.(i12),.3,.7,@(y7:add-var)[03},.(i10),.(i15),.3c,.(i15),.5c,.(i15),"
|
||||
".8c,.4,:0^[(i16)5}.4,'(s20:improper define form),@(y7:x-error)[(i11)2}"
|
||||
"'(y13:define-syntax),.1v?{${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}}{"
|
||||
"f}?{.2a,.3da,${.(i10),'(l1:y9:undefined;),.5,@(y11:add-binding)[03},.8"
|
||||
",.(i13),tc,.(i13),.4c,.(i13),.6c,.4,:0^[(i14)5}.4,'(s27:improper defin"
|
||||
"e-syntax form),@(y7:x-error)[(i11)2}.1K0?{.5,${.9,.8,.6[02}c,.(i10),.("
|
||||
"i10),.(i10),.(i10),:0^[(i11)5}.6,.(i11),.(i11)A8,.(i11)A8,.(i11)A8,@(y"
|
||||
"12:xform-labels)[(i11)5}.0,.5,.5A8,.5A8,.5A8,@(y12:xform-labels)[55}.!"
|
||||
"0.0^_1[25",
|
||||
|
||||
"P", "xform-labels",
|
||||
"%5n,n,.4,.4,.4,,#0.0,.(i11),.(i11),&3{%5.0u?{${:0,:1,&1{%1:0,.1,f,@(y5"
|
||||
|
|
@ -312,19 +311,19 @@ char *t_code[] = {
|
|||
"[12}.!0${.(i12),.6,.(i12)dd,:6^[03},${${.7,.6^,@(y5:%25map1)[02},.5c,@"
|
||||
"(y4:list)c,@(y4:%25map),@(y13:apply-to-list)[02}L6](i11)}.2p?{${.5,.5d"
|
||||
",.5d,:6^[03},.3a,.3a,:6^[43}:7^[40}.!0.0^_1[63}.!6.8,.2,.7,.5,&4{%3,,,"
|
||||
"#0#1#2${${.9,&1{%1:0,.1A3~]1},t,.(i10),:1^[03},:3,&1{%1${${.4,:0[01},@"
|
||||
"(y6:new-id)[01},.1c]1},@(y5:%25map1)[02}.!0${:2^,f,.7,:1^[03}.!1.1,:1,"
|
||||
"&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^[13}.!2.5,.5,,#0.8,.4,:0,.8,.4,&5{%2."
|
||||
"0,,#0.0,.4,:0,:1,:2,:3,:4,&7{%1${.2,@(y3:id?)[01}?{:5,.1A3,.0?{.0}{:0,"
|
||||
".2A3,.0?{.0}{:1^,.3A3}_1}_1d]1}.0V0?{${.2X0,:6^[01}X1]1}.0p?{${.2d,:2^"
|
||||
"[01}}{f}?{${.2a,:3^[01},,,#0#1:5,&1{%1:0,.1A3d]1}.!0.2,.4,:4,&3{%!0${."
|
||||
"2,:2,@(y4:cons),@(y5:%25map2)[03},:1a,:0^[12}.!1.2u?{${.5dd,:6^[01},${"
|
||||
".6a,:6^[01}c]4}${.4,.3^,@(y5:%25map1)[02},${.6dd,:6^[01},${.3,.6^c,@(y"
|
||||
"4:%25map),@(y13:apply-to-list)[02}L6]5}.0p?{${.2d,:6^[01},${.3a,:6^[01"
|
||||
"}c]1}.0]1}.!0.0^_1[21}.!0.0^_1[62}.!7.(i11),.8,.8,&3{%2:2,,#0:0,.3,.5,"
|
||||
":1,.4,&5{%1.0u?{${:3,'(s14:invalid syntax),@(y7:x-error)[02}}.0a,.0a,."
|
||||
"1da,${:2,:3,.5,:4^[03},.0?{.0,.0,.3,.5,:1^[63}.4d,:0^[51}.!0.0^_1[21}]"
|
||||
"(i12)",
|
||||
"#0#1#2${${.9,&1{%1:0,.1A3~]1},t,.(i10),:1^[03},:3,&1{%1${${.4,:0[01},$"
|
||||
"{.5,@(y7:id->sym)[01},@(y6:new-id)[02},.1c]1},@(y5:%25map1)[02}.!0${:2"
|
||||
"^,f,.7,:1^[03}.!1.1,:1,&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^[13}.!2.5,.5,,"
|
||||
"#0.8,.4,:0,.8,.4,&5{%2.0,,#0.0,.4,:0,:1,:2,:3,:4,&7{%1${.2,@(y3:id?)[0"
|
||||
"1}?{:5,.1A3,.0?{.0}{:0,.2A3,.0?{.0}{:1^,.3A3}_1}_1d]1}.0V0?{${.2X0,:6^"
|
||||
"[01}X1]1}.0p?{${.2d,:2^[01}}{f}?{${.2a,:3^[01},,,#0#1:5,&1{%1:0,.1A3d]"
|
||||
"1}.!0.2,.4,:4,&3{%!0${.2,:2,@(y4:cons),@(y5:%25map2)[03},:1a,:0^[12}.!"
|
||||
"1.2u?{${.5dd,:6^[01},${.6a,:6^[01}c]4}${.4,.3^,@(y5:%25map1)[02},${.6d"
|
||||
"d,:6^[01},${.3,.6^c,@(y4:%25map),@(y13:apply-to-list)[02}L6]5}.0p?{${."
|
||||
"2d,:6^[01},${.3a,:6^[01}c]1}.0]1}.!0.0^_1[21}.!0.0^_1[62}.!7.(i11),.8,"
|
||||
".8,&3{%2:2,,#0:0,.3,.5,:1,.4,&5{%1.0u?{${:3,'(s14:invalid syntax),@(y7"
|
||||
":x-error)[02}}.0a,.0a,.1da,${:2,:3,.5,:4^[03},.0?{.0,.0,.3,.5,:1^[63}."
|
||||
"4d,:0^[51}.!0.0^_1[21}](i12)",
|
||||
|
||||
"P", "lookup-in-transformer-env",
|
||||
"%2.0K0?{.0,@(y7:old-den)[21}.1,,#0.2,.1,&2{%1.0p?{:1,.1aaq?{.0a]1}.0d,"
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue