- refactored opt/c to its own struct/prop
- moved opters next to their respective original contracts where possible - the rest moved to contract-basic-opters.ss to avoid module cycle - fixed some typos svn: r4774
This commit is contained in:
Shu-Yu Guo
parent
4cfa7addc3
commit
bd0b34a9ac
|
|
@ -3,17 +3,27 @@
|
|||
"private/contract-arrow.ss"
|
||||
"private/contract-guts.ss"
|
||||
"private/contract-ds.ss"
|
||||
"private/contract-opt-guts.ss"
|
||||
"private/contract-opt.ss"
|
||||
"private/contract-opters.ss" ;; loaded for its effect -- registering the opters
|
||||
)
|
||||
|
||||
"private/contract-basic-opters.ss")
|
||||
|
||||
(provide
|
||||
; (all-from "private/contract-opt.ss") ;; not yet
|
||||
(all-from "private/contract-opt.ss")
|
||||
(all-from "private/contract-opt-guts.ss")
|
||||
(all-from-except "private/contract-opt-guts.ss"
|
||||
make-opt-contract
|
||||
orig-ctc-prop
|
||||
orig-ctc-pred?
|
||||
orig-ctc-get)
|
||||
(all-from "private/contract-ds.ss")
|
||||
(all-from "private/contract-arrow.ss")
|
||||
(all-from-except "private/contract-arrow.ss"
|
||||
check-procedure)
|
||||
(all-from-except "private/contract-guts.ss"
|
||||
build-compound-type-name
|
||||
first-order-prop
|
||||
first-order-get)
|
||||
(all-from "private/contract.ss")))
|
||||
first-order-get
|
||||
check-flat-contract
|
||||
check-flat-named-contract)
|
||||
(all-from-except "private/contract.ss"
|
||||
check-between/c
|
||||
check-unary-between/c)))
|
||||
|
|
@ -2,9 +2,12 @@
|
|||
(require (lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
"contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
"contract-opt-guts.ss"
|
||||
"class-internal.ss")
|
||||
|
||||
(require-for-syntax "contract-helpers.ss"
|
||||
(require-for-syntax "contract-opt-guts.ss"
|
||||
"contract-helpers.ss"
|
||||
(lib "list.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax"))
|
||||
|
|
@ -25,7 +28,9 @@
|
|||
make-mixin-contract
|
||||
is-a?/c
|
||||
subclass?/c
|
||||
implementation?/c)
|
||||
implementation?/c
|
||||
|
||||
check-procedure)
|
||||
|
||||
|
||||
(define-syntax (any stx)
|
||||
|
|
@ -1738,6 +1743,113 @@
|
|||
(void)]
|
||||
[else (loop (cdr counts))]))))
|
||||
(<= min-at-least dom-length))))])))
|
||||
|
||||
;;
|
||||
;; arrow opter
|
||||
;;
|
||||
(define/opter (-> opt/i pos neg stx)
|
||||
(define (opt/arrow-ctc doms rngs)
|
||||
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
|
||||
(generate-temporaries rngs))]
|
||||
[(next-doms lifts-doms partials-doms)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifts-doms null]
|
||||
[partials-doms null])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms) lifts-doms partials-doms)]
|
||||
[else
|
||||
(let-values ([(next lift partial _ __)
|
||||
(opt/i neg pos (car doms))])
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifts-doms lift)
|
||||
(append partials-doms partial)))]))]
|
||||
[(next-rngs lifts-rngs partials-rngs)
|
||||
(let loop ([vars rng-vars]
|
||||
[rngs rngs]
|
||||
[next-rngs null]
|
||||
[lifts-rngs null]
|
||||
[partials-rngs null])
|
||||
(cond
|
||||
[(null? rngs) (values (reverse next-rngs) lifts-rngs partials-rngs)]
|
||||
[else
|
||||
(let-values ([(next lift partial _ __)
|
||||
(opt/i pos neg (car rngs))])
|
||||
(loop (cdr vars)
|
||||
(cdr rngs)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-rngs)
|
||||
(append lifts-rngs lift)
|
||||
(append partials-rngs partial)))]))])
|
||||
(values
|
||||
(with-syntax ((pos pos)
|
||||
((dom-arg ...) dom-vars)
|
||||
((rng-arg ...) rng-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars))
|
||||
((next-rng ...) next-rngs))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len src-info pos orig-str)
|
||||
(λ (dom-arg ...)
|
||||
(let-values ([(rng-arg ...) (val next-dom ...)])
|
||||
(values next-rng ...))))))
|
||||
(append lifts-doms lifts-rngs)
|
||||
(append partials-doms partials-rngs)
|
||||
#f
|
||||
#f)))
|
||||
|
||||
(define (opt/arrow-any-ctc doms)
|
||||
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
||||
[(next-doms lifts-doms partials-doms)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifts-doms null]
|
||||
[partials-doms null])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms) lifts-doms partials-doms)]
|
||||
[else
|
||||
(let-values ([(next lift partial flat _)
|
||||
(opt/i pos neg (car doms))])
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifts-doms lift)
|
||||
(append partials-doms partial)))]))])
|
||||
(values
|
||||
(with-syntax ((pos pos)
|
||||
((dom-arg ...) dom-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars)))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len src-info pos orig-str)
|
||||
(λ (dom-arg ...)
|
||||
(val next-dom ...)))))
|
||||
lifts-doms
|
||||
partials-doms
|
||||
#f
|
||||
#f)))
|
||||
|
||||
(syntax-case stx (-> values any)
|
||||
[(-> dom ... (values rng ...))
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(syntax->list (syntax (rng ...))))]
|
||||
[(-> dom ... any)
|
||||
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
|
||||
[(-> dom ... rng)
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(list #'rng))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Checks and error functions used in macro expansions
|
||||
|
|
|
|||
144
collects/mzlib/private/contract-basic-opters.ss
Normal file
144
collects/mzlib/private/contract-basic-opters.ss
Normal file
|
|
@ -0,0 +1,144 @@
|
|||
(module contract-basic-opters mzscheme
|
||||
(require "contract-guts.ss"
|
||||
"contract-opt.ss")
|
||||
(require-for-syntax "contract-opt-guts.ss")
|
||||
|
||||
;;
|
||||
;; opt/pred helper
|
||||
;;
|
||||
(define-for-syntax (opt/pred pos pred)
|
||||
(let* ((lift-vars (generate-temporaries (syntax (pred))))
|
||||
(lift-pred-var (car lift-vars)))
|
||||
(with-syntax ((lift-pred lift-pred-var))
|
||||
(values
|
||||
(with-syntax ((pos pos))
|
||||
(syntax (if (lift-pred val)
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
((name-get ctc) ctc)
|
||||
val))))
|
||||
(list (cons lift-pred-var pred))
|
||||
null
|
||||
(syntax (lift-pred val))
|
||||
#f))))
|
||||
|
||||
;;
|
||||
;; built-in predicate opters
|
||||
;;
|
||||
(define/opter (null? opt/i pos neg stx)
|
||||
(syntax-case stx (null?)
|
||||
[null? (opt/pred pos #'null?)]))
|
||||
(define/opter (boolean? opt/i pos neg stx)
|
||||
(syntax-case stx (boolean?)
|
||||
[boolean? (opt/pred pos #'boolean?)]))
|
||||
(define/opter (integer? opt/i pos neg stx)
|
||||
(syntax-case stx (integer?)
|
||||
[integer? (opt/pred pos #'integer?)]))
|
||||
(define/opter (number? opt/i pos neg stx)
|
||||
(syntax-case stx (number?)
|
||||
[number? (opt/pred pos #'number?)]))
|
||||
(define/opter (pair? opt/i pos neg stx)
|
||||
(syntax-case stx (pair?)
|
||||
[pair? (opt/pred pos #'pair?)]))
|
||||
|
||||
;;
|
||||
;; any/c
|
||||
;;
|
||||
(define/opter (any/c opt/i pos neg stx)
|
||||
(syntax-case stx (any/c)
|
||||
[any/c (values
|
||||
#'val
|
||||
null
|
||||
null
|
||||
#'#t
|
||||
#f)]))
|
||||
|
||||
;;
|
||||
;; flat-contract helper
|
||||
;;
|
||||
(define-for-syntax (opt/flat-ctc pos pred checker)
|
||||
(syntax-case pred (null? number? integer? boolean? pair?)
|
||||
;; Better way of doing this?
|
||||
[null? (opt/pred pos pred)]
|
||||
[number? (opt/pred pos pred)]
|
||||
[integer? (opt/pred pos pred)]
|
||||
[boolean? (opt/pred pos pred)]
|
||||
[pair? (opt/pred pos pred)]
|
||||
[pred
|
||||
(let* ((lift-vars (generate-temporaries (syntax (pred error-check))))
|
||||
(lift-pred (car lift-vars)))
|
||||
(with-syntax ((pos pos)
|
||||
(lift-pred lift-pred))
|
||||
(values
|
||||
(syntax (if (lift-pred val)
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
((name-get ctc) ctc)
|
||||
val)))
|
||||
(interleave-lifts
|
||||
lift-vars
|
||||
(list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)]
|
||||
[(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])))
|
||||
null
|
||||
(syntax (lift-pred val))
|
||||
#f)))]))
|
||||
|
||||
;;
|
||||
;; flat-contract and friends
|
||||
;;
|
||||
(define/opter (flat-contract opt/i pos neg stx)
|
||||
(syntax-case stx (flat-contract)
|
||||
[(flat-contract pred) (opt/flat-ctc pos #'pred 'check-flat-contract)]))
|
||||
(define/opter (flat-named-contract opt/i pos neg stx)
|
||||
(syntax-case stx (flat-named-contract)
|
||||
[(flat-named-contract name pred) (opt/flat-ctc pos #'pred 'check-flat-named-contract)]))
|
||||
|
||||
;;
|
||||
;; unknown
|
||||
;;
|
||||
;; BUGS: currently, opt/c reports error on something like
|
||||
;; (opt/c (or/c (begin (print "side effect") number?) boolean?))
|
||||
;; because the begin sequence is unrecognized, and we have no idea of
|
||||
;; knowing that `number?' is a pred that we can opt.
|
||||
;; WORKAROUND: wrap `flat-contract' around the pred, it optimizes to the same
|
||||
;; thing.
|
||||
;;
|
||||
(define/opter (unknown opt/i pos neg stx)
|
||||
(define (opt/unknown-ctc uctc)
|
||||
(let* ((lift-vars (generate-temporaries (syntax (lift error-check))))
|
||||
(lift-var (car lift-vars))
|
||||
(partial-var (car (generate-temporaries (syntax (partial))))))
|
||||
(values
|
||||
(with-syntax ((partial-var partial-var)
|
||||
(lift-var lift-var)
|
||||
(uctc uctc))
|
||||
(syntax (partial-var val)))
|
||||
(interleave-lifts
|
||||
lift-vars
|
||||
(list uctc
|
||||
(with-syntax ((lift-var lift-var))
|
||||
(syntax
|
||||
(unless (contract? lift-var)
|
||||
(error 'contract "expected contract, given ~e" lift-var))))))
|
||||
(list (cons
|
||||
partial-var
|
||||
(with-syntax ((lift-var lift-var)
|
||||
(pos pos)
|
||||
(neg neg))
|
||||
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))))
|
||||
#f
|
||||
lift-var)))
|
||||
|
||||
(syntax-case stx ()
|
||||
[ctc
|
||||
(opt/unknown-ctc #'ctc)])))
|
||||
|
|
@ -40,7 +40,11 @@
|
|||
flat-prop flat-pred? flat-get
|
||||
flat-proj
|
||||
first-order-prop
|
||||
first-order-get)
|
||||
first-order-get
|
||||
|
||||
;; for opters
|
||||
check-flat-contract
|
||||
check-flat-named-contract)
|
||||
|
||||
|
||||
;; define-struct/prop is a define-struct-like macro that
|
||||
|
|
@ -313,23 +317,26 @@
|
|||
(define (contract? x) (proj-pred? x))
|
||||
(define (contract-proc ctc) ((proj-get ctc) ctc))
|
||||
|
||||
(define (flat-contract predicate)
|
||||
(define (check-flat-contract predicate)
|
||||
(unless (and (procedure? predicate)
|
||||
(procedure-arity-includes? predicate 1))
|
||||
(error 'flat-contract
|
||||
"expected procedure of one argument as argument, given ~e"
|
||||
predicate))
|
||||
"expected procedure of arity 1 as argument, given ~e"
|
||||
predicate)))
|
||||
(define (flat-contract predicate)
|
||||
(check-flat-contract predicate)
|
||||
(let ([pname (object-name predicate)])
|
||||
(if pname
|
||||
(flat-named-contract pname predicate)
|
||||
(flat-named-contract '??? predicate))))
|
||||
|
||||
(define (flat-named-contract name predicate)
|
||||
(define (check-flat-named-contract predicate)
|
||||
(unless (and (procedure? predicate)
|
||||
(procedure-arity-includes? predicate 1))
|
||||
(error 'flat-named-contract
|
||||
"expected procedure of one argument as second argument, given: ~e, fst arg ~e"
|
||||
predicate name))
|
||||
"expected procedure of arity 1 as second argument, given ~e"
|
||||
predicate)))
|
||||
(define (flat-named-contract name predicate)
|
||||
(check-flat-named-contract predicate)
|
||||
(build-flat-contract name predicate))
|
||||
|
||||
(define (build-flat-contract name predicate) (make-flat-contract name predicate))
|
||||
|
|
|
|||
|
|
@ -1,15 +1,31 @@
|
|||
(module contract-opt-guts mzscheme
|
||||
(require "contract.ss"
|
||||
"contract-guts.ss"
|
||||
"contract-arrow.ss")
|
||||
(require "contract-guts.ss")
|
||||
|
||||
(provide make-known known? known-flag known-sexp
|
||||
get-opter reg-opter! opter
|
||||
make-lifted interleave-lifted)
|
||||
(provide get-opter reg-opter! opter
|
||||
|
||||
make-opt-contract
|
||||
orig-ctc-prop orig-ctc-pred? orig-ctc-get
|
||||
|
||||
make-lifts interleave-lifts)
|
||||
|
||||
(define-struct known (flag sexp))
|
||||
(define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get)
|
||||
(make-struct-type-property 'original-contract))
|
||||
|
||||
;; State information for opters
|
||||
;; optimized contracts
|
||||
;;
|
||||
;; getting the name of an optimized contract is slow, but it is only
|
||||
;; called when blame is raised (thankfully).
|
||||
;;
|
||||
;; note that lifts, partials, flat, and unknown are all built into the
|
||||
;; projection itself and should not be exposed to the outside anyhow.
|
||||
(define-struct/prop opt-contract (proj orig-ctc)
|
||||
((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc)))
|
||||
(name-prop (λ (ctc) ((name-get ((orig-ctc-get ctc) ctc)) ((orig-ctc-get ctc) ctc))))
|
||||
(orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc))))
|
||||
(stronger-prop (λ (this that)
|
||||
#f)))) ;; TODO, how to do this?
|
||||
|
||||
;; a hash table of opters
|
||||
(define opters-table
|
||||
(make-hash-table 'equal))
|
||||
|
||||
|
|
@ -17,7 +33,7 @@
|
|||
(define (get-opter ctc)
|
||||
(hash-table-get opters-table ctc #f))
|
||||
|
||||
;; opter : syntax or symbol -> opter
|
||||
;; opter : (union symbol identifier) -> opter
|
||||
(define (opter ctc)
|
||||
(if (or (identifier? ctc) (symbol? ctc))
|
||||
(let ((key (if (syntax? ctc) (syntax-e ctc) ctc)))
|
||||
|
|
@ -28,20 +44,20 @@
|
|||
(define (reg-opter! ctc opter)
|
||||
(hash-table-put! opters-table ctc opter))
|
||||
|
||||
;; make-lifted : list -> syntax
|
||||
;; make-lifts : list -> syntax
|
||||
;; converts a list of lifted-var lifted-expr pairs into a syntax object
|
||||
;; suitable for use in a let.
|
||||
(define (make-lifted lst)
|
||||
(define (make-lifts lst)
|
||||
(map (λ (x) (with-syntax ((var (car x))
|
||||
(e (cdr x)))
|
||||
(syntax (var e)))) lst))
|
||||
|
||||
;; interleave-lifted : list list -> list
|
||||
;; interleave-lifts : list list -> list
|
||||
;; interleaves a list of variables names and a list of sexps into a list of
|
||||
;; (var sexp) pairs
|
||||
(define (interleave-lifted vars sexps)
|
||||
;; (var sexp) pairs.
|
||||
(define (interleave-lifts vars sexps)
|
||||
(if (= (length vars) (length sexps))
|
||||
(if (null? vars) null
|
||||
(cons (cons (car vars) (car sexps))
|
||||
(interleave-lifted (cdr vars) (cdr sexps))))
|
||||
(error 'interleave-lifted "expected lists of equal length, got ~e and ~e" vars sexps))))
|
||||
(interleave-lifts (cdr vars) (cdr sexps))))
|
||||
(error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps))))
|
||||
|
|
@ -1,13 +1,35 @@
|
|||
(module contract-opt mzscheme
|
||||
(require "contract.ss"
|
||||
"contract-guts.ss"
|
||||
"contract-arrow.ss")
|
||||
(require "contract-guts.ss"
|
||||
"contract-opt-guts.ss")
|
||||
(require-for-syntax "contract-opt-guts.ss"
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide opt/c define/opter)
|
||||
|
||||
;; TODO document this
|
||||
;; define/opter : id -> syntax
|
||||
;;
|
||||
;; Takes an expression which is to be expected of the following signature:
|
||||
;;
|
||||
;; opter : id id syntax ->
|
||||
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
|
||||
;;
|
||||
;; It takes in an identifier for pos, neg, and the original syntax. An identifier
|
||||
;; that can be used to call the opt/i function is also implicitly passed into
|
||||
;; every opter.
|
||||
;;
|
||||
;; Every opter needs to return:
|
||||
;; - the optimized syntax
|
||||
;; - lifted variables: a list of (id, sexp) pairs
|
||||
;; - partially applied contracts: a list of (id, sexp) pairs
|
||||
;; - if the contract being optimized is flat,
|
||||
;; then an sexp that evals to bool,
|
||||
;; else #f
|
||||
;; This is used in conjunction with optimizing flat contracts into one boolean
|
||||
;; expression when optimizing or/c.
|
||||
;; - if the contract can be optimized,
|
||||
;; then #f (that is, it is not unknown)
|
||||
;; else the symbol of the lifted variable
|
||||
;; This is used for contracts with subcontracts (like cons) doing checks.
|
||||
(define-syntax (define/opter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (for opt/i pos neg stx) expr ...)
|
||||
|
|
@ -22,21 +44,20 @@
|
|||
(error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))]))
|
||||
|
||||
;; opt/c : syntax -> syntax
|
||||
;; opt is an optimization routine that takes in an s-expression containing
|
||||
;; opt/c is an optimization routine that takes in an sexp containing
|
||||
;; contract combinators and attempts to "unroll" those combinators to save
|
||||
;; on things such as closure allocation time.
|
||||
(define-syntax (opt/c stx)
|
||||
|
||||
;; opt/i : syntax syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
;; opt/i : id id syntax ->
|
||||
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
|
||||
(define (opt/i pos neg stx)
|
||||
(syntax-case stx ()
|
||||
[(ctc arg ...)
|
||||
(and (identifier? #'ctc) (opter #'ctc))
|
||||
(begin
|
||||
((opter #'ctc) opt/i pos neg stx))]
|
||||
((opter #'ctc) opt/i pos neg stx)]
|
||||
[argless-ctc
|
||||
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
|
||||
;; FIXME computes pred? twice
|
||||
((opter #'argless-ctc) opt/i pos neg stx)]
|
||||
[else
|
||||
(if (opter 'unknown)
|
||||
|
|
@ -45,15 +66,15 @@
|
|||
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
(let-values ([(next lifted partials _ __) (opt/i #'pos #'neg #'e)])
|
||||
(let-values ([(next lifts partials _ __) (opt/i #'pos #'neg #'e)])
|
||||
(with-syntax ((next next)
|
||||
(lifted (make-lifted lifted))
|
||||
(partials (make-lifted partials)))
|
||||
(syntax (let* lifted
|
||||
(make-proj-contract
|
||||
contract-name
|
||||
(λ (pos neg src-info orig-str)
|
||||
(let partials
|
||||
(λ (val)
|
||||
next)))
|
||||
#f)))))])))
|
||||
(lifts (make-lifts lifts))
|
||||
(partials (make-lifts partials))
|
||||
(stx stx))
|
||||
(syntax (make-opt-contract
|
||||
(λ (ctc)
|
||||
(let* lifts
|
||||
(λ (pos neg src-info orig-str)
|
||||
(let partials
|
||||
(λ (val) next)))))
|
||||
(λ () e)))))])))
|
||||
|
|
@ -1,494 +0,0 @@
|
|||
(module contract-opters mzscheme
|
||||
(require "contract.ss"
|
||||
"contract-guts.ss"
|
||||
"contract-arrow.ss"
|
||||
"contract-opt.ss")
|
||||
(require-for-syntax "contract-opt-guts.ss")
|
||||
|
||||
;; opt/between-ctc : syntax syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define-for-syntax (opt/between-ctc pos stx low high op)
|
||||
(let* ((lifted-vars (generate-temporaries (syntax (low high error-check))))
|
||||
(lifted-low (car lifted-vars))
|
||||
(lifted-high (cadr lifted-vars)))
|
||||
(with-syntax ((op op)
|
||||
(n lifted-low)
|
||||
(m lifted-high))
|
||||
(values
|
||||
(with-syntax ((pos pos))
|
||||
(syntax (if (and (number? val) (op n val m)) val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
contract-name
|
||||
val))))
|
||||
(append (interleave-lifted
|
||||
lifted-vars
|
||||
(list low
|
||||
high
|
||||
(syntax (unless (and (number? n) (number? m))
|
||||
(error 'between/c "expected two numbers for bounds, got ~e and ~e" n m)))))
|
||||
(list (cons #'contract-name (syntax (cond
|
||||
[(= n -inf.0) `(<=/c ,m)]
|
||||
[(= m +inf.0) `(>=/c ,n)]
|
||||
[(= n m) `(=/c ,n)]
|
||||
[else `(between/c ,n ,m)])))))
|
||||
null
|
||||
(syntax (and (number? val) (op n val m)))
|
||||
(make-known #t stx)))))
|
||||
|
||||
(define/opter (between/c opt/i pos neg stx)
|
||||
(syntax-case stx (between/c)
|
||||
[(between/c low high) (opt/between-ctc pos stx #'low #'high #'<=)]))
|
||||
|
||||
(define/opter (>/c opt/i pos neg stx)
|
||||
(syntax-case stx (>/c)
|
||||
[(>/c low) (opt/between-ctc #'low #'+inf.0 #'<)]))
|
||||
|
||||
(define/opter (>=/c opt/i pos neg stx)
|
||||
(syntax-case stx (>/c)
|
||||
[(>=/c low) (opt/between-ctc #'low #'+inf.0 #'<=)]))
|
||||
|
||||
(define/opter (</c opt/i pos neg stx)
|
||||
(syntax-case stx (>/c)
|
||||
[(</c high) (opt/between-ctc #'-inf.0 #'high #'<)]))
|
||||
|
||||
(define/opter (<=/c opt/i pos neg stx)
|
||||
(syntax-case stx (>/c)
|
||||
[(<=/c high) (opt/between-ctc #'-inf.0 #'high #'<=)]))
|
||||
|
||||
(define/opter (cons-immutable/c opt/i pos neg stx)
|
||||
|
||||
;; opt/cons-immutable-ctc : syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define (opt/cons-immutable-ctc hdp tlp)
|
||||
(let-values ([(next-hdp lifted-hdp partial-hdp flat?-hdp known?-hdp)
|
||||
(opt/i pos neg hdp)]
|
||||
[(next-tlp lifted-tlp partial-tlp flat?-tlp known?-tlp)
|
||||
(opt/i pos neg tlp)]
|
||||
[(error-check)
|
||||
(car (generate-temporaries (syntax (error-check))))])
|
||||
(with-syntax ((check (syntax (and (immutable? val)
|
||||
(pair? val)))))
|
||||
(values
|
||||
(with-syntax ((pos pos)
|
||||
(next-hdp next-hdp)
|
||||
(next-tlp next-tlp))
|
||||
(syntax (if check
|
||||
(cons-immutable (let ((val (car val))) next-hdp)
|
||||
(let ((val (cdr val))) next-tlp))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
contract-name
|
||||
val))))
|
||||
(append
|
||||
(append lifted-hdp lifted-tlp)
|
||||
;; FIXME naming still broken
|
||||
(list (cons #'contract-name
|
||||
#''cons-immutable/c)))
|
||||
(append partial-hdp partial-tlp)
|
||||
(if (and flat?-hdp flat?-tlp)
|
||||
(with-syntax ((flat-hdp flat?-hdp)
|
||||
(flat-tlp flat?-tlp))
|
||||
(syntax (if (and check
|
||||
(let ((val (car val))) flat-hdp)
|
||||
(let ((val (cdr val))) flat-tlp)) #t #f)))
|
||||
#f)
|
||||
(make-known #t stx)))))
|
||||
|
||||
(syntax-case stx (cons-immutable/c)
|
||||
[(cons-immutable/c hdp tlp)
|
||||
(opt/cons-immutable-ctc #'hdp #'tlp)]))
|
||||
|
||||
(define/opter (cons/c opt/i pos neg stx)
|
||||
|
||||
;; opt/cons-ctc : syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define (opt/cons-ctc hdp tlp)
|
||||
(let-values ([(next-hdp lifted-hdp partial-hdp flat?-hdp known-hdp)
|
||||
(opt/i pos neg hdp)]
|
||||
[(next-tlp lifted-tlp partial-tlp flat?-tlp known-tlp)
|
||||
(opt/i pos neg tlp)]
|
||||
[(error-check)
|
||||
(car (generate-temporaries (syntax (error-check))))])
|
||||
(with-syntax ((next
|
||||
(with-syntax ((flat?-hdp flat?-hdp)
|
||||
(flat?-tlp flat?-tlp))
|
||||
(syntax
|
||||
(and (pair? val)
|
||||
(let ((val (car val))) flat?-hdp)
|
||||
(let ((val (cdr val))) flat?-tlp))))))
|
||||
(values
|
||||
(with-syntax ((pos pos))
|
||||
(syntax (if next
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
contract-name
|
||||
val))))
|
||||
(append
|
||||
lifted-hdp lifted-tlp
|
||||
(list (cons error-check
|
||||
(with-syntax ((hdp (known-sexp known-hdp))
|
||||
(tlp (known-sexp known-tlp))
|
||||
(check (with-syntax ((flat-hdp
|
||||
(cond
|
||||
[(known-flag known-hdp)
|
||||
(if flat?-hdp #'#t #'#f)]
|
||||
[else (with-syntax ((ctc (known-sexp known-hdp)))
|
||||
(syntax (flat-contract? ctc)))]))
|
||||
(flat-tlp
|
||||
(cond
|
||||
[(known-flag known-tlp)
|
||||
(if flat?-tlp #'#t #'#f)]
|
||||
[else (with-syntax ((ctct (known-sexp known-tlp)))
|
||||
(syntax (flat-contract? ctc)))])))
|
||||
(syntax (and flat-hdp flat-tlp)))))
|
||||
(syntax
|
||||
(unless check
|
||||
(error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e"
|
||||
hdp tlp))))))
|
||||
;; FIXME naming still broken
|
||||
(list (cons #'contract-name
|
||||
#''cons/c)))
|
||||
(append partial-hdp partial-tlp)
|
||||
(syntax (if next #t #f))
|
||||
(make-known #t stx)))))
|
||||
|
||||
(syntax-case stx (cons/c)
|
||||
[(cons/c hdp tlp)
|
||||
(opt/cons-ctc #'hdp #'tlp)]))
|
||||
|
||||
;; opt/pred-ctc : (any -> boolean) -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define-for-syntax (opt/pred pos pred)
|
||||
(let* ((lifted-vars (generate-temporaries (syntax (pred))))
|
||||
(lifted-pred-var (car lifted-vars)))
|
||||
(with-syntax ((lifted-pred lifted-pred-var))
|
||||
(values
|
||||
(with-syntax ((pos pos))
|
||||
(syntax (if (lifted-pred val)
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
contract-name
|
||||
val))))
|
||||
(append (list (cons lifted-pred-var pred))
|
||||
#;(list (cons #'contract-name (syntax
|
||||
(if (object-name pred)
|
||||
(object-name pred)
|
||||
'???)))))
|
||||
null
|
||||
(syntax (lifted-pred val))
|
||||
(make-known #t pred)))))
|
||||
|
||||
(define/opter (null? opt/i pos neg stx)
|
||||
(syntax-case stx (null?)
|
||||
[null? (opt/pred pos #'null?)]))
|
||||
|
||||
(define/opter (boolean? opt/i pos neg stx)
|
||||
(syntax-case stx (boolean?)
|
||||
[boolean? (opt/pred pos #'boolean?)]))
|
||||
|
||||
(define/opter (integer? opt/i pos neg stx)
|
||||
(syntax-case stx (integer?)
|
||||
[integer? (opt/pred pos #'integer?)]))
|
||||
|
||||
(define/opter (number? opt/i pos neg stx)
|
||||
(syntax-case stx (number?)
|
||||
[number? (opt/pred pos #'number?)]))
|
||||
|
||||
(define/opter (pair? opt/i pos neg stx)
|
||||
(syntax-case stx (pair?)
|
||||
[pair? (opt/pred pos #'pair?)]))
|
||||
|
||||
(define/opter (any/c opt/i pos neg stx)
|
||||
|
||||
;; opt/any-ctc : -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define opt/any-ctc
|
||||
(values
|
||||
#'val
|
||||
(list (cons #'contract-name
|
||||
#''any/c))
|
||||
null
|
||||
(syntax #t)
|
||||
(make-known #t stx)))
|
||||
|
||||
(syntax-case stx (any/c)
|
||||
[any/c opt/any-ctc]))
|
||||
|
||||
(define/opter (flat-contract opt/i pos neg stx)
|
||||
|
||||
;; opt/flat-ctc : (any -> boolean) -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define (opt/flat-ctc pred)
|
||||
(syntax-case pred (null? number? integer? boolean? pair?)
|
||||
;; Better way of doing this?
|
||||
[null? (opt/pred pos pred)]
|
||||
[number? (opt/pred pos pred)]
|
||||
[integer? (opt/pred pos pred)]
|
||||
[boolean? (opt/pred pos pred)]
|
||||
[pair? (opt/pred pos pred)]
|
||||
[pred
|
||||
(let* ((lifted-vars (generate-temporaries (syntax (pred error-check))))
|
||||
(lifted-pred (car lifted-vars)))
|
||||
(with-syntax ((lifted-pred (car lifted-vars)))
|
||||
(values
|
||||
(with-syntax ((pos pos))
|
||||
(syntax (if (lifted-pred val)
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
contract-name
|
||||
val))))
|
||||
(append (interleave-lifted
|
||||
lifted-vars
|
||||
(list #'pred
|
||||
(syntax (unless (and (procedure? lifted-pred)
|
||||
(procedure-arity-includes? lifted-pred 1))
|
||||
(error 'flat-named-contract
|
||||
"expected procedure of one argument, given: ~e" lifted-pred)))))
|
||||
(list (cons #'contract-name (syntax
|
||||
(if (object-name pred)
|
||||
(object-name pred)
|
||||
'???)))))
|
||||
null
|
||||
(syntax (lifted-pred val))
|
||||
(make-known #t stx))))]))
|
||||
|
||||
(syntax-case stx (flat-contract)
|
||||
[(flat-contract pred)
|
||||
(opt/flat-ctc #'pred)]))
|
||||
|
||||
(define/opter (-> opt/i pos neg stx)
|
||||
|
||||
;; opt/arrow-ctc : list-of-syntax list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define (opt/arrow-ctc doms rngs)
|
||||
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
|
||||
(generate-temporaries rngs))]
|
||||
[(next-doms lifted-doms partial-doms)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifted-doms null]
|
||||
[partial-doms null])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms) lifted-doms partial-doms)]
|
||||
[else
|
||||
(let-values ([(next lifted partial flat? _)
|
||||
(opt/i neg pos (car doms))])
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifted-doms lifted)
|
||||
(append partial-doms partial)))]))]
|
||||
[(next-rngs lifted-rngs partial-rngs)
|
||||
(let loop ([vars rng-vars]
|
||||
[rngs rngs]
|
||||
[next-rngs null]
|
||||
[lifted-rngs null]
|
||||
[partial-rngs null])
|
||||
(cond
|
||||
[(null? rngs) (values (reverse next-rngs) lifted-rngs partial-rngs)]
|
||||
[else
|
||||
(let-values ([(next lifted partial flat? _)
|
||||
(opt/i pos neg (car rngs))])
|
||||
(loop (cdr vars)
|
||||
(cdr rngs)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-rngs)
|
||||
(append lifted-rngs lifted)
|
||||
(append partial-rngs partial)))]))])
|
||||
(values
|
||||
(with-syntax (((dom-arg ...) dom-vars)
|
||||
((rng-arg ...) rng-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars))
|
||||
((next-rng ...) next-rngs))
|
||||
(syntax (if (and (procedure? val) (procedure-arity-includes? val dom-len))
|
||||
(λ (dom-arg ...)
|
||||
(let-values ([(rng-arg ...) (val next-dom ...)])
|
||||
(values next-rng ...)))
|
||||
(error '-> "expected a procedure of arity ~a, got ~e" dom-len val))))
|
||||
(append lifted-doms lifted-rngs
|
||||
(list (cons #'contract-name
|
||||
#''->/c)))
|
||||
(append partial-doms partial-rngs)
|
||||
#f
|
||||
(make-known #t stx))))
|
||||
|
||||
;; opt/arrow-any-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define (opt/arrow-any-ctc doms)
|
||||
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
||||
[(next-doms lifted-doms partial-doms)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifted-doms null]
|
||||
[partial-doms null])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms) lifted-doms partial-doms)]
|
||||
[else
|
||||
(let-values ([(next lifted partial flat? _)
|
||||
(opt/i pos neg (car doms))])
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifted-doms lifted)
|
||||
(append partial-doms partial)))]))])
|
||||
(values
|
||||
(with-syntax (((dom-arg ...) dom-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars)))
|
||||
(syntax (if (and (procedure? val) (procedure-arity-includes? val dom-len))
|
||||
(λ (dom-arg ...)
|
||||
(val next-dom ...))
|
||||
(error '-> "expected a procedure of arity ~a, got ~e" dom-len val))))
|
||||
(append lifted-doms
|
||||
;; FIXME naming still broken
|
||||
(list (cons #'contract-name
|
||||
#''->/c)))
|
||||
(append partial-doms)
|
||||
#f
|
||||
(make-known #t stx))))
|
||||
|
||||
(syntax-case stx (-> values any)
|
||||
[(-> dom ... (values rng ...))
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(syntax->list (syntax (rng ...))))]
|
||||
[(-> dom ... any)
|
||||
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
|
||||
[(-> dom ... rng)
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(list #'rng))]))
|
||||
|
||||
(define/opter (unknown opt/i pos neg stx)
|
||||
|
||||
;; opt/unknown-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define (opt/unknown-ctc ctc)
|
||||
(let* ((lifted-vars (generate-temporaries (syntax (lifted error-check))))
|
||||
(lifted-var (car lifted-vars))
|
||||
(partial-var (car (generate-temporaries (syntax (partial))))))
|
||||
(values
|
||||
(with-syntax ((partial-var partial-var)
|
||||
(lifted-var lifted-var)
|
||||
(ctc ctc))
|
||||
(syntax (partial-var val)))
|
||||
(append
|
||||
(interleave-lifted
|
||||
lifted-vars
|
||||
(list ctc
|
||||
(with-syntax ((lifted-var lifted-var))
|
||||
(syntax
|
||||
(unless (contract? lifted-var)
|
||||
(error 'contract "expected contract, given ~e" lifted-var))))))
|
||||
(list
|
||||
(cons #'contract-name
|
||||
#''opt/c)))
|
||||
(list (cons
|
||||
partial-var
|
||||
(with-syntax ((lifted-var lifted-var)
|
||||
(pos pos)
|
||||
(neg neg))
|
||||
(syntax (((proj-get lifted-var) lifted-var) pos neg src-info orig-str)))))
|
||||
#f
|
||||
(make-known #f lifted-var))))
|
||||
|
||||
(syntax-case stx ()
|
||||
[ctc
|
||||
(opt/unknown-ctc #'ctc)]))
|
||||
|
||||
(define/opter (or/c opt/i pos neg stx)
|
||||
|
||||
;; opt/or-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
||||
(define (opt/or-ctc ps)
|
||||
(let ((lifted-from-hos null)
|
||||
(partial-from-hos null))
|
||||
(let-values ([(opt-ps lifted-ps partial-ps hos ho-ctc)
|
||||
(let loop ([ps ps]
|
||||
[next-ps null]
|
||||
[lifted-ps null]
|
||||
[partial-ps null]
|
||||
[hos null]
|
||||
[ho-ctc #f])
|
||||
(cond
|
||||
[(null? ps) (values next-ps lifted-ps partial-ps (reverse hos) ho-ctc)]
|
||||
[else
|
||||
(let-values ([(next lifted partial flat? _)
|
||||
(opt/i pos neg (car ps))])
|
||||
(if flat?
|
||||
(loop (cdr ps)
|
||||
(cons flat? next-ps)
|
||||
(append lifted-ps lifted)
|
||||
(append partial-ps partial)
|
||||
hos
|
||||
ho-ctc)
|
||||
(if (< (length hos) 1)
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
(append lifted-ps lifted)
|
||||
(append partial-ps partial)
|
||||
(cons (car ps) hos)
|
||||
next)
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
lifted-ps
|
||||
partial-ps
|
||||
(cons (car ps) hos)
|
||||
ho-ctc))))]))])
|
||||
(with-syntax ((next-ps (with-syntax (((opt-p ...) opt-ps))
|
||||
(syntax (or #f opt-p ...)))))
|
||||
(values
|
||||
(cond
|
||||
[(null? hos) (with-syntax ((pos pos))
|
||||
(syntax
|
||||
(if next-ps val
|
||||
(raise-contract-error val src-info pos orig-str
|
||||
"none of the branches of the or/c matched"))))]
|
||||
[(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
|
||||
(syntax
|
||||
(if next-ps val ho-ctc)))]
|
||||
[(> (length hos) 1)
|
||||
(let-values ([(next-hos lifted-hos partial-hos _ __)
|
||||
((opter 'unknown) opt/i pos neg (cons #'or/c hos))])
|
||||
(set! lifted-from-hos lifted-hos)
|
||||
(set! partial-from-hos partial-hos)
|
||||
(with-syntax ((next-hos next-hos))
|
||||
(syntax
|
||||
(if next-ps val next-hos))))])
|
||||
(append lifted-ps
|
||||
lifted-from-hos
|
||||
(list (cons #'contract-name
|
||||
#''or/c-placeholder)))
|
||||
(append partial-ps
|
||||
partial-from-hos)
|
||||
(if (null? hos)
|
||||
(syntax next-ps)
|
||||
#f)
|
||||
(make-known #t stx))))))
|
||||
|
||||
(syntax-case stx (or/c)
|
||||
[(or/c p ...)
|
||||
(opt/or-ctc (syntax->list (syntax (p ...))))])))
|
||||
|
|
@ -15,6 +15,7 @@ add struct contracts for immutable structs?
|
|||
define/contract)
|
||||
|
||||
(require-for-syntax mzscheme
|
||||
"contract-opt-guts.ss"
|
||||
(lib "list.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax"))
|
||||
|
|
@ -24,7 +25,9 @@ add struct contracts for immutable structs?
|
|||
(lib "pretty.ss")
|
||||
(lib "pconvert.ss")
|
||||
"contract-arrow.ss"
|
||||
"contract-guts.ss")
|
||||
"contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
"contract-opt-guts.ss")
|
||||
|
||||
(require "contract-helpers.ss")
|
||||
(require-for-syntax (prefix a: "contract-helpers.ss"))
|
||||
|
|
@ -727,7 +730,10 @@ add struct contracts for immutable structs?
|
|||
box-immutable/c box/c
|
||||
promise/c
|
||||
struct/c
|
||||
syntax/c)
|
||||
syntax/c
|
||||
|
||||
check-between/c
|
||||
check-unary-between/c)
|
||||
|
||||
(define-syntax (flat-rec-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -977,6 +983,74 @@ add struct contracts for immutable structs?
|
|||
this-ctcs
|
||||
that-ctcs))))))
|
||||
(flat-prop (λ (ctc) (flat-or/c-pred ctc)))))
|
||||
|
||||
;;
|
||||
;; or/c opter
|
||||
;;
|
||||
(define/opter (or/c opt/i pos neg stx)
|
||||
(define (opt/or-ctc ps)
|
||||
(let ((lift-from-hos null)
|
||||
(partial-from-hos null))
|
||||
(let-values ([(opt-ps lift-ps partial-ps hos ho-ctc)
|
||||
(let loop ([ps ps]
|
||||
[next-ps null]
|
||||
[lift-ps null]
|
||||
[partial-ps null]
|
||||
[hos null]
|
||||
[ho-ctc #f])
|
||||
(cond
|
||||
[(null? ps) (values next-ps lift-ps partial-ps (reverse hos) ho-ctc)]
|
||||
[else
|
||||
(let-values ([(next lift partial flat _)
|
||||
(opt/i pos neg (car ps))])
|
||||
(if flat
|
||||
(loop (cdr ps)
|
||||
(cons flat next-ps)
|
||||
(append lift-ps lift)
|
||||
(append partial-ps partial)
|
||||
hos
|
||||
ho-ctc)
|
||||
(if (< (length hos) 1)
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
(append lift-ps lift)
|
||||
(append partial-ps partial)
|
||||
(cons (car ps) hos)
|
||||
next)
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
lift-ps
|
||||
partial-ps
|
||||
(cons (car ps) hos)
|
||||
ho-ctc))))]))])
|
||||
(with-syntax ((next-ps (with-syntax (((opt-p ...) opt-ps))
|
||||
(syntax (or #f opt-p ...)))))
|
||||
(values
|
||||
(cond
|
||||
[(null? hos) (with-syntax ((pos pos))
|
||||
(syntax
|
||||
(if next-ps val
|
||||
(raise-contract-error val src-info pos orig-str
|
||||
"none of the branches of the or/c matched"))))]
|
||||
[(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
|
||||
(syntax
|
||||
(if next-ps val ho-ctc)))]
|
||||
[(> (length hos) 1)
|
||||
(let-values ([(next-hos lift-hos partial-hos _ __)
|
||||
((opter 'unknown) opt/i pos neg (cons #'or/c hos))])
|
||||
(set! lift-from-hos lift-hos)
|
||||
(set! partial-from-hos partial-hos)
|
||||
(with-syntax ((next-hos next-hos))
|
||||
(syntax
|
||||
(if next-ps val next-hos))))])
|
||||
(append lift-ps lift-from-hos)
|
||||
(append partial-ps partial-from-hos)
|
||||
(if (null? hos) (syntax next-ps) #f)
|
||||
#f)))))
|
||||
|
||||
(syntax-case stx (or/c)
|
||||
[(or/c p ...)
|
||||
(opt/or-ctc (syntax->list (syntax (p ...))))]))
|
||||
|
||||
(define false/c
|
||||
(flat-named-contract
|
||||
|
|
@ -1079,24 +1153,83 @@ add struct contracts for immutable structs?
|
|||
(λ (x)
|
||||
(and (number? x)
|
||||
(<= n x m))))))))
|
||||
(define (=/c x)
|
||||
|
||||
(define (check-unary-between/c sym x)
|
||||
(unless (number? x)
|
||||
(error '=/c "expected a number, got ~e" x))
|
||||
(error sym "expected a number, got ~e" x)))
|
||||
(define (=/c x)
|
||||
(check-unary-between/c '=/c x)
|
||||
(make-between/c x x))
|
||||
(define (<=/c x)
|
||||
(unless (number? x)
|
||||
(error '<=/c "expected a number, got ~e" x))
|
||||
(check-unary-between/c '<=/c x)
|
||||
(make-between/c -inf.0 x))
|
||||
(define (>=/c x)
|
||||
(unless (number? x)
|
||||
(error '>=/c "expected a number, got ~e" x))
|
||||
(check-unary-between/c '>=/c x)
|
||||
(make-between/c x +inf.0))
|
||||
(define (between/c x y)
|
||||
(define (check-between/c x y)
|
||||
(unless (number? x)
|
||||
(error 'between/c "expected a number as first argument, got ~e, other arg ~e" x y))
|
||||
(unless (number? y)
|
||||
(error 'between/c "expected a number as second argument, got ~e, other arg ~e" y x))
|
||||
(error 'between/c "expected a number as second argument, got ~e, other arg ~e" y x)))
|
||||
(define (between/c x y)
|
||||
(check-between/c x y)
|
||||
(make-between/c x y))
|
||||
|
||||
;;
|
||||
;; between/c opter helper
|
||||
;;
|
||||
(define-for-syntax (opt/between-ctc pos stx low high op checker)
|
||||
(let* ((lift-vars (generate-temporaries (syntax (low high error-check))))
|
||||
(lift-low (car lift-vars))
|
||||
(lift-high (cadr lift-vars)))
|
||||
(with-syntax ((pos pos)
|
||||
(op op)
|
||||
(n lift-low)
|
||||
(m lift-high))
|
||||
(values
|
||||
(syntax (if (and (number? val) (op n val m)) val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
((name-get ctc) ctc)
|
||||
val)))
|
||||
(interleave-lifts
|
||||
lift-vars
|
||||
(list low
|
||||
high
|
||||
(cond
|
||||
[(eq? checker 'between/c) #'(check-between/c n m)]
|
||||
[(eq? checker '>/c #'(check-unary-between/c '>/c n))]
|
||||
[(eq? checker '>=/c #'(check-unary-between/c '>=/c n))]
|
||||
[(eq? checker '</c #'(check-unary-between/c '</c m))]
|
||||
[(eq? checker '<=/c #'(check-unary-between/c '<=/c m))])))
|
||||
null
|
||||
(syntax (and (number? val) (op n val m)))
|
||||
#f))))
|
||||
|
||||
;;
|
||||
;; between/c and friends' opters
|
||||
;;
|
||||
;; note that the checkers are used by both optimized and normal contracts.
|
||||
;;
|
||||
(define/opter (between/c opt/i pos neg stx)
|
||||
(syntax-case stx (between/c)
|
||||
[(between/c low high) (opt/between-ctc pos stx #'low #'high #'<= 'between/c)]))
|
||||
(define/opter (>/c opt/i pos neg stx)
|
||||
(syntax-case stx (>/c)
|
||||
[(>/c low) (opt/between-ctc #'low #'+inf.0 #'< '>/c)]))
|
||||
(define/opter (>=/c opt/i pos neg stx)
|
||||
(syntax-case stx (>=/c)
|
||||
[(>=/c low) (opt/between-ctc #'low #'+inf.0 #'<= '>=/c)]))
|
||||
(define/opter (</c opt/i pos neg stx)
|
||||
(syntax-case stx (</c)
|
||||
[(</c high) (opt/between-ctc #'-inf.0 #'high #'< '</c)]))
|
||||
(define/opter (<=/c opt/i pos neg stx)
|
||||
(syntax-case stx (<=/c)
|
||||
[(<=/c high) (opt/between-ctc #'-inf.0 #'high #'<= '<=/c)]))
|
||||
|
||||
(define (</c x)
|
||||
(flat-named-contract
|
||||
|
|
@ -1267,6 +1400,64 @@ add struct contracts for immutable structs?
|
|||
(test-proc/flat-contract hdp (car x))
|
||||
(test-proc/flat-contract tlp (cdr x))))))
|
||||
|
||||
;;
|
||||
;; cons/c opter
|
||||
;;
|
||||
(define/opter (cons/c opt/i pos neg stx)
|
||||
(define (opt/cons-ctc hdp tlp)
|
||||
(let-values ([(next-hdp lifts-hdp partials-hdp flat-hdp unknown-hdp)
|
||||
(opt/i pos neg hdp)]
|
||||
[(next-tlp lifts-tlp partials-tlp flat-tlp unknown-tlp)
|
||||
(opt/i pos neg tlp)]
|
||||
[(error-check) (car (generate-temporaries (syntax (error-check))))])
|
||||
(with-syntax ((next (with-syntax ((flat-hdp flat-hdp)
|
||||
(flat-tlp flat-tlp))
|
||||
(syntax
|
||||
(and (pair? val)
|
||||
(let ((val (car val))) flat-hdp)
|
||||
(let ((val (cdr val))) flat-tlp))))))
|
||||
(values
|
||||
(with-syntax ((pos pos))
|
||||
(syntax (if next
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
((name-get ctc) ctc)
|
||||
val))))
|
||||
(append
|
||||
lifts-hdp lifts-tlp
|
||||
(list (cons error-check
|
||||
(with-syntax ((hdp hdp)
|
||||
(tlp tlp)
|
||||
(check (with-syntax ((flat-hdp
|
||||
(cond
|
||||
[unknown-hdp
|
||||
(with-syntax ((ctc unknown-hdp))
|
||||
(syntax (flat-contract/predicate? ctc)))]
|
||||
[else (if flat-hdp #'#t #'#f)]))
|
||||
(flat-tlp
|
||||
(cond
|
||||
[unknown-tlp
|
||||
(with-syntax ((ctc unknown-tlp))
|
||||
(syntax (flat-contract/predicate? ctc)))]
|
||||
[else (if flat-tlp #'#t #'#f)])))
|
||||
(syntax (and flat-hdp flat-tlp)))))
|
||||
(syntax
|
||||
(unless check
|
||||
(error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e"
|
||||
hdp tlp)))))))
|
||||
(append partials-hdp partials-tlp)
|
||||
(syntax (if next #t #f))
|
||||
#f))))
|
||||
|
||||
(syntax-case stx (cons/c)
|
||||
[(cons/c hdp tlp)
|
||||
(opt/cons-ctc #'hdp #'tlp)]))
|
||||
|
||||
(define-syntax (*-immutable/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ predicate? constructor (arb? selectors ...) type-name name)
|
||||
|
|
@ -1344,6 +1535,45 @@ add struct contracts for immutable structs?
|
|||
(λ (n v) (= n (vector-length v)))
|
||||
immutable-vector
|
||||
vector-immutable/c))
|
||||
|
||||
;;
|
||||
;; cons-immutable/c opter
|
||||
;;
|
||||
(define/opter (cons-immutable/c opt/i pos neg stx)
|
||||
(define (opt/cons-immutable-ctc hdp tlp)
|
||||
(let-values ([(next-hdp lifts-hdp partials-hdp flat-hdp unknown-hdp)
|
||||
(opt/i pos neg hdp)]
|
||||
[(next-tlp lifts-tlp partials-tlp flat-tlp unknown-tlp)
|
||||
(opt/i pos neg tlp)])
|
||||
(with-syntax ((check (syntax (and (immutable? val) (pair? val)))))
|
||||
(values
|
||||
(with-syntax ((pos pos)
|
||||
(next-hdp next-hdp)
|
||||
(next-tlp next-tlp))
|
||||
(syntax (if check
|
||||
(cons-immutable (let ((val (car val))) next-hdp)
|
||||
(let ((val (cdr val))) next-tlp))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
((name-get ctc) ctc)
|
||||
val))))
|
||||
(append lifts-hdp lifts-tlp)
|
||||
(append partials-hdp partials-tlp)
|
||||
(if (and flat-hdp flat-tlp)
|
||||
(with-syntax ((flat-hdp flat-hdp)
|
||||
(flat-tlp flat-tlp))
|
||||
(syntax (if (and check
|
||||
(let ((val (car val))) flat-hdp)
|
||||
(let ((val (cdr val))) flat-tlp)) #t #f)))
|
||||
#f)
|
||||
#f))))
|
||||
|
||||
(syntax-case stx (cons-immutable/c)
|
||||
[(cons-immutable/c hdp tlp) (opt/cons-immutable-ctc #'hdp #'tlp)]))
|
||||
|
||||
(define (list/c . args)
|
||||
(unless (andmap flat-contract/predicate? args)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
(module contract-opt-tests mzscheme
|
||||
(require (lib "private/contract-opt.scm")
|
||||
(lib "private/contract-opters.scm")
|
||||
(lib "contract.ss")
|
||||
(require (lib "contract.ss")
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 2 1)))
|
||||
|
||||
(define (exn:fail:contract-violation? exn)
|
||||
|
|
@ -141,9 +139,15 @@
|
|||
|
||||
(test-exn
|
||||
"between/c 2"
|
||||
(match-msg "expected two numbers")
|
||||
(match-msg "expected a number as first")
|
||||
(λ ()
|
||||
(contract (opt/c (between/c 'x 'b)) 1 'pos 'neg)))
|
||||
|
||||
(test-exn
|
||||
"between/c 3"
|
||||
(match-msg "expected a number as second")
|
||||
(λ ()
|
||||
(contract (opt/c (between/c 1 'b)) 1 'pos 'neg)))
|
||||
|
||||
))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user