From bb97a65b2fdb6136b73c893c7ee465f99624907c Mon Sep 17 00:00:00 2001 From: ESL Date: Sun, 14 Jul 2024 11:03:54 -0400 Subject: [PATCH] cleanup after 'peek' env introduction --- src/t.scm | 37 ++++++++++++---------------------- t.c | 59 +++++++++++++++++++++++++++---------------------------- 2 files changed, 42 insertions(+), 54 deletions(-) diff --git a/src/t.scm b/src/t.scm index 04e27a3..0f24e07 100644 --- a/src/t.scm +++ b/src/t.scm @@ -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 (... ) must disable ellipsis? in - ; 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=? diff --git a/t.c b/t.c index 00bd47e..8923fca 100644 --- a/t.c +++ b/t.c @@ -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"