Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-26 21:58:51 +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 (not-pat-literal? id) (not (pat-literal? id)))
(define (ellipsis-pair? x use-env) (define (ellipsis-pair? x)
(and (pair? x) (ellipsis? (car x) use-env))) (and (pair? x) (ellipsis? (car x))))
; FIXME: we need undrscore? test for _ pattern to make sure it isn't bound ; 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: 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: ; root-environment may be not yet defined, so instead of this test:
; (free-id=? x mac-env '... root-environment) we will do it manually; ; (free-id=? x mac-env '... root-environment) we will do it manually;
; nb: 'real' ... is a builtin, at this time already registered in rnr ; nb: 'real' ... is a builtin, at this time already registered in rnr
(define ellipsis-den ; we may need to be first to alloc ... binding! (define ellipsis-den ; we may need to be first to alloc ... binding!
(name-lookup *root-name-registry* '... (lambda (n) '...))) (name-lookup *root-name-registry* '... (lambda (n) '...)))
; now we need just peek x in maro env to compare with the above ; now we need just peek x in maro env to compare with the above
(define (ellipsis? x use-env) (define (ellipsis? x)
(if ellipsis (if ellipsis
(eq? x ellipsis) (eq? x ellipsis)
(and (id? x) (eq? (mac-env x 'peek) ellipsis-den)))) (and (id? x) (eq? (mac-env x 'peek) ellipsis-den))))
@ -731,12 +724,12 @@
; pattern or template for which (pred? id) is true. If ; pattern or template for which (pred? id) is true. If
; include-scalars is false, we only include ids that are ; include-scalars is false, we only include ids that are
; within the scope of at least one ellipsis. ; 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 '()]) (let collect ([x x] [inc include-scalars] [l '()])
(cond [(id? x) (if (and inc (pred? x)) (cons x l) l)] (cond [(id? x) (if (and inc (pred? x)) (cons x l) l)]
[(vector? x) (collect (vector->list x) inc l)] [(vector? x) (collect (vector->list x) inc l)]
[(pair? x) [(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) #t (collect (cddr x) inc l))
(collect (car x) inc (collect (cdr x) inc l)))] (collect (car x) inc (collect (cdr x) inc l)))]
[else l]))) [else l])))
@ -754,9 +747,6 @@
(cond (cond
[(id? pat) [(id? pat)
(if (pat-literal? 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))) (continue-if (and (id? sexp) (free-id=? sexp use-env pat mac-env)))
(cons (cons pat sexp) bindings))] (cons (cons pat sexp) bindings))]
[(vector? pat) [(vector? pat)
@ -764,13 +754,13 @@
(match (vector->list pat) (vector->list sexp) bindings)] (match (vector->list pat) (vector->list sexp) bindings)]
[(not (pair? pat)) [(not (pair? pat))
(continue-if (equal? pat sexp))] (continue-if (equal? pat sexp))]
[(ellipsis-pair? (cdr pat) use-env) [(ellipsis-pair? (cdr pat))
(let* ([tail-len (length (cddr pat))] (let* ([tail-len (length (cddr pat))]
[sexp-len (if (list? sexp) (length sexp) (fail))] [sexp-len (if (list? sexp) (length sexp) (fail))]
[seq-len (fx- sexp-len tail-len)] [seq-len (fx- sexp-len tail-len)]
[sexp-tail (begin (if (negative? seq-len) (fail)) (list-tail sexp seq-len))] [sexp-tail (begin (if (negative? seq-len) (fail)) (list-tail sexp seq-len))]
[seq (reverse (list-tail (reverse sexp) tail-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) (define (match1 sexp)
(map cdr (match (car pat) sexp '()))) (map cdr (match (car pat) sexp '())))
(append (append
@ -790,16 +780,15 @@
(define new-literals (define new-literals
(body (body
(define nl (define nl
(map (lambda (id) ; FIXME: ref creates bindings in root env -- and spoils it! (map (lambda (id) (cons id (new-literal-id id mac-env (lambda () nl))))
(cons id (new-literal-id id mac-env (lambda () nl)))) (list-ids tmpl #t (lambda (id) (not (assq id top-bindings))))))
(list-ids tmpl #t (lambda (id) (not (assq id top-bindings))) use-env)))
nl)) nl))
(define ellipsis-vars (define ellipsis-vars
(list-ids pat #f not-pat-literal? use-env)) (list-ids pat #f not-pat-literal?))
(define (list-ellipsis-vars subtmpl) (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 ([tmpl tmpl] [bindings top-bindings])
(let expand-part ([tmpl tmpl]) (let expand-part ([tmpl tmpl])
@ -810,7 +799,7 @@
(assq tmpl new-literals)))] (assq tmpl new-literals)))]
[(vector? tmpl) [(vector? tmpl)
(list->vector (expand-part (vector->list 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))]) (let ([vars-to-iterate (list-ellipsis-vars (car tmpl))])
(define (lookup var) (define (lookup var)
(cdr (assq var bindings))) (cdr (assq var bindings)))
@ -1853,7 +1842,7 @@
(loop l)] (loop l)]
[(and (pair? v) (eq? (car v) 'syntax-rules)) [(and (pair? v) (eq? (car v) 'syntax-rules))
(body (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) (define (sr-env id at)
(cond [(new-id? id) (new-id-lookup id at)] (cond [(new-id? id) (new-id-lookup id at)]
[(eq? at 'peek) ; for free-id=? [(eq? at 'peek) ; for free-id=?

59
t.c
View file

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