823 lines
33 KiB
Scheme
823 lines
33 KiB
Scheme
;; This library is used by match.ss
|
|
|
|
;;!(function render-test-list
|
|
;; (form (render-test-list p ae stx) -> test-list)
|
|
;; (contract (syntax syntax syntax) -> list))
|
|
;; This is the most important function of the entire compiler.
|
|
;; This is where the functionality of each pattern is implemented.
|
|
;; This function maps out how each pattern is compiled. While it
|
|
;; only returns a list of tests, the comp field of those tests
|
|
;; contains a function which inturn knows enough to compile the
|
|
;; pattern.
|
|
;; <p>This is implemented in what Wright terms as mock-continuation-passing
|
|
;; style. The functions that create the syntax for a match success and failure
|
|
;; are passed forward
|
|
;; but they are always called in emit. This is extremely effective for
|
|
;; handling the different structures that are matched. This way we can
|
|
;; specify ahead of time how the rest of the elements of a list or vector
|
|
;; should be handled. Otherwise we would have to pass more information
|
|
;; forward in the argument list of next and then test for it later and
|
|
;; then take the appropriate action. To understand this better take a
|
|
;; look at how proper and improper lists are handled.
|
|
(define (render-test-list p ae stx)
|
|
(include "special-generators.scm")
|
|
(include "ddk-handlers.scm")
|
|
(include "getter-setter.scm")
|
|
(include "emit-assm.scm")
|
|
(include "parse-quasi.scm")
|
|
(include "pattern-predicates.scm")
|
|
|
|
(define (append-if-necc sym stx)
|
|
(syntax-case stx ()
|
|
(() (syntax (list)))
|
|
((a ...)
|
|
(quasisyntax/loc stx (#,sym a ...)))
|
|
(p (syntax p))))
|
|
(syntax-case*
|
|
p
|
|
(_ list quote quasiquote vector box ? app and or not struct set! var
|
|
list-rest get! ... ___ unquote unquote-splicing
|
|
list-no-order hash-table regexp pregexp) stx-equal?
|
|
(_ '()) ;(ks sf bv let-bound))
|
|
(pt
|
|
(and (identifier? (syntax pt))
|
|
(pattern-var? (syntax-object->datum (syntax pt)))
|
|
(not (stx-dot-dot-k? (syntax pt))))
|
|
(render-test-list (syntax/loc stx (var pt)) ae stx))
|
|
((var pt)
|
|
(identifier? (syntax pt))
|
|
(list (make-act `bind-var-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(let ((raw-id (syntax-object->datum (syntax pt))))
|
|
(cond ((ormap (lambda (x)
|
|
(if (equal? raw-id (syntax-object->datum (car x)))
|
|
(cdr x) #f)) bv)
|
|
=> (lambda (bound-exp)
|
|
(emit (lambda (exp)
|
|
(quasisyntax/loc
|
|
p
|
|
(equal? #,exp #,(subst-bindings bound-exp let-bound))))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks)))
|
|
(else
|
|
(ks sf (cons (cons (syntax pt) ae) bv))))))))))
|
|
|
|
((list)
|
|
(list
|
|
(make-reg-test
|
|
`(null? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp)
|
|
(quasisyntax/loc p (null? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))))
|
|
('()
|
|
(list
|
|
(make-reg-test
|
|
`(null? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp)
|
|
(quasisyntax/loc p (null? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks)))))
|
|
)
|
|
|
|
(pt
|
|
;; could convert the syntax once
|
|
(or (stx-? string? (syntax pt))
|
|
(stx-? boolean? (syntax pt))
|
|
(stx-? char? (syntax pt))
|
|
(stx-? number? (syntax pt)))
|
|
(list
|
|
(make-reg-test
|
|
`(equal? ,(syntax-object->datum ae)
|
|
,(syntax-object->datum (syntax pt)))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp) (quasisyntax/loc p (equal? #,exp pt)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks))))))
|
|
|
|
;(pt
|
|
; (stx-? regexp? (syntax pt))
|
|
; (render-test-list (syntax/loc p (regex pt)) ae stx))
|
|
|
|
((quote _)
|
|
(list
|
|
(make-reg-test
|
|
`(equal? ,(syntax-object->datum ae)
|
|
,(syntax-object->datum p))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks))))))
|
|
(`quasi-pat
|
|
(render-test-list (parse-quasi (syntax quasi-pat)) ae stx))
|
|
('item
|
|
(list (make-reg-test
|
|
`(equal? ,(syntax-object->datum ae)
|
|
,(syntax-object->datum p))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp) (quasisyntax/loc p (equal? #,exp #,p)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks))))))
|
|
;;('(items ...)
|
|
;;(emit (quasisyntax/loc p (equal? #,e #,p)) sf bv kf ks))
|
|
((? pred? pat1 pats ...)
|
|
(render-test-list (syntax (and (? pred?) pat1 pats ...)) ae stx))
|
|
;; could we check to see if a predicate is a procedure here?
|
|
((? pred?)
|
|
(list (make-reg-test
|
|
`(,(syntax-object->datum (syntax pred?))
|
|
,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp) (quasisyntax/loc p (pred? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks))))))
|
|
;; syntax checking
|
|
((? pred? ...)
|
|
(match:syntax-err
|
|
p
|
|
(if (zero? (length (syntax-e (syntax (pred? ...)))))
|
|
"a predicate pattern must have a predicate following the ?"
|
|
"syntax error in predicate pattern")))
|
|
|
|
((regexp reg-exp)
|
|
(render-test-list (quasisyntax/loc
|
|
p
|
|
(and (? string?)
|
|
(? (lambda (x) (regexp-match reg-exp x)))))
|
|
ae
|
|
stx))
|
|
((pregexp reg-exp)
|
|
(render-test-list (quasisyntax/loc
|
|
p
|
|
(and (? string?)
|
|
(? (lambda (x) (pregexp-match-with-error
|
|
reg-exp x)))))
|
|
ae
|
|
stx))
|
|
|
|
((regexp reg-exp pat)
|
|
(render-test-list (quasisyntax/loc
|
|
p
|
|
(and (? string?)
|
|
(app (lambda (x) (regexp-match reg-exp x)) pat)))
|
|
ae
|
|
stx))
|
|
|
|
((pregexp reg-exp pat)
|
|
(render-test-list (quasisyntax/loc
|
|
p
|
|
(and (? string?)
|
|
(app (lambda (x) (pregexp-match-with-error
|
|
reg-exp x)) pat)))
|
|
ae
|
|
stx))
|
|
|
|
((app op pat)
|
|
(render-test-list (syntax pat)
|
|
(quasisyntax/loc p (op #,ae))
|
|
stx))
|
|
;; syntax checking
|
|
((app op ...)
|
|
(match:syntax-err
|
|
p
|
|
(if (zero? (length (syntax-e (syntax (op ...)))))
|
|
"an operation pattern must have a procedure following the app"
|
|
"there should be one pattern following the operator")))
|
|
((and pats ...)
|
|
(let loop
|
|
((p (syntax (pats ...))))
|
|
(syntax-case p ()
|
|
(() '()) ;(ks seensofar boundvars let-bound))
|
|
((pat1 pats ...)
|
|
(append (render-test-list (syntax pat1) ae stx)
|
|
(loop (syntax (pats ...))))))))
|
|
|
|
((or pats ...)
|
|
(list (make-act
|
|
'or-pat ;`(or-pat ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(or-gen ae (syntax-e (syntax (pats ...)))
|
|
stx sf bv ks kf let-bound))))))
|
|
|
|
; backtracking or
|
|
|
|
; ((or pats ...)
|
|
; (let* ((pat-list (syntax->list (syntax (pats ...)))))
|
|
; (let* ((bound (getbindings (stx-car (syntax (pats ...)))))
|
|
; (bind-map
|
|
; (map (lambda (x)
|
|
; (cons x
|
|
; #`#,(gensym (syntax-object->datum x))))
|
|
; bound))
|
|
; (id (begin (set! or-id (add1 or-id)) (sub1 or-id))))
|
|
; (write id)(newline)
|
|
; (write (syntax-object->datum (syntax (pats ...))))(newline)
|
|
; (list
|
|
; (make-act
|
|
; 'or-pat
|
|
; ae
|
|
; (lambda (ks kf let-bound)
|
|
; (lambda (sf bv)
|
|
; (write id)(newline)
|
|
; (if (stx-null? (syntax (pats ...)))
|
|
; (kf sf bv)
|
|
; #`(let #,(map (lambda (b)
|
|
; #`(#,(cdr b) '()))
|
|
; bind-map)
|
|
; (if (or
|
|
; #,@(map (lambda (p)
|
|
; #`(#,(create-test-func
|
|
; p
|
|
; sf
|
|
; let-bound
|
|
; bind-map
|
|
; #f) #,(subst-bindings ae
|
|
; let-bound)))
|
|
; pat-list))
|
|
; #,(ks sf (append bind-map bv))
|
|
; #,(kf sf bv)))))))))))
|
|
|
|
((not pat)
|
|
(list (make-act
|
|
'not-pat ;`(not-pat ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
;; swap success and fail
|
|
(next-outer (syntax pat) ae sf bv let-bound ks kf))))))
|
|
;; could try to catch syntax local value error and rethrow syntax error
|
|
|
|
((list-no-order pats ...)
|
|
(if (stx-null? (syntax (pats ...)))
|
|
(render-test-list (syntax/loc p (list)) ae stx)
|
|
(let* ((pat-list (syntax->list (syntax (pats ...))))
|
|
(ddk-list (ddk-in-list? pat-list))
|
|
(ddk (ddk-only-at-end-of-list? pat-list)))
|
|
(if (or (not ddk-list)
|
|
(and ddk-list ddk))
|
|
(let* ((bound (getbindings (append-if-necc 'list
|
|
(syntax (pats ...)))))
|
|
(bind-map
|
|
(map (lambda (x)
|
|
(cons x
|
|
#`#,(gensym (syntax-object->datum x))))
|
|
bound)))
|
|
|
|
(list
|
|
(make-shape-test
|
|
`(list? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp)
|
|
(quasisyntax/loc stx (list? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(make-act
|
|
'list-no-order
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(let ((last-test
|
|
(if ddk
|
|
(let ((pl (cdr (reverse pat-list))))
|
|
(begin
|
|
(set! pat-list (reverse (cdr pl)))
|
|
(create-test-func (car pl)
|
|
sf
|
|
let-bound
|
|
bind-map
|
|
#t)))
|
|
#f)))
|
|
#`(let #,(map (lambda (b)
|
|
#`(#,(cdr b) '()))
|
|
bind-map)
|
|
(let ((last-test #,last-test)
|
|
(test-list
|
|
(list
|
|
#,@(map (lambda (p)
|
|
(create-test-func
|
|
p
|
|
sf
|
|
let-bound
|
|
bind-map
|
|
#f))
|
|
pat-list))))
|
|
(if (match:test-no-order test-list
|
|
#,ae
|
|
last-test
|
|
#,ddk)
|
|
#,(ks sf (append bind-map bv))
|
|
#,(kf sf bv))))))))))
|
|
(match:syntax-err
|
|
p
|
|
(string-append "dot dot k can only appear at "
|
|
"the end of unordered match patterns"))))))
|
|
|
|
((hash-table pats ...)
|
|
;; must check the structure
|
|
(proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
|
|
(list
|
|
(make-shape-test
|
|
`(hash-table? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp) (quasisyntax/loc stx (hash-table? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(let ((mod-pat
|
|
(lambda (pat)
|
|
(syntax-case pat ()
|
|
((key value) (syntax (list key value)))
|
|
(ddk
|
|
(stx-dot-dot-k? (syntax ddk))
|
|
(syntax ddk))
|
|
(id
|
|
(and (identifier? (syntax id))
|
|
(pattern-var? (syntax-object->datum (syntax id)))
|
|
(not (stx-dot-dot-k? (syntax id))))
|
|
(syntax id))
|
|
(p (match:syntax-err
|
|
(syntax/loc stx p)
|
|
"poorly formed hash-table pattern"))))))
|
|
(make-act
|
|
'hash-table-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(let ((hash-name (gensym 'hash)))
|
|
#`(let ((#,hash-name
|
|
(hash-table-map #,(subst-bindings ae
|
|
let-bound)
|
|
(lambda (k v) (list k v)))))
|
|
#,(next-outer #`(list-no-order #,@(map mod-pat (syntax->list (syntax (pats ...)))))
|
|
#`#,hash-name
|
|
sf
|
|
;; these tests have to be true
|
|
;;(append (list
|
|
;; '(pair? exp)
|
|
;; '(pair? (cdr exp))
|
|
;; '(null? (cdr (cdr exp))))
|
|
;; sf)
|
|
bv
|
|
let-bound
|
|
kf
|
|
ks)))))))))
|
|
|
|
((hash-table pats ...)
|
|
(match:syntax-err
|
|
p
|
|
"improperly formed hash table pattern"))
|
|
|
|
((struct struct-name (fields ...))
|
|
(identifier? (syntax struct-name))
|
|
(let ((num-of-fields (stx-length (syntax (fields ...)))))
|
|
(let-values (((pred accessors mutators parental-chain)
|
|
(struct-pred-accessors-mutators
|
|
(syntax struct-name)
|
|
(lambda ()
|
|
(match:syntax-err
|
|
(syntax struct-name)
|
|
"not a defined structure")))))
|
|
(let ((dif (- (length accessors) num-of-fields)))
|
|
(if (not (zero? dif))
|
|
(match:syntax-err
|
|
p
|
|
(string-append
|
|
(if (> dif 0) "not enough " "too many ")
|
|
"fields for structure in pattern"))
|
|
(cons
|
|
(make-shape-test
|
|
`(struct-pred ,(syntax-object->datum pred)
|
|
,(map syntax-object->datum parental-chain)
|
|
,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp)
|
|
(quasisyntax/loc stx (struct-pred #,pred #,parental-chain #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(let ((field-pats (syntax->list (syntax (fields ...)))))
|
|
(let rloop ((n 0))
|
|
(if (= n num-of-fields)
|
|
'()
|
|
(append
|
|
(let ((cur-pat (list-ref field-pats n)))
|
|
(syntax-case cur-pat (set! get!)
|
|
((set! setter-name)
|
|
(list (make-act
|
|
'set!-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(ks sf
|
|
(cons (cons (syntax setter-name)
|
|
#`(lambda (y)
|
|
(#,(list-ref
|
|
mutators
|
|
n)
|
|
#,ae y)))
|
|
bv)))))))
|
|
((get! getter-name)
|
|
(list (make-act
|
|
'get!-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(ks sf
|
|
(cons (cons (syntax getter-name)
|
|
#`(lambda ()
|
|
(#,(list-ref
|
|
accessors
|
|
n)
|
|
#,ae)))
|
|
bv)))))))
|
|
(_
|
|
(render-test-list
|
|
cur-pat
|
|
(quasisyntax/loc
|
|
stx
|
|
(#,(list-ref accessors n) #,ae))
|
|
stx))))
|
|
(rloop (+ 1 n))))))))))))
|
|
;; syntax checking
|
|
((struct ident ...)
|
|
(match:syntax-err
|
|
p
|
|
(if (zero? (length (syntax-e (syntax (ident ...)))))
|
|
(format "~a~n~a~n~a"
|
|
"a structure pattern must have the name "
|
|
"of a defined structure followed by a list of patterns "
|
|
"to match each field of that structure")
|
|
"syntax error in structure pattern")))
|
|
((set! ident)
|
|
(identifier? (syntax ident))
|
|
(list (make-act
|
|
'set!-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(ks sf (cons (cons (syntax ident)
|
|
(setter ae p let-bound))
|
|
bv)))))))
|
|
;; syntax checking
|
|
((set! ident ...)
|
|
(let ((x (length (syntax-e (syntax (ident ...))))))
|
|
(match:syntax-err
|
|
p
|
|
(if (= x 1)
|
|
"there should be an identifier after set! in pattern"
|
|
(string-append "there should "
|
|
(if (zero? x) "" "only ")
|
|
"be one identifier after set! in pattern")))))
|
|
((get! ident)
|
|
(identifier? (syntax ident))
|
|
(list (make-act
|
|
'get!-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(ks sf (cons (cons (syntax ident)
|
|
(getter ae p let-bound))
|
|
bv)))))))
|
|
((get! ident ...)
|
|
(let ((x (length (syntax-e (syntax (ident ...))))))
|
|
(match:syntax-err
|
|
p
|
|
(if (= x 1)
|
|
"there should be an identifier after get! in pattern"
|
|
(string-append "there should "
|
|
(if (zero? x) "" "only ")
|
|
"be one identifier after get! in pattern")))))
|
|
|
|
((list pat dot-dot-k pat-rest ...)
|
|
(and (not (or (memq (syntax-e (syntax pat))
|
|
'(unquote unquote-splicing ... ___))
|
|
(stx-dot-dot-k? (syntax pat))))
|
|
(stx-dot-dot-k? (syntax dot-dot-k)))
|
|
(list
|
|
(make-shape-test
|
|
`(list? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
;;(write 'here)(write let-bound)(newline)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc stx (list? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(make-act
|
|
'list-ddk-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(if (stx-null? (syntax (pat-rest ...)))
|
|
(handle-end-ddk-list ae kf ks
|
|
(syntax pat)
|
|
(syntax dot-dot-k)
|
|
stx let-bound)
|
|
(handle-inner-ddk-list ae kf ks
|
|
(syntax pat)
|
|
(syntax dot-dot-k)
|
|
(append-if-necc 'list
|
|
(syntax (pat-rest ...)))
|
|
stx
|
|
let-bound))))))
|
|
|
|
((list-rest pat dot-dot-k pat-rest ...)
|
|
(and (not (or (memq (syntax-e (syntax pat))
|
|
'(unquote unquote-splicing ... ___))
|
|
(stx-dot-dot-k? (syntax pat))
|
|
(stx-null? (syntax (pat-rest ...)))))
|
|
(stx-dot-dot-k? (syntax dot-dot-k)))
|
|
(list
|
|
(make-shape-test
|
|
`(pair? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
;;(write 'here)(write let-bound)(newline)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(make-act
|
|
'list-ddk-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(handle-inner-ddk-list
|
|
ae kf ks
|
|
(syntax pat)
|
|
(syntax dot-dot-k)
|
|
(if (= 1 (length
|
|
(syntax->list (syntax (pat-rest ...)))))
|
|
(stx-car (syntax (pat-rest ...)))
|
|
(append-if-necc 'list-rest
|
|
(syntax (pat-rest ...))))
|
|
stx
|
|
let-bound)))))
|
|
|
|
;; handle proper and improper lists
|
|
|
|
((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...)
|
|
(not (or (memq (syntax-e (syntax car-pat))
|
|
'(unquote unquote-splicing))
|
|
(stx-dot-dot-k? (syntax car-pat))))
|
|
(cons
|
|
(make-shape-test
|
|
`(pair? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
;;(write 'here)(write let-bound)(newline)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(append
|
|
(render-test-list (syntax car-pat)
|
|
(quasisyntax/loc (syntax car-pat) (car #,ae))
|
|
stx) ;(add-a e)
|
|
(render-test-list
|
|
(syntax cdr-pat)
|
|
(quasisyntax/loc (syntax cdr-pat) (cdr #,ae))
|
|
stx))))
|
|
|
|
((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
|
|
(not (or (memq (syntax-e (syntax car-pat))
|
|
'(unquote unquote-splicing))
|
|
(stx-dot-dot-k? (syntax car-pat))))
|
|
(cons
|
|
(make-shape-test
|
|
`(pair? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
;;(write 'here)(write let-bound)(newline)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(append
|
|
(render-test-list (syntax car-pat)
|
|
(quasisyntax/loc (syntax car-pat) (car #,ae))
|
|
stx) ;(add-a e)
|
|
(render-test-list
|
|
(append-if-necc 'list-rest (syntax (cdr-pat ...)))
|
|
(quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
|
|
stx))))
|
|
|
|
((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...)
|
|
(not (or (memq (syntax-e (syntax car-pat))
|
|
'(unquote unquote-splicing))
|
|
(stx-dot-dot-k? (syntax car-pat))))
|
|
(cons
|
|
(make-shape-test
|
|
`(pair? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
;;(write 'here)(write let-bound)(newline)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(append
|
|
(render-test-list (syntax car-pat)
|
|
(quasisyntax/loc (syntax car-pat) (car #,ae))
|
|
stx) ;(add-a e)
|
|
(if (stx-null? (syntax (cdr-pat ...)))
|
|
(list
|
|
(make-shape-test
|
|
`(null? (cdr ,(syntax-object->datum ae)))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp)
|
|
(quasisyntax/loc p (null? #,exp)))
|
|
(quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae));ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks)))))
|
|
(render-test-list
|
|
(append-if-necc 'list (syntax (cdr-pat ...)))
|
|
(quasisyntax/loc (syntax (cdr-pat ...)) (cdr #,ae))
|
|
stx)))))
|
|
|
|
((vector pats ...)
|
|
(ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
|
|
(list
|
|
(make-shape-test
|
|
`(vector? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
(make-act
|
|
'vec-ddk-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(handle-ddk-vector ae kf ks
|
|
(syntax/loc p #(pats ...))
|
|
stx let-bound)))))
|
|
|
|
((vector pats ...)
|
|
(let* ((temp (syntax-e (syntax (pats ...))))
|
|
(len (length temp)))
|
|
(and (>= len 2)
|
|
(ddk-in-list? temp)))
|
|
;; make this contains ddk with no ddks consecutive
|
|
;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
|
|
(list
|
|
(make-shape-test
|
|
`(vector? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit (lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf
|
|
bv
|
|
kf
|
|
ks))))
|
|
;; we have to look at the first pattern and see if a ddk follows it
|
|
;; if so handle that case else handle the pattern
|
|
(make-act
|
|
'vec-ddk-pat
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(handle-ddk-vector-inner ae kf ks
|
|
(syntax/loc p #(pats ...))
|
|
stx let-bound)))))
|
|
|
|
((vector pats ...)
|
|
(let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
|
|
(vlen (vector-length syntax-vec)))
|
|
(cons
|
|
(make-shape-test
|
|
`(vector? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc stx (vector? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks))))
|
|
(cons
|
|
(make-shape-test
|
|
`(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc
|
|
stx
|
|
(equal? (vector-length #,exp) #,vlen)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks))))
|
|
(let vloop ((n 0))
|
|
(if (= n vlen)
|
|
'()
|
|
(append
|
|
(render-test-list
|
|
(vector-ref syntax-vec n)
|
|
(quasisyntax/loc stx (vector-ref #,ae #,n))
|
|
stx)
|
|
(vloop (+ 1 n)))))))))
|
|
|
|
((box pat)
|
|
(cons
|
|
(make-shape-test
|
|
`(box? ,(syntax-object->datum ae))
|
|
ae
|
|
(lambda (ks kf let-bound)
|
|
(lambda (sf bv)
|
|
(emit
|
|
(lambda (exp) (quasisyntax/loc stx (box? #,exp)))
|
|
ae
|
|
let-bound
|
|
sf bv kf ks))))
|
|
(render-test-list
|
|
(syntax pat)
|
|
(quasisyntax/loc stx (unbox #,ae))
|
|
stx)))
|
|
(got-too-far
|
|
(match:syntax-err
|
|
(syntax/loc stx got-too-far)
|
|
"syntax error in pattern"))))
|