syndicate-lang
/
minimart-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Handle empty matcher in matcher-match-value

This commit is contained in:
Tony Garnock-Jones 2014-05-13 23:11:50 -04:00
parent f788caf754
commit 8210272054
1 changed files with 53 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
minimart/route.rkt
View File

@ -268,51 +268,53 @@
[(r1 r2) (walk r1 r2)])))) [(r1 r2) (walk r1 r2)]))))
(define (matcher-match-value r v) (define (matcher-match-value r v)
(let walk ((vs (list v)) (stack '(())) (r r)) (if (matcher-empty? r)
(define (walk-wild vs stack) (set)
(match (rlookup r ?) (let walk ((vs (list v)) (stack '(())) (r r))
[#f (set)] (define (walk-wild vs stack)
[k (walk vs stack k)])) (match (rlookup r ?)
(match r [#f (set)]
[(wildcard-sequence k) [k (walk vs stack k)]))
(match stack (match r
['() (set)] [(wildcard-sequence k)
[(cons rest stack1) (walk rest stack1 k)])] (match stack
[(? set?) ['() (set)]
(if (and (null? vs) [(cons rest stack1) (walk rest stack1 k)])]
(null? stack)) [(? set?)
r (if (and (null? vs)
(set))] (null? stack))
[(? hash?) r
(match vs (set))]
['() [(? hash?)
(match stack (match vs
['() (set)] ['()
[(cons rest stack1) (match stack
(match (rlookup r EOS) ['() (set)]
[#f (set)] [(cons rest stack1)
[k (walk rest stack1 k)])])] (match (rlookup r EOS)
[(cons (== ?) rest) [#f (set)]
(error 'matcher-match-value "Cannot match wildcard as a value")] [k (walk rest stack1 k)])])]
[(cons (cons v1 v2) rest) [(cons (== ?) rest)
(match (rlookup r SOP) (error 'matcher-match-value "Cannot match wildcard as a value")]
[#f (walk-wild rest stack)] [(cons (cons v1 v2) rest)
[k (walk (list v1 v2) (cons rest stack) k)])] (match (rlookup r SOP)
[(cons (vector vv ...) rest) [#f (walk-wild rest stack)]
(match (rlookup r SOV) [k (walk (list v1 v2) (cons rest stack) k)])]
[#f (walk-wild rest stack)] [(cons (vector vv ...) rest)
[k (walk vv (cons rest stack) k)])] (match (rlookup r SOV)
[(cons (? non-object-struct? s) rest) [#f (walk-wild rest stack)]
(define-values (t skipped?) (struct-info s)) [k (walk vv (cons rest stack) k)])]
(when skipped? (error 'matcher-match-value "Cannot reflect on struct instance ~v" s)) [(cons (? non-object-struct? s) rest)
(define fs (cdr (vector->list (struct->vector s)))) (define-values (t skipped?) (struct-info s))
(match (rlookup r t) (when skipped? (error 'matcher-match-value "Cannot reflect on struct instance ~v" s))
[#f (walk-wild rest stack)] (define fs (cdr (vector->list (struct->vector s))))
[k (walk fs (cons rest stack) k)])] (match (rlookup r t)
[(cons v rest) [#f (walk-wild rest stack)]
(match (rlookup r v) [k (walk fs (cons rest stack) k)])]
[#f (walk-wild rest stack)] [(cons v rest)
[k (walk rest stack k)])])]))) (match (rlookup r v)
[#f (walk-wild rest stack)]
[k (walk rest stack k)])])]))))
(define (matcher-match-matcher re1 re2) (define (matcher-match-matcher re1 re2)
(let () (let ()
@ -578,6 +580,12 @@
(string->list expectedstr)))) (string->list expectedstr))))
(walk rest)]))) (walk rest)])))
(check-matches
#f
(list 'z 'x) ""
'foo ""
(list (list 'z (list 'z))) "")
(void (pretty-print-matcher (void (pretty-print-matcher
(matcher-union (pattern->matcher 'A (list (list ?) 'x)) (matcher-union (pattern->matcher 'A (list (list ?) 'x))
(pattern->matcher 'B (list (list ?) 'y))))) (pattern->matcher 'B (list (list ?) 'y)))))