extra syntax-rules pattern escapes

This commit is contained in:
ESL 2024-07-25 01:02:38 -04:00
parent 3ac77eafab
commit 8d5d967a97
2 changed files with 96 additions and 54 deletions

View file

@ -142,6 +142,7 @@
(define (list2? x) (and (pair? x) (list1? (cdr x)))) (define (list2? x) (and (pair? x) (list1? (cdr x))))
(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 (list3+? x) (and (pair? x) (list2+? (cdr x))))
(define (read-code-sexp port) (define (read-code-sexp port)
; for now, we will just use read with no support for circular structures ; 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)) (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 ; standard way of comparing identifiers used as keywords and such; details below
(define (free-id=? id1 env1 id2 env2) (define (free-id=? id1 env1 id2 . ?env2)
(let ([p1 (env1 id1 'peek)] [p2 (env2 id2 'peek)]) (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 (and p1 p2 ; both envs should be supported by name registries
(if (and (name-registry? p1) (name-registry? p2)) (if (and (name-registry? p1) (name-registry? p2))
(and (eq? p1 p2) (eq? id1 id2)) ; would end w/same loc if alloced (and (eq? p1 p2) (eq? id1 id2)) ; would end w/same loc if alloced
@ -695,6 +697,17 @@
(apply x-error args) (apply x-error args)
(x-error "improper syntax-error form" (cons 'syntax-error tail))))) (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 ; make transformer procedure from the rules
@ -723,6 +736,10 @@
(define (underscore? x) (define (underscore? x)
(and (id? x) (eq? (mac-env x 'peek) underscore-den))) (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 ; 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 ; (pred? id) is true. If 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.
@ -731,6 +748,8 @@
(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)]
[(box? x) (collect (unbox 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) [(pair? x)
(if (ellipsis-pair? (cdr x)) (if (ellipsis-pair? (cdr x))
(collect (car x) #t (collect (cddr x) inc l)) (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 ; 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 ; 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 (call-with-current-continuation
(lambda (return) (lambda (return)
(define (fail) (return #f)) (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) (define (continue-if condition)
(if condition bindings (fail))) (if condition bindings (fail)))
(cond (cond
[(underscore? pat) bindings] [(and (not esc?) (underscore? pat)) bindings]
[(id? pat) [(id? pat)
(if (pat-literal? pat) (if (pat-literal? pat)
(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) (or (vector? sexp) (fail)) [(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)) [(box? pat) (or (box? sexp) (fail))
(match (unbox pat) (unbox sexp) bindings)] (match (unbox pat) (unbox sexp) bindings esc?)]
[(not (pair? pat)) [(not (pair? pat))
(continue-if (equal? pat sexp))] (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)] (let* ([tail-len (proper-head-length (cddr pat) #t)]
[sexp-len (proper-head-length sexp #f)] [sexp-len (proper-head-length sexp #f)]
[seq-len (fx- sexp-len tail-len)] [seq-len (fx- sexp-len tail-len)]
@ -774,13 +798,13 @@
[seq (list-head sexp seq-len)] [seq (list-head sexp seq-len)]
[vars (list-ids (car pat) #t not-pat-literal?)]) [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 '() esc?)))
(append (append
(apply map (cons list (cons vars (map match1 seq)))) (apply map (cons list (cons vars (map match1 seq))))
(match (cddr pat) sexp-tail bindings)))] (match (cddr pat) sexp-tail bindings esc?)))]
[(pair? sexp) [(pair? sexp)
(match (car pat) (car sexp) (match (car pat) (car sexp)
(match (cdr pat) (cdr sexp) bindings))] (match (cdr pat) (cdr sexp) bindings esc?) esc?)]
[else (fail)]))))) [else (fail)])))))
(define (expand-template pat tmpl top-bindings) (define (expand-template pat tmpl top-bindings)

104
t.c
View file

@ -92,6 +92,9 @@ char *t_code[] = {
"P", "list3?", "P", "list3?",
"%1.0p?{.0d,@(y6:list2?)[11}f]1", "%1.0p?{.0d,@(y6:list2?)[11}f]1",
"P", "list3+?",
"%1.0p?{.0d,@(y7:list2+?)[11}f]1",
"P", "read-code-sexp", "P", "read-code-sexp",
"%1.0,@(y11:read-simple)[11", "%1.0,@(y11:read-simple)[11",
@ -239,9 +242,10 @@ char *t_code[] = {
"ntax-quote-id)", "ntax-quote-id)",
"P", "free-id=?", "P", "free-id=?",
"%4${'(y4:peek),.5,.7[02},${'(y4:peek),.4,.6[02},.0?{.1?{${.2,@(y14:nam" "%!3${'(y4:peek),.4,.6[02},@(y20:*root-name-registry*),.2p?{${'(y4:peek"
"e-registry?)[01}?{${.3,@(y14:name-registry?)[01}}{f}?{.1,.1q?{.4,.3q]6" "),.8,.6a[02}}{${f,.8,.4,@(y11:name-lookup)[03},.0?{.0}{.1}_1},.2?{.0?{"
"}f]6}.1,.1q]6}f]6}f]6", "${.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", "P", "xform",
"%3${.3,@(y3:id?)[01}?{${.4,.4,@(y9:xform-ref)[02},.1?{.0]4}.0U0?{.0U7," "%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" "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", "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*", "P", "syntax-rules*",
"%4,,,,,,,,,,,#0#1#2#3#4#5#6#7#8#9#(i10).(i13),&1{%1:0,.1A0]1}.!0.0,&1{" "%4,,,,,,,,,,,,#0#1#2#3#4#5#6#7#8#9#(i10)#(i11).(i14),&1{%1:0,.1A0]1}.!"
"%1${.2,:0^[01}~]1}.!1.4,&1{%1.0p?{.0a,:0^[11}f]1}.!2${&0{%1'(y3:...)]1" "0.0,&1{%1${.2,:0^[01}~]1}.!1.4,&1{%1.0p?{.0a,:0^[11}f]1}.!2${&0{%1'(y3"
"},'(y3:...),@(y20:*root-name-registry*),@(y11:name-lookup)[03}.!3.(i11" ":...)]1},'(y3:...),@(y20:*root-name-registry*),@(y11:name-lookup)[03}."
"),.4,.(i14),&3{%1:0?{:0,.1q]1}${.2,@(y3:id?)[01}?{:1^,${'(y4:peek),.4," "!3.(i12),.4,.(i15),&3{%1:0?{:0,.1q]1}${.2,@(y3:id?)[01}?{:1^,${'(y4:pe"
":2[02}q]1}f]1}.!4${&0{%1'(y1:_)]1},'(y1:_),@(y20:*root-name-registry*)" "ek),.4,:2[02}q]1}f]1}.!4${&0{%1'(y1:_)]1},'(y1:_),@(y20:*root-name-reg"
",@(y11:name-lookup)[03}.!5.(i11),.6,&2{%1${.2,@(y3:id?)[01}?{:0^,${'(y" "istry*),@(y11:name-lookup)[03}.!5.(i12),.6,&2{%1${.2,@(y3:id?)[01}?{:0"
"4:peek),.4,:1[02}q]1}f]1}.!6.2,&1{%3n,.2,.2,,#0:0,.1,.8,&3{%3${.2,@(y3" "^,${'(y4:peek),.4,:1[02}q]1}f]1}.!6.(i12),&1{%2${.2,@(y3:id?)[01}?{.1,"
":id?)[01}?{.1?{${.2,:0[01}}{f}?{.2,.1c]3}.2]3}.0V0?{.2,.2,.2X0,:1^[33}" ":0,.2,@(y9:free-id=?)[23}f]2}.!7.4,.3,&2{%3n,.2,.2,,#0:0,.1,:1,.9,&4{%"
".0Y2?{.2,.2,.2z,:1^[33}.0p?{${.2d,:2^[01}?{${.4,.4,.4dd,:1^[03},t,.2a," "3${.2,@(y3:id?)[01}?{.1?{${.2,:0[01}}{f}?{.2,.1c]3}.2]3}.0V0?{.2,.2,.2"
":1^[33}${.4,.4,.4d,:1^[03},.2,.2a,:1^[33}.2]3}.!0.0^_1[33}.!7.4,&1{%2'" "X0,:2^[33}.0Y2?{.2,.2,.2z,:2^[33}${.2,@(y7:list3+?)[01}?{${.2a,:1^[01}"
"0,.1,,#0.0,.4,.6,:0,&4{%2.0p~?{.1]2}:1?{${.2a,:0^[01}}{f}?{:2,'(s41:mi" "}{f}?{.2,.2,.2dd,:2^[33}.0p?{${.2d,:3^[01}?{${.4,.4,.4dd,:2^[03},t,.2a"
"splaced ellipsis in syntax-case pattern),@(y7:x-error)[22}'1,.2I+,.1d," ",:2^[33}${.4,.4,.4d,:2^[03},.2,.2a,:2^[33}.2]3}.!0.0^_1[33}.!8.4,&1{%2"
":3^[22}.!0.0^_1[22}.!8.7,.2,.(i10),.5,.4,.(i16),.(i12),&7{%3k3,.0,,#0." "'0,.1,,#0.0,.4,.6,:0,&4{%2.0p~?{.1]2}:1?{${.2a,:0^[01}}{f}?{:2,'(s41:m"
"1,&1{%0f,:0[01}.!0n,.5,.5,,#0.4,.1,:6,:5,:4,:3,:2,:1,.(i17),:0,&(i10){" "isplaced ellipsis in syntax-case pattern),@(y7:x-error)[22}'1,.2I+,.1d"
"%3,#0:9,.4,&2{%1.0?{:0]1}:1^[10}.!0${.3,:0^[01}?{.3]4}${.3,@(y3:id?)[0" ",:3^[22}.!0.0^_1[22}.!9.7,.5,.4,.(i12),.5,.(i13),.6,.(i19),.(i14),&9{%"
"1}?{${.3,:3^[01}?{${.4,@(y3:id?)[01}?{${:2,.4,:1,.7,@(y9:free-id=?)[04" "3k3,.0,,#0.1,&1{%0f,:0[01}.!0f,n,.6,.6,,#0:8,:7,.(i12),:6,:5,:4,:3,.7,"
"}}{f},.1^[41}.3,.3,.3cc]4}.1V0?{.2V0,.0?{.0}{${:9^[00}}_1.3,.3X0,.3X0," ".(i13),:2,:1,:0,&(i12){%4,#0:3,.4,&2{%1.0?{:0]1}:1^[10}.!0.4~?{${.3,:0"
":8^[43}.1Y2?{.2Y2,.0?{.0}{${:9^[00}}_1.3,.3z,.3z,:8^[43}.1p~?{.2,.2e,." "^[01}}{f}?{.3]5}${.3,@(y3:id?)[01}?{${.3,:2^[01}?{${.4,@(y3:id?)[01}?{"
"1^[41}${.3d,:4^[01}?{${t,.4dd,:5^[02},${f,.6,:5^[02},.1,.1I-,.0<0?{${:" "${:1,.4,:9,.7,@(y9:free-id=?)[04}}{f},.1^[51}.3,.3,.3cc]5}.1V0?{.2V0,."
"9^[00}}{.0,.6A6},${.3,.9,@(y9:list-head)[02},${:6^,t,.(i10)a,:7^[03},," "0?{.0}{${:3^[00}}_1.4,.4,.4X0,.4X0,:4^[54}.1Y2?{.2Y2,.0?{.0}{${:3^[00}"
"#0:8,.9,&2{%1${n,.3,:0a,:1^[03},@(y3:cdr),@(y5:%25map1)[12}.!0${.(i12)" "}_1.4,.4,.4z,.4z,:4^[54}.1p~?{.2,.2e,.1^[51}.4~?{${.3a,:(i10)^[01}?{${"
",.6,.(i12)dd,:8^[03},${${.7,.6^,@(y5:%25map1)[02},.5c,@(y4:list)c,@(y4" ".3,@(y6:list2?)[01}}{f}}{f}?{t,.4,.4,.4da,:4^[54}.4~?{${.3a,:(i10)^[01"
":%25map),@(y13:apply-to-list)[02}L6](i11)}.2p?{${.5,.5d,.5d,:8^[03},.3" "}?{${.3,@(y6:list3?)[01}?{${:(i11)^,.4da,@(y20:pattern-escape->test)[0"
"a,.3a,:8^[43}:9^[40}.!0.0^_1[63}.!9.(i11),.2,.9,.5,.8,&5{%3,,,#0#1#2,#" "2}}{f}}{f}}{f},.0?{.0,${:9,.7,.4[02}?{.6,.6,.6,.6dda,:4^[74}:3^[70}.5~"
"0${${.(i10),&1{%1:0,.1A3~]1},t,.(i11),:2^[03},:4,.4,&2{%1${:0,&1{%0:0^" "?{${.4a,:(i10)^[01}}{f}?{:3^[60}.5~?{${.4d,:8^[01}}{f}?{${t,.5dd,:7^[0"
"]0},:1,.4,@(y14:new-literal-id)[03},.1c]1},@(y5:%25map1)[02}.!0.0^_1.!" "2},${f,.7,:7^[02},.1,.1I-,.0<0?{${:3^[00}}{.0,.7A6},${.3,.(i10),@(y9:l"
"0${:3^,f,.7,:2^[03}.!1.1,:2,&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^[13}.!2f," "ist-head)[02},${:6^,t,.(i11)a,:5^[03},,#0:4,.(i10),.(i14),&3{%1${:0,n,"
".6,.6,,#0.9,.5,:0,:1,.(i10),.5,&6{%3.2,.1,,#0.0,.5,:0,:1,:2,:3,:4,:5,&" ".4,:1a,:2^[04},@(y3:cdr),@(y5:%25map1)[12}.!0${.(i14),.(i14),.7,.(i14)"
"8{%2${.2,@(y3:id?)[01}?{:6,.1A3,.0?{.0}{:0,.2A3,.0?{.0}{:1^,.3A3}_1}_1" "dd,:4^[04},${${.7,.6^,@(y5:%25map1)[02},.5c,@(y4:list)c,@(y4:%25map),@"
"d]2}.0V0?{${.3,.3X0,:7^[02}X1]2}.0Y2?{${.3,.3z,:7^[02}b]2}.1~?{.0p?{${" "(y13:apply-to-list)[02}L6](i13)}.3p?{.5,${.8,.8,.8d,.8d,:4^[04},.5a,.5"
".2a,:2^[01}}{f}}{f}?{.0dp?{t,.1da,:7^[22}.0,'(s31:invalid escaped temp" "a,:4^[64}:3^[60}.!0.0^_1[64}.!(i10).(i12),.2,.(i10),.5,.8,&5{%3,,,#0#1"
"late syntax),@(y7:x-error)[22}.1~?{.0p?{${.2d,:3^[01}}{f}}{f}?{${.2a,:" "#2,#0${${.(i10),&1{%1:0,.1A3~]1},t,.(i11),:2^[03},:4,.4,&2{%1${:0,&1{%"
"4^[01},,,#0#1:6,&1{%1:0,.1A3d]1}.!0.2,.4,:5,&3{%!1.1,${.3,:2,@(y4:cons" "0:0^]0},:1,.4,@(y14:new-literal-id)[03},.1c]1},@(y5:%25map1)[02}.!0.0^"
"),@(y5:%25map2)[03},:1a,:0^[23}.!1.2u?{${.6,.6dd,:7^[02},${.7,.7a,:7^[" "_1.!0${:3^,f,.7,:2^[03}.!1.1,:2,&2{%1:1,&1{%1:0^,.1A0]1},t,.2,:0^[13}."
"02}c]5}.4,.2,&2{%!0.0,:1c,:0^,@(y13:apply-to-list)[12},${.5,.4^,@(y5:%" "!2f,.6,.6,,#0.9,.5,:0,:1,.(i10),.5,&6{%3.2,.1,,#0.0,.5,:0,:1,:2,:3,:4,"
"25map1)[02},${.8,.8dd,:7^[02},${.3,.5c,@(y4:%25map),@(y13:apply-to-lis" ":5,&8{%2${.2,@(y3:id?)[01}?{:6,.1A3,.0?{.0}{:0,.2A3,.0?{.0}{:1^,.3A3}_"
"t)[02}L6]7}.0p?{${.3,.3d,:7^[02},${.4,.4a,:7^[02}c]2}.0]2}.!0.0^_1[32}" "1}_1d]2}.0V0?{${.3,.3X0,:7^[02}X1]2}.0Y2?{${.3,.3z,:7^[02}b]2}.1~?{.0p"
".!0.0^_1[63}.!(i10).(i14),.(i11),.(i11),&3{%2:2,,#0:0,.3,.5,:1,.4,&5{%" "?{${.2a,:2^[01}}{f}}{f}?{.0dp?{t,.1da,:7^[22}.0,'(s31:invalid escaped "
"1.0u?{${:3,'(s14:invalid syntax),@(y7:x-error)[02}}.0a,.0a,.1da,${:2,:" "template syntax),@(y7:x-error)[22}.1~?{.0p?{${.2d,:3^[01}}{f}}{f}?{${."
"3,.5,:4^[03},.0?{.0,.0,.3,.5,:1^[63}.4d,:0^[51}.!0.0^_1[21}](i15)", "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", "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"