From 8d5d967a975a3897b88410ee6e3e80b80dfac406 Mon Sep 17 00:00:00 2001 From: ESL Date: Thu, 25 Jul 2024 01:02:38 -0400 Subject: [PATCH] extra syntax-rules pattern escapes --- pre/t.scm | 46 ++++++++++++++++++------ t.c | 104 ++++++++++++++++++++++++++++++++---------------------- 2 files changed, 96 insertions(+), 54 deletions(-) diff --git a/pre/t.scm b/pre/t.scm index 4349da3..0f3ea5e 100644 --- a/pre/t.scm +++ b/pre/t.scm @@ -142,6 +142,7 @@ (define (list2? x) (and (pair? x) (list1? (cdr x)))) (define (list2+? x) (and (pair? x) (list1+? (cdr x)))) (define (list3? x) (and (pair? x) (list2? (cdr x)))) +(define (list3+? x) (and (pair? x) (list2+? (cdr x)))) (define (read-code-sexp port) ; for now, we will just use read with no support for circular structures @@ -371,8 +372,9 @@ (define syntax-quote-id (new-id 'syntax-quote (make-location 'syntax-quote) #f)) ; standard way of comparing identifiers used as keywords and such; details below -(define (free-id=? id1 env1 id2 env2) - (let ([p1 (env1 id1 'peek)] [p2 (env2 id2 'peek)]) +(define (free-id=? id1 env1 id2 . ?env2) + (let* ([p1 (env1 id1 'peek)] [nr *root-name-registry*] + [p2 (if (pair? ?env2) ((car ?env2) id2 'peek) (or (name-lookup nr id2 #f) nr))]) (and p1 p2 ; both envs should be supported by name registries (if (and (name-registry? p1) (name-registry? p2)) (and (eq? p1 p2) (eq? id1 id2)) ; would end w/same loc if alloced @@ -695,6 +697,17 @@ (apply x-error args) (x-error "improper syntax-error form" (cons 'syntax-error tail))))) +; named pattern/template escapes + +(define (pattern-escape->test x named-escape?) + (cond [(named-escape? x 'number?) (lambda (sexp env) (number? sexp))] + [(named-escape? x 'exact-integer?) (lambda (sexp env) (exact-integer? sexp))] + [(named-escape? x 'boolean?) (lambda (sexp env) (boolean? sexp))] + [(named-escape? x 'char?) (lambda (sexp env) (char? sexp))] + [(named-escape? x 'string?) (lambda (sexp env) (string? sexp))] + [(named-escape? x 'bytevector?) (lambda (sexp env) (bytevector? sexp))] + [(named-escape? x 'id?) (lambda (sexp env) (id? sexp))] + [else #f])) ; make transformer procedure from the rules @@ -723,6 +736,10 @@ (define (underscore? x) (and (id? x) (eq? (mac-env x 'peek) underscore-den))) + ; lazier variant for named escapes + (define (named-escape? x sym) + (and (id? x) (free-id=? x mac-env sym))) + ; List-ids returns a list of the non-ellipsis ids in a 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. @@ -731,6 +748,8 @@ (cond [(id? x) (if (and inc (pred? x)) (cons x l) l)] [(vector? x) (collect (vector->list x) inc l)] [(box? x) (collect (unbox x) inc l)] + [(and (list3+? x) (ellipsis? (car x))) + (collect (cddr x) inc l)] ; args of escape [(pair? x) (if (ellipsis-pair? (cdr x)) (collect (car x) #t (collect (cddr x) inc l)) @@ -747,26 +766,31 @@ ; Returns #f or an alist mapping each pattern var to a part of the input. Ellipsis vars ; are mapped to lists of parts (or lists of lists ...). There is no mapping for underscore - (define (match-pattern pat use use-env) + (define (match-pattern mac-pat use use-env) (call-with-current-continuation (lambda (return) (define (fail) (return #f)) - (let match ([pat pat] [sexp use] [bindings '()]) + (let match ([pat mac-pat] [sexp use] [bindings '()] [esc? #f]) (define (continue-if condition) (if condition bindings (fail))) (cond - [(underscore? pat) bindings] + [(and (not esc?) (underscore? pat)) bindings] [(id? pat) (if (pat-literal? pat) (continue-if (and (id? sexp) (free-id=? sexp use-env pat mac-env))) (cons (cons pat sexp) bindings))] [(vector? pat) (or (vector? sexp) (fail)) - (match (vector->list pat) (vector->list sexp) bindings)] + (match (vector->list pat) (vector->list sexp) bindings esc?)] [(box? pat) (or (box? sexp) (fail)) - (match (unbox pat) (unbox sexp) bindings)] + (match (unbox pat) (unbox sexp) bindings esc?)] [(not (pair? pat)) (continue-if (equal? pat sexp))] - [(ellipsis-pair? (cdr pat)) + [(and (not esc?) (ellipsis? (car pat)) (list2? pat)) + (match (cadr pat) sexp bindings #t)] + [(and (not esc?) (ellipsis? (car pat)) (list3? pat) (pattern-escape->test (cadr pat) named-escape?)) + => (lambda (test) (if (test sexp use-env) (match (caddr pat) sexp bindings esc?) (fail)))] + [(and (not esc?) (ellipsis? (car pat))) (fail)] + [(and (not esc?) (ellipsis-pair? (cdr pat))) (let* ([tail-len (proper-head-length (cddr pat) #t)] [sexp-len (proper-head-length sexp #f)] [seq-len (fx- sexp-len tail-len)] @@ -774,13 +798,13 @@ [seq (list-head sexp seq-len)] [vars (list-ids (car pat) #t not-pat-literal?)]) (define (match1 sexp) - (map cdr (match (car pat) sexp '()))) + (map cdr (match (car pat) sexp '() esc?))) (append (apply map (cons list (cons vars (map match1 seq)))) - (match (cddr pat) sexp-tail bindings)))] + (match (cddr pat) sexp-tail bindings esc?)))] [(pair? sexp) (match (car pat) (car sexp) - (match (cdr pat) (cdr sexp) bindings))] + (match (cdr pat) (cdr sexp) bindings esc?) esc?)] [else (fail)]))))) (define (expand-template pat tmpl top-bindings) diff --git a/t.c b/t.c index cabfe34..6ee3fc8 100644 --- a/t.c +++ b/t.c @@ -92,6 +92,9 @@ char *t_code[] = { "P", "list3?", "%1.0p?{.0d,@(y6:list2?)[11}f]1", + "P", "list3+?", + "%1.0p?{.0d,@(y7:list2+?)[11}f]1", + "P", "read-code-sexp", "%1.0,@(y11:read-simple)[11", @@ -239,9 +242,10 @@ char *t_code[] = { "ntax-quote-id)", "P", "free-id=?", - "%4${'(y4:peek),.5,.7[02},${'(y4:peek),.4,.6[02},.0?{.1?{${.2,@(y14:nam" - "e-registry?)[01}?{${.3,@(y14:name-registry?)[01}}{f}?{.1,.1q?{.4,.3q]6" - "}f]6}.1,.1q]6}f]6}f]6", + "%!3${'(y4:peek),.4,.6[02},@(y20:*root-name-registry*),.2p?{${'(y4:peek" + "),.8,.6a[02}}{${f,.8,.4,@(y11:name-lookup)[03},.0?{.0}{.1}_1},.2?{.0?{" + "${.4,@(y14:name-registry?)[01}?{${.2,@(y14:name-registry?)[01}}{f}?{.0" + ",.3q?{.6,.5q]7}f]7}.0,.3q]7}f]7}f]7", "P", "xform", "%3${.3,@(y3:id?)[01}?{${.4,.4,@(y9:xform-ref)[02},.1?{.0]4}.0U0?{.0U7," @@ -439,47 +443,61 @@ char *t_code[] = { "1}?{.0aS0}{f}?{.0,@(y7:x-error),@(y13:apply-to-list)[32}.1,'(y12:synta" "x-error)c,'(s26:improper syntax-error form),@(y7:x-error)[32", + "P", "pattern-escape->test", + "%2${'(y7:number?),.3,.5[02}?{&0{%2.0N0]2}]2}${'(y14:exact-integer?),.3" + ",.5[02}?{&0{%2.0I0]2}]2}${'(y8:boolean?),.3,.5[02}?{&0{%2.0Y1]2}]2}${'" + "(y5:char?),.3,.5[02}?{&0{%2.0C0]2}]2}${'(y7:string?),.3,.5[02}?{&0{%2." + "0S0]2}]2}${'(y11:bytevector?),.3,.5[02}?{&0{%2.0B0]2}]2}${'(y3:id?),.3" + ",.5[02}?{&0{%2.0,@(y3:id?)[21}]2}f]2", + "P", "syntax-rules*", - "%4,,,,,,,,,,,#0#1#2#3#4#5#6#7#8#9#(i10).(i13),&1{%1:0,.1A0]1}.!0.0,&1{" - "%1${.2,:0^[01}~]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.(i11" - "),.4,.(i14),&3{%1:0?{:0,.1q]1}${.2,@(y3:id?)[01}?{:1^,${'(y4:peek),.4," - ":2[02}q]1}f]1}.!4${&0{%1'(y1:_)]1},'(y1:_),@(y20:*root-name-registry*)" - ",@(y11:name-lookup)[03}.!5.(i11),.6,&2{%1${.2,@(y3:id?)[01}?{:0^,${'(y" - "4:peek),.4,:1[02}q]1}f]1}.!6.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}" - ".0Y2?{.2,.2,.2z,: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}.!7.4,&1{%2'" - "0,.1,,#0.0,.4,.6,:0,&4{%2.0p~?{.1]2}:1?{${.2a,:0^[01}}{f}?{:2,'(s41:mi" - "splaced ellipsis in syntax-case pattern),@(y7:x-error)[22}'1,.2I+,.1d," - ":3^[22}.!0.0^_1[22}.!8.7,.2,.(i10),.5,.4,.(i16),.(i12),&7{%3k3,.0,,#0." - "1,&1{%0f,:0[01}.!0n,.5,.5,,#0.4,.1,:6,:5,:4,:3,:2,:1,.(i17),:0,&(i10){" - "%3,#0:9,.4,&2{%1.0?{:0]1}:1^[10}.!0${.3,:0^[01}?{.3]4}${.3,@(y3:id?)[0" - "1}?{${.3,:3^[01}?{${.4,@(y3:id?)[01}?{${:2,.4,:1,.7,@(y9:free-id=?)[04" - "}}{f},.1^[41}.3,.3,.3cc]4}.1V0?{.2V0,.0?{.0}{${:9^[00}}_1.3,.3X0,.3X0," - ":8^[43}.1Y2?{.2Y2,.0?{.0}{${:9^[00}}_1.3,.3z,.3z,:8^[43}.1p~?{.2,.2e,." - "1^[41}${.3d,:4^[01}?{${t,.4dd,:5^[02},${f,.6,:5^[02},.1,.1I-,.0<0?{${:" - "9^[00}}{.0,.6A6},${.3,.9,@(y9:list-head)[02},${:6^,t,.(i10)a,:7^[03},," - "#0:8,.9,&2{%1${n,.3,:0a,:1^[03},@(y3:cdr),@(y5:%25map1)[12}.!0${.(i12)" - ",.6,.(i12)dd,:8^[03},${${.7,.6^,@(y5:%25map1)[02},.5c,@(y4:list)c,@(y4" - ":%25map),@(y13:apply-to-list)[02}L6](i11)}.2p?{${.5,.5d,.5d,:8^[03},.3" - "a,.3a,:8^[43}:9^[40}.!0.0^_1[63}.!9.(i11),.2,.9,.5,.8,&5{%3,,,#0#1#2,#" - "0${${.(i10),&1{%1:0,.1A3~]1},t,.(i11),:2^[03},:4,.4,&2{%1${:0,&1{%0:0^" - "]0},:1,.4,@(y14:new-literal-id)[03},.1c]1},@(y5:%25map1)[02}.!0.0^_1.!" - "0${:3^,f,.7,:2^[03}.!1.1,:2,&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^[13}.!2f," - ".6,.6,,#0.9,.5,:0,:1,.(i10),.5,&6{%3.2,.1,,#0.0,.5,:0,:1,:2,:3,:4,:5,&" - "8{%2${.2,@(y3:id?)[01}?{:6,.1A3,.0?{.0}{:0,.2A3,.0?{.0}{:1^,.3A3}_1}_1" - "d]2}.0V0?{${.3,.3X0,:7^[02}X1]2}.0Y2?{${.3,.3z,:7^[02}b]2}.1~?{.0p?{${" - ".2a,:2^[01}}{f}}{f}?{.0dp?{t,.1da,:7^[22}.0,'(s31:invalid escaped temp" - "late syntax),@(y7:x-error)[22}.1~?{.0p?{${.2d,:3^[01}}{f}}{f}?{${.2a,:" - "4^[01},,,#0#1:6,&1{%1:0,.1A3d]1}.!0.2,.4,:5,&3{%!1.1,${.3,:2,@(y4:cons" - "),@(y5:%25map2)[03},:1a,:0^[23}.!1.2u?{${.6,.6dd,:7^[02},${.7,.7a,:7^[" - "02}c]5}.4,.2,&2{%!0.0,:1c,:0^,@(y13:apply-to-list)[12},${.5,.4^,@(y5:%" - "25map1)[02},${.8,.8dd,:7^[02},${.3,.5c,@(y4:%25map),@(y13:apply-to-lis" - "t)[02}L6]7}.0p?{${.3,.3d,:7^[02},${.4,.4a,:7^[02}c]2}.0]2}.!0.0^_1[32}" - ".!0.0^_1[63}.!(i10).(i14),.(i11),.(i11),&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}](i15)", + "%4,,,,,,,,,,,,#0#1#2#3#4#5#6#7#8#9#(i10)#(i11).(i14),&1{%1:0,.1A0]1}.!" + "0.0,&1{%1${.2,:0^[01}~]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.(i12),.4,.(i15),&3{%1:0?{:0,.1q]1}${.2,@(y3:id?)[01}?{:1^,${'(y4:pe" + "ek),.4,:2[02}q]1}f]1}.!4${&0{%1'(y1:_)]1},'(y1:_),@(y20:*root-name-reg" + "istry*),@(y11:name-lookup)[03}.!5.(i12),.6,&2{%1${.2,@(y3:id?)[01}?{:0" + "^,${'(y4:peek),.4,:1[02}q]1}f]1}.!6.(i12),&1{%2${.2,@(y3:id?)[01}?{.1," + ":0,.2,@(y9:free-id=?)[23}f]2}.!7.4,.3,&2{%3n,.2,.2,,#0:0,.1,:1,.9,&4{%" + "3${.2,@(y3:id?)[01}?{.1?{${.2,:0[01}}{f}?{.2,.1c]3}.2]3}.0V0?{.2,.2,.2" + "X0,:2^[33}.0Y2?{.2,.2,.2z,:2^[33}${.2,@(y7:list3+?)[01}?{${.2a,:1^[01}" + "}{f}?{.2,.2,.2dd,:2^[33}.0p?{${.2d,:3^[01}?{${.4,.4,.4dd,:2^[03},t,.2a" + ",:2^[33}${.4,.4,.4d,:2^[03},.2,.2a,:2^[33}.2]3}.!0.0^_1[33}.!8.4,&1{%2" + "'0,.1,,#0.0,.4,.6,:0,&4{%2.0p~?{.1]2}:1?{${.2a,:0^[01}}{f}?{:2,'(s41:m" + "isplaced ellipsis in syntax-case pattern),@(y7:x-error)[22}'1,.2I+,.1d" + ",:3^[22}.!0.0^_1[22}.!9.7,.5,.4,.(i12),.5,.(i13),.6,.(i19),.(i14),&9{%" + "3k3,.0,,#0.1,&1{%0f,:0[01}.!0f,n,.6,.6,,#0:8,:7,.(i12),:6,:5,:4,:3,.7," + ".(i13),:2,:1,:0,&(i12){%4,#0:3,.4,&2{%1.0?{:0]1}:1^[10}.!0.4~?{${.3,:0" + "^[01}}{f}?{.3]5}${.3,@(y3:id?)[01}?{${.3,:2^[01}?{${.4,@(y3:id?)[01}?{" + "${:1,.4,:9,.7,@(y9:free-id=?)[04}}{f},.1^[51}.3,.3,.3cc]5}.1V0?{.2V0,." + "0?{.0}{${:3^[00}}_1.4,.4,.4X0,.4X0,:4^[54}.1Y2?{.2Y2,.0?{.0}{${:3^[00}" + "}_1.4,.4,.4z,.4z,:4^[54}.1p~?{.2,.2e,.1^[51}.4~?{${.3a,:(i10)^[01}?{${" + ".3,@(y6:list2?)[01}}{f}}{f}?{t,.4,.4,.4da,:4^[54}.4~?{${.3a,:(i10)^[01" + "}?{${.3,@(y6:list3?)[01}?{${:(i11)^,.4da,@(y20:pattern-escape->test)[0" + "2}}{f}}{f}}{f},.0?{.0,${:9,.7,.4[02}?{.6,.6,.6,.6dda,:4^[74}:3^[70}.5~" + "?{${.4a,:(i10)^[01}}{f}?{:3^[60}.5~?{${.4d,:8^[01}}{f}?{${t,.5dd,:7^[0" + "2},${f,.7,:7^[02},.1,.1I-,.0<0?{${:3^[00}}{.0,.7A6},${.3,.(i10),@(y9:l" + "ist-head)[02},${:6^,t,.(i11)a,:5^[03},,#0:4,.(i10),.(i14),&3{%1${:0,n," + ".4,:1a,:2^[04},@(y3:cdr),@(y5:%25map1)[12}.!0${.(i14),.(i14),.7,.(i14)" + "dd,:4^[04},${${.7,.6^,@(y5:%25map1)[02},.5c,@(y4:list)c,@(y4:%25map),@" + "(y13:apply-to-list)[02}L6](i13)}.3p?{.5,${.8,.8,.8d,.8d,:4^[04},.5a,.5" + "a,:4^[64}:3^[60}.!0.0^_1[64}.!(i10).(i12),.2,.(i10),.5,.8,&5{%3,,,#0#1" + "#2,#0${${.(i10),&1{%1:0,.1A3~]1},t,.(i11),:2^[03},:4,.4,&2{%1${:0,&1{%" + "0:0^]0},:1,.4,@(y14:new-literal-id)[03},.1c]1},@(y5:%25map1)[02}.!0.0^" + "_1.!0${:3^,f,.7,:2^[03}.!1.1,:2,&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^[13}." + "!2f,.6,.6,,#0.9,.5,:0,:1,.(i10),.5,&6{%3.2,.1,,#0.0,.5,:0,:1,:2,:3,:4," + ":5,&8{%2${.2,@(y3:id?)[01}?{:6,.1A3,.0?{.0}{:0,.2A3,.0?{.0}{:1^,.3A3}_" + "1}_1d]2}.0V0?{${.3,.3X0,:7^[02}X1]2}.0Y2?{${.3,.3z,:7^[02}b]2}.1~?{.0p" + "?{${.2a,:2^[01}}{f}}{f}?{.0dp?{t,.1da,:7^[22}.0,'(s31:invalid escaped " + "template syntax),@(y7:x-error)[22}.1~?{.0p?{${.2d,:3^[01}}{f}}{f}?{${." + "2a,:4^[01},,,#0#1:6,&1{%1:0,.1A3d]1}.!0.2,.4,:5,&3{%!1.1,${.3,:2,@(y4:" + "cons),@(y5:%25map2)[03},:1a,:0^[23}.!1.2u?{${.6,.6dd,:7^[02},${.7,.7a," + ":7^[02}c]5}.4,.2,&2{%!0.0,:1c,:0^,@(y13:apply-to-list)[12},${.5,.4^,@(" + "y5:%25map1)[02},${.8,.8dd,:7^[02},${.3,.5c,@(y4:%25map),@(y13:apply-to" + "-list)[02}L6]7}.0p?{${.3,.3d,:7^[02},${.4,.4a,:7^[02}c]2}.0]2}.!0.0^_1" + "[32}.!0.0^_1[63}.!(i11).(i15),.(i12),.(i12),&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}](i16)", "P", "make-include-transformer", "%1,,,,#0#1#2#3&0{%2${.2,@(y6:list2?)[01}?{.0daS0}{f}~?{${.2,'(s14:inva"