mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 14:19:18 +02:00
simplifying code
This commit is contained in:
Alex Shinn
parent
2a424658b0
commit
d2e094e4c1
1 changed files with 142 additions and 143 deletions
|
|
@ -45,8 +45,7 @@
|
||||||
|
|
||||||
(define-syntax match-syntax-error
|
(define-syntax match-syntax-error
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_)
|
((_) (match-syntax-error "invalid match-syntax-error usage"))))
|
||||||
(match-syntax-error "invalid match-syntax-error usage"))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
|
@ -61,49 +60,50 @@
|
||||||
((match)
|
((match)
|
||||||
(match-syntax-error "missing match expression"))
|
(match-syntax-error "missing match expression"))
|
||||||
((match atom)
|
((match atom)
|
||||||
(match-syntax-error "missing match clause"))
|
(match-syntax-error "no match clauses"))
|
||||||
((match (app ...) (pat . body) ...)
|
((match (app ...) (pat . body) ...)
|
||||||
(let ((v (app ...)))
|
(let ((v (app ...)))
|
||||||
(match-next v (app ...) (set! (app ...)) (pat . body) ...)))
|
(match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
|
||||||
((match #(vec ...) (pat . body) ...)
|
((match #(vec ...) (pat . body) ...)
|
||||||
(let ((v #(vec ...)))
|
(let ((v #(vec ...)))
|
||||||
(match-next v v (set! v) (pat . body) ...)))
|
(match-next v (v (set! v)) (pat . body) ...)))
|
||||||
((match atom (pat . body) ...)
|
((match atom (pat . body) ...)
|
||||||
(match-next atom atom (set! atom) (pat . body) ...))
|
(match-next atom (atom (set! atom)) (pat . body) ...))
|
||||||
))
|
))
|
||||||
|
|
||||||
;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
|
;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
|
||||||
;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
|
;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
|
||||||
;; clauses. `g' and `s' are the get! and set! expressions
|
;; clauses. `g+s' is a list of two elements, the get! and set!
|
||||||
;; respectively.
|
;; expressions respectively.
|
||||||
|
|
||||||
(define-syntax match-next
|
(define-syntax match-next
|
||||||
(syntax-rules (=>)
|
(syntax-rules (=>)
|
||||||
;; no more clauses, the match failed
|
;; no more clauses, the match failed
|
||||||
((match-next v g s)
|
((match-next v g+s)
|
||||||
(error 'match "no matching pattern"))
|
(error 'match "no matching pattern"))
|
||||||
;; named failure continuation
|
;; named failure continuation
|
||||||
((match-next v g s (pat (=> failure) . body) . rest)
|
((match-next v g+s (pat (=> failure) . body) . rest)
|
||||||
(let ((failure (lambda () (match-next v g s . rest))))
|
(let ((failure (lambda () (match-next v g+s . rest))))
|
||||||
;; match-one analyzes the pattern for us
|
;; match-one analyzes the pattern for us
|
||||||
(match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
|
(match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
|
||||||
;; anonymous failure continuation, give it a dummy name
|
;; anonymous failure continuation, give it a dummy name
|
||||||
((match-next v g s (pat . body) . rest)
|
((match-next v g+s (pat . body) . rest)
|
||||||
(match-next v g s (pat (=> failure) . body) . rest))))
|
(match-next v g+s (pat (=> failure) . body) . rest))))
|
||||||
|
|
||||||
;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
|
;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
|
||||||
;; MATCH-TWO.
|
;; MATCH-TWO.
|
||||||
|
|
||||||
(define-syntax match-one
|
(define-syntax match-one
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
;; If it's a list of two values, check to see if the second one is
|
;; If it's a list of two or more values, check to see if the
|
||||||
;; an ellipse and handle accordingly, otherwise go to MATCH-TWO.
|
;; second one is an ellipse and handle accordingly, otherwise go
|
||||||
((match-one v (p q . r) g s sk fk i)
|
;; to MATCH-TWO.
|
||||||
|
((match-one v (p q . r) g+s sk fk i)
|
||||||
(match-check-ellipse
|
(match-check-ellipse
|
||||||
q
|
q
|
||||||
(match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
|
(match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ())
|
||||||
(match-two v (p q . r) g s sk fk i)))
|
(match-two v (p q . r) g+s sk fk i)))
|
||||||
;; Otherwise, go directly to MATCH-TWO.
|
;; Go directly to MATCH-TWO.
|
||||||
((match-one . x)
|
((match-one . x)
|
||||||
(match-two . x))))
|
(match-two . x))))
|
||||||
|
|
||||||
|
|
@ -114,7 +114,7 @@
|
||||||
;;
|
;;
|
||||||
;; usually abbreviated
|
;; usually abbreviated
|
||||||
;;
|
;;
|
||||||
;; (match-two v p g s sk fk i)
|
;; (match-two v p g+s sk fk i)
|
||||||
;;
|
;;
|
||||||
;; where VAR is the symbol name of the current variable we are
|
;; where VAR is the symbol name of the current variable we are
|
||||||
;; matching, PATTERN is the current pattern, getter and setter are the
|
;; matching, PATTERN is the current pattern, getter and setter are the
|
||||||
|
|
@ -126,58 +126,57 @@
|
||||||
|
|
||||||
(define-syntax match-two
|
(define-syntax match-two
|
||||||
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
|
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
|
||||||
((match-two v () g s (sk ...) fk i)
|
((match-two v () g+s (sk ...) fk i)
|
||||||
(if (null? v) (sk ... i) fk))
|
(if (null? v) (sk ... i) fk))
|
||||||
((match-two v (quote p) g s (sk ...) fk i)
|
((match-two v (quote p) g+s (sk ...) fk i)
|
||||||
(if (equal? v 'p) (sk ... i) fk))
|
(if (equal? v 'p) (sk ... i) fk))
|
||||||
((match-two v (quasiquote p) g s sk fk i)
|
((match-two v (quasiquote p) . x)
|
||||||
(match-quasiquote v p g s sk fk i))
|
(match-quasiquote v p . x))
|
||||||
((match-two v (and) g s (sk ...) fk i) (sk ... i))
|
((match-two v (and) g+s (sk ...) fk i) (sk ... i))
|
||||||
((match-two v (and p q ...) g s sk fk i)
|
((match-two v (and p q ...) g+s sk fk i)
|
||||||
(match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
|
(match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
|
||||||
((match-two v (or) g s sk fk i) fk)
|
((match-two v (or) g+s sk fk i) fk)
|
||||||
((match-two v (or p) g s sk fk i)
|
((match-two v (or p) . x)
|
||||||
(match-one v p g s sk fk i))
|
(match-one v p . x))
|
||||||
((match-two v (or p ...) g s sk fk i)
|
((match-two v (or p ...) g+s sk fk i)
|
||||||
(match-extract-vars (or p ...) (match-gen-or v (p ...) g s sk fk i) i ()))
|
(match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
|
||||||
((match-two v (not p) g s (sk ...) fk i)
|
((match-two v (not p) g+s (sk ...) fk i)
|
||||||
(match-one v p g s (match-drop-ids fk) (sk ... i) i))
|
(match-one v p g+s (match-drop-ids fk) (sk ... i) i))
|
||||||
((match-two v (get! getter) g s (sk ...) fk i)
|
((match-two v (get! getter) (g s) (sk ...) fk i)
|
||||||
(let ((getter (lambda () g))) (sk ... i)))
|
(let ((getter (lambda () g))) (sk ... i)))
|
||||||
((match-two v (set! setter) g (s ...) (sk ...) fk i)
|
((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
|
||||||
(let ((setter (lambda (x) (s ... x)))) (sk ... i)))
|
(let ((setter (lambda (x) (s ... x)))) (sk ... i)))
|
||||||
((match-two v (? pred p ...) g s sk fk i)
|
((match-two v (? pred . p) g+s sk fk i)
|
||||||
(if (pred v) (match-one v (and p ...) g s sk fk i) fk))
|
(if (pred v) (match-one v (and . p) g+s sk fk i) fk))
|
||||||
((match-two v (= proc p) g s sk fk i)
|
((match-two v (= proc p) . x)
|
||||||
(let ((w (proc v)))
|
(let ((w (proc v))) (match-one w p . x)))
|
||||||
(match-one w p g s sk fk i)))
|
((match-two v (p ___ . r) g+s sk fk i)
|
||||||
((match-two v (p ___ . r) g s sk fk i)
|
(match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
|
||||||
(match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
|
((match-two v (p) g+s sk fk i)
|
||||||
((match-two v (p) g s sk fk i)
|
|
||||||
(if (and (pair? v) (null? (cdr v)))
|
(if (and (pair? v) (null? (cdr v)))
|
||||||
(let ((w (car v)))
|
(let ((w (car v)))
|
||||||
(match-one w p (car v) (set-car! v) sk fk i))
|
(match-one w p ((car v) (set-car! v)) sk fk i))
|
||||||
fk))
|
fk))
|
||||||
((match-two v (p *** q) g s sk fk i)
|
((match-two v (p *** q) g+s sk fk i)
|
||||||
(match-extract-vars p (match-gen-search v p q g s sk fk i) i ()))
|
(match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
|
||||||
((match-two v (p *** . q) g s sk fk i)
|
((match-two v (p *** . q) g+s sk fk i)
|
||||||
(match-syntax-error "invalid use of ***" (p *** . q)))
|
(match-syntax-error "invalid use of ***" (p *** . q)))
|
||||||
((match-two v (p . q) g s sk fk i)
|
((match-two v (p . q) g+s sk fk i)
|
||||||
(if (pair? v)
|
(if (pair? v)
|
||||||
(let ((w (car v)) (x (cdr v)))
|
(let ((w (car v)) (x (cdr v)))
|
||||||
(match-one w p (car v) (set-car! v)
|
(match-one w p ((car v) (set-car! v))
|
||||||
(match-one x q (cdr v) (set-cdr! v) sk fk)
|
(match-one x q ((cdr v) (set-cdr! v)) sk fk)
|
||||||
fk
|
fk
|
||||||
i))
|
i))
|
||||||
fk))
|
fk))
|
||||||
((match-two v #(p ...) g s sk fk i)
|
((match-two v #(p ...) g+s . x)
|
||||||
(match-vector v 0 () (p ...) sk fk i))
|
(match-vector v 0 () (p ...) . x))
|
||||||
((match-two v _ g s (sk ...) fk i) (sk ... i))
|
((match-two v _ g+s (sk ...) fk i) (sk ... i))
|
||||||
;; Not a pair or vector or special literal, test to see if it's a
|
;; Not a pair or vector or special literal, test to see if it's a
|
||||||
;; new symbol, in which case we just bind it, or if it's an
|
;; new symbol, in which case we just bind it, or if it's an
|
||||||
;; already bound symbol or some other literal, in which case we
|
;; already bound symbol or some other literal, in which case we
|
||||||
;; compare it with EQUAL?.
|
;; compare it with EQUAL?.
|
||||||
((match-two v x g s (sk ...) fk (id ...))
|
((match-two v x g+s (sk ...) fk (id ...))
|
||||||
(let-syntax
|
(let-syntax
|
||||||
((new-sym?
|
((new-sym?
|
||||||
(syntax-rules (id ...)
|
(syntax-rules (id ...)
|
||||||
|
|
@ -192,53 +191,55 @@
|
||||||
|
|
||||||
(define-syntax match-quasiquote
|
(define-syntax match-quasiquote
|
||||||
(syntax-rules (unquote unquote-splicing quasiquote)
|
(syntax-rules (unquote unquote-splicing quasiquote)
|
||||||
((_ v (unquote p) g s sk fk i)
|
((_ v (unquote p) g+s sk fk i)
|
||||||
(match-one v p g s sk fk i))
|
(match-one v p g+s sk fk i))
|
||||||
((_ v ((unquote-splicing p) . rest) g s sk fk i)
|
((_ v ((unquote-splicing p) . rest) g+s sk fk i)
|
||||||
(if (pair? v)
|
(if (pair? v)
|
||||||
(match-one v
|
(match-one v
|
||||||
(p . tmp)
|
(p . tmp)
|
||||||
(match-quasiquote tmp rest g s sk fk)
|
(match-quasiquote tmp rest g+s sk fk)
|
||||||
fk
|
fk
|
||||||
i)
|
i)
|
||||||
fk))
|
fk))
|
||||||
((_ v (quasiquote p) g s sk fk i . depth)
|
((_ v (quasiquote p) g+s sk fk i . depth)
|
||||||
(match-quasiquote v p g s sk fk i #f . depth))
|
(match-quasiquote v p g+s sk fk i #f . depth))
|
||||||
((_ v (unquote p) g s sk fk i x . depth)
|
((_ v (unquote p) g+s sk fk i x . depth)
|
||||||
(match-quasiquote v p g s sk fk i . depth))
|
(match-quasiquote v p g+s sk fk i . depth))
|
||||||
((_ v (unquote-splicing p) g s sk fk i x . depth)
|
((_ v (unquote-splicing p) g+s sk fk i x . depth)
|
||||||
(match-quasiquote v p g s sk fk i . depth))
|
(match-quasiquote v p g+s sk fk i . depth))
|
||||||
((_ v (p . q) g s sk fk i . depth)
|
((_ v (p . q) g+s sk fk i . depth)
|
||||||
(if (pair? v)
|
(if (pair? v)
|
||||||
(let ((w (car v)) (x (cdr v)))
|
(let ((w (car v)) (x (cdr v)))
|
||||||
(match-quasiquote
|
(match-quasiquote
|
||||||
w p g s
|
w p g+s
|
||||||
(match-quasiquote-step x q g s sk fk depth)
|
(match-quasiquote-step x q g+s sk fk depth)
|
||||||
fk i . depth))
|
fk i . depth))
|
||||||
fk))
|
fk))
|
||||||
((_ v #(elt ...) g s sk fk i . depth)
|
((_ v #(elt ...) g+s sk fk i . depth)
|
||||||
(if (vector? v)
|
(if (vector? v)
|
||||||
(let ((ls (vector->list v)))
|
(let ((ls (vector->list v)))
|
||||||
(match-quasiquote ls (elt ...) g s sk fk i . depth))
|
(match-quasiquote ls (elt ...) g+s sk fk i . depth))
|
||||||
fk))
|
fk))
|
||||||
((_ v x g s sk fk i . depth)
|
((_ v x g+s sk fk i . depth)
|
||||||
(match-one v 'x g s sk fk i))))
|
(match-one v 'x g+s sk fk i))))
|
||||||
|
|
||||||
(define-syntax match-quasiquote-step
|
(define-syntax match-quasiquote-step
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((match-quasiquote-step x q g s sk fk depth i)
|
((match-quasiquote-step x q g+s sk fk depth i)
|
||||||
(match-quasiquote x q g s sk fk i . depth))
|
(match-quasiquote x q g+s sk fk i . depth))))
|
||||||
))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Utilities
|
;; Utilities
|
||||||
|
|
||||||
;; A CPS utility that takes two values and just expands into the
|
;; Takes two values and just expands into the first.
|
||||||
;; first.
|
|
||||||
(define-syntax match-drop-ids
|
(define-syntax match-drop-ids
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ expr ids ...) expr)))
|
((_ expr ids ...) expr)))
|
||||||
|
|
||||||
|
(define-syntax match-drop-first-arg
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ arg expr) expr)))
|
||||||
|
|
||||||
;; To expand an OR group we try each clause in succession, passing the
|
;; To expand an OR group we try each clause in succession, passing the
|
||||||
;; first that succeeds to the success continuation. On failure for
|
;; first that succeeds to the success continuation. On failure for
|
||||||
;; any clause, we just try the next clause, finally resorting to the
|
;; any clause, we just try the next clause, finally resorting to the
|
||||||
|
|
@ -248,22 +249,21 @@
|
||||||
|
|
||||||
(define-syntax match-gen-or
|
(define-syntax match-gen-or
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
|
((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
|
||||||
(let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
|
(let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
|
||||||
(match-gen-or-step
|
(match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
|
||||||
v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))
|
|
||||||
|
|
||||||
(define-syntax match-gen-or-step
|
(define-syntax match-gen-or-step
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ v () g s sk fk i)
|
((_ v () g+s sk fk . x)
|
||||||
;; no OR clauses, call the failure continuation
|
;; no OR clauses, call the failure continuation
|
||||||
fk)
|
fk)
|
||||||
((_ v (p) g s sk fk i)
|
((_ v (p) . x)
|
||||||
;; last (or only) OR clause, just expand normally
|
;; last (or only) OR clause, just expand normally
|
||||||
(match-one v p g s sk fk i))
|
(match-one v p . x))
|
||||||
((_ v (p . q) g s sk fk i)
|
((_ v (p . q) g+s sk fk i)
|
||||||
;; match one and try the remaining on failure
|
;; match one and try the remaining on failure
|
||||||
(match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))
|
(match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
|
||||||
))
|
))
|
||||||
|
|
||||||
;; We match a pattern (p ...) by matching the pattern p in a loop on
|
;; We match a pattern (p ...) by matching the pattern p in a loop on
|
||||||
|
|
@ -279,7 +279,7 @@
|
||||||
|
|
||||||
(define-syntax match-gen-ellipses
|
(define-syntax match-gen-ellipses
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ v p () g s (sk ...) fk i ((id id-ls) ...))
|
((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
|
||||||
(match-check-identifier p
|
(match-check-identifier p
|
||||||
;; simplest case equivalent to (p ...), just bind the list
|
;; simplest case equivalent to (p ...), just bind the list
|
||||||
(let ((p v))
|
(let ((p v))
|
||||||
|
|
@ -293,12 +293,12 @@
|
||||||
(let ((id (reverse id-ls)) ...) (sk ... i)))
|
(let ((id (reverse id-ls)) ...) (sk ... i)))
|
||||||
((pair? ls)
|
((pair? ls)
|
||||||
(let ((w (car ls)))
|
(let ((w (car ls)))
|
||||||
(match-one w p (car ls) (set-car! ls)
|
(match-one w p ((car ls) (set-car! ls))
|
||||||
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
|
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
|
||||||
fk i)))
|
fk i)))
|
||||||
(else
|
(else
|
||||||
fk)))))
|
fk)))))
|
||||||
((_ v p r g s (sk ...) fk i ((id id-ls) ...))
|
((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
|
||||||
;; general case, trailing patterns to match, keep track of the
|
;; general case, trailing patterns to match, keep track of the
|
||||||
;; remaining list length so we don't need any backtracking
|
;; remaining list length so we don't need any backtracking
|
||||||
(match-verify-no-ellipses
|
(match-verify-no-ellipses
|
||||||
|
|
@ -312,10 +312,10 @@
|
||||||
(cond
|
(cond
|
||||||
((= n tail-len)
|
((= n tail-len)
|
||||||
(let ((id (reverse id-ls)) ...)
|
(let ((id (reverse id-ls)) ...)
|
||||||
(match-one ls r #f #f (sk ... i) fk i)))
|
(match-one ls r (#f #f) (sk ... i) fk i)))
|
||||||
((pair? ls)
|
((pair? ls)
|
||||||
(let ((w (car ls)))
|
(let ((w (car ls)))
|
||||||
(match-one w p (car ls) (set-car! ls)
|
(match-one w p ((car ls) (set-car! ls))
|
||||||
(match-drop-ids
|
(match-drop-ids
|
||||||
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
|
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
|
||||||
fk
|
fk
|
||||||
|
|
@ -323,6 +323,28 @@
|
||||||
(else
|
(else
|
||||||
fk)))))))))
|
fk)))))))))
|
||||||
|
|
||||||
|
;; This is just a safety check. Although unlike syntax-rules we allow
|
||||||
|
;; trailing patterns after an ellipses, we explicitly disable multiple
|
||||||
|
;; ellipses at the same level. This is because in the general case
|
||||||
|
;; such patterns are exponential in the number of ellipses, and we
|
||||||
|
;; don't want to make it easy to construct very expensive operations
|
||||||
|
;; with simple looking patterns. For example, it would be O(n^2) for
|
||||||
|
;; patterns like (a ... b ...) because we must consider every trailing
|
||||||
|
;; element for every possible break for the leading "a ...".
|
||||||
|
|
||||||
|
(define-syntax match-verify-no-ellipses
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ (x . y) sk)
|
||||||
|
(match-check-ellipse
|
||||||
|
x
|
||||||
|
(match-syntax-error
|
||||||
|
"multiple ellipse patterns not allowed at same level")
|
||||||
|
(match-verify-no-ellipses y sk)))
|
||||||
|
((_ () sk)
|
||||||
|
sk)
|
||||||
|
((_ x sk)
|
||||||
|
(match-syntax-error "dotted tail not allowed after ellipse" x))))
|
||||||
|
|
||||||
;; Matching a tree search pattern is only slightly more complicated.
|
;; Matching a tree search pattern is only slightly more complicated.
|
||||||
;; Here we allow patterns of the form
|
;; Here we allow patterns of the form
|
||||||
;;
|
;;
|
||||||
|
|
@ -351,9 +373,9 @@
|
||||||
|
|
||||||
(define-syntax match-gen-search
|
(define-syntax match-gen-search
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((match-gen-search v p q g s sk fk i ((id id-ls) ...))
|
((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
|
||||||
(letrec ((try (lambda (w fail id-ls ...)
|
(letrec ((try (lambda (w fail id-ls ...)
|
||||||
(match-one w q g s
|
(match-one w q g+s
|
||||||
(match-drop-ids
|
(match-drop-ids
|
||||||
(let ((id (reverse id-ls)) ...)
|
(let ((id (reverse id-ls)) ...)
|
||||||
sk))
|
sk))
|
||||||
|
|
@ -363,7 +385,7 @@
|
||||||
(fail)
|
(fail)
|
||||||
(let ((u (car w)))
|
(let ((u (car w)))
|
||||||
(match-one
|
(match-one
|
||||||
u p (car w) (set-car! w)
|
u p ((car w) (set-car! w))
|
||||||
(match-drop-ids
|
(match-drop-ids
|
||||||
;; accumulate the head variables from
|
;; accumulate the head variables from
|
||||||
;; the p pattern, and loop over the tail
|
;; the p pattern, and loop over the tail
|
||||||
|
|
@ -380,38 +402,16 @@
|
||||||
(let ((id-ls '()) ...)
|
(let ((id-ls '()) ...)
|
||||||
(try v (lambda () fk) id-ls ...))))))
|
(try v (lambda () fk) id-ls ...))))))
|
||||||
|
|
||||||
;; This is just a safety check. Although unlike syntax-rules we allow
|
|
||||||
;; trailing patterns after an ellipses, we explicitly disable multiple
|
|
||||||
;; ellipses at the same level. This is because in the general case
|
|
||||||
;; such patterns are exponential in the number of ellipses, and we
|
|
||||||
;; don't want to make it easy to construct very expensive operations
|
|
||||||
;; with simple looking patterns. For example, it would be O(n^2) for
|
|
||||||
;; patterns like (a ... b ...) because we must consider every trailing
|
|
||||||
;; element for every possible break for the leading "a ...".
|
|
||||||
|
|
||||||
(define-syntax match-verify-no-ellipses
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ (x . y) sk)
|
|
||||||
(match-check-ellipse
|
|
||||||
x
|
|
||||||
(match-syntax-error
|
|
||||||
"multiple ellipse patterns not allowed at same level")
|
|
||||||
(match-verify-no-ellipses y sk)))
|
|
||||||
((_ () sk) sk)
|
|
||||||
((_ x sk)
|
|
||||||
(match-syntax-error "dotted tail not allowed after ellipse" x))
|
|
||||||
))
|
|
||||||
|
|
||||||
;; Vector patterns are just more of the same, with the slight
|
;; Vector patterns are just more of the same, with the slight
|
||||||
;; exception that we pass around the current vector index being
|
;; exception that we pass around the current vector index being
|
||||||
;; matched.
|
;; matched.
|
||||||
|
|
||||||
(define-syntax match-vector
|
(define-syntax match-vector
|
||||||
(syntax-rules (___)
|
(syntax-rules (___)
|
||||||
((_ v n pats (p q) sk fk i)
|
((_ v n pats (p q) . x)
|
||||||
(match-check-ellipse q
|
(match-check-ellipse q
|
||||||
(match-gen-vector-ellipses v n pats p sk fk i)
|
(match-gen-vector-ellipses v n pats p . x)
|
||||||
(match-vector-two v n pats (p q) sk fk i)))
|
(match-vector-two v n pats (p q) . x)))
|
||||||
((_ v n pats (p ___) sk fk i)
|
((_ v n pats (p ___) sk fk i)
|
||||||
(match-gen-vector-ellipses v n pats p sk fk i))
|
(match-gen-vector-ellipses v n pats p sk fk i))
|
||||||
((_ . x)
|
((_ . x)
|
||||||
|
|
@ -423,21 +423,20 @@
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ v n ((pat index) ...) () sk fk i)
|
((_ v n ((pat index) ...) () sk fk i)
|
||||||
(if (vector? v)
|
(if (vector? v)
|
||||||
(let ((len (vector-length v)))
|
(let ((len (vector-length v)))
|
||||||
(if (= len n)
|
(if (= len n)
|
||||||
(match-vector-step v ((pat index) ...) sk fk i)
|
(match-vector-step v ((pat index) ...) sk fk i)
|
||||||
fk))
|
fk))
|
||||||
fk))
|
fk))
|
||||||
((_ v n (pats ...) (p . q) sk fk i)
|
((_ v n (pats ...) (p . q) . x)
|
||||||
(match-vector v (+ n 1) (pats ... (p n)) q sk fk i))
|
(match-vector v (+ n 1) (pats ... (p n)) q . x))))
|
||||||
))
|
|
||||||
|
|
||||||
(define-syntax match-vector-step
|
(define-syntax match-vector-step
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ v () (sk ...) fk i) (sk ... i))
|
((_ v () (sk ...) fk i) (sk ... i))
|
||||||
((_ v ((pat index) . rest) sk fk i)
|
((_ v ((pat index) . rest) sk fk i)
|
||||||
(let ((w (vector-ref v index)))
|
(let ((w (vector-ref v index)))
|
||||||
(match-one w pat (vector-ref v index) (vector-set! v index)
|
(match-one w pat ((vector-ref v index) (vector-set! v index))
|
||||||
(match-vector-step v rest sk fk)
|
(match-vector-step v rest sk fk)
|
||||||
fk i)))))
|
fk i)))))
|
||||||
|
|
||||||
|
|
@ -468,7 +467,7 @@
|
||||||
(if (>= j len)
|
(if (>= j len)
|
||||||
(let ((id (reverse id-ls)) ...) (sk ... i))
|
(let ((id (reverse id-ls)) ...) (sk ... i))
|
||||||
(let ((w (vector-ref v j)))
|
(let ((w (vector-ref v j)))
|
||||||
(match-one w p (vector-ref v j) (vetor-set! v j)
|
(match-one w p ((vector-ref v j) (vetor-set! v j))
|
||||||
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
|
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
|
||||||
fk i)))))))
|
fk i)))))))
|
||||||
|
|
||||||
|
|
@ -486,22 +485,22 @@
|
||||||
|
|
||||||
(define-syntax match-extract-vars
|
(define-syntax match-extract-vars
|
||||||
(syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
|
(syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
|
||||||
((match-extract-vars (? pred . p) k i v)
|
((match-extract-vars (? pred . p) . x)
|
||||||
(match-extract-vars p k i v))
|
(match-extract-vars p . x))
|
||||||
((match-extract-vars ($ rec . p) k i v)
|
((match-extract-vars ($ rec . p) . x)
|
||||||
(match-extract-vars p k i v))
|
(match-extract-vars p . x))
|
||||||
((match-extract-vars (= proc p) k i v)
|
((match-extract-vars (= proc p) . x)
|
||||||
(match-extract-vars p k i v))
|
(match-extract-vars p . x))
|
||||||
((match-extract-vars (quote x) (k ...) i v)
|
((match-extract-vars (quote x) (k ...) i v)
|
||||||
(k ... v))
|
(k ... v))
|
||||||
((match-extract-vars (quasiquote x) k i v)
|
((match-extract-vars (quasiquote x) k i v)
|
||||||
(match-extract-quasiquote-vars x k i v (#t)))
|
(match-extract-quasiquote-vars x k i v (#t)))
|
||||||
((match-extract-vars (and . p) k i v)
|
((match-extract-vars (and . p) . x)
|
||||||
(match-extract-vars p k i v))
|
(match-extract-vars p . x))
|
||||||
((match-extract-vars (or . p) k i v)
|
((match-extract-vars (or . p) . x)
|
||||||
(match-extract-vars p k i v))
|
(match-extract-vars p . x))
|
||||||
((match-extract-vars (not . p) k i v)
|
((match-extract-vars (not . p) . x)
|
||||||
(match-extract-vars p k i v))
|
(match-extract-vars p . x))
|
||||||
;; A non-keyword pair, expand the CAR with a continuation to
|
;; A non-keyword pair, expand the CAR with a continuation to
|
||||||
;; expand the CDR.
|
;; expand the CDR.
|
||||||
((match-extract-vars (p q . r) k i v)
|
((match-extract-vars (p q . r) k i v)
|
||||||
|
|
@ -511,8 +510,8 @@
|
||||||
(match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
|
(match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
|
||||||
((match-extract-vars (p . q) k i v)
|
((match-extract-vars (p . q) k i v)
|
||||||
(match-extract-vars p (match-extract-vars-step q k i v) i ()))
|
(match-extract-vars p (match-extract-vars-step q k i v) i ()))
|
||||||
((match-extract-vars #(p ...) k i v)
|
((match-extract-vars #(p ...) . x)
|
||||||
(match-extract-vars (p ...) k i v))
|
(match-extract-vars (p ...) . x))
|
||||||
((match-extract-vars _ (k ...) i v) (k ... v))
|
((match-extract-vars _ (k ...) i v) (k ... v))
|
||||||
((match-extract-vars ___ (k ...) i v) (k ... v))
|
((match-extract-vars ___ (k ...) i v) (k ... v))
|
||||||
((match-extract-vars *** (k ...) i v) (k ... v))
|
((match-extract-vars *** (k ...) i v) (k ... v))
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue