Port render-test-list.scm and helpers to use new-style units.
svn: r5035
This commit is contained in:
Sam Tobin-Hochstadt
parent
3459c3a58f
commit
2b876b1f11
File diff suppressed because it is too large
Load Diff
|
|
@ -5,123 +5,124 @@
|
||||||
"update-binding-counts.scm"
|
"update-binding-counts.scm"
|
||||||
"render-helpers.ss"
|
"render-helpers.ss"
|
||||||
"render-sigs.ss"
|
"render-sigs.ss"
|
||||||
(lib "unitsig.ss"))
|
(lib "unit.ss"))
|
||||||
|
|
||||||
(require-for-template mzscheme)
|
(require-for-template mzscheme)
|
||||||
|
|
||||||
(define getbindings@
|
(define-unit getbindings@
|
||||||
(unit/sig getbindings^ (import render-test-list^)
|
(import render-test-list^)
|
||||||
|
(export getbindings^)
|
||||||
|
|
||||||
;;!(function next-outer
|
;;!(function next-outer
|
||||||
;; (form (next-outer p ae sf bv let-bound kf ks syntax bool)
|
;; (form (next-outer p ae sf bv let-bound kf ks syntax bool)
|
||||||
;; ->
|
;; ->
|
||||||
;; syntax)
|
;; syntax)
|
||||||
;; (contract (syntax syntax list list list (list list -> syntax)
|
;; (contract (syntax syntax list list list (list list -> syntax)
|
||||||
;; (list list -> syntax) syntax bool)
|
;; (list list -> syntax) syntax bool)
|
||||||
;; ->
|
;; ->
|
||||||
;; syntax))
|
;; syntax))
|
||||||
;; The function next-outer is basically a throw-back to the next
|
;; The function next-outer is basically a throw-back to the next
|
||||||
;; function of the original match compiler. It compiles a pattern
|
;; function of the original match compiler. It compiles a pattern
|
||||||
;; or sub-pattern of a clause and does not yield a list of
|
;; or sub-pattern of a clause and does not yield a list of
|
||||||
;; partially compiled test structs. This function is called
|
;; partially compiled test structs. This function is called
|
||||||
;; inside of test constructs that cannot be eliminated because of
|
;; inside of test constructs that cannot be eliminated because of
|
||||||
;; a related presence in the test-so-far list. So, instead of
|
;; a related presence in the test-so-far list. So, instead of
|
||||||
;; partially compiling patterns this function fully compiles patterns.
|
;; partially compiling patterns this function fully compiles patterns.
|
||||||
(define/opt (next-outer
|
(define/opt (next-outer
|
||||||
p
|
p
|
||||||
ae ;; this is the actual expression
|
ae ;; this is the actual expression
|
||||||
sf
|
sf
|
||||||
bv
|
bv
|
||||||
let-bound
|
let-bound
|
||||||
kf
|
kf
|
||||||
ks
|
ks
|
||||||
cert
|
cert
|
||||||
[stx (syntax '())])
|
[stx (syntax '())])
|
||||||
(next-outer-helper p ae sf bv let-bound
|
(next-outer-helper p ae sf bv let-bound
|
||||||
(lambda (x) kf) (lambda (a b) ks) cert stx))
|
(lambda (x) kf) (lambda (a b) ks) cert stx))
|
||||||
|
|
||||||
;;!(function next-outer-helper
|
;;!(function next-outer-helper
|
||||||
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
|
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
|
||||||
;; ->
|
;; ->
|
||||||
;; syntax)
|
;; syntax)
|
||||||
;; (contract (syntax syntax list list list (list list -> syntax)
|
;; (contract (syntax syntax list list list (list list -> syntax)
|
||||||
;; (list list -> syntax) syntax bool)
|
;; (list list -> syntax) syntax bool)
|
||||||
;; ->
|
;; ->
|
||||||
;; syntax))
|
;; syntax))
|
||||||
;; The function next-outer-helper contains the meat of next-outer
|
;; The function next-outer-helper contains the meat of next-outer
|
||||||
;; and allows the programmer to pass higher order functions
|
;; and allows the programmer to pass higher order functions
|
||||||
;; ks-func and kf-func that will be given compile time imformation
|
;; ks-func and kf-func that will be given compile time imformation
|
||||||
;; about let-bindings etc. which in turn will allow the programmer
|
;; about let-bindings etc. which in turn will allow the programmer
|
||||||
;; to take advantage of this info.
|
;; to take advantage of this info.
|
||||||
(define/opt (next-outer-helper
|
(define/opt (next-outer-helper
|
||||||
p
|
p
|
||||||
ae ;; this is the actual expression
|
ae ;; this is the actual expression
|
||||||
sf
|
sf
|
||||||
bv
|
bv
|
||||||
let-bound
|
let-bound
|
||||||
kf-func
|
kf-func
|
||||||
ks-func
|
ks-func
|
||||||
cert
|
cert
|
||||||
[stx (syntax '())])
|
[stx (syntax '())])
|
||||||
;; right now this does not bind new variables
|
;; right now this does not bind new variables
|
||||||
(let ((rendered-list (render-test-list p ae cert stx)))
|
(let ((rendered-list (render-test-list p ae cert stx)))
|
||||||
;; no need to reorder lists although I suspect that it may be
|
;; no need to reorder lists although I suspect that it may be
|
||||||
;; better to put shape tests first
|
;; better to put shape tests first
|
||||||
(update-binding-count rendered-list)
|
(update-binding-count rendered-list)
|
||||||
((couple-tests rendered-list ks-func kf-func let-bound) sf bv)))
|
((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)
|
;; (form (create-test-func p sf let-bound bind-map last-test)
|
||||||
;; ->
|
;; ->
|
||||||
;; syntax)
|
;; syntax)
|
||||||
;; (contract (syntax list list a-list bool) -> syntax))
|
;; (contract (syntax list list a-list bool) -> syntax))
|
||||||
;; This function creates a runtime function that is used as an
|
;; This function creates a runtime function that is used as an
|
||||||
;; individual test in a list of tests for the list-no-order
|
;; individual test in a list of tests for the list-no-order
|
||||||
;; pattern.
|
;; pattern.
|
||||||
;; <pre>
|
;; <pre>
|
||||||
;; bindmap - a-list of bindings mapped to their expressions
|
;; bindmap - a-list of bindings mapped to their expressions
|
||||||
;; last-test - a boolean value that indicates whether this function
|
;; last-test - a boolean value that indicates whether this function
|
||||||
;; is collecting one value or a list of values.</pre>
|
;; is collecting one value or a list of values.</pre>
|
||||||
(define (create-test-func p sf let-bound bind-map last-test cert)
|
(define (create-test-func p sf let-bound bind-map last-test cert)
|
||||||
#`(lambda (exp)
|
#`(lambda (exp)
|
||||||
#,(next-outer-helper
|
#,(next-outer-helper
|
||||||
p #'exp sf '() let-bound
|
p #'exp sf '() let-bound
|
||||||
(lambda (let-bound)
|
(lambda (let-bound)
|
||||||
(lambda (sf bv)
|
(lambda (sf bv)
|
||||||
#'#f))
|
#'#f))
|
||||||
(lambda (fail let-bound)
|
(lambda (fail let-bound)
|
||||||
(lambda (sf bv)
|
(lambda (sf bv)
|
||||||
#`(begin
|
#`(begin
|
||||||
#,@(map (lambda (bind)
|
#,@(map (lambda (bind)
|
||||||
(let ((binding-name (get-bind-val (car bind) bind-map))
|
(let ((binding-name (get-bind-val (car bind) bind-map))
|
||||||
(exp-to-bind
|
(exp-to-bind
|
||||||
(subst-bindings (cdr bind) let-bound)))
|
(subst-bindings (cdr bind) let-bound)))
|
||||||
(if last-test
|
(if last-test
|
||||||
#`(set! #,binding-name
|
#`(set! #,binding-name
|
||||||
(cons #,exp-to-bind #,binding-name))
|
(cons #,exp-to-bind #,binding-name))
|
||||||
#`(set! #,binding-name
|
#`(set! #,binding-name
|
||||||
#,exp-to-bind))))
|
#,exp-to-bind))))
|
||||||
bv)
|
bv)
|
||||||
#t)))
|
#t)))
|
||||||
cert)))
|
cert)))
|
||||||
|
|
||||||
;;!(function getbindings
|
;;!(function getbindings
|
||||||
;; (form (getbindings pat-syntax) -> list)
|
;; (form (getbindings pat-syntax) -> list)
|
||||||
;; (contract syntax -> list))
|
;; (contract syntax -> list))
|
||||||
;; This function given a pattern returns a list of pattern
|
;; This function given a pattern returns a list of pattern
|
||||||
;; variable names which are found in the pattern.
|
;; variable names which are found in the pattern.
|
||||||
(define (getbindings pat-syntax cert)
|
(define (getbindings pat-syntax cert)
|
||||||
(let/cc out
|
(let/cc out
|
||||||
(next-outer
|
(next-outer
|
||||||
pat-syntax
|
pat-syntax
|
||||||
(quote-syntax dummy)
|
(quote-syntax dummy)
|
||||||
'()
|
'()
|
||||||
'()
|
'()
|
||||||
'()
|
'()
|
||||||
(lambda (sf bv) #'(dummy-symbol))
|
(lambda (sf bv) #'(dummy-symbol))
|
||||||
(lambda (sf bv) (out (map car bv)))
|
(lambda (sf bv) (out (map car bv)))
|
||||||
cert)))
|
cert)))
|
||||||
|
|
||||||
;; end getbindings@
|
;; end getbindings@
|
||||||
))
|
)
|
||||||
)
|
)
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
(module render-sigs mzscheme
|
(module render-sigs mzscheme
|
||||||
(require (lib "unitsig.ss"))
|
(require (lib "unit.ss"))
|
||||||
|
|
||||||
(provide (all-defined))
|
(provide (all-defined))
|
||||||
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -7,18 +7,13 @@
|
||||||
"render-test-list-impl.ss"
|
"render-test-list-impl.ss"
|
||||||
"getbindings.ss"
|
"getbindings.ss"
|
||||||
"ddk-handlers.ss"
|
"ddk-handlers.ss"
|
||||||
(lib "unitsig.ss"))
|
(lib "unit.ss"))
|
||||||
|
|
||||||
(define rtl@
|
(define-compound-unit/infer rtl@
|
||||||
(compound-unit/sig
|
(import)
|
||||||
(import)
|
(export render-test-list^)
|
||||||
(link (RTL : render-test-list^ (render-test-list@ DDK GET))
|
(link render-test-list@ getbindings@ ddk-handlers@))
|
||||||
(GET : getbindings^ (getbindings@ RTL))
|
|
||||||
(DDK : ddk-handlers^ (ddk-handlers@ GET RTL))
|
|
||||||
)
|
|
||||||
(export (var (RTL render-test-list)))
|
|
||||||
))
|
|
||||||
|
|
||||||
(define-values/invoke-unit/sig render-test-list^ rtl@)
|
(define-values/invoke-unit/infer rtl@)
|
||||||
|
|
||||||
)
|
)
|
||||||
Loading…
Reference in New Issue
Block a user