convert-pat:
- reformatting - use constant-data? render-test-list-impl: - reformatting - refactoring
This commit is contained in:
Sam Tobin-Hochstadt
parent
a6f8fbe350
commit
00383c4c5d
|
|
@ -3,7 +3,7 @@
|
|||
"match-helper.ss"
|
||||
"match-expander-struct.ss"
|
||||
"observe-step.ss")
|
||||
|
||||
|
||||
(require-for-template mzscheme
|
||||
"match-error.ss")
|
||||
|
||||
|
|
@ -11,61 +11,61 @@
|
|||
|
||||
;; these functions convert the patterns from the old syntax
|
||||
;; to the new syntax
|
||||
|
||||
|
||||
(define (handle-clause stx)
|
||||
(syntax-case stx ()
|
||||
[(pat . rest) (quasisyntax/loc stx (#,(convert-pat #'pat) . rest))]))
|
||||
|
||||
(define (handle-clauses stx) (syntax-map handle-clause stx))
|
||||
|
||||
|
||||
|
||||
(define (convert-pats stx)
|
||||
(with-syntax ([new-pats (syntax-map convert-pat stx)])
|
||||
#'new-pats))
|
||||
|
||||
(define (imp-list? stx)
|
||||
(define datum (syntax-e stx))
|
||||
(define (keyword? x)
|
||||
(memq (syntax-object->datum x)
|
||||
'(quote quasiquote ? = and or not $ set! get!)))
|
||||
(let/ec out
|
||||
(let loop ([x datum])
|
||||
(cond [(null? x) (out #f)]
|
||||
[(or (not (pair? x))
|
||||
(and (list? x)
|
||||
(keyword? (car x))))
|
||||
(list
|
||||
(quasisyntax/loc stx #,x))]
|
||||
[else (cons (car x) (loop (cdr x)))]))))
|
||||
(define (imp-list? stx)
|
||||
(define datum (syntax-e stx))
|
||||
(define (keyword? x)
|
||||
(memq (syntax-object->datum x)
|
||||
'(quote quasiquote ? = and or not $ set! get!)))
|
||||
(let/ec out
|
||||
(let loop ([x datum])
|
||||
(cond [(null? x) (out #f)]
|
||||
[(or (not (pair? x))
|
||||
(and (list? x)
|
||||
(keyword? (car x))))
|
||||
(list
|
||||
(quasisyntax/loc stx #,x))]
|
||||
[else (cons (car x) (loop (cdr x)))]))))
|
||||
|
||||
(define (convert-quasi stx)
|
||||
(syntax-case stx (unquote quasiquote unquote-splicing)
|
||||
[,pat (quasisyntax/loc stx ,#,(convert-pat (syntax pat)))]
|
||||
[,@pat (quasisyntax/loc stx ,@#,(convert-pat (syntax pat)))]
|
||||
[(x . y)
|
||||
(quasisyntax/loc
|
||||
stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y))))]
|
||||
[pat
|
||||
(vector? (syntax-e stx))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
#,(list->vector (map convert-quasi
|
||||
(vector->list (syntax-e stx)))))]
|
||||
[pat
|
||||
(box? (syntax-e stx))
|
||||
(quasisyntax/loc
|
||||
stx #,(box (convert-quasi (unbox (syntax-e stx)))))]
|
||||
[pat stx]))
|
||||
|
||||
(define (convert-quasi stx)
|
||||
(syntax-case stx (unquote quasiquote unquote-splicing)
|
||||
[,pat #`,#,(convert-pat (syntax pat))]
|
||||
[,@pat #`,@#,(convert-pat (syntax pat))]
|
||||
((x . y)
|
||||
(quasisyntax/loc
|
||||
stx (#,(convert-quasi (syntax x)) . #,(convert-quasi (syntax y)))))
|
||||
(pat
|
||||
(vector? (syntax-e stx))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
#,(list->vector (map convert-quasi
|
||||
(vector->list (syntax-e stx))))))
|
||||
(pat
|
||||
(box? (syntax-e stx))
|
||||
(quasisyntax/loc
|
||||
stx #,(box (convert-quasi (unbox (syntax-e stx))))))
|
||||
(pat stx)))
|
||||
|
||||
(define (convert-pat stx)
|
||||
(convert-pat/cert stx (lambda (x) x)))
|
||||
|
||||
|
||||
(define (convert-pat/cert stx cert)
|
||||
(let ([convert-pat (lambda (x) (convert-pat/cert x cert))])
|
||||
(syntax-case*
|
||||
stx
|
||||
(_ ? = and or not $ set! get! quasiquote
|
||||
quote unquote unquote-splicing) stx-equal?
|
||||
(_ ? = and or not $ set! get! quasiquote
|
||||
quote unquote unquote-splicing) stx-equal?
|
||||
[(expander . args)
|
||||
(and (identifier? #'expander)
|
||||
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
|
||||
|
|
@ -89,13 +89,7 @@
|
|||
[() (syntax/loc stx (list))]
|
||||
['() (syntax/loc stx (list))]
|
||||
['item stx]
|
||||
[p
|
||||
(let ((old-pat (syntax-e #'p)))
|
||||
(or (string? old-pat)
|
||||
(boolean? old-pat)
|
||||
(char? old-pat)
|
||||
(number? old-pat)))
|
||||
stx]
|
||||
[p (constant-data? (syntax-e stx)) stx]
|
||||
[(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))]
|
||||
[(? pred . a)
|
||||
(with-syntax ([pred (cert #'pred)]
|
||||
|
|
|
|||
|
|
@ -139,6 +139,7 @@
|
|||
;; then take the appropriate action. To understand this better take a
|
||||
;; look at how proper and improper lists are handled.
|
||||
(define/opt (render-test-list p ae cert [stx #'here])
|
||||
(define ae-datum (syntax-object->datum ae))
|
||||
(syntax-case*
|
||||
p
|
||||
(_ list quote quasiquote vector box ? app and or not struct set! var
|
||||
|
|
@ -163,7 +164,7 @@
|
|||
(certifier (cert id) #f introducer))
|
||||
stx))))]
|
||||
|
||||
;; underscore is reserved to match nothing
|
||||
;; underscore is reserved to match anything and bind nothing
|
||||
(_ '()) ;(ks sf bv let-bound))
|
||||
|
||||
;; for variable patterns, we do bindings, and check if we've seen this variable before
|
||||
|
|
@ -195,7 +196,7 @@
|
|||
(constant-data? (syntax-e #'pt))
|
||||
(list
|
||||
(reg-test
|
||||
`(equal? ,(syntax-object->datum ae)
|
||||
`(equal? ,ae-datum
|
||||
,(syntax-object->datum (syntax pt)))
|
||||
ae (lambda (exp) #`(equal? #,exp pt))))]
|
||||
|
||||
|
|
@ -205,20 +206,20 @@
|
|||
|
||||
;; match a quoted datum
|
||||
;; this is very similar to the previous pattern, except for the second argument to equal?
|
||||
((quote item)
|
||||
[(quote item)
|
||||
(list
|
||||
(reg-test
|
||||
`(equal? ,(syntax-object->datum ae)
|
||||
`(equal? ,ae-datum
|
||||
,(syntax-object->datum p))
|
||||
ae (lambda (exp) #`(equal? #,exp #,p)))))
|
||||
ae (lambda (exp) #`(equal? #,exp #,p))))]
|
||||
|
||||
;; check for predicate patterns
|
||||
;; could we check to see if a predicate is a procedure here?
|
||||
((? pred?)
|
||||
[(? pred?)
|
||||
(list (reg-test
|
||||
`(,(syntax-object->datum #'pred?)
|
||||
,(syntax-object->datum ae))
|
||||
ae (lambda (exp) #`(#,(cert #'pred?) #,exp)))))
|
||||
,ae-datum)
|
||||
ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))]
|
||||
|
||||
;; app patterns just apply their operation.
|
||||
((app op pat)
|
||||
|
|
@ -229,7 +230,7 @@
|
|||
|
||||
((or . pats)
|
||||
(list (make-act
|
||||
'or-pat ;`(or-pat ,(syntax-object->datum ae))
|
||||
'or-pat ;`(or-pat ,ae-datum)
|
||||
ae
|
||||
(lambda (ks kf let-bound)
|
||||
(lambda (sf bv)
|
||||
|
|
@ -240,7 +241,7 @@
|
|||
|
||||
((not pat)
|
||||
(list (make-act
|
||||
'not-pat ;`(not-pat ,(syntax-object->datum ae))
|
||||
'not-pat ;`(not-pat ,ae-datum)
|
||||
ae
|
||||
(lambda (ks kf let-bound)
|
||||
(lambda (sf bv)
|
||||
|
|
@ -266,7 +267,7 @@
|
|||
|
||||
(list
|
||||
(shape-test
|
||||
`(list? ,(syntax-object->datum ae))
|
||||
`(list? ,ae-datum)
|
||||
ae (lambda (exp) #`(list? #,exp)))
|
||||
(make-act
|
||||
'list-no-order
|
||||
|
|
@ -316,7 +317,7 @@
|
|||
#;(proper-hash-table-pattern? (syntax->list (syntax (pats ...))))
|
||||
(list
|
||||
(shape-test
|
||||
`(hash-table? ,(syntax-object->datum ae))
|
||||
`(hash-table? ,ae-datum)
|
||||
ae (lambda (exp) #`(hash-table? #,exp)))
|
||||
|
||||
(let ([mod-pat
|
||||
|
|
@ -368,7 +369,7 @@
|
|||
(shape-test
|
||||
`(struct-pred ,(syntax-object->datum pred)
|
||||
,(map syntax-object->datum parental-chain)
|
||||
,(syntax-object->datum ae))
|
||||
,ae-datum)
|
||||
ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp)))
|
||||
(map-append
|
||||
(lambda (cur-pat cur-mutator cur-accessor)
|
||||
|
|
@ -384,7 +385,7 @@
|
|||
(#,cur-accessor #,ae)))]
|
||||
[_ (render-test-list
|
||||
cur-pat
|
||||
(quasisyntax/loc stx (#,cur-accessor #,ae))
|
||||
(quasisyntax/loc cur-pat (#,cur-accessor #,ae))
|
||||
cert
|
||||
stx)]))
|
||||
field-pats mutators accessors))))
|
||||
|
|
@ -416,7 +417,7 @@
|
|||
(stx-dot-dot-k? (syntax dot-dot-k)))
|
||||
(list
|
||||
(shape-test
|
||||
`(list? ,(syntax-object->datum ae))
|
||||
`(list? ,ae-datum)
|
||||
ae (lambda (exp) #`(list? #,exp)))
|
||||
(make-act
|
||||
'list-ddk-pat
|
||||
|
|
@ -445,7 +446,7 @@
|
|||
(stx-dot-dot-k? (syntax dot-dot-k)))
|
||||
(list
|
||||
(shape-test
|
||||
`(pair? ,(syntax-object->datum ae))
|
||||
`(pair? ,ae-datum)
|
||||
ae (lambda (exp) #`(pair? #,exp)))
|
||||
(make-act
|
||||
'list-ddk-pat
|
||||
|
|
@ -471,7 +472,7 @@
|
|||
(stx-dot-dot-k? (syntax car-pat))))
|
||||
(cons
|
||||
(shape-test
|
||||
`(pair? ,(syntax-object->datum ae))
|
||||
`(pair? ,ae-datum)
|
||||
ae (lambda (exp) #`(pair? #,exp)))
|
||||
(append
|
||||
(render-test-list (syntax car-pat)
|
||||
|
|
@ -491,7 +492,7 @@
|
|||
(stx-dot-dot-k? (syntax car-pat))))
|
||||
(cons
|
||||
(shape-test
|
||||
`(pair? ,(syntax-object->datum ae))
|
||||
`(pair? ,ae-datum)
|
||||
ae (lambda (exp) #`(pair? #,exp)))
|
||||
(append
|
||||
(render-test-list (syntax car-pat)
|
||||
|
|
@ -511,7 +512,7 @@
|
|||
(stx-dot-dot-k? (syntax car-pat))))
|
||||
(cons
|
||||
(shape-test
|
||||
`(pair? ,(syntax-object->datum ae))
|
||||
`(pair? ,ae-datum)
|
||||
ae (lambda (exp) #`(pair? #,exp)))
|
||||
(append
|
||||
(render-test-list (syntax car-pat)
|
||||
|
|
@ -521,7 +522,7 @@
|
|||
(if (stx-null? (syntax (cdr-pat ...)))
|
||||
(list
|
||||
(shape-test
|
||||
`(null? (cdr ,(syntax-object->datum ae)))
|
||||
`(null? (cdr ,ae-datum))
|
||||
ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae)))
|
||||
(render-test-list
|
||||
(append-if-necc 'list (syntax (cdr-pat ...)))
|
||||
|
|
@ -534,7 +535,7 @@
|
|||
(ddk-only-at-end-of-list? (syntax-e (syntax (pats ...))))
|
||||
(list
|
||||
(shape-test
|
||||
`(vector? ,(syntax-object->datum ae))
|
||||
`(vector? ,ae-datum)
|
||||
ae (lambda (exp) #`(vector? #,exp)))
|
||||
(make-act
|
||||
'vec-ddk-pat
|
||||
|
|
@ -546,7 +547,7 @@
|
|||
cert)))))
|
||||
|
||||
;; vector pattern with ooo or ook, but not at end
|
||||
((vector pats ...)
|
||||
[(vector pats ...)
|
||||
(let* ((temp (syntax-e (syntax (pats ...))))
|
||||
(len (length temp)))
|
||||
(and (>= len 2)
|
||||
|
|
@ -555,7 +556,7 @@
|
|||
;;(stx-dot-dot-k? (vector-ref temp (sub1 len))))))
|
||||
(list
|
||||
(shape-test
|
||||
`(vector? ,(syntax-object->datum ae))
|
||||
`(vector? ,ae-datum)
|
||||
ae (lambda (exp) #`(vector? #,exp)))
|
||||
;; we have to look at the first pattern and see if a ddk follows it
|
||||
;; if so handle that case else handle the pattern
|
||||
|
|
@ -566,18 +567,18 @@
|
|||
(handle-ddk-vector-inner ae kf ks
|
||||
#'#(pats ...)
|
||||
let-bound
|
||||
cert)))))
|
||||
cert))))]
|
||||
|
||||
;; plain old vector pattern
|
||||
((vector pats ...)
|
||||
(let* ((syntax-vec (list->vector (syntax->list (syntax (pats ...)))))
|
||||
(vlen (vector-length syntax-vec)))
|
||||
[(vector pats ...)
|
||||
(let* ([syntax-vec (list->vector (syntax->list (syntax (pats ...))))]
|
||||
[vlen (vector-length syntax-vec)])
|
||||
(list*
|
||||
(shape-test
|
||||
`(vector? ,(syntax-object->datum ae)) ae
|
||||
`(vector? ,ae-datum) ae
|
||||
(lambda (exp) #`(vector? #,exp)))
|
||||
(shape-test
|
||||
`(equal? (vector-length ,(syntax-object->datum ae)) ,vlen)
|
||||
`(equal? (vector-length ,ae-datum) ,vlen)
|
||||
ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen)))
|
||||
(let vloop ((n 0))
|
||||
(if (= n vlen)
|
||||
|
|
@ -588,21 +589,21 @@
|
|||
#`(vector-ref #,ae #,n)
|
||||
cert
|
||||
stx)
|
||||
(vloop (+ 1 n))))))))
|
||||
(vloop (+ 1 n)))))))]
|
||||
|
||||
((box pat)
|
||||
[(box pat)
|
||||
(cons
|
||||
(shape-test
|
||||
`(box? ,(syntax-object->datum ae))
|
||||
`(box? ,ae-datum)
|
||||
ae (lambda (exp) #`(box? #,exp)))
|
||||
(render-test-list
|
||||
#'pat #`(unbox #,ae) cert stx)))
|
||||
#'pat #`(unbox #,ae) cert stx))]
|
||||
|
||||
;; This pattern wasn't a valid form.
|
||||
(got-too-far
|
||||
[got-too-far
|
||||
(match:syntax-err
|
||||
#'got-too-far
|
||||
"syntax error in pattern"))))
|
||||
"syntax error in pattern")]))
|
||||
|
||||
;; end of render-test-list@
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user