mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-25 21:58:54 +01:00
extra syntax-rules pattern escapes
This commit is contained in:
ESL
parent
3ac77eafab
commit
8d5d967a97
2 changed files with 96 additions and 54 deletions
46
pre/t.scm
46
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)
|
||||
|
|
|
|||
104
t.c
104
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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue