Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-25 21:58:54 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

cleanup after 'peek' env introduction

Browse source
This commit is contained in:
ESL 2024-07-14 11:03:54 -04:00
parent d93c440331
commit bb97a65b2f
2 changed files with 42 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
src/t.scm
View file

@ -705,24 +705,17 @@
(define (not-pat-literal? id) (not (pat-literal? id)))
(define (ellipsis-pair? x use-env)
(and (pair? x) (ellipsis? (car x) use-env)))
(define (ellipsis-pair? x)
(and (pair? x) (ellipsis? (car x))))
; FIXME: we need undrscore? test for _ pattern to make sure it isn't bound
; FIXME: template of the form (... <templ>) must disable ellipsis? in <templ>
; FIXME: here we have a major problem: to determine if some id is an ellipsis
; we look it up in mac-env for free-id=? purposes that can ony work
; if we allocate denotations in use-env AND in mac-env(= root env?),
; which by design has to keep only very important ids, not random junk!
;(define (ellipsis-denotation? den)
; (eq? (location-val den) '...)) ; FIXME: need eq? with correct location!
; (ellipsis-denotation? (xenv-ref mac-env x))
; root-environment may be not yet defined, so instead of this test:
; (free-id=? x mac-env '... root-environment) we will do it manually;
; nb: 'real' ... is a builtin, at this time already registered in rnr
(define ellipsis-den ; we may need to be first to alloc ... binding!
(name-lookup *root-name-registry* '... (lambda (n) '...)))
; now we need just peek x in maro env to compare with the above
(define (ellipsis? x use-env)
(define (ellipsis? x)
(if ellipsis
(eq? x ellipsis)
(and (id? x) (eq? (mac-env x 'peek) ellipsis-den))))
@ -731,12 +724,12 @@
; pattern or template for which (pred? id) is true. If
; include-scalars is false, we only include ids that are
; within the scope of at least one ellipsis.
(define (list-ids x include-scalars pred? use-env)
(define (list-ids x include-scalars pred?)
(let collect ([x x] [inc include-scalars] [l '()])
(cond [(id? x) (if (and inc (pred? x)) (cons x l) l)]
[(vector? x) (collect (vector->list x) inc l)]
[(pair? x)
(if (ellipsis-pair? (cdr x) use-env)
(if (ellipsis-pair? (cdr x))
(collect (car x) #t (collect (cddr x) inc l))
(collect (car x) inc (collect (cdr x) inc l)))]
[else l])))
@ -754,9 +747,6 @@
(cond
[(id? pat)
(if (pat-literal? pat)
; FIXME: another use of mav-env for free-id=? purposes that can ony work
; if we allocate denotations in use-env AND in mac-env(= root env?),
; which by design has to keep only very important ids, not random junk!
(continue-if (and (id? sexp) (free-id=? sexp use-env pat mac-env)))
(cons (cons pat sexp) bindings))]
[(vector? pat)
@ -764,13 +754,13 @@
(match (vector->list pat) (vector->list sexp) bindings)]
[(not (pair? pat))
(continue-if (equal? pat sexp))]
[(ellipsis-pair? (cdr pat) use-env)
[(ellipsis-pair? (cdr pat))
(let* ([tail-len (length (cddr pat))]
[sexp-len (if (list? sexp) (length sexp) (fail))]
[seq-len (fx- sexp-len tail-len)]
[sexp-tail (begin (if (negative? seq-len) (fail)) (list-tail sexp seq-len))]
[seq (reverse (list-tail (reverse sexp) tail-len))]
[vars (list-ids (car pat) #t not-pat-literal? use-env)])
[vars (list-ids (car pat) #t not-pat-literal?)])
(define (match1 sexp)
(map cdr (match (car pat) sexp '())))
(append
@ -790,16 +780,15 @@
(define new-literals
(body
(define nl
(map (lambda (id) ; FIXME: ref creates bindings in root env -- and spoils it!
(cons id (new-literal-id id mac-env (lambda () nl))))
(list-ids tmpl #t (lambda (id) (not (assq id top-bindings))) use-env)))
(map (lambda (id) (cons id (new-literal-id id mac-env (lambda () nl))))
(list-ids tmpl #t (lambda (id) (not (assq id top-bindings))))))
nl))
(define ellipsis-vars
(list-ids pat #f not-pat-literal? use-env))
(list-ids pat #f not-pat-literal?))
(define (list-ellipsis-vars subtmpl)
(list-ids subtmpl #t (lambda (id) (memq id ellipsis-vars)) use-env))
(list-ids subtmpl #t (lambda (id) (memq id ellipsis-vars))))
(let expand ([tmpl tmpl] [bindings top-bindings])
(let expand-part ([tmpl tmpl])
@ -810,7 +799,7 @@
(assq tmpl new-literals)))]
[(vector? tmpl)
(list->vector (expand-part (vector->list tmpl)))]
[(and (pair? tmpl) (ellipsis-pair? (cdr tmpl) use-env))
[(and (pair? tmpl) (ellipsis-pair? (cdr tmpl)))
(let ([vars-to-iterate (list-ellipsis-vars (car tmpl))])
(define (lookup var)
(cdr (assq var bindings)))
@ -1853,7 +1842,7 @@
(loop l)]
[(and (pair? v) (eq? (car v) 'syntax-rules))
(body
; FIXME: this is the mac-env for built-in syntax-rules macros!
; this is the mac-env for built-in syntax-rules macros!
(define (sr-env id at)
(cond [(new-id? id) (new-id-lookup id at)]
[(eq? at 'peek) ; for free-id=?

59
t.c
View file

@ -451,36 +451,35 @@ char *t_code[] = {
"P", "syntax-rules*",
"%4,,,,,,,,#0#1#2#3#4#5#6#7.(i10),&1{%1:0,.1A0]1}.!0.0,&1{%1${.2,:0^[01"
"}~]1}.!1.4,&1{%2.0p?{.1,.1a,:0^[22}f]2}.!2${&0{%1'(y3:...)]1},'(y3:..."
"),@(y20:*root-name-registry*),@(y11:name-lookup)[03}.!3.8,.4,.(i11),&3"
"{%2:0?{:0,.1q]2}${.2,@(y3:id?)[01}?{:1^,${'(y4:peek),.4,:2[02}q]2}f]2}"
".!4.2,&1{%4n,.2,.2,,#0.7,:0,.2,.9,&4{%3${.2,@(y3:id?)[01}?{.1?{${.2,:0"
"[01}}{f}?{.2,.1c]3}.2]3}.0V0?{.2,.2,.2X0,:1^[33}.0p?{${:3,.3d,:2^[02}?"
"{${.4,.4,.4dd,:1^[03},t,.2a,:1^[33}${.4,.4,.4d,:1^[03},.2,.2a,:1^[33}."
"2]3}.!0.0^_1[43}.!5.5,.2,.4,.3,.(i12),&5{%3k3,.0,,#0.1,&1{%0f,:0[01}.!"
"0n,.5,.5,,#0.4,.1,:4,:3,.(i13),:2,:1,:0,&8{%3,#0:7,.4,&2{%1.0?{:0]1}:1"
"^[10}.!0${.3,@(y3:id?)[01}?{${.3,:1^[01}?{${.4,@(y3:id?)[01}?{${:0,.4,"
":3,.7,@(y9:free-id=?)[04}}{f},.1^[41}.3,.3,.3cc]4}.1V0?{.2V0,.0?{.0}{$"
"{:7^[00}}_1.3,.3X0,.3X0,:6^[43}.1p~?{.2,.2e,.1^[41}${:3,.4d,:2^[02}?{."
"1ddg,.3L0?{.3g}{${:7^[00}},.1,.1I-,.0<0?{${:7^[00}}.0,.6A6,.3,.7A8A6A8"
",${:3,:4^,t,.(i11)a,:5^[04},,#0:6,.9,&2{%1${n,.3,:0a,:1^[03},@(y3:cdr)"
",@(y5:%25map1)[12}.!0${.(i12),.6,.(i12)dd,:6^[03},${${.7,.6^,@(y5:%25m"
"ap1)[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{%4,,,#0#1#2,#0${${.(i11),.(i11),&1{%1:0,.1A3~]1},t,.(i12),:1^"
"[04},:3,.4,&2{%1${:0,&1{%0:0^]0},:1,.4,@(y14:new-literal-id)[03},.1c]1"
"},@(y5:%25map1)[02}.!0.0^_1.!0${.8,:2^,f,.8,:1^[04}.!1.6,.2,:1,&3{%1:2"
",:1,&1{%1:0^,.1A0]1},t,.3,:0^[14}.!2.5,.5,,#0.8,.4,:0,.(i12),.9,.5,&6{"
"%2.0,,#0.0,.4,:0,:1,:2,:3,:4,:5,&8{%1${.2,@(y3:id?)[01}?{:6,.1A3,.0?{."
"0}{:0,.2A3,.0?{.0}{:1^,.3A3}_1}_1d]1}.0V0?{${.2X0,:7^[01}X1]1}.0p?{${:"
"3,.3d,:2^[02}}{f}?{${.2a,:4^[01},,,#0#1:6,&1{%1:0,.1A3d]1}.!0.2,.4,:5,"
"&3{%!0${.2,:2,@(y4:cons),@(y5:%25map2)[03},:1a,:0^[12}.!1.2u?{${.5dd,:"
"7^[01},${.6a,:7^[01}c]4}${.4,.3^,@(y5:%25map1)[02},${.6dd,:7^[01},${.3"
",.6^c,@(y4:%25map),@(y13:apply-to-list)[02}L6]5}.0p?{${.2d,:7^[01},${."
"3a,:7^[01}c]1}.0]1}.!0.0^_1[21}.!0.0^_1[72}.!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,:2,.1,.4,.6,:1^[64}.4d,:0^[51}."
"!0.0^_1[21}](i12)",
"}~]1}.!1.4,&1{%1.0p?{.0a,:0^[11}f]1}.!2${&0{%1'(y3:...)]1},'(y3:...),@"
"(y20:*root-name-registry*),@(y11:name-lookup)[03}.!3.8,.4,.(i11),&3{%1"
":0?{:0,.1q]1}${.2,@(y3:id?)[01}?{:1^,${'(y4:peek),.4,:2[02}q]1}f]1}.!4"
".2,&1{%3n,.2,.2,,#0:0,.1,.8,&3{%3${.2,@(y3:id?)[01}?{.1?{${.2,:0[01}}{"
"f}?{.2,.1c]3}.2]3}.0V0?{.2,.2,.2X0,:1^[33}.0p?{${.2d,:2^[01}?{${.4,.4,"
".4dd,:1^[03},t,.2a,:1^[33}${.4,.4,.4d,:1^[03},.2,.2a,:1^[33}.2]3}.!0.0"
"^_1[33}.!5.5,.2,.4,.3,.(i12),&5{%3k3,.0,,#0.1,&1{%0f,:0[01}.!0n,.5,.5,"
",#0.4,.1,:4,:3,:2,:1,:0,.(i16),&8{%3,#0:7,.4,&2{%1.0?{:0]1}:1^[10}.!0$"
"{.3,@(y3:id?)[01}?{${.3,:2^[01}?{${.4,@(y3:id?)[01}?{${:1,.4,:0,.7,@(y"
"9:free-id=?)[04}}{f},.1^[41}.3,.3,.3cc]4}.1V0?{.2V0,.0?{.0}{${:7^[00}}"
"_1.3,.3X0,.3X0,:6^[43}.1p~?{.2,.2e,.1^[41}${.3d,:3^[01}?{.1ddg,.3L0?{."
"3g}{${:7^[00}},.1,.1I-,.0<0?{${:7^[00}}.0,.6A6,.3,.7A8A6A8,${:4^,t,.(i"
"10)a,:5^[03},,#0:6,.9,&2{%1${n,.3,:0a,:1^[03},@(y3:cdr),@(y5:%25map1)["
"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{%4,,,#"
"0#1#2,#0${${.(i10),&1{%1:0,.1A3~]1},t,.(i11),:1^[03},:3,.4,&2{%1${:0,&"
"1{%0:0^]0},:1,.4,@(y14:new-literal-id)[03},.1c]1},@(y5:%25map1)[02}.!0"
".0^_1.!0${:2^,f,.7,:1^[03}.!1.1,:1,&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^[1"
"3}.!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:%25map"
"1)[02},${.6dd,:6^[01},${.3,.6^c,@(y4:%25map),@(y13:apply-to-list)[02}L"
"6]5}.0p?{${.2d,:6^[01},${.3a,:6^[01}c]1}.0]1}.!0.0^_1[21}.!0.0^_1[72}."
"!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,:2,.1"
",.4,.6,:1^[64}.4d,:0^[51}.!0.0^_1[21}](i12)",
"P", "make-include-transformer",
"%1,,,,#0#1#2#3&0{%2${.2,@(y6:list2?)[01}?{.0daS0}{f}~?{${.2,'(s14:inva"