refactored contract opters so they return structs instead
of (8!) multiple values
This commit is contained in:
Robby Findler
parent
4c59943b0d
commit
7221d01483
|
|
@ -377,154 +377,3 @@
|
|||
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
|
||||
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
|
||||
|
||||
;;
|
||||
;; arrow opter
|
||||
;;
|
||||
(define/opter (-> opt/i opt/info stx)
|
||||
(define (opt/arrow-ctc doms rngs)
|
||||
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
|
||||
(generate-temporaries rngs))]
|
||||
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom doms-chaperone?)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifts-doms null]
|
||||
[superlifts-doms null]
|
||||
[partials-doms null]
|
||||
[stronger-ribs null]
|
||||
[chaperone? #t])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms)
|
||||
lifts-doms
|
||||
superlifts-doms
|
||||
partials-doms
|
||||
stronger-ribs
|
||||
chaperone?)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
|
||||
(opt/i (opt/info-swap-blame opt/info) (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 superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and chaperone? this-chaperone?)))]))]
|
||||
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rngs-chaperone?)
|
||||
(let loop ([vars rng-vars]
|
||||
[rngs rngs]
|
||||
[next-rngs null]
|
||||
[lifts-rngs null]
|
||||
[superlifts-rngs null]
|
||||
[partials-rngs null]
|
||||
[stronger-ribs null]
|
||||
[chaperone? #t])
|
||||
(cond
|
||||
[(null? rngs) (values (reverse next-rngs)
|
||||
lifts-rngs
|
||||
superlifts-rngs
|
||||
partials-rngs
|
||||
stronger-ribs
|
||||
chaperone?)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
|
||||
(opt/i opt/info (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 superlifts-rngs superlift)
|
||||
(append partials-rngs partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and this-chaperone? chaperone?)))]))])
|
||||
(values
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
((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 0 '() '() #| keywords |# blame)
|
||||
(λ (dom-arg ...)
|
||||
(let-values ([(rng-arg ...) (val next-dom ...)])
|
||||
(values next-rng ...))))))
|
||||
(append lifts-doms lifts-rngs)
|
||||
(append superlifts-doms superlifts-rngs)
|
||||
(append partials-doms partials-rngs)
|
||||
#f
|
||||
#f
|
||||
(append stronger-ribs-dom stronger-ribs-rng)
|
||||
(and rngs-chaperone? doms-chaperone?))))
|
||||
|
||||
(define (opt/arrow-any-ctc doms)
|
||||
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
||||
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom doms-chaperone?)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifts-doms null]
|
||||
[superlifts-doms null]
|
||||
[partials-doms null]
|
||||
[stronger-ribs null]
|
||||
[chaperone? #t])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms)
|
||||
lifts-doms
|
||||
superlifts-doms
|
||||
partials-doms
|
||||
stronger-ribs
|
||||
chaperone?)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?)
|
||||
(opt/i (opt/info-swap-blame opt/info) (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 superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and chaperone? this-chaperone?)))]))])
|
||||
(values
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars)))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len 0 '() '() #|keywords|# blame)
|
||||
(λ (dom-arg ...)
|
||||
(val next-dom ...)))))
|
||||
lifts-doms
|
||||
superlifts-doms
|
||||
partials-doms
|
||||
#f
|
||||
#f
|
||||
stronger-ribs-dom
|
||||
doms-chaperone?)))
|
||||
|
||||
(syntax-case* stx (-> values any) module-or-top-identifier=?
|
||||
[(-> dom ... (values rng ...))
|
||||
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
|
||||
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(syntax->list (syntax (rng ...)))))]
|
||||
[(-> dom ... any)
|
||||
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
|
||||
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
|
||||
(opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))]
|
||||
[(-> dom ... rng)
|
||||
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
|
||||
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(list #'rng)))]))
|
||||
|
|
|
|||
|
|
@ -12,20 +12,21 @@
|
|||
;;
|
||||
(define-for-syntax (opt/pred opt/info pred)
|
||||
(with-syntax ((pred pred))
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(blame (opt/info-blame opt/info)))
|
||||
(syntax (if (pred val)
|
||||
val
|
||||
(raise-opt/pred-error blame val 'pred))))
|
||||
null
|
||||
null
|
||||
null
|
||||
(syntax (pred val))
|
||||
#f
|
||||
null
|
||||
#t)))
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat (syntax (pred val))
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t)))
|
||||
|
||||
(define (raise-opt/pred-error blame val pred-name)
|
||||
(raise-blame-error
|
||||
|
|
@ -52,15 +53,15 @@
|
|||
;;
|
||||
(define/opter (any/c opt/i opt/info stx)
|
||||
(syntax-case stx (any/c)
|
||||
[any/c (values
|
||||
(opt/info-val opt/info)
|
||||
null
|
||||
null
|
||||
null
|
||||
#'#t
|
||||
#f
|
||||
null
|
||||
#t)]))
|
||||
[any/c
|
||||
(build-optres #:exp (opt/info-val opt/info)
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #'#t
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t)]))
|
||||
|
||||
;;
|
||||
;; false/c
|
||||
|
|
@ -86,8 +87,8 @@
|
|||
(ctc (opt/info-contract opt/info))
|
||||
(blame (opt/info-blame opt/info))
|
||||
(lift-pred lift-pred))
|
||||
(values
|
||||
(syntax (if (lift-pred val)
|
||||
(build-optres
|
||||
#:exp (syntax (if (lift-pred val)
|
||||
val
|
||||
(raise-blame-error
|
||||
blame
|
||||
|
|
@ -96,16 +97,17 @@
|
|||
(contract-name ctc)
|
||||
(given/produced blame)
|
||||
val)))
|
||||
#:lifts
|
||||
(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
|
||||
null
|
||||
(syntax (lift-pred val))
|
||||
#f
|
||||
null
|
||||
#t)))]))
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat (syntax (lift-pred val))
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t)))]))
|
||||
|
||||
;;
|
||||
;; flat-contract and friends
|
||||
|
|
|
|||
|
|
@ -147,15 +147,15 @@ which are then called when the contract's fields are explored
|
|||
(and (identifier? #'f)
|
||||
(opt/info-recf opt/info)
|
||||
(free-identifier=? (opt/info-recf opt/info) #'f))
|
||||
(values
|
||||
#`(f #,id arg ...)
|
||||
null
|
||||
null
|
||||
null
|
||||
#f
|
||||
#f
|
||||
null
|
||||
#f)]
|
||||
(build-optres
|
||||
#:exp #`(f #,id arg ...)
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #f
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #f)]
|
||||
[else (opt/i (opt/info-change-val id opt/info)
|
||||
stx)]))
|
||||
|
||||
|
|
@ -193,8 +193,7 @@ which are then called when the contract's fields are explored
|
|||
[(id (x ...) ctc-exp)
|
||||
(and (identifier? (syntax id))
|
||||
(andmap identifier? (syntax->list (syntax (x ...)))))
|
||||
(let*-values ([(next lifts superlifts partials _ _2 _3 chaperone?)
|
||||
(opt/enforcer-clause let-var (syntax ctc-exp))]
|
||||
(let*-values ([(an-optres) (opt/enforcer-clause let-var (syntax ctc-exp))]
|
||||
[(maker-arg)
|
||||
(with-syntax ([val (opt/info-val opt/info)]
|
||||
[(new-let-bindings ...)
|
||||
|
|
@ -204,11 +203,12 @@ which are then called when the contract's fields are explored
|
|||
arglist)])
|
||||
#`(#,let-var
|
||||
#,(bind-lifts
|
||||
superlifts
|
||||
(optres-superlifts an-optres)
|
||||
#`(let (new-let-bindings ...)
|
||||
#,(bind-lifts
|
||||
(append lifts partials)
|
||||
next)))))])
|
||||
(append (optres-lifts an-optres)
|
||||
(optres-partials an-optres))
|
||||
(optres-exp an-optres))))))])
|
||||
(loop (cdr clauses)
|
||||
(cdr let-vars)
|
||||
(cdr arglists)
|
||||
|
|
@ -227,23 +227,22 @@ which are then called when the contract's fields are explored
|
|||
(syntax->list (syntax (x ...)))))]
|
||||
[(id ctc-exp)
|
||||
(identifier? (syntax id))
|
||||
(let*-values ([(next lifts superlifts partials _ __ stronger-ribs chaperone?)
|
||||
(opt/enforcer-clause let-var (syntax ctc-exp))]
|
||||
(let*-values ([(an-optres) (opt/enforcer-clause let-var (syntax ctc-exp))]
|
||||
[(maker-arg)
|
||||
(with-syntax ((val (opt/info-val opt/info)))
|
||||
#`(#,let-var
|
||||
#,(bind-lifts
|
||||
partials
|
||||
next)))])
|
||||
(optres-partials an-optres)
|
||||
(optres-exp an-optres))))])
|
||||
(loop (cdr clauses)
|
||||
(cdr let-vars)
|
||||
(cdr arglists)
|
||||
(cdr ac-ids)
|
||||
(cons (car ac-ids) prior-ac-ids)
|
||||
(cons maker-arg maker-args)
|
||||
(append lifts-ps lifts)
|
||||
(append superlifts-ps superlifts)
|
||||
(append stronger-ribs-ps stronger-ribs)))]
|
||||
(append lifts-ps (optres-lifts an-optres))
|
||||
(append superlifts-ps (optres-superlifts an-optres))
|
||||
(append stronger-ribs-ps (optres-stronger-ribs an-optres))))]
|
||||
[(id ctc-exp)
|
||||
(raise-syntax-error name "expected identifier" stx (syntax id))]))]))))
|
||||
|
||||
|
|
|
|||
|
|
@ -427,7 +427,8 @@ it around flattened out.
|
|||
(cons contract/info-var
|
||||
(syntax
|
||||
(make-opt-contract/info ctc enforcer-id id))))])
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(syntax
|
||||
(cond
|
||||
[(opt-wrap-predicate val)
|
||||
|
|
@ -462,15 +463,13 @@ it around flattened out.
|
|||
(contract-name ctc)
|
||||
(given/produced blame)
|
||||
val)]))
|
||||
lifts
|
||||
superlifts
|
||||
partials
|
||||
#f
|
||||
#f
|
||||
stronger-ribs
|
||||
;; opt'd struct contracts don't use chaperones yet
|
||||
#f)))))))]))
|
||||
)))))
|
||||
#:lifts lifts
|
||||
#:superlifts superlifts
|
||||
#:partials partials
|
||||
#:flat #f
|
||||
#:opt #f
|
||||
#:stronger-ribs stronger-ribs
|
||||
#:chaperone #f)))))))])))))))
|
||||
|
||||
(define-syntax (define-contract-struct stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -23,7 +23,81 @@
|
|||
opt/info-change-val
|
||||
|
||||
opt/unknown
|
||||
combine-two-chaperone?s)
|
||||
combine-two-chaperone?s
|
||||
|
||||
|
||||
optres-exp
|
||||
optres-lifts
|
||||
optres-superlifts
|
||||
optres-partials
|
||||
optres-flat
|
||||
optres-opt
|
||||
optres-stronger-ribs
|
||||
optres-chaperone
|
||||
build-optres)
|
||||
|
||||
;; (define/opter (<contract-combinator> opt/i opt/info stx) body)
|
||||
;;
|
||||
;; An opter is to a function with the following signature:
|
||||
;;
|
||||
;; opter : (syntax opt/info -> <opter-results>) opt/info list-of-ids -> opt-res
|
||||
;;
|
||||
;; The first argument can be used to recursively process sub-contracts
|
||||
;; It returns what an opter returns and its results should be accumulated
|
||||
;; into the opter's results.
|
||||
;;
|
||||
;; The opt/info struct has a number of identifiers that get used to build
|
||||
;; contracts; see opt-guts.rkt for the selectors.
|
||||
;;
|
||||
;; The last argument is a list of free-variables if the calling context
|
||||
;; was define/opt, otherwise it is null.
|
||||
;;
|
||||
;; The fields of the optres struct are:
|
||||
;; - the optimized syntax
|
||||
;; - lifted variables: a list of (id, sexp) pairs
|
||||
;; - super-lifted variables: functions or the such defined at the toplevel of the
|
||||
;; calling context of the opt routine.
|
||||
;; Currently this is only used for struct contracts.
|
||||
;; - partially applied contracts: a list of (id, sexp) pairs
|
||||
;; - if the contract being optimized is flat,
|
||||
;; then an sexp that evals to bool, indicating if the contract passed or not,
|
||||
;; 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.
|
||||
;; - a list of stronger-ribs
|
||||
;; - a boolean or a syntax object; if it is a boolean,
|
||||
;; the boolean indicaties if this contract is a chaperone contract
|
||||
;; if it is a syntax object, then evaluating its contents determines
|
||||
;; if this is a chaperone contract
|
||||
|
||||
(struct optres (exp
|
||||
lifts
|
||||
superlifts
|
||||
partials
|
||||
flat
|
||||
opt
|
||||
stronger-ribs
|
||||
chaperone))
|
||||
(define (build-optres #:exp exp
|
||||
#:lifts lifts
|
||||
#:superlifts superlifts
|
||||
#:partials partials
|
||||
#:flat flat
|
||||
#:opt opt
|
||||
#:stronger-ribs stronger-ribs
|
||||
#:chaperone chaperone)
|
||||
(optres exp
|
||||
lifts
|
||||
superlifts
|
||||
partials
|
||||
flat
|
||||
opt
|
||||
stronger-ribs
|
||||
chaperone))
|
||||
|
||||
;; a hash table of opters
|
||||
(define opters-table
|
||||
|
|
@ -169,7 +243,7 @@
|
|||
[val (opt/info-val opt/info)]
|
||||
[uctc uctc]
|
||||
[blame (opt/info-blame opt/info)])
|
||||
(values
|
||||
(optres
|
||||
#'(partial-var val)
|
||||
(list (cons #'lift-var
|
||||
#'(coerce-contract 'opt/c uctc)))
|
||||
|
|
@ -200,4 +274,3 @@
|
|||
(and chaperone-b? chaperone-a?)]
|
||||
[else
|
||||
#`(and #,chaperone-a? #,chaperone-b?)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -11,45 +11,6 @@
|
|||
opt/direct
|
||||
begin-lifted)
|
||||
|
||||
;; (define/opter (<contract-combinator> opt/i opt/info stx) body)
|
||||
;;
|
||||
;; An opter is to a function with the following signature:
|
||||
;;
|
||||
;; opter : (syntax opt/info -> <opter-results>) opt/info list-of-ids ->
|
||||
;; (values syntax syntax-list syntax-list
|
||||
;; syntax-list (union syntax #f) (union syntax #f) syntax)
|
||||
;;
|
||||
;; The first argument can be used to recursively process sub-contracts
|
||||
;; It returns what an opter returns and its results should be accumulated
|
||||
;; into the opter's results.
|
||||
;;
|
||||
;; The opt/info struct has a number of identifiers that get used to build
|
||||
;; contracts; see opt-guts.rkt for the selectors.
|
||||
;;
|
||||
;; The last argument is a list of free-variables if the calling context
|
||||
;; was define/opt otherwise it is null.
|
||||
;;
|
||||
;; Every opter needs to return:
|
||||
;; - the optimized syntax
|
||||
;; - lifted variables: a list of (id, sexp) pairs
|
||||
;; - super-lifted variables: functions or the such defined at the toplevel of the
|
||||
;; calling context of the opt routine.
|
||||
;; Currently this is only used for struct contracts.
|
||||
;; - 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.
|
||||
;; - a list of stronger-ribs
|
||||
;; - a boolean or a syntax object; if it is a boolean,
|
||||
;; the boolean indicaties if this contract is a chaperone contract
|
||||
;; if it is a syntax object, then evaluating its contents determines
|
||||
;; if this is a chaperone contract
|
||||
(define-syntax (define/opter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (for opt/i opt/info stx) expr ...)
|
||||
|
|
@ -66,23 +27,20 @@
|
|||
;;
|
||||
;; opt/recursive-call
|
||||
;;
|
||||
;; BUG: currently does not try to optimize the arguments, this requires changing
|
||||
;; every opter to keep track of bound variables.
|
||||
;;
|
||||
(define-for-syntax (opt/recursive-call opt/info stx)
|
||||
(values
|
||||
(with-syntax ((stx stx)
|
||||
(build-optres
|
||||
#:exp (with-syntax ((stx stx)
|
||||
(val (opt/info-val opt/info))
|
||||
(blame (opt/info-blame opt/info)))
|
||||
(syntax (let ((ctc stx))
|
||||
(((contract-projection ctc) blame) val))))
|
||||
null
|
||||
null
|
||||
null
|
||||
#f
|
||||
#f
|
||||
null
|
||||
null))
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #f
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone null))
|
||||
|
||||
;; make-stronger : list-of-(union syntax #f) -> syntax
|
||||
(define-for-syntax (make-stronger strongers)
|
||||
|
|
@ -122,17 +80,18 @@
|
|||
[(number? konst)
|
||||
(values #`(and (number? #,v) (= #,konst #,v))
|
||||
"=")]))
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
#`(if #,predicate
|
||||
#,v
|
||||
(opt-constant-contract-failure #,(opt/info-blame opt/info) #,v #,word #,konst))
|
||||
null
|
||||
null
|
||||
null
|
||||
predicate
|
||||
#f
|
||||
null
|
||||
#t))
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat predicate
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t))
|
||||
|
||||
(define (opt-constant-contract-failure blame val compare should-be)
|
||||
(raise-blame-error blame val "expected a value ~a to ~e" compare should-be))
|
||||
|
|
@ -144,7 +103,7 @@
|
|||
;; opt/i : id opt/info syntax ->
|
||||
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
|
||||
(define-for-syntax (opt/i opt/info stx)
|
||||
;; the case dispatch here must match what top-level-unknown? is doing
|
||||
;; te case dispatch here must match what top-level-unknown? is doing
|
||||
(syntax-case stx ()
|
||||
[(ctc arg ...)
|
||||
(and (identifier? #'ctc) (opter #'ctc))
|
||||
|
|
@ -155,19 +114,20 @@
|
|||
[(f arg ...)
|
||||
(and (identifier? #'f)
|
||||
(define-opt/recursive-fn? (syntax-local-value #'f (λ () #f))))
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
#`(#,(define-opt/recursive-fn-internal-fn (syntax-local-value #'f))
|
||||
#,(opt/info-contract opt/info)
|
||||
#,(opt/info-blame opt/info)
|
||||
#,(opt/info-val opt/info)
|
||||
arg ...)
|
||||
null
|
||||
null
|
||||
null
|
||||
#f
|
||||
#f
|
||||
null
|
||||
#t)]
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #f
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t)]
|
||||
[konst
|
||||
(coerecable-constant? #'konst)
|
||||
(opt-constant-contract (syntax->datum #'konst) opt/info)]
|
||||
|
|
@ -201,32 +161,24 @@
|
|||
(define-syntax (opt/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
(let*-values ([(info) (make-opt/info #'ctc
|
||||
#'val
|
||||
#'blame
|
||||
#f
|
||||
'()
|
||||
#f
|
||||
#f
|
||||
#'this
|
||||
#'that)]
|
||||
[(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)])
|
||||
(with-syntax ([next next])
|
||||
(let ()
|
||||
(define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
|
||||
(define an-optres (opt/i info #'e))
|
||||
(bind-superlifts
|
||||
superlifts
|
||||
(optres-superlifts an-optres)
|
||||
(bind-lifts
|
||||
lifts
|
||||
(optres-lifts an-optres)
|
||||
#`(make-opt-contract
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
#,(bind-superlifts
|
||||
partials
|
||||
#`(λ (val) next))))
|
||||
(optres-partials an-optres)
|
||||
#`(λ (val) #,(optres-exp an-optres)))))
|
||||
(λ () e)
|
||||
(λ (this that) #f)
|
||||
(vector)
|
||||
(begin-lifted (box #f))
|
||||
#,chaperone?)))))]))
|
||||
#,(optres-chaperone an-optres)))))]))
|
||||
|
||||
;; this macro optimizes 'e' as a contract,
|
||||
;; using otherwise-id if it does not recognize 'e'.
|
||||
|
|
@ -234,28 +186,21 @@
|
|||
(syntax-case stx ()
|
||||
[(_ e val-e blame-e otherwise-id)
|
||||
(identifier? #'otherwise-id)
|
||||
(if (top-level-unknown? #'e)
|
||||
#'(otherwise-id e val-e blame-e)
|
||||
(let*-values ([(info) (make-opt/info #'ctc
|
||||
#'val
|
||||
#'blame
|
||||
#f
|
||||
'()
|
||||
#f
|
||||
#f
|
||||
#'this
|
||||
#'that)]
|
||||
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
|
||||
(cond
|
||||
[(top-level-unknown? #'e) #'(otherwise-id e val-e blame-e)]
|
||||
[else
|
||||
(define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
|
||||
(define an-optres (opt/i info #'e))
|
||||
#`(let ([ctc e] ;;; hm... what to do about this?!
|
||||
[val val-e]
|
||||
[blame blame-e])
|
||||
#,(bind-superlifts
|
||||
superlifts
|
||||
(optres-superlifts an-optres)
|
||||
(bind-lifts
|
||||
lifts
|
||||
(optres-lifts an-optres)
|
||||
(bind-superlifts
|
||||
partials
|
||||
next))))))]))
|
||||
(optres-partials an-optres)
|
||||
(optres-exp an-optres)))))])]))
|
||||
|
||||
(define-syntax (begin-lifted stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -285,31 +230,23 @@
|
|||
(define-syntax (opt/c-helper stx)
|
||||
(syntax-case stx ()
|
||||
[(_ f1 f2 (id args ...) e)
|
||||
(let*-values ([(info) (make-opt/info #'ctc
|
||||
#'val
|
||||
#'blame
|
||||
#f
|
||||
(syntax->list #'(args ...))
|
||||
#f
|
||||
#f
|
||||
#'this
|
||||
#'that)]
|
||||
[(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)])
|
||||
(with-syntax ([next next])
|
||||
(let ()
|
||||
(define info (make-opt/info #'ctc #'val #'blame #f (syntax->list #'(args ...)) #f #f #'this #'that))
|
||||
(define an-optres (opt/i info #'e))
|
||||
#`(let ()
|
||||
(define (f2 ctc blame val args ...)
|
||||
#,(bind-superlifts
|
||||
superlifts
|
||||
(optres-superlifts an-optres)
|
||||
(bind-lifts
|
||||
lifts
|
||||
(optres-lifts an-optres)
|
||||
(bind-superlifts
|
||||
partials
|
||||
#'next))))
|
||||
(optres-partials an-optres)
|
||||
(optres-exp an-optres)))))
|
||||
(define (f1 args ...)
|
||||
#,(bind-superlifts
|
||||
superlifts
|
||||
(optres-superlifts an-optres)
|
||||
(bind-lifts
|
||||
lifts
|
||||
(optres-lifts an-optres)
|
||||
#`(make-opt-contract
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
|
|
@ -319,8 +256,8 @@
|
|||
(λ (this that) #f)
|
||||
(vector)
|
||||
(begin-lifted (box #f))
|
||||
#,chaperone?))))
|
||||
(values f1 f2))))]))
|
||||
#,(optres-chaperone an-optres)))))
|
||||
(values f1 f2)))]))
|
||||
|
||||
;; optimized contracts
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -18,24 +18,18 @@
|
|||
(partial-var (car (generate-temporaries (syntax (partial))))))
|
||||
(values
|
||||
(with-syntax ((partial-var partial-var)
|
||||
(lift-var lift-var)
|
||||
(uctc uctc)
|
||||
(val (opt/info-val opt/info)))
|
||||
(syntax (partial-var val)))
|
||||
(list (cons lift-var
|
||||
;; FIXME needs to get the contract name somehow
|
||||
(with-syntax ((uctc uctc))
|
||||
(syntax (coerce-contract 'opt/c uctc)))))
|
||||
null
|
||||
'()
|
||||
(list (cons
|
||||
partial-var
|
||||
(with-syntax ((lift-var lift-var)
|
||||
(blame (opt/info-blame opt/info)))
|
||||
(syntax ((contract-projection lift-var) blame)))))
|
||||
#f
|
||||
lift-var
|
||||
(list #f)
|
||||
null)))
|
||||
(syntax ((contract-projection lift-var) blame))))))))
|
||||
|
||||
(define (opt/or-ctc ps)
|
||||
(let ((lift-from-hos null)
|
||||
|
|
@ -61,28 +55,27 @@
|
|||
ho-ctc
|
||||
chaperone?)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?)
|
||||
(opt/i opt/info (car ps))])
|
||||
(if flat
|
||||
(define ps-optres (opt/i opt/info (car ps)))
|
||||
(if (optres-flat ps-optres)
|
||||
(loop (cdr ps)
|
||||
(cons flat next-ps)
|
||||
(append lift-ps lift)
|
||||
(append superlift-ps superlift)
|
||||
(append partial-ps partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(cons (optres-flat ps-optres) next-ps)
|
||||
(append lift-ps (optres-lifts ps-optres))
|
||||
(append superlift-ps (optres-superlifts ps-optres))
|
||||
(append partial-ps (optres-partials ps-optres))
|
||||
(append (optres-stronger-ribs ps-optres) stronger-ribs)
|
||||
hos
|
||||
ho-ctc
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?))
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone ps-optres)))
|
||||
(if (< (length hos) 1)
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
(append lift-ps lift)
|
||||
(append superlift-ps superlift)
|
||||
(append partial-ps partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(append lift-ps (optres-lifts ps-optres))
|
||||
(append superlift-ps (optres-superlifts ps-optres))
|
||||
(append partial-ps (optres-partials ps-optres))
|
||||
(append (optres-stronger-ribs ps-optres) stronger-ribs)
|
||||
(cons (car ps) hos)
|
||||
next
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?))
|
||||
(optres-exp ps-optres)
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone ps-optres)))
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
lift-ps
|
||||
|
|
@ -91,11 +84,12 @@
|
|||
stronger-ribs
|
||||
(cons (car ps) hos)
|
||||
ho-ctc
|
||||
chaperone?))))]))])
|
||||
chaperone?)))]))])
|
||||
(with-syntax ((next-ps
|
||||
(with-syntax (((opt-p ...) (reverse opt-ps)))
|
||||
(syntax (or opt-p ...)))))
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(cond
|
||||
[(null? hos)
|
||||
(with-syntax ([val (opt/info-val opt/info)]
|
||||
|
|
@ -113,21 +107,22 @@
|
|||
(if next-ps val ho-ctc)))]
|
||||
;; FIXME something's not right with this case.
|
||||
[(> (length hos) 1)
|
||||
(let-values ([(next-hos lift-hos superlift-hos partial-hos _ __ stronger-hos stronger-vars-hos)
|
||||
(opt/or-unknown stx)])
|
||||
(set! lift-from-hos lift-hos)
|
||||
(set! superlift-from-hos superlift-hos)
|
||||
(set! partial-from-hos partial-hos)
|
||||
(with-syntax ((next-hos next-hos))
|
||||
(syntax
|
||||
(if next-ps val next-hos))))])
|
||||
(define-values (exp new-lifts new-superlifts new-partials) (opt/or-unknown stx))
|
||||
(set! lift-from-hos new-lifts)
|
||||
(set! superlift-from-hos new-superlifts)
|
||||
(set! partial-from-hos new-partials)
|
||||
#`(if next-ps val #,exp)])
|
||||
#:lifts
|
||||
(append lift-ps lift-from-hos)
|
||||
#:superlifts
|
||||
(append superlift-ps superlift-from-hos)
|
||||
#:partials
|
||||
(append partial-ps partial-from-hos)
|
||||
#:flat
|
||||
(if (null? hos) (syntax next-ps) #f)
|
||||
#f
|
||||
stronger-ribs
|
||||
chaperone?)))))
|
||||
#:opt #f
|
||||
#:stronger-ribs stronger-ribs
|
||||
#:chaperone chaperone?)))))
|
||||
|
||||
(syntax-case stx (or/c)
|
||||
[(or/c p ...)
|
||||
|
|
@ -152,16 +147,18 @@
|
|||
(blame (opt/info-blame opt/info))
|
||||
(this (opt/info-this opt/info))
|
||||
(that (opt/info-that opt/info)))
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(syntax (if (and (number? val) (<= n val m))
|
||||
val
|
||||
(raise-opt-between/c-error
|
||||
blame val n m)))
|
||||
lifts3
|
||||
null
|
||||
null
|
||||
(syntax (and (number? val) (<= n val m)))
|
||||
#f
|
||||
#:lifts lifts3
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat (syntax (and (number? val) (<= n val m)))
|
||||
#:opt #f
|
||||
#:stronger-ribs
|
||||
(list (new-stronger-var
|
||||
lift-low
|
||||
(λ (this that)
|
||||
|
|
@ -174,6 +171,7 @@
|
|||
(with-syntax ([this this]
|
||||
[that that])
|
||||
(syntax (<= this that))))))
|
||||
#:chaperone
|
||||
#t)))))]))
|
||||
|
||||
(define (raise-opt-between/c-error blame val lo hi)
|
||||
|
|
@ -195,23 +193,25 @@
|
|||
(blame (opt/info-blame opt/info))
|
||||
(this (opt/info-this opt/info))
|
||||
(that (opt/info-that opt/info)))
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(syntax
|
||||
(if (and (real? val) (comparison val m))
|
||||
val
|
||||
(raise-opt-single-comparison-opter-error blame val comparison m)))
|
||||
lifts3
|
||||
null
|
||||
null
|
||||
(syntax (and (number? val) (comparison val m)))
|
||||
#f
|
||||
#:lifts lifts3
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat (syntax (and (number? val) (comparison val m)))
|
||||
#:opt #f
|
||||
#:stronger-ribs
|
||||
(list (new-stronger-var
|
||||
lift-low
|
||||
(λ (this that)
|
||||
(with-syntax ([this this]
|
||||
[that that])
|
||||
(syntax (comparison this that))))))
|
||||
#t)))))))
|
||||
#:chaperone #t)))))))
|
||||
|
||||
(define (raise-opt-single-comparison-opter-error blame val comparison m)
|
||||
(raise-blame-error
|
||||
|
|
@ -286,18 +286,17 @@
|
|||
|
||||
(define/opter (cons/c opt/i opt/info stx)
|
||||
(define (opt/cons-ctc hdp tlp)
|
||||
(let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd hd-chaperone?)
|
||||
(opt/i opt/info hdp)]
|
||||
[(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl tl-chaperone?)
|
||||
(opt/i opt/info tlp)])
|
||||
(define optres-hd (opt/i opt/info hdp))
|
||||
(define optres-tl (opt/i opt/info tlp))
|
||||
(with-syntax ((check (with-syntax ((val (opt/info-val opt/info)))
|
||||
(syntax (pair? val)))))
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(blame (opt/info-blame opt/info))
|
||||
(next-hdp next-hdp)
|
||||
(next-tlp next-tlp))
|
||||
(next-hdp (optres-exp optres-hd))
|
||||
(next-tlp (optres-exp optres-tl)))
|
||||
(syntax (if check
|
||||
(cons (let ((val (car val))) next-hdp)
|
||||
(let ((val (cdr val))) next-tlp))
|
||||
|
|
@ -308,36 +307,42 @@
|
|||
(contract-name ctc)
|
||||
(given/produced blame)
|
||||
val))))
|
||||
(append lifts-hdp lifts-tlp)
|
||||
(append superlifts-hdp superlifts-tlp)
|
||||
(append partials-hdp partials-tlp)
|
||||
(if (and flat-hdp flat-tlp)
|
||||
#:lifts
|
||||
(append (optres-lifts optres-hd) (optres-lifts optres-tl))
|
||||
#:superlifts
|
||||
(append (optres-superlifts optres-hd) (optres-superlifts optres-tl))
|
||||
#:partials
|
||||
(append (optres-partials optres-hd) (optres-partials optres-tl))
|
||||
#:flat
|
||||
(if (and (optres-flat optres-hd) (optres-flat optres-tl))
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(flat-hdp flat-hdp)
|
||||
(flat-tlp flat-tlp))
|
||||
(flat-hdp (optres-flat optres-hd))
|
||||
(flat-tlp (optres-flat optres-tl)))
|
||||
(syntax (and check
|
||||
(let ((val (car val))) flat-hdp)
|
||||
(let ((val (cdr val))) flat-tlp))))
|
||||
#f)
|
||||
#f
|
||||
(append stronger-ribs-hd stronger-ribs-tl)
|
||||
(combine-two-chaperone?s hd-chaperone? tl-chaperone?)))))
|
||||
#:opt #f
|
||||
#:stronger-ribs
|
||||
(append (optres-stronger-ribs optres-hd) (optres-stronger-ribs optres-tl))
|
||||
#:chaperone
|
||||
(combine-two-chaperone?s (optres-chaperone optres-hd) (optres-chaperone optres-tl)))))
|
||||
|
||||
(syntax-case stx (cons/c)
|
||||
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
|
||||
|
||||
(define-for-syntax (opt/listof-ctc content non-empty? opt/i opt/info)
|
||||
(let-values ([(next lifts superlifts partials flat unknown stronger-ribs chaperone?)
|
||||
(opt/i opt/info content)])
|
||||
(define optres-ele (opt/i opt/info content))
|
||||
(with-syntax ([check (with-syntax ((val (opt/info-val opt/info)))
|
||||
(if non-empty?
|
||||
#'(and (list? val) (pair? val))
|
||||
#'(list? val)))]
|
||||
[val (opt/info-val opt/info)])
|
||||
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(with-syntax ([blame (opt/info-blame opt/info)]
|
||||
[next next])
|
||||
[next (optres-exp optres-ele)])
|
||||
(with-syntax ([(non-empty-check ...) (if non-empty?
|
||||
(list #'(pair? val))
|
||||
(list))])
|
||||
|
|
@ -350,12 +355,13 @@
|
|||
#,(if non-empty?
|
||||
"expected a non-empty list"
|
||||
"expected a list")))))
|
||||
lifts
|
||||
superlifts
|
||||
partials
|
||||
(if flat
|
||||
#:lifts (optres-lifts optres-ele)
|
||||
#:superlifts (optres-superlifts optres-ele)
|
||||
#:partials (optres-partials optres-ele)
|
||||
#:flat
|
||||
(if (optres-flat optres-ele)
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(flat flat))
|
||||
(flat (optres-flat optres-ele)))
|
||||
#`(and check
|
||||
#,@(if non-empty? (list #'(pair? val)) '())
|
||||
(let loop ([lst val])
|
||||
|
|
@ -366,9 +372,9 @@
|
|||
(and flat
|
||||
(loop (cdr lst))))]))))
|
||||
#f)
|
||||
#f
|
||||
stronger-ribs
|
||||
chaperone?))))
|
||||
#:opt #f
|
||||
#:stronger-ribs (optres-stronger-ribs optres-ele)
|
||||
#:chaperone (optres-chaperone optres-ele))))
|
||||
|
||||
(define/opter (listof opt/i opt/info stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -403,20 +409,19 @@
|
|||
stronger-ribs
|
||||
chaperone?)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
|
||||
(opt/i (opt/info-swap-blame opt/info) (car doms))])
|
||||
(define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(cons (with-syntax ((next (optres-exp optres-dom))
|
||||
(car-vars (car vars))
|
||||
(val (opt/info-val opt/info)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifts-doms lift)
|
||||
(append superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?)))]))]
|
||||
(append lifts-doms (optres-lifts optres-dom))
|
||||
(append superlifts-doms (optres-superlifts optres-dom))
|
||||
(append partials-doms (optres-partials optres-dom))
|
||||
(append (optres-stronger-ribs optres-dom) stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))]
|
||||
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?)
|
||||
(let loop ([vars rng-vars]
|
||||
[rngs rngs]
|
||||
|
|
@ -434,20 +439,19 @@
|
|||
stronger-ribs
|
||||
chaperone?)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
|
||||
(opt/i opt/info (car rngs))])
|
||||
(define optres-rng (opt/i opt/info (car rngs)))
|
||||
(loop (cdr vars)
|
||||
(cdr rngs)
|
||||
(cons (with-syntax ((next next)
|
||||
(cons (with-syntax ((next (optres-exp optres-rng))
|
||||
(car-vars (car vars))
|
||||
(val (opt/info-val opt/info)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-rngs)
|
||||
(append lifts-rngs lift)
|
||||
(append superlifts-rngs superlift)
|
||||
(append partials-rngs partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?)))]))])
|
||||
(append lifts-rngs (optres-lifts optres-rng))
|
||||
(append superlifts-rngs (optres-superlifts optres-rng))
|
||||
(append partials-rngs (optres-partials optres-rng))
|
||||
(append (optres-stronger-ribs optres-rng) stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone optres-rng)))]))])
|
||||
(values
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(blame (opt/info-blame opt/info))
|
||||
|
|
@ -499,19 +503,16 @@
|
|||
stronger-ribs
|
||||
chaperone?)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?)
|
||||
(opt/i (opt/info-swap-blame opt/info) (car doms))])
|
||||
(define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
(cons #`(let ([#,(opt/info-val opt/info) #,(car vars)]) #,(optres-exp optres-dom))
|
||||
next-doms)
|
||||
(append lifts-doms lift)
|
||||
(append superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?)))]))])
|
||||
(append lifts-doms (optres-lifts optres-dom))
|
||||
(append superlifts-doms (optres-superlifts optres-dom))
|
||||
(append partials-doms (optres-partials optres-dom))
|
||||
(append (optres-stronger-ribs optres-dom) stronger-ribs)
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))])
|
||||
(values
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
|
|
@ -536,45 +537,49 @@
|
|||
(syntax-case* stx (-> values any any/c) module-or-top-identifier=?
|
||||
[(-> any/c ... any)
|
||||
(with-syntax ([n (- (length (syntax->list stx)) 2)])
|
||||
(values
|
||||
(build-optres
|
||||
#:exp
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(blame (opt/info-blame opt/info)))
|
||||
(syntax (if (procedure-arity-includes? val n)
|
||||
val
|
||||
(raise-flat-arrow-err blame val n))))
|
||||
null
|
||||
null
|
||||
null
|
||||
#'(procedure-arity-includes? val n)
|
||||
#f
|
||||
null
|
||||
#t))]
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #'(procedure-arity-includes? val n)
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t))]
|
||||
[(-> dom ... (values rng ...))
|
||||
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
|
||||
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
|
||||
(let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?)
|
||||
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?)
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(syntax->list (syntax (rng ...))))])
|
||||
(if (eq? chaperone? #t)
|
||||
(values next lift superlift partial flat _ stronger-ribs chaperone?)
|
||||
(build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial
|
||||
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?)
|
||||
(opt/unknown opt/i opt/info stx))))]
|
||||
[(-> dom ... any)
|
||||
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
|
||||
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
|
||||
(let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?)
|
||||
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?)
|
||||
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))])
|
||||
(if (eq? chaperone? #t)
|
||||
(values next lift superlift partial flat _ stronger-ribs chaperone?)
|
||||
(build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial
|
||||
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?)
|
||||
(opt/unknown opt/i opt/info stx))))]
|
||||
[(-> dom ... rng)
|
||||
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
|
||||
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
|
||||
(let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?)
|
||||
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?)
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(list #'rng))])
|
||||
(if (eq? chaperone? #t)
|
||||
(values next lift superlift partial flat _ stronger-ribs chaperone?)
|
||||
(build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial
|
||||
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?)
|
||||
(opt/unknown opt/i opt/info stx))))]))
|
||||
|
||||
(define (raise-flat-arrow-err blame val n)
|
||||
|
|
|
|||
|
|
@ -795,17 +795,12 @@
|
|||
|
||||
(define sub-val (car (generate-temporaries '(struct/dc))))
|
||||
|
||||
(define-values (this-code
|
||||
this-lifts this-super-lifts this-partially-applied
|
||||
this-flat? this-can-be-optimized? this-stronger-ribs
|
||||
this-chaperone?)
|
||||
(opt/i (opt/info-change-val sub-val opt/info)
|
||||
exp))
|
||||
(define this-optres (opt/i (opt/info-change-val sub-val opt/info) exp))
|
||||
|
||||
(when dep-vars
|
||||
(for ([dep-var (in-list (syntax->list dep-vars))])
|
||||
(free-identifier-mapping-put! depended-on-fields dep-var #t)))
|
||||
(free-identifier-mapping-put! flat-fields sel-id this-flat?)
|
||||
(free-identifier-mapping-put! flat-fields sel-id (optres-flat this-optres))
|
||||
|
||||
(define this-body-code
|
||||
(cond
|
||||
|
|
@ -815,17 +810,17 @@
|
|||
[(dep-var ...) dep-vars])
|
||||
#`(let ([dep-var (sel #,(opt/info-val opt/info))] ...)
|
||||
#,(bind-superlifts
|
||||
this-super-lifts
|
||||
(optres-superlifts this-optres)
|
||||
(bind-lifts
|
||||
this-lifts
|
||||
(optres-lifts this-optres)
|
||||
(bind-lifts
|
||||
this-partially-applied
|
||||
this-code)))))]
|
||||
[else this-code]))
|
||||
(optres-partials this-optres)
|
||||
(optres-exp this-optres))))))]
|
||||
[else (optres-exp this-optres)]))
|
||||
|
||||
|
||||
(define this-chap-code
|
||||
(and (or (not this-flat?)
|
||||
(and (or (not (optres-flat this-optres))
|
||||
lazy?)
|
||||
(with-syntax ([proc-name (string->symbol
|
||||
(format "~a-~a-chap"
|
||||
|
|
@ -844,7 +839,7 @@
|
|||
proc-name))))))
|
||||
|
||||
(define this-fo-code
|
||||
(and (and this-flat?
|
||||
(and (and (optres-flat this-optres)
|
||||
(not lazy?))
|
||||
#`(let ([#,sub-val
|
||||
(#,(id->sel-id #'struct-id sel-id)
|
||||
|
|
@ -857,12 +852,12 @@
|
|||
(if this-chap-code
|
||||
(list* this-chap-code (id->sel-id #'struct-id sel-id) s-chap-code)
|
||||
s-chap-code)
|
||||
(if dep-vars s-lifts (append this-lifts s-lifts))
|
||||
(if dep-vars s-super-lifts (append this-super-lifts s-super-lifts))
|
||||
(if dep-vars s-partially-applied (append this-partially-applied s-partially-applied))
|
||||
(and this-can-be-optimized? can-be-optimized?)
|
||||
(if dep-vars stronger-ribs (append this-stronger-ribs stronger-ribs))
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?))))
|
||||
(if dep-vars s-lifts (append (optres-lifts this-optres) s-lifts))
|
||||
(if dep-vars s-super-lifts (append (optres-superlifts this-optres) s-super-lifts))
|
||||
(if dep-vars s-partially-applied (append (optres-partials this-optres) s-partially-applied))
|
||||
(and (optres-opt this-optres) can-be-optimized?)
|
||||
(if dep-vars stronger-ribs (append (optres-stronger-ribs this-optres) stronger-ribs))
|
||||
(combine-two-chaperone?s chaperone? (optres-chaperone this-optres)))))
|
||||
|
||||
;; to avoid having to deal with indy-ness, just give up if any
|
||||
;; of the fields that are depended on aren't flat
|
||||
|
|
@ -879,7 +874,9 @@
|
|||
[(free-var ...) (opt/info-free-vars opt/info)]
|
||||
[(index ...) (build-list (length (opt/info-free-vars opt/info)) values)]
|
||||
[pred? (list-ref info 2)])
|
||||
(values (if (null? s-chap-code) ;; if this is #t, when we have to avoid putting the property on here.
|
||||
(build-optres
|
||||
#:exp
|
||||
(if (null? s-chap-code) ;; if this is #t, when we have to avoid putting the property on here.
|
||||
#`(if (pred? #,(opt/info-val opt/info))
|
||||
(begin
|
||||
#,@s-fo-code
|
||||
|
|
@ -898,14 +895,16 @@
|
|||
stronger-prop-desc
|
||||
(vector free-var ...)))
|
||||
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))))
|
||||
#:lifts
|
||||
s-lifts
|
||||
#:superlifts
|
||||
s-super-lifts
|
||||
#:partials
|
||||
s-partially-applied
|
||||
#f ;; flat sexp
|
||||
can-be-optimized?
|
||||
stronger-ribs
|
||||
#t ;;chaperone?
|
||||
))]))]))
|
||||
#:flat #f
|
||||
#:opt can-be-optimized?
|
||||
#:stronger-ribs stronger-ribs
|
||||
#:chaperone #t))]))]))
|
||||
|
||||
(define (struct/dc-error blame obj what)
|
||||
(raise-blame-error blame obj
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user