suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactored contract opters so they return structs instead

Browse Source 
of (8!) multiple values
This commit is contained in:
Robby Findler 2012-05-08 11:29:14 -05:00
parent 4c59943b0d
commit 7221d01483
8 changed files with 480 additions and 617 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

151
collects/mzlib/private/contract-arrow.rkt
View File

@ -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 select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx 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)))]))

68
collects/racket/contract/private/basic-opters.rkt
View File

@ -12,20 +12,21 @@
;; ;;
(define-for-syntax (opt/pred opt/info pred) (define-for-syntax (opt/pred opt/info pred)
(with-syntax ((pred pred)) (with-syntax ((pred pred))
(values (build-optres
#:exp
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(blame (opt/info-blame opt/info))) (blame (opt/info-blame opt/info)))
(syntax (if (pred val) (syntax (if (pred val)
val val
(raise-opt/pred-error blame val 'pred)))) (raise-opt/pred-error blame val 'pred))))
null #:lifts null
null #:superlifts null
null #:partials null
(syntax (pred val)) #:flat (syntax (pred val))
#f #:opt #f
null #:stronger-ribs null
#t))) #:chaperone #t)))
(define (raise-opt/pred-error blame val pred-name) (define (raise-opt/pred-error blame val pred-name)
(raise-blame-error (raise-blame-error
@ -52,15 +53,15 @@
;; ;;
(define/opter (any/c opt/i opt/info stx) (define/opter (any/c opt/i opt/info stx)
(syntax-case stx (any/c) (syntax-case stx (any/c)
[any/c (values [any/c
(opt/info-val opt/info) (build-optres #:exp (opt/info-val opt/info)
null #:lifts null
null #:superlifts null
null #:partials null
#'#t #:flat #'#t
#f #:opt #f
null #:stronger-ribs null
#t)])) #:chaperone #t)]))
;; ;;
;; false/c ;; false/c
@ -86,26 +87,27 @@
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(blame (opt/info-blame opt/info)) (blame (opt/info-blame opt/info))
(lift-pred lift-pred)) (lift-pred lift-pred))
(values (build-optres
(syntax (if (lift-pred val) #:exp (syntax (if (lift-pred val)
val val
(raise-blame-error (raise-blame-error
blame blame
val val
"expected: ~s, ~a: ~e" "expected: ~s, ~a: ~e"
(contract-name ctc) (contract-name ctc)
(given/produced blame) (given/produced blame)
val))) val)))
#:lifts
(interleave-lifts (interleave-lifts
lift-vars lift-vars
(list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)] (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)]))) [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])))
null #:superlifts null
null #:partials null
(syntax (lift-pred val)) #:flat (syntax (lift-pred val))
#f #:opt #f
null #:stronger-ribs null
#t)))])) #:chaperone #t)))]))
;; ;;
;; flat-contract and friends ;; flat-contract and friends

41
collects/racket/contract/private/ds-helpers.rkt
View File

@ -147,15 +147,15 @@ which are then called when the contract's fields are explored
(and (identifier? #'f) (and (identifier? #'f)
(opt/info-recf opt/info) (opt/info-recf opt/info)
(free-identifier=? (opt/info-recf opt/info) #'f)) (free-identifier=? (opt/info-recf opt/info) #'f))
(values (build-optres
#`(f #,id arg ...) #:exp #`(f #,id arg ...)
null #:lifts null
null #:superlifts null
null #:partials null
#f #:flat #f
#f #:opt #f
null #:stronger-ribs null
#f)] #:chaperone #f)]
[else (opt/i (opt/info-change-val id opt/info) [else (opt/i (opt/info-change-val id opt/info)
stx)])) stx)]))
@ -193,8 +193,7 @@ which are then called when the contract's fields are explored
[(id (x ...) ctc-exp) [(id (x ...) ctc-exp)
(and (identifier? (syntax id)) (and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...))))) (andmap identifier? (syntax->list (syntax (x ...)))))
(let*-values ([(next lifts superlifts partials _ _2 _3 chaperone?) (let*-values ([(an-optres) (opt/enforcer-clause let-var (syntax ctc-exp))]
(opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg) [(maker-arg)
(with-syntax ([val (opt/info-val opt/info)] (with-syntax ([val (opt/info-val opt/info)]
[(new-let-bindings ...) [(new-let-bindings ...)
@ -204,11 +203,12 @@ which are then called when the contract's fields are explored
arglist)]) arglist)])
#`(#,let-var #`(#,let-var
#,(bind-lifts #,(bind-lifts
superlifts (optres-superlifts an-optres)
#`(let (new-let-bindings ...) #`(let (new-let-bindings ...)
#,(bind-lifts #,(bind-lifts
(append lifts partials) (append (optres-lifts an-optres)
next)))))]) (optres-partials an-optres))
(optres-exp an-optres))))))])
(loop (cdr clauses) (loop (cdr clauses)
(cdr let-vars) (cdr let-vars)
(cdr arglists) (cdr arglists)
@ -227,23 +227,22 @@ which are then called when the contract's fields are explored
(syntax->list (syntax (x ...)))))] (syntax->list (syntax (x ...)))))]
[(id ctc-exp) [(id ctc-exp)
(identifier? (syntax id)) (identifier? (syntax id))
(let*-values ([(next lifts superlifts partials _ __ stronger-ribs chaperone?) (let*-values ([(an-optres) (opt/enforcer-clause let-var (syntax ctc-exp))]
(opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg) [(maker-arg)
(with-syntax ((val (opt/info-val opt/info))) (with-syntax ((val (opt/info-val opt/info)))
#`(#,let-var #`(#,let-var
#,(bind-lifts #,(bind-lifts
partials (optres-partials an-optres)
next)))]) (optres-exp an-optres))))])
(loop (cdr clauses) (loop (cdr clauses)
(cdr let-vars) (cdr let-vars)
(cdr arglists) (cdr arglists)
(cdr ac-ids) (cdr ac-ids)
(cons (car ac-ids) prior-ac-ids) (cons (car ac-ids) prior-ac-ids)
(cons maker-arg maker-args) (cons maker-arg maker-args)
(append lifts-ps lifts) (append lifts-ps (optres-lifts an-optres))
(append superlifts-ps superlifts) (append superlifts-ps (optres-superlifts an-optres))
(append stronger-ribs-ps stronger-ribs)))] (append stronger-ribs-ps (optres-stronger-ribs an-optres))))]
[(id ctc-exp) [(id ctc-exp)
(raise-syntax-error name "expected identifier" stx (syntax id))]))])))) (raise-syntax-error name "expected identifier" stx (syntax id))]))]))))

