plt-match.ss/match.ss:
- don't export match:test-no-order, which is only used in generated code test-no-order.ss - reformat code - use ormap instead of let loop render-test-list: - add define/opt sugar - remove a lot of pointless stx arguments - remove a lot of [quasi]syntax/loc gen-match: - use internal define instead of let - remove quasisyntax/loc - reformat - remove pointlessly optional argument coupling-and-binding: - reformat - use memf instead of custom loops svn: r908
This commit is contained in:
Sam Tobin-Hochstadt
parent
821aa78044
commit
d96e47c4b7
|
|
@ -117,8 +117,7 @@
|
|||
match-equality-test
|
||||
exn:misc:match?
|
||||
exn:misc:match-value
|
||||
define-match-expander
|
||||
match:test-no-order)
|
||||
define-match-expander)
|
||||
|
||||
;; FIXME: match-helper and match-error should each be split
|
||||
;; into a compile-time part and a run-time part.
|
||||
|
|
|
|||
|
|
@ -142,8 +142,7 @@
|
|||
exn:misc:match?
|
||||
exn:misc:match-value
|
||||
match-equality-test
|
||||
define-match-expander
|
||||
match:test-no-order)
|
||||
define-match-expander)
|
||||
|
||||
(require "private/match-internal-func.ss"
|
||||
"private/match-expander.ss"
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@
|
|||
(provide couple-tests meta-couple subst-bindings)
|
||||
|
||||
(require "test-structure.scm"
|
||||
"match-helper.ss")
|
||||
"match-helper.ss"
|
||||
(lib "list.ss"))
|
||||
|
||||
(require-for-template mzscheme)
|
||||
|
||||
|
|
@ -25,57 +26,49 @@
|
|||
;; passed around to the various partially compiled tests so that
|
||||
;; compilation can be completed. This returns a function that takes a
|
||||
;; list of tests so far and a list of bound pattern variables.
|
||||
(define couple-tests
|
||||
(lambda (test-list ks-func kf-func let-bound)
|
||||
(if (null? test-list)
|
||||
(ks-func (kf-func let-bound) let-bound)
|
||||
(let ((cur-test (car test-list)))
|
||||
(if (and (>= (test-bind-count cur-test) 2)
|
||||
(not (exp-already-bound?
|
||||
(test-bind-exp cur-test)
|
||||
let-bound))) ;; if it is member of
|
||||
;;let-bound skip it
|
||||
(let* ((new-exp (get-exp-var))
|
||||
(binding (list (test-bind-exp cur-test)
|
||||
(test-bind-exp-stx cur-test)
|
||||
new-exp))
|
||||
(let-bound (cons binding
|
||||
let-bound))
|
||||
(kf (kf-func let-bound)))
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
(test-bind-exp-stx cur-test)
|
||||
(let ((#,new-exp
|
||||
#,(sub-expr-subst (bind-get-exp-stx binding)
|
||||
let-bound)))
|
||||
#,(((test-comp (car test-list))
|
||||
(couple-tests (cdr test-list)
|
||||
ks-func
|
||||
(if (negate-test? cur-test)
|
||||
(lambda (let-bound)
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
(test-bind-exp-stx cur-test)
|
||||
(match-failure))))
|
||||
kf-func)
|
||||
;kf-func
|
||||
let-bound)
|
||||
kf let-bound) sf bv)))))
|
||||
(let* ((kf (kf-func let-bound)))
|
||||
((test-comp (car test-list))
|
||||
(couple-tests (cdr test-list)
|
||||
ks-func
|
||||
(if (negate-test? cur-test)
|
||||
(lambda (let-bound)
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
(test-bind-exp-stx cur-test)
|
||||
(match-failure))))
|
||||
kf-func)
|
||||
;kf-func
|
||||
let-bound)
|
||||
kf
|
||||
let-bound)))))))
|
||||
(define (couple-tests test-list ks-func kf-func let-bound)
|
||||
(if (null? test-list)
|
||||
(ks-func (kf-func let-bound) let-bound)
|
||||
(let ([cur-test (car test-list)])
|
||||
(if (and (>= (test-bind-count cur-test) 2)
|
||||
(not (exp-already-bound?
|
||||
(test-bind-exp cur-test)
|
||||
let-bound))) ;; if it is member of
|
||||
;;let-bound skip it
|
||||
(let* ([new-exp (get-exp-var)]
|
||||
[binding (list (test-bind-exp cur-test)
|
||||
(test-bind-exp-stx cur-test)
|
||||
new-exp)]
|
||||
[let-bound (cons binding let-bound)]
|
||||
[kf (kf-func let-bound)])
|
||||
(lambda (sf bv)
|
||||
#`(let ((#,new-exp
|
||||
#,(sub-expr-subst (bind-get-exp-stx binding)
|
||||
let-bound)))
|
||||
#,(((test-comp (car test-list))
|
||||
(couple-tests (cdr test-list)
|
||||
ks-func
|
||||
(if (negate-test? cur-test)
|
||||
(lambda (let-bound)
|
||||
(lambda (sf bv)
|
||||
#`(match-failure)))
|
||||
kf-func)
|
||||
;kf-func
|
||||
let-bound)
|
||||
kf let-bound) sf bv))))
|
||||
(let* ([kf (kf-func let-bound)])
|
||||
((test-comp (car test-list))
|
||||
(couple-tests (cdr test-list)
|
||||
ks-func
|
||||
(if (negate-test? cur-test)
|
||||
(lambda (let-bound)
|
||||
(lambda (sf bv)
|
||||
#`(match-failure)))
|
||||
kf-func)
|
||||
;kf-func
|
||||
let-bound)
|
||||
kf
|
||||
let-bound))))))
|
||||
|
||||
;;!(function bind-get-exp
|
||||
;; (form (bind-get-exp binding) -> exp)
|
||||
|
|
@ -108,13 +101,11 @@
|
|||
;; -> (syntax (car 'exp5))))
|
||||
;; This function substitutes let bound variables names for the
|
||||
;; expressions that they represent.
|
||||
(define subst-bindings
|
||||
(lambda (exp-stx let-bound)
|
||||
(let* ((exp (syntax-object->datum exp-stx))
|
||||
(binding (get-bind exp let-bound)))
|
||||
(if binding
|
||||
(bind-get-new-exp binding)
|
||||
(sub-expr-subst exp-stx let-bound)))))
|
||||
(define (subst-bindings exp-stx let-bound)
|
||||
(define binding (get-bind exp-stx let-bound))
|
||||
(if binding
|
||||
(bind-get-new-exp binding)
|
||||
(sub-expr-subst exp-stx let-bound)))
|
||||
|
||||
;;!(function sub-exp-subst
|
||||
;; (form (sub-exp-subst exp-stx let-bound) -> syntax)
|
||||
|
|
@ -127,22 +118,19 @@
|
|||
;; This function substitutes let bound variables names for the
|
||||
;; expressions that they represent. This only works if a
|
||||
;; subexpression of exp-stx is bound in the let-bound list.
|
||||
(define sub-expr-subst
|
||||
(lambda (exp-stx let-bound)
|
||||
(syntax-case exp-stx ()
|
||||
((access sub-exp rest ...)
|
||||
(let ((binding (get-bind
|
||||
(syntax-object->datum (syntax sub-exp))
|
||||
let-bound)))
|
||||
;;(write (syntax sub-exp))(newline) (write binding)(newline)
|
||||
(if binding
|
||||
(quasisyntax/loc
|
||||
exp-stx (access #,(bind-get-new-exp binding) rest ...))
|
||||
(quasisyntax/loc
|
||||
exp-stx (access #,(sub-expr-subst (syntax sub-exp)
|
||||
let-bound)
|
||||
rest ...)))))
|
||||
(other (syntax other)))))
|
||||
(define (sub-expr-subst exp-stx let-bound)
|
||||
(syntax-case exp-stx ()
|
||||
[(access sub-exp rest ...)
|
||||
(let ([binding (get-bind #'sub-exp let-bound)])
|
||||
;;(write (syntax sub-exp))(newline) (write binding)(newline)
|
||||
(if binding
|
||||
#`(access #,(bind-get-new-exp binding) rest ...)
|
||||
#`(access #,(sub-expr-subst #'sub-exp let-bound) rest ...)))]
|
||||
[_ exp-stx]))
|
||||
|
||||
; helper for the following functions
|
||||
(define ((equal-bind-get exp) e)
|
||||
(equal? exp (bind-get-exp e)))
|
||||
|
||||
;;!(function get-bind
|
||||
;; (form (get-bind exp let-bound) -> binding)
|
||||
|
|
@ -150,24 +138,18 @@
|
|||
;; This function looks up the binding for a given expression exp
|
||||
;; in the binding list let-bound. If the binding is found then the
|
||||
;; binding is returned if not then #f is returned.
|
||||
(define get-bind
|
||||
(lambda (exp let-bound)
|
||||
(cond ((null? let-bound) #f)
|
||||
((equal? exp (bind-get-exp (car let-bound))) (car let-bound))
|
||||
(else (get-bind exp (cdr let-bound))))))
|
||||
(define (get-bind exp let-bound)
|
||||
(cond [(memf (equal-bind-get (syntax-object->datum exp)) let-bound) => car]
|
||||
[else #f]))
|
||||
|
||||
;;!(function exp-already-bound?
|
||||
;; (form (exp-already-bound? exp let-bound) -> binding)
|
||||
;; (contract (any list) -> list))
|
||||
;; (contract (any list) -> boolean))
|
||||
;; This function looks up the binding for a given expression exp
|
||||
;; in the binding list let-bound. If the binding is found then #t
|
||||
;; binding is returned if not then #f is returned.
|
||||
(define exp-already-bound?
|
||||
(lambda (exp let-bound)
|
||||
;;(write exp) (newline) (write let-bound)(newline)
|
||||
(cond ((null? let-bound) #f)
|
||||
((equal? exp (bind-get-exp (car let-bound))) #t)
|
||||
(else (exp-already-bound? exp (cdr let-bound))))))
|
||||
(define (exp-already-bound? exp let-bound)
|
||||
(ormap (equal-bind-get exp) let-bound))
|
||||
|
||||
;;!(function meta-couple
|
||||
;; (form (meta-couple rendered-list failure-func
|
||||
|
|
@ -181,22 +163,21 @@
|
|||
;; success functions attached and couples the whole lot together
|
||||
;; yeilding one function that when invoked will compile the whole
|
||||
;; original match expression.
|
||||
(define meta-couple
|
||||
(lambda (rendered-list failure-func let-bound bvsf)
|
||||
(if (null? rendered-list)
|
||||
failure-func
|
||||
;; here we erase the previously bound variables
|
||||
(let* ((failed
|
||||
(lambda (let-bound)
|
||||
(lambda (sf bv)
|
||||
((meta-couple (cdr rendered-list)
|
||||
failure-func
|
||||
let-bound
|
||||
bvsf) sf bvsf)))))
|
||||
(couple-tests (caar rendered-list)
|
||||
(cdar rendered-list) ;; successfunc needs
|
||||
;; failure method
|
||||
failed ;; needs let-bound
|
||||
let-bound ;; initial-let bindings
|
||||
))))) ;; fail-func
|
||||
(define (meta-couple rendered-list failure-func let-bound bvsf)
|
||||
(if (null? rendered-list)
|
||||
failure-func
|
||||
;; here we erase the previously bound variables
|
||||
(let* ([failed
|
||||
(lambda (let-bound)
|
||||
(lambda (sf bv)
|
||||
((meta-couple (cdr rendered-list)
|
||||
failure-func
|
||||
let-bound
|
||||
bvsf) sf bvsf)))])
|
||||
(couple-tests (caar rendered-list)
|
||||
(cdar rendered-list) ;; successfunc needs
|
||||
;; failure method
|
||||
failed ;; needs let-bound
|
||||
let-bound ;; initial-let bindings
|
||||
)))) ;; fail-func
|
||||
)
|
||||
|
|
@ -68,54 +68,50 @@
|
|||
;; result is a function which takes a failure function and a list
|
||||
;; of let-bound expressions and returns a success-function.
|
||||
(define (test-list-with-success-func exp car-patlist stx success-func)
|
||||
(let-values ([(pat body fail-sym) (parse-clause (car car-patlist))])
|
||||
(define (success fail let-bound)
|
||||
(if (not success-func)
|
||||
(lambda (sf bv)
|
||||
;; mark this pattern as reached
|
||||
(set-cdr! car-patlist #t)
|
||||
(if fail-sym
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(let/ec fail-cont
|
||||
(let
|
||||
((failure
|
||||
(lambda ()
|
||||
(fail-cont
|
||||
; it seems like fail is called
|
||||
; twice in this situation
|
||||
#,( fail sf bv)))))
|
||||
((lambda (#,fail-sym
|
||||
#,@(map car bv))
|
||||
#,@body)
|
||||
failure
|
||||
#,@(map (lambda (b)
|
||||
(subst-bindings
|
||||
(define-values (pat body fail-sym) (parse-clause (car car-patlist)))
|
||||
(define (success fail let-bound)
|
||||
(if (not success-func)
|
||||
(lambda (sf bv)
|
||||
;; mark this pattern as reached
|
||||
(set-cdr! car-patlist #t)
|
||||
(if fail-sym
|
||||
#`(let/ec fail-cont
|
||||
(let
|
||||
((failure
|
||||
(lambda ()
|
||||
(fail-cont
|
||||
; it seems like fail is called
|
||||
; twice in this situation
|
||||
#,( fail sf bv)))))
|
||||
((lambda (#,fail-sym
|
||||
#,@(map car bv))
|
||||
#,@body)
|
||||
failure
|
||||
#,@(map (lambda (b)
|
||||
(subst-bindings
|
||||
(cdr b)
|
||||
let-bound))
|
||||
bv))))
|
||||
#`((lambda #,(map car bv)
|
||||
#,@body)
|
||||
#,@(map
|
||||
(lambda (b) (subst-bindings
|
||||
(cdr b)
|
||||
let-bound))
|
||||
bv)))))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
((lambda #,(map car bv)
|
||||
#,@body)
|
||||
#,@(map
|
||||
(lambda (b) (subst-bindings
|
||||
(cdr b)
|
||||
let-bound))
|
||||
bv)))))
|
||||
(lambda (sf bv)
|
||||
;; mark this pattern as reached
|
||||
(set-cdr! car-patlist #t)
|
||||
(let ((bv (map
|
||||
(lambda (bind)
|
||||
(cons (car bind)
|
||||
(subst-bindings
|
||||
(cdr bind)
|
||||
let-bound)))
|
||||
bv)))
|
||||
(success-func sf bv)))))
|
||||
(define test-list (render-test-list pat exp stx))
|
||||
(cons test-list success)))
|
||||
bv))))
|
||||
(lambda (sf bv)
|
||||
;; mark this pattern as reached
|
||||
(set-cdr! car-patlist #t)
|
||||
(let ((bv (map
|
||||
(lambda (bind)
|
||||
(cons (car bind)
|
||||
(subst-bindings
|
||||
(cdr bind)
|
||||
let-bound)))
|
||||
bv)))
|
||||
(success-func sf bv)))))
|
||||
(define test-list (render-test-list pat exp stx))
|
||||
(cons test-list success))
|
||||
|
||||
;;!(function gen-match
|
||||
;; (form (gen-match exp tsf patlist stx [success-func])
|
||||
|
|
@ -169,20 +165,16 @@
|
|||
;; also wraps the final compilation in syntax which binds the
|
||||
;; match-failure function.
|
||||
(define (gen-help opt)
|
||||
;(opt-lambda (exp tsf patlist stx opt [success-func #f])
|
||||
(when (stx-null? patlist)
|
||||
(match:syntax-err stx "null clause list"))
|
||||
(let* ((marked-clauses (mark-patlist patlist))
|
||||
(compiled-match
|
||||
(quasisyntax/loc stx
|
||||
(let ((match-failure
|
||||
(lambda ()
|
||||
(match:error #,exp (quote #,stx)))))
|
||||
(let* ([marked-clauses (mark-patlist patlist)]
|
||||
[compiled-match
|
||||
#`(let ([match-failure (lambda () (match:error #,exp '#,stx))])
|
||||
#,(gen exp tsf marked-clauses
|
||||
stx
|
||||
(syntax (match-failure))
|
||||
#'(match-failure)
|
||||
opt
|
||||
success-func)))))
|
||||
success-func))])
|
||||
(unreachable marked-clauses stx)
|
||||
compiled-match))
|
||||
|
||||
|
|
@ -213,31 +205,20 @@
|
|||
;; determind which supexpressions of the expression to be matched
|
||||
;; need to be bound by let expressions. After all of this the
|
||||
;; tests are "coupled" together for final compilation.
|
||||
(define gen
|
||||
(opt-lambda (exp tsf patlist stx failure-func opt [success-func #f])
|
||||
(define (gen exp tsf patlist stx failure-func opt success-func)
|
||||
;; iterate through list and render each pattern to a list of tests
|
||||
;; and success functions
|
||||
(let ((rendered-list
|
||||
(let loop ((clause-list patlist))
|
||||
(if (null? clause-list)
|
||||
'()
|
||||
(cons (test-list-with-success-func exp
|
||||
(car clause-list)
|
||||
stx
|
||||
success-func)
|
||||
(loop (cdr clause-list)))))))
|
||||
(update-counts rendered-list)
|
||||
(tag-negate-tests rendered-list)
|
||||
(update-binding-counts rendered-list)
|
||||
(let* ((rendered-list (reorder-all-lists rendered-list))
|
||||
(output
|
||||
(begin
|
||||
;(pretty-print rendered-list)(newline)
|
||||
((meta-couple rendered-list
|
||||
(lambda (sf bv) failure-func)
|
||||
'()
|
||||
'())
|
||||
'() '()))))
|
||||
output))))
|
||||
(define rendered-list
|
||||
(map (lambda (clause) (test-list-with-success-func
|
||||
exp clause stx success-func))
|
||||
patlist))
|
||||
(update-counts rendered-list)
|
||||
(tag-negate-tests rendered-list)
|
||||
(update-binding-counts rendered-list)
|
||||
((meta-couple (reorder-all-lists rendered-list)
|
||||
(lambda (sf bv) failure-func)
|
||||
'()
|
||||
'())
|
||||
'() '()))
|
||||
(gen-help #f)))
|
||||
)
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(require (lib "etc.ss"))
|
||||
(require (lib "stx.ss" "syntax"))
|
||||
(require (rename (lib "1.ss" "srfi") map-append append-map ))
|
||||
(require (rename (lib "1.ss" "srfi") map-append append-map))
|
||||
|
||||
(require "match-error.ss"
|
||||
"match-helper.ss"
|
||||
|
|
@ -28,13 +28,18 @@
|
|||
"test-no-order.ss"
|
||||
"match-helper.ss")
|
||||
|
||||
(define-syntax define/opt
|
||||
(syntax-rules ()
|
||||
[(_ (nm args ...) body ...)
|
||||
(define nm (opt-lambda (args ...) body ...))]))
|
||||
|
||||
;; BEGIN SPECIAL-GENERATORS.SCM
|
||||
|
||||
;;!(function or-gen
|
||||
;; (form (or-gen exp orpatlist stx sf bv ks kf let-bound)
|
||||
;; (form (or-gen exp orpatlist sf bv ks kf let-bound)
|
||||
;; ->
|
||||
;; syntax)
|
||||
;; (contract (syntax list syntax list list (list list -> syntax)
|
||||
;; (contract (syntax list list list (list list -> syntax)
|
||||
;; (list list -> syntax) list)
|
||||
;; ->
|
||||
;; syntax))
|
||||
|
|
@ -45,29 +50,24 @@
|
|||
;; larger pattern and the state of compilation has information
|
||||
;; that will help optimaize its compilation. And the success of
|
||||
;; any pattern results in the same outcome.
|
||||
(define or-gen
|
||||
(lambda (exp orpatlist stx sf bv ks kf let-bound)
|
||||
(let ((rendered-list
|
||||
(map
|
||||
(lambda (pat)
|
||||
(cons (render-test-list pat exp stx)
|
||||
(lambda (fail let-bound)
|
||||
(lambda (sf bv)
|
||||
(let ((bv (map
|
||||
(lambda (bind)
|
||||
(cons (car bind)
|
||||
(define (or-gen exp orpatlist sf bv ks kf let-bound)
|
||||
(define rendered-list
|
||||
(map
|
||||
(lambda (pat)
|
||||
(cons (render-test-list pat exp)
|
||||
(lambda (fail let-bound)
|
||||
(lambda (sf bv)
|
||||
(let ((bv (map
|
||||
(lambda (bind)
|
||||
(cons (car bind)
|
||||
(subst-bindings (cdr bind)
|
||||
let-bound)))
|
||||
bv)))
|
||||
(ks sf bv))))))
|
||||
orpatlist)))
|
||||
(update-counts rendered-list)
|
||||
(update-binding-counts rendered-list)
|
||||
(let* ((rendered-list
|
||||
(reorder-all-lists rendered-list)
|
||||
)
|
||||
(output ((meta-couple rendered-list kf let-bound bv) sf bv)))
|
||||
output))))
|
||||
bv)))
|
||||
(ks sf bv))))))
|
||||
orpatlist))
|
||||
(update-counts rendered-list)
|
||||
(update-binding-counts rendered-list)
|
||||
((meta-couple (reorder-all-lists rendered-list) kf let-bound bv) sf bv))
|
||||
|
||||
;;!(function next-outer
|
||||
;; (form (next-outer p ae sf bv let-bound kf ks syntax bool)
|
||||
|
|
@ -84,18 +84,18 @@
|
|||
;; inside of test constructs that cannot be eliminated because of
|
||||
;; a related presence in the test-so-far list. So, instead of
|
||||
;; partially compiling patterns this function fully compiles patterns.
|
||||
(define next-outer
|
||||
(opt-lambda (p
|
||||
ae ;; this is the actual expression
|
||||
sf
|
||||
bv
|
||||
let-bound
|
||||
kf
|
||||
ks
|
||||
[stx (syntax '())]
|
||||
[opt #f])
|
||||
(next-outer-helper p ae sf bv let-bound
|
||||
(lambda (x) kf) (lambda (a b) ks) stx opt)))
|
||||
(define/opt (next-outer
|
||||
p
|
||||
ae ;; this is the actual expression
|
||||
sf
|
||||
bv
|
||||
let-bound
|
||||
kf
|
||||
ks
|
||||
[stx (syntax '())]
|
||||
[opt #f])
|
||||
(next-outer-helper p ae sf bv let-bound
|
||||
(lambda (x) kf) (lambda (a b) ks) stx opt))
|
||||
|
||||
;;!(function next-outer-helper
|
||||
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
|
||||
|
|
@ -110,24 +110,24 @@
|
|||
;; ks-func and kf-func that will be given compile time imformation
|
||||
;; about let-bindings etc. which in turn will allow the programmer
|
||||
;; to take advantage of this info.
|
||||
(define next-outer-helper
|
||||
(opt-lambda (p
|
||||
ae ;; this is the actual expression
|
||||
sf
|
||||
bv
|
||||
let-bound
|
||||
kf-func
|
||||
ks-func
|
||||
[stx (syntax '())]
|
||||
[opt #f])
|
||||
;; right now this does not bind new variables
|
||||
(let ((rendered-list (render-test-list p ae stx)))
|
||||
(define/opt (next-outer-helper
|
||||
p
|
||||
ae ;; this is the actual expression
|
||||
sf
|
||||
bv
|
||||
let-bound
|
||||
kf-func
|
||||
ks-func
|
||||
[stx (syntax '())]
|
||||
[opt #f])
|
||||
;; right now this does not bind new variables
|
||||
(let ((rendered-list (render-test-list p ae stx)))
|
||||
;; no need to reorder lists although I suspect that it may be
|
||||
;; better to put shape tests first
|
||||
(update-binding-count rendered-list)
|
||||
((couple-tests rendered-list ks-func kf-func let-bound) sf bv))))
|
||||
(update-binding-count rendered-list)
|
||||
((couple-tests rendered-list ks-func kf-func let-bound) sf bv)))
|
||||
|
||||
;;!(function create-test-func
|
||||
;;!(function create-test-func
|
||||
;; (form (create-test-func p sf let-bound bind-map last-test)
|
||||
;; ->
|
||||
;; syntax)
|
||||
|
|
@ -140,9 +140,7 @@
|
|||
;; last-test - a boolean value that indicates whether this function
|
||||
;; is collecting one value or a list of values.</pre>
|
||||
(define (create-test-func p sf let-bound bind-map last-test)
|
||||
(quasisyntax/loc
|
||||
p
|
||||
(lambda (exp)
|
||||
#`(lambda (exp)
|
||||
#,(next-outer-helper
|
||||
p #'exp sf '() let-bound
|
||||
(lambda (let-bound)
|
||||
|
|
@ -161,7 +159,7 @@
|
|||
#`(set! #,binding-name
|
||||
#,exp-to-bind))))
|
||||
bv)
|
||||
#t)))))))
|
||||
#t))))))
|
||||
|
||||
;;!(function getbindings
|
||||
;; (form (getbindings pat-syntax) -> list)
|
||||
|
|
@ -199,7 +197,7 @@
|
|||
|
||||
;;!(function handle-end-ddk-list
|
||||
;; (form (handle-end-ddk-list ae kf ks pat
|
||||
;; dot-dot-k stx
|
||||
;; dot-dot-k
|
||||
;; let-bound)
|
||||
;; ->
|
||||
;; ((list list) -> syntax))
|
||||
|
|
@ -208,7 +206,6 @@
|
|||
;; ((list list) -> syntax)
|
||||
;; syntax
|
||||
;; syntax
|
||||
;; syntax
|
||||
;; list)
|
||||
;; ->
|
||||
;; ((list list) -> syntax)))
|
||||
|
|
@ -221,9 +218,8 @@
|
|||
;; ks - a success function
|
||||
;; pat - the pattern to be matched repeatedly
|
||||
;; dot-dot-k - the ddk pattern
|
||||
;; stx - the source stx for error purposes
|
||||
;; let-bound - a list of let bindings
|
||||
(define ((handle-end-ddk-list ae kf ks pat dot-dot-k stx let-bound) sf bv)
|
||||
(define ((handle-end-ddk-list ae kf ks pat dot-dot-k let-bound) sf bv)
|
||||
(let* ((k (stx-dot-dot-k? dot-dot-k))
|
||||
(ksucc (lambda (sf bv)
|
||||
(let ((bound (getbindings pat)))
|
||||
|
|
@ -252,14 +248,10 @@
|
|||
(syntax exp-sym)))
|
||||
(syntax pred))
|
||||
(whatever
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(lambda (exp-sym)
|
||||
#,ptst))))))
|
||||
(assm (quasisyntax/loc
|
||||
stx
|
||||
(andmap #,tst
|
||||
#,(subst-bindings ae let-bound)))
|
||||
#`(lambda (exp-sym)
|
||||
#,ptst)))))
|
||||
(assm #`(andmap #,tst
|
||||
#,(subst-bindings ae let-bound))
|
||||
(kf sf bv)
|
||||
(ks sf bv)))))
|
||||
(id
|
||||
|
|
@ -276,21 +268,13 @@
|
|||
(gensym (syntax-object->datum x))
|
||||
'-bindings)))
|
||||
bound))
|
||||
(loop-name (quasisyntax/loc
|
||||
(syntax the-pat)
|
||||
#,(gensym 'loop)))
|
||||
(exp-name (quasisyntax/loc
|
||||
(syntax the-pat)
|
||||
#,(gensym 'exp))))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(let #,loop-name
|
||||
(loop-name (gensym 'loop))
|
||||
(exp-name (gensym 'exp)))
|
||||
#`(let #,loop-name
|
||||
((#,exp-name #,(subst-bindings ae let-bound))
|
||||
#,@(map
|
||||
(lambda (x)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(#,x '())))
|
||||
#`(#,x '()))
|
||||
binding-list-names))
|
||||
(if (null? #,exp-name)
|
||||
#,(ks sf
|
||||
|
|
@ -299,15 +283,11 @@
|
|||
bound
|
||||
(map
|
||||
(lambda (x)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(reverse #,x)))
|
||||
#`(reverse #,x))
|
||||
binding-list-names))
|
||||
bv))
|
||||
#,(next-outer (syntax the-pat)
|
||||
(quasisyntax/loc
|
||||
(syntax the-pat)
|
||||
(car #,exp-name))
|
||||
#,(next-outer #'the-pat
|
||||
#`(car #,exp-name)
|
||||
sf
|
||||
bv ;; we always start
|
||||
;; over with the old
|
||||
|
|
@ -315,36 +295,32 @@
|
|||
let-bound
|
||||
kf
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(#,loop-name
|
||||
#`(#,loop-name
|
||||
(cdr #,exp-name)
|
||||
#,@(map
|
||||
(lambda
|
||||
(b-var
|
||||
bindings-var)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(cons
|
||||
#`(cons
|
||||
#,(get-bind-val
|
||||
b-var
|
||||
bv)
|
||||
#,bindings-var)))
|
||||
bound binding-list-names))))))))))))))))
|
||||
#,bindings-var))
|
||||
bound binding-list-names))))))))))))))
|
||||
(case k
|
||||
((0) (ksucc sf bv))
|
||||
((1) (emit (lambda (exp) (quasisyntax/loc stx (pair? #,exp)))
|
||||
((1) (emit (lambda (exp) #`(pair? #,exp))
|
||||
ae
|
||||
let-bound
|
||||
sf bv kf ksucc))
|
||||
(else (emit (lambda (exp) (quasisyntax/loc stx (>= (length #,exp) #,k)))
|
||||
(else (emit (lambda (exp) #`(>= (length #,exp) #,k))
|
||||
ae
|
||||
let-bound
|
||||
sf bv kf ksucc)))))
|
||||
|
||||
;;!(function handle-inner-ddk-list
|
||||
;; (form (handle-inner-ddk-list ae kf ks pat
|
||||
;; dot-dot-k pat-rest stx
|
||||
;; dot-dot-k pat-rest
|
||||
;; let-bound)
|
||||
;; ->
|
||||
;; ((list list) -> syntax))
|
||||
|
|
@ -354,7 +330,6 @@
|
|||
;; syntax
|
||||
;; syntax
|
||||
;; syntax
|
||||
;; syntax
|
||||
;; list)
|
||||
;; ->
|
||||
;; ((list list) -> syntax)))
|
||||
|
|
@ -370,9 +345,8 @@
|
|||
;; pat - the pattern that preceeds the ddk
|
||||
;; dot-dot-k - the ddk pattern
|
||||
;; pat-rest - the rest of the list pattern that occurs after the ddk
|
||||
;; stx - the source stx for error purposes
|
||||
;; let-bound - a list of let bindings
|
||||
(define ((handle-inner-ddk-list ae kf ks pat dot-dot-k pat-rest stx let-bound) sf bv)
|
||||
(define ((handle-inner-ddk-list ae kf ks pat dot-dot-k pat-rest let-bound) sf bv)
|
||||
(let* ((k (stx-dot-dot-k? dot-dot-k)))
|
||||
(let ((bound (getbindings pat)))
|
||||
(if (syntax? bound)
|
||||
|
|
@ -402,8 +376,7 @@
|
|||
(syntax exp-sym)))
|
||||
(syntax pred))
|
||||
(whatever
|
||||
(quasisyntax/loc stx (lambda (exp-sym)
|
||||
#,ptst)))))
|
||||
#`(lambda (exp-sym) #,ptst))))
|
||||
(loop-name (gensym 'ddnnl))
|
||||
(exp-name (gensym 'exp))
|
||||
(count-name (gensym 'count)))
|
||||
|
|
@ -461,8 +434,7 @@
|
|||
(map cons
|
||||
bound
|
||||
(map
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx (reverse #,x)))
|
||||
(lambda (x) #`(reverse #,x))
|
||||
binding-list-names)) bv)))
|
||||
(quasisyntax/loc
|
||||
(syntax the-pat)
|
||||
|
|
@ -510,32 +482,27 @@
|
|||
(syntax the-pat)
|
||||
(#,fail-name)))
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(#,loop-name
|
||||
#`(#,loop-name
|
||||
(cdr #,exp-name)
|
||||
(add1 #,count-name)
|
||||
#,@(map
|
||||
(lambda
|
||||
(b-var
|
||||
bindings-var)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(cons
|
||||
#`(cons
|
||||
#,(get-bind-val
|
||||
b-var
|
||||
bv)
|
||||
#,bindings-var)))
|
||||
#,bindings-var))
|
||||
bound
|
||||
binding-list-names))))))))))))))))
|
||||
binding-list-names)))))))))))))))
|
||||
;;!(function handle-ddk-vector
|
||||
;; (form (handle-ddk-vector ae kf ks pt let-bound)
|
||||
;; (form (handle-ddk-vector ae kf ks let-bound)
|
||||
;; ->
|
||||
;; ((list list) -> syntax))
|
||||
;; (contract (syntax
|
||||
;; ((list list) -> syntax)
|
||||
;; ((list list) -> syntax)
|
||||
;; syntax
|
||||
;; list)
|
||||
;; ->
|
||||
;; ((list list) -> syntax)))
|
||||
|
|
@ -548,7 +515,7 @@
|
|||
;; ks - a success function
|
||||
;; pt - the whole vector pattern
|
||||
;; let-bound - a list of let bindings
|
||||
(define (handle-ddk-vector ae kf ks pt stx let-bound)
|
||||
(define (handle-ddk-vector ae kf ks pt let-bound)
|
||||
(let* ((vec-stx (syntax-e pt))
|
||||
(vlen (- (vector-length vec-stx) 2)) ;; length minus
|
||||
;; the pat ...
|
||||
|
|
@ -564,9 +531,7 @@
|
|||
(quasisyntax/loc
|
||||
pt
|
||||
(let ((#,exp-name #,(subst-bindings ae let-bound)))
|
||||
#,(assm (quasisyntax/loc
|
||||
stx
|
||||
(>= (vector-length #,exp-name) #,minlen))
|
||||
#,(assm #`(>= (vector-length #,exp-name) #,minlen)
|
||||
(kf sf bv)
|
||||
((let vloop ((n 0))
|
||||
(lambda (sf bv)
|
||||
|
|
@ -574,9 +539,7 @@
|
|||
((not (= n vlen))
|
||||
(next-outer
|
||||
(vector-ref vec-stx n)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(vector-ref #,exp-name #,n))
|
||||
#`(vector-ref #,exp-name #,n)
|
||||
sf
|
||||
bv
|
||||
let-bound
|
||||
|
|
@ -597,12 +560,9 @@
|
|||
bound))
|
||||
(vloop-name (gensym 'vloop))
|
||||
(index-name (gensym 'index)))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(let #,vloop-name
|
||||
#`(let #,vloop-name
|
||||
((#,index-name (- (vector-length #,exp-name) 1))
|
||||
#,@(map (lambda (x)
|
||||
(quasisyntax/loc stx (#,x '())))
|
||||
#,@(map (lambda (x) #`(#,x '()))
|
||||
binding-list-names))
|
||||
(if (> #,vlen #,index-name)
|
||||
#,(ks sf
|
||||
|
|
@ -611,30 +571,25 @@
|
|||
bv))
|
||||
#,(next-outer
|
||||
(vector-ref vec-stx n)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(vector-ref #,exp-name #,index-name))
|
||||
#`(vector-ref #,exp-name #,index-name)
|
||||
sf
|
||||
bv ;; we alway start over
|
||||
;; with the old bindings
|
||||
let-bound
|
||||
kf
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
stx (#,vloop-name
|
||||
#`(#,vloop-name
|
||||
(- #,index-name 1)
|
||||
#,@(map
|
||||
(lambda (b-var
|
||||
bindings-var)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(cons
|
||||
#`(cons
|
||||
#,(get-bind-val
|
||||
b-var
|
||||
bv)
|
||||
#,bindings-var)))
|
||||
#,bindings-var))
|
||||
bound
|
||||
binding-list-names)))))))))))))
|
||||
binding-list-names)))))))))))
|
||||
sf
|
||||
bv))))))))
|
||||
|
||||
|
|
@ -658,8 +613,7 @@
|
|||
;; ks - a success function
|
||||
;; pt - the whole vector pattern
|
||||
;; let-bound - a list of let bindings
|
||||
(define handle-ddk-vector-inner
|
||||
(lambda (ae kf ks pt stx let-bound)
|
||||
(define (handle-ddk-vector-inner ae kf ks pt let-bound)
|
||||
(let* ((vec-stx (syntax-e pt))
|
||||
;; vlen as an index points at the pattern before the ddk
|
||||
(vlen (- (vector-length vec-stx) 2)) ;; length minus
|
||||
|
|
@ -677,16 +631,12 @@
|
|||
;; if so handle that case else handle the pattern
|
||||
(lambda (sf bv)
|
||||
;; minlen here could be the lentgh plus the k's - 1 for each ddk
|
||||
(quasisyntax/loc
|
||||
pt
|
||||
(let ((#,exp-name #,(subst-bindings ae let-bound)))
|
||||
#`(let ((#,exp-name #,(subst-bindings ae let-bound)))
|
||||
(let ((#,length-of-vector-name (vector-length #,exp-name)))
|
||||
#,(assm (quasisyntax/loc pt (>= #,length-of-vector-name #,minlen))
|
||||
#,(assm #`(>= #,length-of-vector-name #,minlen)
|
||||
(kf sf bv)
|
||||
(let ((current-index-name (gensym 'curr-ind)))
|
||||
(quasisyntax/loc
|
||||
pt
|
||||
(let ((#,current-index-name 0))
|
||||
#`(let ((#,current-index-name 0))
|
||||
#,((let vloop ((n 0)
|
||||
(count-offset-name-passover
|
||||
current-index-name))
|
||||
|
|
@ -703,7 +653,7 @@
|
|||
((stx-dot-dot-k? (vector-ref vec-stx n))
|
||||
;;this could be it
|
||||
(match:syntax-err
|
||||
stx
|
||||
pt
|
||||
"should not get here"))
|
||||
;; if the next one is not a ddk do a normal pattern match
|
||||
;; on element
|
||||
|
|
@ -717,9 +667,7 @@
|
|||
#,(kf sf bv)
|
||||
#,(next-outer
|
||||
(vector-ref vec-stx n) ;this could be it
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(vector-ref #,exp-name #,count-offset-name-passover))
|
||||
#`(vector-ref #,exp-name #,count-offset-name-passover)
|
||||
'() ;we don't want these tests to take part in future
|
||||
; elimination or to be eliminated
|
||||
bv
|
||||
|
|
@ -728,10 +676,8 @@
|
|||
(lambda (bsf bv)
|
||||
;(set! current-index-name #`(add1 #,current-index-name))
|
||||
(let ((cindnm (gensym 'cindnm)))
|
||||
(quasisyntax/loc
|
||||
pt
|
||||
(let ((#,cindnm (add1 #,count-offset-name-passover)))
|
||||
#,((vloop (+ 1 n) cindnm) sf bv)))))))))
|
||||
#`(let ((#,cindnm (add1 #,count-offset-name-passover)))
|
||||
#,((vloop (+ 1 n) cindnm) sf bv))))))))
|
||||
((and (eq? (syntax-object->datum
|
||||
(vector-ref vec-stx n)) ;this could be it
|
||||
'_)
|
||||
|
|
@ -754,19 +700,15 @@
|
|||
(vloop-name (gensym 'vloop))
|
||||
(count-name (gensym 'count))
|
||||
(index-name (gensym 'index)))
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(let #,vloop-name
|
||||
#`(let #,vloop-name
|
||||
((#,count-name #,count-offset-name-passover)
|
||||
#,@(map (lambda (x) (quasisyntax/loc stx (#,x '())))
|
||||
#,@(map (lambda (x) #`(#,x '()))
|
||||
binding-list-names))
|
||||
#,(let ((fail-name (gensym 'fail))
|
||||
(count-offset-name (gensym 'count-offset))
|
||||
(index-name (gensym 'index))
|
||||
)
|
||||
(quasisyntax/loc
|
||||
pt
|
||||
(let ((#,fail-name
|
||||
#`(let ((#,fail-name
|
||||
(lambda (#,count-offset-name #,index-name)
|
||||
#,(let ((body ((vloop (+ n 2) index-name) sf
|
||||
(append (map (lambda (b bln)
|
||||
|
|
@ -791,52 +733,38 @@
|
|||
#,count-name)
|
||||
#,(next-outer
|
||||
(vector-ref vec-stx n) ;this could be it
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(vector-ref #,exp-name #,count-name))
|
||||
#`(vector-ref #,exp-name #,count-name)
|
||||
'() ;sf
|
||||
bv ;; we alway start over
|
||||
;; with the old bindings
|
||||
let-bound
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
pt
|
||||
(#,fail-name
|
||||
#`(#,fail-name
|
||||
(- #,count-name
|
||||
#,count-offset-name-passover)
|
||||
#,count-name)))
|
||||
#,count-name))
|
||||
(lambda (sf bv)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(let ((arglist
|
||||
#`(let ((arglist
|
||||
(list
|
||||
#,@(map
|
||||
(lambda (b-var
|
||||
bindings-var)
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(cons
|
||||
#`(cons
|
||||
#,(get-bind-val
|
||||
b-var
|
||||
bv)
|
||||
#,bindings-var)))
|
||||
#,bindings-var))
|
||||
bound
|
||||
binding-list-names))))
|
||||
(apply
|
||||
#,vloop-name
|
||||
(add1 #,count-name)
|
||||
arglist))))))))))))))))))
|
||||
arglist)))))))))))))))
|
||||
sf
|
||||
bv))))))))))))
|
||||
bv)))))))))
|
||||
|
||||
;; END DDK-HANDLERS.SCM
|
||||
|
||||
;(include "ddk-handlers.scm")
|
||||
;(include "getter-setter.scm")
|
||||
;(include "emit-assm.scm")
|
||||
;(include "parse-quasi.scm")
|
||||
;(include "pattern-predicates.scm")
|
||||
|
||||
;; some convenient syntax for make-reg-test and make-shape-test
|
||||
(define make-test-gen
|
||||
(case-lambda
|
||||
|
|
@ -906,7 +834,7 @@
|
|||
;; 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)
|
||||
(define/opt (render-test-list p ae [stx #'here])
|
||||
(syntax-case*
|
||||
p
|
||||
(_ list quote quasiquote vector box ? app and or not struct set! var
|
||||
|
|
@ -1052,7 +980,7 @@
|
|||
(lambda (ks kf let-bound)
|
||||
(lambda (sf bv)
|
||||
(or-gen ae (syntax-e #'pats)
|
||||
stx sf bv ks kf let-bound))))))
|
||||
sf bv ks kf let-bound))))))
|
||||
|
||||
|
||||
((not pat)
|
||||
|
|
@ -1204,11 +1132,11 @@
|
|||
(syntax-case cur-pat (set! get!)
|
||||
[(set! . rest)
|
||||
(unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
|
||||
(set/get-matcher 'set! ae stx (syntax rest)
|
||||
(set/get-matcher 'set! ae p #'rest
|
||||
#`(lambda (y)
|
||||
(#,cur-mutator #,ae y)))]
|
||||
[(get! . rest)
|
||||
(set/get-matcher 'get! ae stx (syntax rest)
|
||||
(set/get-matcher 'get! ae p #'rest
|
||||
#`(lambda ()
|
||||
(#,cur-accessor #,ae)))]
|
||||
[_ (render-test-list
|
||||
|
|
@ -1254,13 +1182,12 @@
|
|||
(handle-end-ddk-list ae kf ks
|
||||
(syntax pat)
|
||||
(syntax dot-dot-k)
|
||||
stx let-bound)
|
||||
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 pattern with a ooo or ook pattern
|
||||
|
|
@ -1287,7 +1214,6 @@
|
|||
(stx-car (syntax (pat-rest ...)))
|
||||
(append-if-necc 'list-rest
|
||||
(syntax (pat-rest ...))))
|
||||
stx
|
||||
let-bound)))))
|
||||
|
||||
;; list-rest pattern for improper lists
|
||||
|
|
@ -1363,7 +1289,7 @@
|
|||
(lambda (ks kf let-bound)
|
||||
(handle-ddk-vector ae kf ks
|
||||
#'#(pats ...)
|
||||
stx let-bound)))))
|
||||
let-bound)))))
|
||||
|
||||
;; vector pattern with ooo or ook, but not at end
|
||||
((vector pats ...)
|
||||
|
|
@ -1385,7 +1311,7 @@
|
|||
(lambda (ks kf let-bound)
|
||||
(handle-ddk-vector-inner ae kf ks
|
||||
#'#(pats ...)
|
||||
stx let-bound)))))
|
||||
let-bound)))))
|
||||
|
||||
;; plain old vector pattern
|
||||
((vector pats ...)
|
||||
|
|
|
|||
|
|
@ -18,31 +18,21 @@
|
|||
(and (>= (length l) ddk-num)
|
||||
(andmap test l)))
|
||||
(define (dep-first-test head rest tests)
|
||||
(cond ((null? tests)
|
||||
(cond [(null? tests)
|
||||
(if last-test
|
||||
(handle-last-test last-test (cons head rest))
|
||||
#f))
|
||||
((null? rest)
|
||||
#f)]
|
||||
[(null? rest)
|
||||
(if last-test
|
||||
(and (= 0 ddk-num)
|
||||
(= 1 (length tests))
|
||||
((car tests) head))
|
||||
(and (= 1 (length tests))
|
||||
((car tests) head))))
|
||||
(else (and (pair? tests)
|
||||
((car tests) head)))]
|
||||
[else (and (pair? tests)
|
||||
((car tests) head)
|
||||
(match:test-no-order (cdr tests)
|
||||
rest
|
||||
last-test
|
||||
ddk-num)))))
|
||||
; I think this is equivalent to
|
||||
#;(ormap (lambda (elem)
|
||||
(dep-first-test elem
|
||||
(remove elem l)
|
||||
tests))
|
||||
l)
|
||||
(let loop ((lst l))
|
||||
(if (null? lst)
|
||||
#f
|
||||
(or (dep-first-test (car lst) (remove (car lst) l) tests)
|
||||
(loop (cdr lst)))))))
|
||||
ddk-num))]))
|
||||
(ormap (lambda (elem) (dep-first-test elem (remove elem l) tests)) l)))
|
||||
Loading…
Reference in New Issue
Block a user