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

procedure ids store their syms with dens

Browse source
This commit is contained in:
ESL 2023-04-15 18:08:08 -04:00
parent c10c65e90c
commit 3476c64553
4 changed files with 2480 additions and 2494 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4835
k.c
View file

File diff suppressed because it is too large Load diff

29
src/k.sf
View file

@ -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
View file

@ -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
View file

@ -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,"