19
collects/racket/contract/private/ds.rkt
View File

@ -427,7 +427,8 @@ it around flattened out.
(cons contract/info-var (cons contract/info-var
(syntax (syntax
(make-opt-contract/info ctc enforcer-id id))))]) (make-opt-contract/info ctc enforcer-id id))))])
(values (build-optres
#:exp
(syntax (syntax
(cond (cond
[(opt-wrap-predicate val) [(opt-wrap-predicate val)
@ -462,15 +463,13 @@ it around flattened out.
(contract-name ctc) (contract-name ctc)
(given/produced blame) (given/produced blame)
val)])) val)]))
lifts #:lifts lifts
superlifts #:superlifts superlifts
partials #:partials partials
#f #:flat #f
#f #:opt #f
stronger-ribs #:stronger-ribs stronger-ribs
;; opt'd struct contracts don't use chaperones yet #:chaperone #f)))))))])))))))
#f)))))))]))
)))))
(define-syntax (define-contract-struct stx) (define-syntax (define-contract-struct stx)
(syntax-case stx () (syntax-case stx ()

79
collects/racket/contract/private/opt-guts.rkt
View File

@ -23,7 +23,81 @@
opt/info-change-val opt/info-change-val
opt/unknown 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 ;; a hash table of opters
(define opters-table (define opters-table
@ -169,7 +243,7 @@
[val (opt/info-val opt/info)] [val (opt/info-val opt/info)]
[uctc uctc] [uctc uctc]
[blame (opt/info-blame opt/info)]) [blame (opt/info-blame opt/info)])
(values (optres
#'(partial-var val) #'(partial-var val)
(list (cons #'lift-var (list (cons #'lift-var
#'(coerce-contract 'opt/c uctc))) #'(coerce-contract 'opt/c uctc)))
@ -200,4 +274,3 @@
(and chaperone-b? chaperone-a?)] (and chaperone-b? chaperone-a?)]
[else [else
#`(and #,chaperone-a? #,chaperone-b?)])) #`(and #,chaperone-a? #,chaperone-b?)]))

249
collects/racket/contract/private/opt.rkt
View File

@ -11,45 +11,6 @@
opt/direct opt/direct
begin-lifted) 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) (define-syntax (define/opter stx)
(syntax-case stx () (syntax-case stx ()
[(_ (for opt/i opt/info stx) expr ...) [(_ (for opt/i opt/info stx) expr ...)
@ -66,23 +27,20 @@
;; ;;
;; opt/recursive-call ;; 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) (define-for-syntax (opt/recursive-call opt/info stx)
(values (build-optres
(with-syntax ((stx stx) #:exp (with-syntax ((stx stx)
(val (opt/info-val opt/info)) (val (opt/info-val opt/info))
(blame (opt/info-blame opt/info))) (blame (opt/info-blame opt/info)))
(syntax (let ((ctc stx)) (syntax (let ((ctc stx))
(((contract-projection ctc) blame) val)))) (((contract-projection ctc) blame) val))))
null #:lifts null
null #:superlifts null
null #:partials null
#f #:flat #f
#f #:opt #f
null #:stronger-ribs null
null)) #:chaperone null))
;; make-stronger : list-of-(union syntax #f) -> syntax ;; make-stronger : list-of-(union syntax #f) -> syntax
(define-for-syntax (make-stronger strongers) (define-for-syntax (make-stronger strongers)
@ -122,17 +80,18 @@
[(number? konst) [(number? konst)
(values #`(and (number? #,v) (= #,konst #,v)) (values #`(and (number? #,v) (= #,konst #,v))
"=")])) "=")]))
(values (build-optres
#:exp
#`(if #,predicate #`(if #,predicate
#,v #,v
(opt-constant-contract-failure #,(opt/info-blame opt/info) #,v #,word #,konst)) (opt-constant-contract-failure #,(opt/info-blame opt/info) #,v #,word #,konst))
null #:lifts null
null #:superlifts null
null #:partials null
predicate #:flat predicate
#f #:opt #f
null #:stronger-ribs null
#t)) #:chaperone #t))
(define (opt-constant-contract-failure blame val compare should-be) (define (opt-constant-contract-failure blame val compare should-be)
(raise-blame-error blame val "expected a value ~a to ~e" 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 -> ;; opt/i : id opt/info syntax ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) ;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
(define-for-syntax (opt/i opt/info stx) (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 () (syntax-case stx ()
[(ctc arg ...) [(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc)) (and (identifier? #'ctc) (opter #'ctc))
@ -155,19 +114,20 @@
[(f arg ...) [(f arg ...)
(and (identifier? #'f) (and (identifier? #'f)
(define-opt/recursive-fn? (syntax-local-value #'f (λ () #f)))) (define-opt/recursive-fn? (syntax-local-value #'f (λ () #f))))
(values (build-optres
#:exp
#`(#,(define-opt/recursive-fn-internal-fn (syntax-local-value #'f)) #`(#,(define-opt/recursive-fn-internal-fn (syntax-local-value #'f))
#,(opt/info-contract opt/info) #,(opt/info-contract opt/info)
#,(opt/info-blame opt/info) #,(opt/info-blame opt/info)
#,(opt/info-val opt/info) #,(opt/info-val opt/info)
arg ...) arg ...)
null #:lifts null
null #:superlifts null
null #:partials null
#f #:flat #f
#f #:opt #f
null #:stronger-ribs null
#t)] #:chaperone #t)]
[konst [konst
(coerecable-constant? #'konst) (coerecable-constant? #'konst)
(opt-constant-contract (syntax->datum #'konst) opt/info)] (opt-constant-contract (syntax->datum #'konst) opt/info)]
@ -201,32 +161,24 @@
(define-syntax (opt/c stx) (define-syntax (opt/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ e) [(_ e)
(let*-values ([(info) (make-opt/info #'ctc (let ()
#'val (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
#'blame (define an-optres (opt/i info #'e))
#f (bind-superlifts
'() (optres-superlifts an-optres)
#f (bind-lifts
#f (optres-lifts an-optres)
#'this #`(make-opt-contract
#'that)] (λ (ctc)
[(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)]) (λ (blame)
(with-syntax ([next next]) #,(bind-superlifts
(bind-superlifts (optres-partials an-optres)
superlifts #`(λ (val) #,(optres-exp an-optres)))))
(bind-lifts (λ () e)
lifts (λ (this that) #f)
#`(make-opt-contract (vector)
(λ (ctc) (begin-lifted (box #f))
(λ (blame) #,(optres-chaperone an-optres)))))]))
#,(bind-superlifts
partials
#`(λ (val) next))))
(λ () e)
(λ (this that) #f)
(vector)
(begin-lifted (box #f))
#,chaperone?)))))]))
;; this macro optimizes 'e' as a contract, ;; this macro optimizes 'e' as a contract,
;; using otherwise-id if it does not recognize 'e'. ;; using otherwise-id if it does not recognize 'e'.
@ -234,28 +186,21 @@
(syntax-case stx () (syntax-case stx ()
[(_ e val-e blame-e otherwise-id) [(_ e val-e blame-e otherwise-id)
(identifier? #'otherwise-id) (identifier? #'otherwise-id)
(if (top-level-unknown? #'e) (cond
#'(otherwise-id e val-e blame-e) [(top-level-unknown? #'e) #'(otherwise-id e val-e blame-e)]
(let*-values ([(info) (make-opt/info #'ctc [else
#'val (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
#'blame (define an-optres (opt/i info #'e))
#f #`(let ([ctc e] ;;; hm... what to do about this?!
'() [val val-e]
#f [blame blame-e])
#f #,(bind-superlifts
#'this (optres-superlifts an-optres)
#'that)] (bind-lifts
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) (optres-lifts an-optres)
#`(let ([ctc e] ;;; hm... what to do about this?! (bind-superlifts
[val val-e] (optres-partials an-optres)
[blame blame-e]) (optres-exp an-optres)))))])]))
#,(bind-superlifts
superlifts
(bind-lifts
lifts
(bind-superlifts
partials
next))))))]))
(define-syntax (begin-lifted stx) (define-syntax (begin-lifted stx)
(syntax-case stx () (syntax-case stx ()
@ -285,42 +230,34 @@
(define-syntax (opt/c-helper stx) (define-syntax (opt/c-helper stx)
(syntax-case stx () (syntax-case stx ()
[(_ f1 f2 (id args ...) e) [(_ f1 f2 (id args ...) e)
(let*-values ([(info) (make-opt/info #'ctc (let ()
#'val (define info (make-opt/info #'ctc #'val #'blame #f (syntax->list #'(args ...)) #f #f #'this #'that))
#'blame (define an-optres (opt/i info #'e))
#f #`(let ()
(syntax->list #'(args ...)) (define (f2 ctc blame val args ...)
#f #,(bind-superlifts
#f (optres-superlifts an-optres)
#'this (bind-lifts
#'that)] (optres-lifts an-optres)
[(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)]) (bind-superlifts
(with-syntax ([next next]) (optres-partials an-optres)
#`(let () (optres-exp an-optres)))))
(define (f2 ctc blame val args ...) (define (f1 args ...)
#,(bind-superlifts #,(bind-superlifts
superlifts (optres-superlifts an-optres)
(bind-lifts (bind-lifts
lifts (optres-lifts an-optres)
(bind-superlifts #`(make-opt-contract
partials (λ (ctc)
#'next)))) (λ (blame)
(define (f1 args ...) (λ (val)
#,(bind-superlifts (f2 ctc blame val args ...))))
superlifts (λ () e)
(bind-lifts (λ (this that) #f)
lifts (vector)
#`(make-opt-contract (begin-lifted (box #f))
(λ (ctc) #,(optres-chaperone an-optres)))))
(λ (blame) (values f1 f2)))]))
(λ (val)
(f2 ctc blame val args ...))))
(λ () e)
(λ (this that) #f)
(vector)
(begin-lifted (box #f))
#,chaperone?))))
(values f1 f2))))]))
;; optimized contracts ;; optimized contracts
;; ;;

399
collects/racket/contract/private/opters.rkt
View File

@ -18,24 +18,18 @@
(partial-var (car (generate-temporaries (syntax (partial)))))) (partial-var (car (generate-temporaries (syntax (partial))))))
(values (values
(with-syntax ((partial-var partial-var) (with-syntax ((partial-var partial-var)
(lift-var lift-var)
(uctc uctc)
(val (opt/info-val opt/info))) (val (opt/info-val opt/info)))
(syntax (partial-var val))) (syntax (partial-var val)))
(list (cons lift-var (list (cons lift-var
;; FIXME needs to get the contract name somehow ;; FIXME needs to get the contract name somehow
(with-syntax ((uctc uctc)) (with-syntax ((uctc uctc))
(syntax (coerce-contract 'opt/c uctc))))) (syntax (coerce-contract 'opt/c uctc)))))
null '()
(list (cons (list (cons
partial-var partial-var
(with-syntax ((lift-var lift-var) (with-syntax ((lift-var lift-var)
(blame (opt/info-blame opt/info))) (blame (opt/info-blame opt/info)))
(syntax ((contract-projection lift-var) blame))))) (syntax ((contract-projection lift-var) blame))))))))
#f
lift-var
(list #f)
null)))
(define (opt/or-ctc ps) (define (opt/or-ctc ps)
(let ((lift-from-hos null) (let ((lift-from-hos null)
@ -61,41 +55,41 @@
ho-ctc ho-ctc
chaperone?)] chaperone?)]
[else [else
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?) (define ps-optres (opt/i opt/info (car ps)))
(opt/i opt/info (car ps))]) (if (optres-flat ps-optres)
(if flat (loop (cdr ps)
(loop (cdr ps) (cons (optres-flat ps-optres) next-ps)
(cons flat next-ps) (append lift-ps (optres-lifts ps-optres))
(append lift-ps lift) (append superlift-ps (optres-superlifts ps-optres))
(append superlift-ps superlift) (append partial-ps (optres-partials ps-optres))
(append partial-ps partial) (append (optres-stronger-ribs ps-optres) stronger-ribs)
(append this-stronger-ribs stronger-ribs) hos
hos ho-ctc
ho-ctc (combine-two-chaperone?s chaperone? (optres-chaperone ps-optres)))
(combine-two-chaperone?s chaperone? this-chaperone?)) (if (< (length hos) 1)
(if (< (length hos) 1) (loop (cdr ps)
(loop (cdr ps) next-ps
next-ps (append lift-ps (optres-lifts ps-optres))
(append lift-ps lift) (append superlift-ps (optres-superlifts ps-optres))
(append superlift-ps superlift) (append partial-ps (optres-partials ps-optres))
(append partial-ps partial) (append (optres-stronger-ribs ps-optres) stronger-ribs)
(append this-stronger-ribs stronger-ribs) (cons (car ps) hos)
(cons (car ps) hos) (optres-exp ps-optres)
next (combine-two-chaperone?s chaperone? (optres-chaperone ps-optres)))
(combine-two-chaperone?s chaperone? this-chaperone?)) (loop (cdr ps)
(loop (cdr ps) next-ps
next-ps lift-ps
lift-ps superlift-ps
superlift-ps partial-ps
partial-ps stronger-ribs
stronger-ribs (cons (car ps) hos)
(cons (car ps) hos) ho-ctc
ho-ctc chaperone?)))]))])
chaperone?))))]))])
(with-syntax ((next-ps (with-syntax ((next-ps
(with-syntax (((opt-p ...) (reverse opt-ps))) (with-syntax (((opt-p ...) (reverse opt-ps)))
(syntax (or opt-p ...))))) (syntax (or opt-p ...)))))
(values (build-optres
#:exp
(cond (cond
[(null? hos) [(null? hos)
(with-syntax ([val (opt/info-val opt/info)] (with-syntax ([val (opt/info-val opt/info)]
@ -113,21 +107,22 @@
(if next-ps val ho-ctc)))] (if next-ps val ho-ctc)))]
;; FIXME something's not right with this case. ;; FIXME something's not right with this case.
[(> (length hos) 1) [(> (length hos) 1)
(let-values ([(next-hos lift-hos superlift-hos partial-hos _ __ stronger-hos stronger-vars-hos) (define-values (exp new-lifts new-superlifts new-partials) (opt/or-unknown stx))
(opt/or-unknown stx)]) (set! lift-from-hos new-lifts)
(set! lift-from-hos lift-hos) (set! superlift-from-hos new-superlifts)
(set! superlift-from-hos superlift-hos) (set! partial-from-hos new-partials)
(set! partial-from-hos partial-hos) #`(if next-ps val #,exp)])
(with-syntax ((next-hos next-hos)) #:lifts
(syntax
(if next-ps val next-hos))))])
(append lift-ps lift-from-hos) (append lift-ps lift-from-hos)
#:superlifts
(append superlift-ps superlift-from-hos) (append superlift-ps superlift-from-hos)
#:partials
(append partial-ps partial-from-hos) (append partial-ps partial-from-hos)
#:flat
(if (null? hos) (syntax next-ps) #f) (if (null? hos) (syntax next-ps) #f)
#f #:opt #f
stronger-ribs #:stronger-ribs stronger-ribs
chaperone?))))) #:chaperone chaperone?)))))
(syntax-case stx (or/c) (syntax-case stx (or/c)
[(or/c p ...) [(or/c p ...)
@ -152,16 +147,18 @@
(blame (opt/info-blame opt/info)) (blame (opt/info-blame opt/info))
(this (opt/info-this opt/info)) (this (opt/info-this opt/info))
(that (opt/info-that opt/info))) (that (opt/info-that opt/info)))
(values (build-optres
#:exp
(syntax (if (and (number? val) (<= n val m)) (syntax (if (and (number? val) (<= n val m))
val val
(raise-opt-between/c-error (raise-opt-between/c-error
blame val n m))) blame val n m)))
lifts3 #:lifts lifts3
null #:superlifts null
null #:partials null
(syntax (and (number? val) (<= n val m))) #:flat (syntax (and (number? val) (<= n val m)))
#f #:opt #f
#:stronger-ribs
(list (new-stronger-var (list (new-stronger-var
lift-low lift-low
(λ (this that) (λ (this that)
@ -174,6 +171,7 @@
(with-syntax ([this this] (with-syntax ([this this]
[that that]) [that that])
(syntax (<= this that)))))) (syntax (<= this that))))))
#:chaperone
#t)))))])) #t)))))]))
(define (raise-opt-between/c-error blame val lo hi) (define (raise-opt-between/c-error blame val lo hi)
@ -195,23 +193,25 @@
(blame (opt/info-blame opt/info)) (blame (opt/info-blame opt/info))
(this (opt/info-this opt/info)) (this (opt/info-this opt/info))
(that (opt/info-that opt/info))) (that (opt/info-that opt/info)))
(values (build-optres
#:exp
(syntax (syntax
(if (and (real? val) (comparison val m)) (if (and (real? val) (comparison val m))
val val
(raise-opt-single-comparison-opter-error blame val comparison m))) (raise-opt-single-comparison-opter-error blame val comparison m)))
lifts3 #:lifts lifts3
null #:superlifts null
null #:partials null
(syntax (and (number? val) (comparison val m))) #:flat (syntax (and (number? val) (comparison val m)))
#f #:opt #f
#:stronger-ribs
(list (new-stronger-var (list (new-stronger-var
lift-low lift-low
(λ (this that) (λ (this that)
(with-syntax ([this this] (with-syntax ([this this]
[that that]) [that that])
(syntax (comparison this that)))))) (syntax (comparison this that))))))
#t))))))) #:chaperone #t)))))))
(define (raise-opt-single-comparison-opter-error blame val comparison m) (define (raise-opt-single-comparison-opter-error blame val comparison m)
(raise-blame-error (raise-blame-error
@ -286,89 +286,95 @@
(define/opter (cons/c opt/i opt/info stx) (define/opter (cons/c opt/i opt/info stx)
(define (opt/cons-ctc hdp tlp) (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?) (define optres-hd (opt/i opt/info hdp))
(opt/i opt/info hdp)] (define optres-tl (opt/i opt/info tlp))
[(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl tl-chaperone?) (with-syntax ((check (with-syntax ((val (opt/info-val opt/info)))
(opt/i opt/info tlp)]) (syntax (pair? val)))))
(with-syntax ((check (with-syntax ((val (opt/info-val opt/info))) (build-optres
(syntax (pair? val))))) #:exp
(values (with-syntax ((val (opt/info-val opt/info))
(with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info))
(ctc (opt/info-contract opt/info)) (blame (opt/info-blame opt/info))
(blame (opt/info-blame opt/info)) (next-hdp (optres-exp optres-hd))
(next-hdp next-hdp) (next-tlp (optres-exp optres-tl)))
(next-tlp next-tlp)) (syntax (if check
(syntax (if check (cons (let ((val (car val))) next-hdp)
(cons (let ((val (car val))) next-hdp) (let ((val (cdr val))) next-tlp))
(let ((val (cdr val))) next-tlp)) (raise-blame-error
(raise-blame-error blame
blame val
val "expected: ~s, ~a: ~e"
"expected: ~s, ~a: ~e" (contract-name ctc)
(contract-name ctc) (given/produced blame)
(given/produced blame) val))))
val)))) #:lifts
(append lifts-hdp lifts-tlp) (append (optres-lifts optres-hd) (optres-lifts optres-tl))
(append superlifts-hdp superlifts-tlp) #:superlifts
(append partials-hdp partials-tlp) (append (optres-superlifts optres-hd) (optres-superlifts optres-tl))
(if (and flat-hdp flat-tlp) #:partials
(with-syntax ((val (opt/info-val opt/info)) (append (optres-partials optres-hd) (optres-partials optres-tl))
(flat-hdp flat-hdp) #:flat
(flat-tlp flat-tlp)) (if (and (optres-flat optres-hd) (optres-flat optres-tl))
(syntax (and check (with-syntax ((val (opt/info-val opt/info))
(let ((val (car val))) flat-hdp) (flat-hdp (optres-flat optres-hd))
(let ((val (cdr val))) flat-tlp)))) (flat-tlp (optres-flat optres-tl)))
#f) (syntax (and check
#f (let ((val (car val))) flat-hdp)
(append stronger-ribs-hd stronger-ribs-tl) (let ((val (cdr val))) flat-tlp))))
(combine-two-chaperone?s hd-chaperone? tl-chaperone?))))) #f)
#: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) (syntax-case stx (cons/c)
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)])) [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
(define-for-syntax (opt/listof-ctc content non-empty? opt/i opt/info) (define-for-syntax (opt/listof-ctc content non-empty? opt/i opt/info)
(let-values ([(next lifts superlifts partials flat unknown stronger-ribs chaperone?) (define optres-ele (opt/i opt/info content))
(opt/i opt/info content)]) (with-syntax ([check (with-syntax ((val (opt/info-val opt/info)))
(with-syntax ([check (with-syntax ((val (opt/info-val opt/info))) (if non-empty?
(if non-empty? #'(and (list? val) (pair? val))
#'(and (list? val) (pair? val)) #'(list? val)))]
#'(list? val)))] [val (opt/info-val opt/info)])
[val (opt/info-val opt/info)])
(build-optres
(values #:exp
(with-syntax ([blame (opt/info-blame opt/info)] (with-syntax ([blame (opt/info-blame opt/info)]
[next next]) [next (optres-exp optres-ele)])
(with-syntax ([(non-empty-check ...) (if non-empty? (with-syntax ([(non-empty-check ...) (if non-empty?
(list #'(pair? val)) (list #'(pair? val))
(list))]) (list))])
#`(if check #`(if check
(for/list ([val (in-list val)]) (for/list ([val (in-list val)])
next) next)
(raise-blame-error (raise-blame-error
blame blame
val val
#,(if non-empty? #,(if non-empty?
"expected a non-empty list" "expected a non-empty list"
"expected a list"))))) "expected a list")))))
lifts #:lifts (optres-lifts optres-ele)
superlifts #:superlifts (optres-superlifts optres-ele)
partials #:partials (optres-partials optres-ele)
(if flat #:flat
(with-syntax ((val (opt/info-val opt/info)) (if (optres-flat optres-ele)
(flat flat)) (with-syntax ((val (opt/info-val opt/info))
#`(and check (flat (optres-flat optres-ele)))
#,@(if non-empty? (list #'(pair? val)) '()) #`(and check
(let loop ([lst val]) #,@(if non-empty? (list #'(pair? val)) '())
(cond (let loop ([lst val])
[(null? lst) #t] (cond
[else [(null? lst) #t]
(let ([val (car lst)]) [else
(and flat (let ([val (car lst)])
(loop (cdr lst))))])))) (and flat
#f) (loop (cdr lst))))]))))
#f #f)
stronger-ribs #:opt #f
chaperone?)))) #:stronger-ribs (optres-stronger-ribs optres-ele)
#:chaperone (optres-chaperone optres-ele))))
(define/opter (listof opt/i opt/info stx) (define/opter (listof opt/i opt/info stx)
(syntax-case stx () (syntax-case stx ()
@ -403,20 +409,19 @@
stronger-ribs stronger-ribs
chaperone?)] chaperone?)]
[else [else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?) (define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
(opt/i (opt/info-swap-blame opt/info) (car doms))]) (loop (cdr vars)
(loop (cdr vars) (cdr doms)
(cdr doms) (cons (with-syntax ((next (optres-exp optres-dom))
(cons (with-syntax ((next next) (car-vars (car vars))
(car-vars (car vars)) (val (opt/info-val opt/info)))
(val (opt/info-val opt/info))) (syntax (let ((val car-vars)) next)))
(syntax (let ((val car-vars)) next))) next-doms)
next-doms) (append lifts-doms (optres-lifts optres-dom))
(append lifts-doms lift) (append superlifts-doms (optres-superlifts optres-dom))
(append superlifts-doms superlift) (append partials-doms (optres-partials optres-dom))
(append partials-doms partial) (append (optres-stronger-ribs optres-dom) stronger-ribs)
(append this-stronger-ribs stronger-ribs) (combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))]
(combine-two-chaperone?s chaperone? this-chaperone?)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?) [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?)
(let loop ([vars rng-vars] (let loop ([vars rng-vars]
[rngs rngs] [rngs rngs]
@ -434,20 +439,19 @@
stronger-ribs stronger-ribs
chaperone?)] chaperone?)]
[else [else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?) (define optres-rng (opt/i opt/info (car rngs)))
(opt/i opt/info (car rngs))]) (loop (cdr vars)
(loop (cdr vars) (cdr rngs)
(cdr rngs) (cons (with-syntax ((next (optres-exp optres-rng))
(cons (with-syntax ((next next) (car-vars (car vars))
(car-vars (car vars)) (val (opt/info-val opt/info)))
(val (opt/info-val opt/info))) (syntax (let ((val car-vars)) next)))
(syntax (let ((val car-vars)) next))) next-rngs)
next-rngs) (append lifts-rngs (optres-lifts optres-rng))
(append lifts-rngs lift) (append superlifts-rngs (optres-superlifts optres-rng))
(append superlifts-rngs superlift) (append partials-rngs (optres-partials optres-rng))
(append partials-rngs partial) (append (optres-stronger-ribs optres-rng) stronger-ribs)
(append this-stronger-ribs stronger-ribs) (combine-two-chaperone?s chaperone? (optres-chaperone optres-rng)))]))])
(combine-two-chaperone?s chaperone? this-chaperone?)))]))])
(values (values
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(blame (opt/info-blame opt/info)) (blame (opt/info-blame opt/info))
@ -499,19 +503,16 @@
stronger-ribs stronger-ribs
chaperone?)] chaperone?)]
[else [else
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?) (define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
(opt/i (opt/info-swap-blame opt/info) (car doms))]) (loop (cdr vars)
(loop (cdr vars) (cdr doms)
(cdr doms) (cons #`(let ([#,(opt/info-val opt/info) #,(car vars)]) #,(optres-exp optres-dom))
(cons (with-syntax ((next next) next-doms)
(car-vars (car vars))) (append lifts-doms (optres-lifts optres-dom))
(syntax (let ((val car-vars)) next))) (append superlifts-doms (optres-superlifts optres-dom))
next-doms) (append partials-doms (optres-partials optres-dom))
(append lifts-doms lift) (append (optres-stronger-ribs optres-dom) stronger-ribs)
(append superlifts-doms superlift) (combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))])
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)
(combine-two-chaperone?s chaperone? this-chaperone?)))]))])
(values (values
(with-syntax ((blame (opt/info-blame opt/info)) (with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
@ -536,45 +537,49 @@
(syntax-case* stx (-> values any any/c) module-or-top-identifier=? (syntax-case* stx (-> values any any/c) module-or-top-identifier=?
[(-> any/c ... any) [(-> any/c ... any)
(with-syntax ([n (- (length (syntax->list stx)) 2)]) (with-syntax ([n (- (length (syntax->list stx)) 2)])
(values (build-optres
#:exp
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(blame (opt/info-blame opt/info))) (blame (opt/info-blame opt/info)))
(syntax (if (procedure-arity-includes? val n) (syntax (if (procedure-arity-includes? val n)
val val
(raise-flat-arrow-err blame val n)))) (raise-flat-arrow-err blame val n))))
null #:lifts null
null #:superlifts null
null #:partials null
#'(procedure-arity-includes? val n) #:flat #'(procedure-arity-includes? val n)
#f #:opt #f
null #:stronger-ribs null
#t))] #:chaperone #t))]
[(-> dom ... (values rng ...)) [(-> dom ... (values rng ...))
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) (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/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 ...))) (opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...))))]) (syntax->list (syntax (rng ...))))])
(if (eq? chaperone? #t) (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))))] (opt/unknown opt/i opt/info stx))))]
[(-> dom ... any) [(-> dom ... any)
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) (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/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 ...))))]) (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))])
(if (eq? chaperone? #t) (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))))] (opt/unknown opt/i opt/info stx))))]
[(-> dom ... rng) [(-> dom ... rng)
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) (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/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 ...))) (opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))]) (list #'rng))])
(if (eq? chaperone? #t) (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))))])) (opt/unknown opt/i opt/info stx))))]))
(define (raise-flat-arrow-err blame val n) (define (raise-flat-arrow-err blame val n)

91
collects/racket/contract/private/struct-dc.rkt
View File

@ -795,17 +795,12 @@
(define sub-val (car (generate-temporaries '(struct/dc)))) (define sub-val (car (generate-temporaries '(struct/dc))))
(define-values (this-code (define this-optres (opt/i (opt/info-change-val sub-val opt/info) exp))
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))
(when dep-vars (when dep-vars
(for ([dep-var (in-list (syntax->list 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! 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 (define this-body-code
(cond (cond
@ -815,17 +810,17 @@
[(dep-var ...) dep-vars]) [(dep-var ...) dep-vars])
#`(let ([dep-var (sel #,(opt/info-val opt/info))] ...) #`(let ([dep-var (sel #,(opt/info-val opt/info))] ...)
#,(bind-superlifts #,(bind-superlifts
this-super-lifts (optres-superlifts this-optres)
(bind-lifts (bind-lifts
this-lifts (optres-lifts this-optres)
(bind-lifts (bind-lifts
this-partially-applied (optres-partials this-optres)
this-code)))))] (optres-exp this-optres))))))]
[else this-code])) [else (optres-exp this-optres)]))
(define this-chap-code (define this-chap-code
(and (or (not this-flat?) (and (or (not (optres-flat this-optres))
lazy?) lazy?)
(with-syntax ([proc-name (string->symbol (with-syntax ([proc-name (string->symbol
(format "~a-~a-chap" (format "~a-~a-chap"
@ -844,7 +839,7 @@
proc-name)))))) proc-name))))))
(define this-fo-code (define this-fo-code
(and (and this-flat? (and (and (optres-flat this-optres)
(not lazy?)) (not lazy?))
#`(let ([#,sub-val #`(let ([#,sub-val
(#,(id->sel-id #'struct-id sel-id) (#,(id->sel-id #'struct-id sel-id)
@ -857,12 +852,12 @@
(if this-chap-code (if this-chap-code
(list* this-chap-code (id->sel-id #'struct-id sel-id) s-chap-code) (list* this-chap-code (id->sel-id #'struct-id sel-id) s-chap-code)
s-chap-code) s-chap-code)
(if dep-vars s-lifts (append this-lifts s-lifts)) (if dep-vars s-lifts (append (optres-lifts this-optres) s-lifts))
(if dep-vars s-super-lifts (append this-super-lifts s-super-lifts)) (if dep-vars s-super-lifts (append (optres-superlifts this-optres) s-super-lifts))
(if dep-vars s-partially-applied (append this-partially-applied s-partially-applied)) (if dep-vars s-partially-applied (append (optres-partials this-optres) s-partially-applied))
(and this-can-be-optimized? can-be-optimized?) (and (optres-opt this-optres) can-be-optimized?)
(if dep-vars stronger-ribs (append this-stronger-ribs stronger-ribs)) (if dep-vars stronger-ribs (append (optres-stronger-ribs this-optres) stronger-ribs))
(combine-two-chaperone?s chaperone? this-chaperone?)))) (combine-two-chaperone?s chaperone? (optres-chaperone this-optres)))))
;; to avoid having to deal with indy-ness, just give up if any ;; to avoid having to deal with indy-ness, just give up if any
;; of the fields that are depended on aren't flat ;; of the fields that are depended on aren't flat
@ -879,33 +874,37 @@
[(free-var ...) (opt/info-free-vars opt/info)] [(free-var ...) (opt/info-free-vars opt/info)]
[(index ...) (build-list (length (opt/info-free-vars opt/info)) values)] [(index ...) (build-list (length (opt/info-free-vars opt/info)) values)]
[pred? (list-ref info 2)]) [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
#`(if (pred? #,(opt/info-val opt/info)) #:exp
(begin (if (null? s-chap-code) ;; if this is #t, when we have to avoid putting the property on here.
#,@s-fo-code #`(if (pred? #,(opt/info-val opt/info))
#,(opt/info-val opt/info)) (begin
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)) #,@s-fo-code
#`(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) #,(opt/info-val opt/info))
(let ([v (stronger-prop-get #,(opt/info-val opt/info))]) (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))
(and (eq? (vector-ref v index) free-var) ...))) #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info))
(let ([v (stronger-prop-get #,(opt/info-val opt/info))])
(and (eq? (vector-ref v index) free-var) ...)))
#,(opt/info-val opt/info)
(if (pred? #,(opt/info-val opt/info))
(begin
#,@s-fo-code
(chaperone-struct
#,(opt/info-val opt/info) #,(opt/info-val opt/info)
(if (pred? #,(opt/info-val opt/info)) #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here
(begin stronger-prop-desc
#,@s-fo-code (vector free-var ...)))
(chaperone-struct (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))))
#,(opt/info-val opt/info) #:lifts
#,@(reverse s-chap-code) ;; built the last backwards, so reverse it here s-lifts
stronger-prop-desc #:superlifts
(vector free-var ...))) s-super-lifts
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))) #:partials
s-lifts s-partially-applied
s-super-lifts #:flat #f
s-partially-applied #:opt can-be-optimized?
#f ;; flat sexp #:stronger-ribs stronger-ribs
can-be-optimized? #:chaperone #t))]))]))
stronger-ribs
#t ;;chaperone?
))]))]))
(define (struct/dc-error blame obj what) (define (struct/dc-error blame obj what)
(raise-blame-error blame obj (raise-blame-error blame obj