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

merged the opt/c changes back into the trunk (finally!)

Browse Source 
svn: r5481
This commit is contained in:
Robby Findler 2007-01-28 02:54:16 +00:00
parent e911124dbf
commit 4ad8fdadea
10 changed files with 2272 additions and 1195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mzlib/contract.ss
View File

@ -9,14 +9,10 @@
"private/contract-basic-opters.ss") "private/contract-basic-opters.ss")
(provide (provide
;; opt is not ready yet opt/c ;(all-from "private/contract-opt.ss")
#;(all-from "private/contract-opt.ss") (all-from-except "private/contract-ds.ss"
#;(all-from-except "private/contract-opt-guts.ss" lazy-depth-to-look)
make-opt-contract
orig-ctc-prop
orig-ctc-pred?
orig-ctc-get)
(all-from "private/contract-ds.ss")
(all-from-except "private/contract-arrow.ss" (all-from-except "private/contract-arrow.ss"
check-procedure) check-procedure)
(all-from-except "private/contract-guts.ss" (all-from-except "private/contract-guts.ss"

80
collects/mzlib/private/contract-arrow.ss
View File

@ -1747,21 +1747,27 @@
;; ;;
;; arrow opter ;; arrow opter
;; ;;
(define/opter (-> opt/i pos neg stx) (define/opter (-> opt/i opt/info stx)
(define (opt/arrow-ctc doms rngs) (define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))] (generate-temporaries rngs))]
[(next-doms lifts-doms partials-doms) [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars] (let loop ([vars dom-vars]
[doms doms] [doms doms]
[next-doms null] [next-doms null]
[lifts-doms null] [lifts-doms null]
[partials-doms null]) [superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond (cond
[(null? doms) (values (reverse next-doms) lifts-doms partials-doms)] [(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else [else
(let-values ([(next lift partial _ __) (let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i neg pos (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 next) (cons (with-syntax ((next next)
@ -1769,18 +1775,26 @@
(syntax (let ((val car-vars)) next))) (syntax (let ((val car-vars)) next)))
next-doms) next-doms)
(append lifts-doms lift) (append lifts-doms lift)
(append partials-doms partial)))]))] (append superlifts-doms superlift)
[(next-rngs lifts-rngs partials-rngs) (append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
(let loop ([vars rng-vars] (let loop ([vars rng-vars]
[rngs rngs] [rngs rngs]
[next-rngs null] [next-rngs null]
[lifts-rngs null] [lifts-rngs null]
[partials-rngs null]) [superlifts-rngs null]
[partials-rngs null]
[stronger-ribs null])
(cond (cond
[(null? rngs) (values (reverse next-rngs) lifts-rngs partials-rngs)] [(null? rngs) (values (reverse next-rngs)
lifts-rngs
superlifts-rngs
partials-rngs
stronger-ribs)]
[else [else
(let-values ([(next lift partial _ __) (let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i pos neg (car rngs))]) (opt/i opt/info (car rngs))])
(loop (cdr vars) (loop (cdr vars)
(cdr rngs) (cdr rngs)
(cons (with-syntax ((next next) (cons (with-syntax ((next next)
@ -1788,9 +1802,13 @@
(syntax (let ((val car-vars)) next))) (syntax (let ((val car-vars)) next)))
next-rngs) next-rngs)
(append lifts-rngs lift) (append lifts-rngs lift)
(append partials-rngs partial)))]))]) (append superlifts-rngs superlift)
(append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values (values
(with-syntax ((pos pos) (with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars) ((rng-arg ...) rng-vars)
((next-dom ...) next-doms) ((next-dom ...) next-doms)
@ -1802,23 +1820,31 @@
(let-values ([(rng-arg ...) (val next-dom ...)]) (let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...)))))) (values next-rng ...))))))
(append lifts-doms lifts-rngs) (append lifts-doms lifts-rngs)
(append superlifts-doms superlifts-rngs)
(append partials-doms partials-rngs) (append partials-doms partials-rngs)
#f #f
#f))) #f
(append stronger-ribs-dom stronger-ribs-rng))))
(define (opt/arrow-any-ctc doms) (define (opt/arrow-any-ctc doms)
(let*-values ([(dom-vars) (generate-temporaries doms)] (let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms partials-doms) [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars] (let loop ([vars dom-vars]
[doms doms] [doms doms]
[next-doms null] [next-doms null]
[lifts-doms null] [lifts-doms null]
[partials-doms null]) [superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond (cond
[(null? doms) (values (reverse next-doms) lifts-doms partials-doms)] [(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else [else
(let-values ([(next lift partial flat _) (let-values ([(next lift superlift partial flat _ this-stronger-ribs)
(opt/i pos neg (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 next) (cons (with-syntax ((next next)
@ -1826,9 +1852,13 @@
(syntax (let ((val car-vars)) next))) (syntax (let ((val car-vars)) next)))
next-doms) next-doms)
(append lifts-doms lift) (append lifts-doms lift)
(append partials-doms partial)))]))]) (append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values (values
(with-syntax ((pos pos) (with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars))) (dom-len (length dom-vars)))
@ -1837,11 +1867,13 @@
(λ (dom-arg ...) (λ (dom-arg ...)
(val next-dom ...))))) (val next-dom ...)))))
lifts-doms lifts-doms
superlifts-doms
partials-doms partials-doms
#f #f
#f))) #f
stronger-ribs-dom)))
(syntax-case stx (-> values any) (syntax-case* stx (-> values any) module-or-top-identifier=?
[(-> dom ... (values rng ...)) [(-> dom ... (values rng ...))
(opt/arrow-ctc (syntax->list (syntax (dom ...))) (opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...))))] (syntax->list (syntax (rng ...))))]

163
collects/mzlib/private/contract-basic-opters.ss
View File

@ -1,81 +1,104 @@
(module contract-basic-opters mzscheme (module contract-basic-opters mzscheme
(require "contract-guts.ss" (require "contract-guts.ss"
"contract-opt.ss") "contract-opt.ss"
"contract.ss")
(require-for-syntax "contract-opt-guts.ss") (require-for-syntax "contract-opt-guts.ss")
;; ;;
;; opt/pred helper ;; opt/pred helper
;; ;;
(define-for-syntax (opt/pred pos pred) (define-for-syntax (opt/pred opt/info pred)
(let* ((lift-vars (generate-temporaries (syntax (pred)))) (printf "~s\n" (list 'opt/pred opt/info pred))
(lift-pred-var (car lift-vars))) (with-syntax ((pred pred))
(with-syntax ((lift-pred lift-pred-var)) (values
(values (with-syntax ((val (opt/info-val opt/info))
(with-syntax ((pos pos)) (ctc (opt/info-contract opt/info))
(syntax (if (lift-pred val) (pos (opt/info-pos opt/info))
val (src-info (opt/info-src-info opt/info))
(raise-contract-error (orig-str (opt/info-orig-str opt/info)))
val (syntax (if (pred val)
src-info val
pos (raise-contract-error
orig-str val
"expected <~a>, given: ~e" src-info
((name-get ctc) ctc) pos
val)))) orig-str
(list (cons lift-pred-var pred)) "expected <~a>, given: ~e"
null ((name-get ctc) ctc)
(syntax (lift-pred val)) val))))
#f)))) null
null
null
(syntax (pred val))
#f
null)))
;; ;;
;; built-in predicate opters ;; built-in predicate opters
;; ;;
(define/opter (null? opt/i pos neg stx) (define/opter (null? opt/i opt/info stx)
(syntax-case stx (null?) (syntax-case stx (null?)
[null? (opt/pred pos #'null?)])) [null? (opt/pred opt/info #'null?)]))
(define/opter (boolean? opt/i pos neg stx) (define/opter (boolean? opt/i opt/info stx)
(printf "boolean opter\n")
(syntax-case stx (boolean?) (syntax-case stx (boolean?)
[boolean? (opt/pred pos #'boolean?)])) [boolean? (opt/pred opt/info #'boolean?)]))
(define/opter (integer? opt/i pos neg stx) (define/opter (integer? opt/i opt/info stx)
(syntax-case stx (integer?) (syntax-case stx (integer?)
[integer? (opt/pred pos #'integer?)])) [integer? (opt/pred opt/info #'integer?)]))
(define/opter (char? opt/i pos neg stx) (define/opter (char? opt/i opt/info stx)
(syntax-case stx (char?) (syntax-case stx (char?)
[char? (opt/pred pos #'char?)])) [char? (opt/pred opt/info #'char?)]))
(define/opter (number? opt/i pos neg stx) (define/opter (number? opt/i opt/info stx)
(syntax-case stx (number?) (syntax-case stx (number?)
[number? (opt/pred pos #'number?)])) [number? (opt/pred opt/info #'number?)]))
(define/opter (pair? opt/i pos neg stx) (define/opter (pair? opt/i opt/info stx)
(syntax-case stx (pair?) (syntax-case stx (pair?)
[pair? (opt/pred pos #'pair?)])) [pair? (opt/pred opt/info #'pair?)]))
(define/opter (not opt/i opt/info stx)
(syntax-case stx (not)
[not (opt/pred opt/info #'not)]))
;; ;;
;; any/c ;; any/c
;; ;;
(define/opter (any/c opt/i pos neg 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 (values
#'val (opt/info-val opt/info)
null
null null
null null
#'#t #'#t
#f)])) #f
null)]))
;;
;; false/c
;;
(define/opter (false/c opt/i opt/info stx)
(syntax-case stx (false/c)
[false/c (opt/pred opt/info #'not)]))
;; ;;
;; flat-contract helper ;; flat-contract helper
;; ;;
(define-for-syntax (opt/flat-ctc pos pred checker) (define-for-syntax (opt/flat-ctc opt/info pred checker)
(syntax-case pred (null? number? integer? boolean? pair?) (syntax-case pred (null? number? integer? boolean? pair? not)
;; Better way of doing this? ;; Better way of doing this?
[null? (opt/pred pos pred)] [null? (opt/pred opt/info pred)]
[number? (opt/pred pos pred)] [number? (opt/pred opt/info pred)]
[integer? (opt/pred pos pred)] [integer? (opt/pred opt/info pred)]
[boolean? (opt/pred pos pred)] [boolean? (opt/pred opt/info pred)]
[pair? (opt/pred pos pred)] [pair? (opt/pred opt/info pred)]
[pred [pred
(let* ((lift-vars (generate-temporaries (syntax (pred error-check)))) (let* ((lift-vars (generate-temporaries (syntax (pred error-check))))
(lift-pred (car lift-vars))) (lift-pred (car lift-vars)))
(with-syntax ((pos pos) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(lift-pred lift-pred)) (lift-pred lift-pred))
(values (values
(syntax (if (lift-pred val) (syntax (if (lift-pred val)
@ -93,55 +116,17 @@
(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 null
null
(syntax (lift-pred val)) (syntax (lift-pred val))
#f)))])) #f
null)))]))
;; ;;
;; flat-contract and friends ;; flat-contract and friends
;; ;;
(define/opter (flat-contract opt/i pos neg stx) (define/opter (flat-contract opt/i opt/info stx)
(syntax-case stx (flat-contract) (syntax-case stx (flat-contract)
[(flat-contract pred) (opt/flat-ctc pos #'pred 'check-flat-contract)])) [(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)]))
(define/opter (flat-named-contract opt/i pos neg stx) (define/opter (flat-named-contract opt/i opt/info stx)
(syntax-case stx (flat-named-contract) (syntax-case stx (flat-named-contract)
[(flat-named-contract name pred) (opt/flat-ctc pos #'pred 'check-flat-named-contract)])) [(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)])))
;;
;; unknown
;;
;; BUGS: currently, opt/c reports error on something like
;; (opt/c (or/c (begin (print "side effect") number?) boolean?))
;; because the begin sequence is unrecognized, and we have no idea of
;; knowing that `number?' is a pred that we can opt.
;; WORKAROUND: wrap `flat-contract' around the pred, it optimizes to the same
;; thing.
;;
(define/opter (unknown opt/i pos neg stx)
(define (opt/unknown-ctc uctc)
(let* ((lift-vars (generate-temporaries (syntax (lift error-check))))
(lift-var (car lift-vars))
(partial-var (car (generate-temporaries (syntax (partial))))))
(values
(with-syntax ((partial-var partial-var)
(lift-var lift-var)
(uctc uctc))
(syntax (partial-var val)))
(interleave-lifts
lift-vars
(list uctc
(with-syntax ((lift-var lift-var))
(syntax
(unless (contract? lift-var)
(error 'contract "expected contract, given ~e" lift-var))))))
(list (cons
partial-var
(with-syntax ((lift-var lift-var)
(pos pos)
(neg neg))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))))
#f
lift-var)))
(syntax-case stx ()
[ctc
(opt/unknown-ctc #'ctc)])))

215
collects/mzlib/private/contract-ds-helpers.ss
View File

@ -2,9 +2,11 @@
(provide ensure-well-formed (provide ensure-well-formed
build-func-params build-func-params
build-clauses build-clauses
build-enforcer-clauses
generate-arglists) generate-arglists)
(require (lib "list.ss")) (require (lib "list.ss")
"contract-opt-guts.ss")
(require-for-template mzscheme) (require-for-template mzscheme)
#| #|
@ -32,14 +34,19 @@ which are then called when the contract's fields are explored
(define (build-clauses name coerce-contract stx clauses) (define (build-clauses name coerce-contract stx clauses)
(let* ([field-names (let* ([field-names
(map (λ (clause) (let loop ([clauses (syntax->list clauses)])
(syntax-case clause () (cond
[(id . whatever) (syntax id)] [(null? clauses) null]
[else
(let ([clause (car clauses)])
(syntax-case* clause (where and) raw-comparison?
[where null]
[and null]
[(id . whatever) (cons (syntax id) (loop (cdr clauses)))]
[else (raise-syntax-error name [else (raise-syntax-error name
"expected a field name and a contract together" "expected a field name and a contract together"
stx stx
clause)])) clause)]))]))]
(syntax->list clauses))]
[all-ac-ids (generate-temporaries field-names)] [all-ac-ids (generate-temporaries field-names)]
[defeat-inlining [defeat-inlining
;; makes the procedure "big enough" so ;; makes the procedure "big enough" so
@ -55,23 +62,165 @@ which are then called when the contract's fields are explored
[maker-args '()]) [maker-args '()])
(cond (cond
[(null? clauses) [(null? clauses)
(reverse maker-args)] (with-syntax ([(maker-args ...) (reverse maker-args)])
(syntax ((maker-args ... #f)
())))]
[else [else
(let ([clause (car clauses)])
(syntax-case* clause (and where) raw-comparison?
[where
(build-clauses/where name stx (cdr clauses) field-names (reverse maker-args))]
[and
(build-clauses/and name stx (cdr clauses) '() '() (reverse maker-args))]
[else
(let ([ac-id (car ac-ids)])
(syntax-case clause ()
[(id (x ...) ctc-exp)
(and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...)))))
(let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids)
(syntax (x ...))
field-names)
#,(defeat-inlining
#`(#,coerce-contract '#,name ctc-exp)))])
(loop (cdr clauses)
(cdr ac-ids)
(cons (car ac-ids) prior-ac-ids)
(cons maker-arg maker-args)))]
[(id (x ...) ctc-exp)
(begin
(unless (identifier? (syntax id))
(raise-syntax-error name "expected identifier" stx (syntax id)))
(for-each (λ (x) (unless (identifier? x)
(raise-syntax-error name "expected identifier" stx x)))
(syntax->list (syntax (x ...)))))]
[(id ctc-exp)
(identifier? (syntax id))
(loop (cdr clauses)
(cdr ac-ids)
(cons (car ac-ids) prior-ac-ids)
(cons #`(#,coerce-contract '#,name ctc-exp) maker-args))]
[(id ctc-exp)
(raise-syntax-error name "expected identifier" stx (syntax id))]
[_
(raise-syntax-error name "expected name/identifier binding" stx clause)]))]))]))))
(define (build-clauses/where name stx clauses field-names maker-args)
(with-syntax ([(field-names ...) field-names])
(let loop ([clauses clauses]
[vars '()]
[procs '()])
(cond
[(null? clauses)
;; if there is no `and' clause, assume that it is always satisfied
(build-clauses/and name stx (list (syntax #t)) vars procs maker-args)]
[else
(let ([clause (car clauses)])
(syntax-case* clause (and) raw-comparison?
[and (build-clauses/and name stx (cdr clauses) vars procs maker-args)]
[(id exp)
(identifier? (syntax id))
(loop (cdr clauses)
(cons (syntax id) vars)
(cons (syntax (λ (field-names ...) exp)) procs))]
[(id exp)
(raise-syntax-error name "expected an identifier" stx (syntax id))]
[_
(raise-syntax-error name "expected an identifier and an expression" stx clause)]))]))))
(define (build-enforcer-clauses opt/i opt/info name stx clauses f-x/vals f-xs/vals
helper-id helper-info helper-freev)
(define (opt/enforcer-clause stx)
(syntax-case stx ()
[(f arg ...)
;; we need to override the default optimization of recursive calls to use our helper
(and (opt/info-recf opt/info) (module-identifier=? (opt/info-recf opt/info) #'f))
(values
#`(f #,(opt/info-val opt/info) arg ...)
null
null
null
#f
#f
null)]
#;
[(f arg ...)
;; we need to override the default optimization of recursive calls to use our helper
(module-identifier=? (opt/info-recf opt/info) #'f)
(with-syntax ((helper helper-id)
(val (opt/info-val opt/info))
(info helper-info))
(values
(syntax (helper val info arg ...))
null
null
null
#f
#f
null))]
[else (opt/i opt/info stx)]))
(let* ([field-names
(map (λ (clause)
(syntax-case clause ()
[(id . whatever) (syntax id)]
[else (raise-syntax-error name
"expected a field name and a contract together"
stx
clause)]))
(syntax->list clauses))]
[all-ac-ids (generate-temporaries field-names)])
(let loop ([clauses (syntax->list clauses)]
[let-vars f-x/vals]
[arglists f-xs/vals]
[ac-ids all-ac-ids]
[prior-ac-ids '()]
[maker-args '()]
[lifts-ps '()]
[superlifts-ps '()]
[stronger-ribs-ps '()])
(cond
[(null? clauses)
(values (reverse maker-args)
lifts-ps
superlifts-ps
stronger-ribs-ps)]
[else
(let ([clause (car clauses)] (let ([clause (car clauses)]
[let-var (car let-vars)]
[arglist (car arglists)]
[ac-id (car ac-ids)]) [ac-id (car ac-ids)])
(syntax-case clause () (syntax-case clause ()
[(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 ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids) (let*-values ([(next lifts superlifts partials _ _2 _3)
(syntax (x ...)) (opt/enforcer-clause (syntax ctc-exp))]
field-names) [(maker-arg)
#,(defeat-inlining (with-syntax ((val (opt/info-val opt/info))
#`(#,coerce-contract '#,name ctc-exp)))]) ((arg ...) arglist)
[(new-let-vars ...) (match-up (reverse prior-ac-ids)
(syntax (x ...))
field-names)])
#`(#,let-var
#,(bind-lifts
superlifts
#`(let ([new-let-vars arg] ...)
#,(bind-lifts
(append lifts partials)
#`(let ((val #,let-var))
#,next))))))])
(loop (cdr clauses) (loop (cdr clauses)
(cdr let-vars)
(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)
lifts-ps
superlifts-ps
stronger-ribs-ps))]
[(id (x ...) ctc-exp) [(id (x ...) ctc-exp)
(begin (begin
(unless (identifier? (syntax id)) (unless (identifier? (syntax id))
@ -81,13 +230,45 @@ 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))
(loop (cdr clauses) (let*-values ([(next lifts superlifts partials _ __ stronger-ribs)
(cdr ac-ids) (opt/enforcer-clause (syntax ctc-exp))]
(cons (car ac-ids) prior-ac-ids) [(maker-arg)
(cons #`(#,coerce-contract '#,name ctc-exp) maker-args))] (with-syntax ((val (opt/info-val opt/info)))
#`(#,let-var
#,(bind-lifts
partials
#`(let ((val #,let-var))
#,next))))])
(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)))]
[(id ctc-exp) [(id ctc-exp)
(raise-syntax-error name "expected identifier" stx (syntax id))]))])))) (raise-syntax-error name "expected identifier" stx (syntax id))]))]))))
(define (build-clauses/and name stx clauses synth-names synth-procs maker-args)
(unless (pair? clauses)
(raise-syntax-error name "expected an expression after `and' keyword" stx))
(unless (null? (cdr clauses))
(raise-syntax-error name "expected only one expression after `and' keyword" stx (cadr clauses)))
(with-syntax ([(maker-args ...) maker-args]
[(synth-names ...) synth-names]
[(synth-procs ...) synth-procs]
[exp (car clauses)])
(syntax ((maker-args ... (list (λ (ht) (let ([synth-names (hash-table-get ht 'synth-names)] ...) exp))
(cons 'synth-names synth-procs) ...))
(synth-names ...)))))
(define (raw-comparison? x y)
(and (identifier? x)
(identifier? y)
(eq? (syntax-e x) (syntax-e y))))
;; generate-arglists : (listof X) -> (listof (listof X)) ;; generate-arglists : (listof X) -> (listof (listof X))
;; produces the list of arguments to the dependent contract ;; produces the list of arguments to the dependent contract
;; functions, given the names of some variables. ;; functions, given the names of some variables.

500
collects/mzlib/private/contract-ds.ss
View File

@ -1,5 +1,10 @@
#| #|
Need to break the parent pointer links at some point.
This leaks, as is.
---
why make a separate struct for the contract information why make a separate struct for the contract information
instead of putting it into the wrapper struct in an instead of putting it into the wrapper struct in an
extra field? extra field?
@ -12,11 +17,27 @@ it around flattened out.
(module contract-ds mzscheme (module contract-ds mzscheme
(require "contract-guts.ss") (require "contract-guts.ss"
"contract-opt.ss"
"contract-ds-helpers.ss")
(require-for-syntax "contract-ds-helpers.ss" (require-for-syntax "contract-ds-helpers.ss"
"contract-helpers.ss") "contract-helpers.ss"
"contract-opt-guts.ss"
(lib "etc.ss"))
(provide define-contract-struct) (provide define-contract-struct
make-opt-contract/info
opt-contract/info-contract
opt-contract/info-enforcer
opt-contract/info-pos
opt-contract/info-neg
opt-contract/info-src-info
opt-contract/info-orig-str
lazy-depth-to-look
unknown?
synthesized-value)
(define-syntax (define-contract-struct stx) (define-syntax (define-contract-struct stx)
(syntax-case stx () (syntax-case stx ()
@ -43,9 +64,11 @@ it around flattened out.
[predicate/val (list-ref struct-names 2)] [predicate/val (list-ref struct-names 2)]
[selectors/val (cdddr struct-names)] [selectors/val (cdddr struct-names)]
[struct/c-name/val (add-suffix "/c")] [struct/c-name/val (add-suffix "/c")]
[struct/dc-name/val(add-suffix "/dc")] [struct/dc-name/val (add-suffix "/dc")]
[field-count/val (length selectors/val)] [field-count/val (length selectors/val)]
[f-x/vals (generate-temporaries (syntax (fields ...)))]) [f-x/vals (generate-temporaries (syntax (fields ...)))]
[f-xs/vals (generate-arglists f-x/vals)])
(with-syntax ([struct/c struct/c-name/val] (with-syntax ([struct/c struct/c-name/val]
[struct/dc struct/dc-name/val] [struct/dc struct/dc-name/val]
[field-count field-count/val] [field-count field-count/val]
@ -57,8 +80,9 @@ it around flattened out.
[(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))] [(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))]
[(ctc-x ...) (generate-temporaries (syntax (fields ...)))] [(ctc-x ...) (generate-temporaries (syntax (fields ...)))]
[(f-x ...) f-x/vals] [(f-x ...) f-x/vals]
[((f-xs ...) ...) (generate-arglists f-x/vals)] [((f-xs ...) ...) f-xs/vals]
[wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))]) [wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))]
[opt-wrap-name (string->symbol (format "~a/lazy-opt-contract" (syntax-e (syntax name))))])
#` #`
(begin (begin
@ -66,15 +90,52 @@ it around flattened out.
#,@(if (eq? (syntax-local-context) 'top-level) #,@(if (eq? (syntax-local-context) 'top-level)
(list (list
(syntax (syntax
(define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set) (define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set
already-there? burrow-in rewrite-fields wrap-get)
(values)))) (values))))
(list)) (list))
(define (evaluate-attrs stct contract/info)
(when (wrap-parent-get stct 0) ;; test to make sure this even has attributes
(let* ([any-unknown? #f]
[any-became-known? #f]
[synth-info (wrap-parent-get stct 0)]
[ht (synth-info-vals synth-info)])
(hash-table-for-each
ht
(lambda (k v)
(when (unknown? v)
(let ([proc (unknown-proc v)])
(let ([new (proc (wrap-get stct selector-indicies+1) ...)])
(cond
[(unknown? new)
(set! any-unknown? #t)]
[else
(set! any-became-known? #t)
(hash-table-put! ht k new)]))))))
(unless any-unknown?
(check-synth-info-test stct synth-info contract/info))
(when any-became-known?
(for-each
(lambda (x) ((evaluate-attr-prop-accessor x) x contract/info))
(synth-info-parents synth-info)))
(unless any-unknown?
(set-synth-info-parents! synth-info '())))))
(define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set) (define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set)
(make-struct-type 'wrap-name (make-struct-type 'wrap-name
wrap-parent-type ;; super struct
2 ;; field count
(max 0 (- field-count 1)) ;; auto-field-k
#f ;; auto-field-v
(list (cons evaluate-attr-prop evaluate-attrs))
inspector))
(define-values (opt-wrap-type opt-wrap-maker opt-wrap-predicate opt-wrap-get opt-wrap-set)
(make-struct-type 'opt-wrap-name
#f ;; super struct #f ;; super struct
2 ;; field count 2 ;; field count
(- field-count 1) ;; auto-field-k field-count ;; auto-field-k
#f ;; auto-field-v #f ;; auto-field-v
'() ;; prop-value-list '() ;; prop-value-list
inspector)) inspector))
@ -88,17 +149,20 @@ it around flattened out.
'() ;; prop-value-list '() ;; prop-value-list
inspector)) inspector))
(define (predicate x) (or (raw-predicate x) (wrap-predicate x))) (define (predicate x) (or (raw-predicate x) (opt-wrap-predicate x) (wrap-predicate x)))
(define-syntax (struct/dc stx) (define-syntax (struct/dc stx)
(syntax-case stx () (syntax-case stx ()
[(_ clause (... ...)) [(_ clause (... ...))
(with-syntax ([(maker-args (... ...)) (with-syntax ([((maker-args (... ...))
(names (... ...)))
(build-clauses 'struct/dc (build-clauses 'struct/dc
(syntax coerce-contract) (syntax coerce-contract)
stx stx
(syntax (clause (... ...))))]) (syntax (clause (... ...))))])
(syntax (contract-maker maker-args (... ...))))])) (syntax
(let ([names 'names] (... ...))
(contract-maker maker-args (... ...)))))]))
(define (do-selection stct i+1) (define (do-selection stct i+1)
(let-values ([(stct fields ...) (let-values ([(stct fields ...)
@ -107,32 +171,54 @@ it around flattened out.
[(raw-predicate stct) [(raw-predicate stct)
;; found the original value ;; found the original value
(values #f (get stct selector-indicies) ...)] (values #f (get stct selector-indicies) ...)]
[else
[(opt-wrap-predicate stct)
(let ((inner (opt-wrap-get stct 0)))
(if inner
(let* ((info (opt-wrap-get stct 1))
(enforcer (opt-contract/info-enforcer info)))
(let-values ([(inner-stct fields ...) (loop inner)])
(let-values ([(fields ...) (enforcer stct fields ...)])
(opt-wrap-set stct 0 #f)
(opt-wrap-set stct selector-indicies+1 fields) ...
(values stct fields ...))))
;; found a cached version
(values #f (opt-wrap-get stct selector-indicies+1) ...)))]
[(wrap-predicate stct)
(let ([inner (wrap-get stct 0)]) (let ([inner (wrap-get stct 0)])
(if inner (if inner
;; we have a contract to update ;; we have a contract to update
(let-values ([(_1 fields ...) (loop inner)]) (let ([contract/info (wrap-get stct 1)])
(let-values ([(fields ...) (let-values ([(_1 fields ...) (loop inner)])
(rewrite-fields (wrap-get stct 1) fields ...)]) (let-values ([(fields ...)
(wrap-set stct 0 #f) (rewrite-fields stct contract/info fields ...)])
(wrap-set stct selector-indicies+1 fields) ... (wrap-set stct 0 #f)
(values stct fields ...))) (wrap-set stct selector-indicies+1 fields) ...
(evaluate-attrs stct contract/info)
(values stct fields ...))))
;; found a cached version of the value ;; found a cached version of the value
(values #f (wrap-get stct selector-indicies+1) ...)))]))]) (values #f (wrap-get stct selector-indicies+1) ...)))]))])
(wrap-get stct i+1))) (cond
[(opt-wrap-predicate stct) (opt-wrap-get stct i+1)]
[(wrap-predicate stct) (wrap-get stct i+1)])))
(define (rewrite-fields contract/info ctc-x ...) (define (rewrite-fields parent contract/info ctc-x ...)
(let* ([f-x (let ([ctc-field (contract-get (contract/info-contract contract/info) (let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info)
selector-indicies)]) selector-indicies)]
(let ([ctc (if (procedure? ctc-field) [ctc (if (procedure? ctc-field)
(ctc-field f-xs ...) (ctc-field f-xs ...)
ctc-field)]) ctc-field)]
((((proj-get ctc) ctc) (contract/info-pos contract/info)
(contract/info-neg contract/info) [ctc-field-val
(contract/info-src-info contract/info) ((((proj-get ctc) ctc) (contract/info-pos contract/info)
(contract/info-orig-str contract/info)) (contract/info-neg contract/info)
ctc-x)))] ...) (contract/info-src-info contract/info)
(contract/info-orig-str contract/info))
ctc-x)])
(update-parent-links parent ctc-field-val)
ctc-field-val)] ...)
(values f-x ...))) (values f-x ...)))
(define (stronger-lazy-contract? a b) (define (stronger-lazy-contract? a b)
@ -145,7 +231,8 @@ it around flattened out.
(λ (pos-blame neg-blame src-info orig-str) (λ (pos-blame neg-blame src-info orig-str)
(let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str)]) (let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str)])
(λ (val) (λ (val)
(unless (or (wrap-predicate val) (unless (or (wrap-predicate val)
(opt-wrap-predicate val)
(raw-predicate val)) (raw-predicate val))
(raise-contract-error (raise-contract-error
val val
@ -157,22 +244,43 @@ it around flattened out.
[(already-there? contract/info val lazy-depth-to-look) [(already-there? contract/info val lazy-depth-to-look)
val] val]
[else [else
(wrap-maker val contract/info)]))))) (let ([wrapper (wrap-maker val contract/info)])
(let ([synth-setup-stuff (contract-get ctc field-count)])
(when synth-setup-stuff
(let ([ht (make-hash-table)])
(for-each (λ (pr) (hash-table-put! ht (car pr) (make-unknown (cdr pr))))
(cdr synth-setup-stuff))
(wrap-parent-set wrapper 0 (make-synth-info '() ht (car synth-setup-stuff))))))
wrapper)])))))
(define (already-there/opt? val new-n new-r)
(cond
[(and (opt-wrap-predicate val)
(opt-wrap-get val 0))
(let ([old-n (opt-wrap-get val 2)]
[old-r (opt-wrap-get val 3)])
(flattened-stronger old-n old-r new-n new-r))]
[else #f]))
(define (flattened-stronger this-val this-rank that-val that-rank)
(and (<= this-val that-val)
(>= this-rank that-rank)))
(define (already-there? new-contract/info val depth) (define (already-there? new-contract/info val depth)
(cond (cond
[(raw-predicate val) #f] [(raw-predicate val) #f]
[(zero? depth) #f] [(zero? depth) #f]
[(wrap-get val 0) [(wrap-predicate val)
(let ([old-contract/info (wrap-get val 1)]) (and (wrap-get val 0)
(if (and (eq? (contract/info-pos new-contract/info) (let ([old-contract/info (wrap-get val 1)])
(contract/info-pos old-contract/info)) (if (and (eq? (contract/info-pos new-contract/info)
(eq? (contract/info-neg new-contract/info) (contract/info-pos old-contract/info))
(contract/info-neg old-contract/info)) (eq? (contract/info-neg new-contract/info)
(contract-stronger? (contract/info-contract old-contract/info) (contract/info-neg old-contract/info))
(contract/info-contract new-contract/info))) (contract-stronger? (contract/info-contract old-contract/info)
#t (contract/info-contract new-contract/info)))
(already-there? new-contract/info (wrap-get val 0) (- depth 1))))] #t
(already-there? new-contract/info (wrap-get val 0) (- depth 1)))))]
[else [else
;; when the zeroth field is cleared out, we don't ;; when the zeroth field is cleared out, we don't
;; have a contract to compare to anymore. ;; have a contract to compare to anymore.
@ -180,14 +288,19 @@ it around flattened out.
(define (struct/c ctc-x ...) (define (struct/c ctc-x ...)
(let ([ctc-x (coerce-contract 'struct/c ctc-x)] ...) (let ([ctc-x (coerce-contract 'struct/c ctc-x)] ...)
(contract-maker ctc-x ...))) (contract-maker ctc-x ... #f)))
(define (selectors x) (burrow-in x 'selectors selector-indicies)) ... (define (selectors x)
(burrow-in x 'selectors selector-indicies)) ...
(define (burrow-in struct selector-name i) (define (burrow-in struct selector-name i)
(cond (cond
[(raw-predicate struct) [(raw-predicate struct)
(get struct i)] (get struct i)]
[(opt-wrap-predicate struct)
(if (opt-wrap-get struct 0)
(do-selection struct (+ i 1))
(opt-wrap-get struct (+ i 1)))]
[(wrap-predicate struct) [(wrap-predicate struct)
(if (wrap-get struct 0) (if (wrap-get struct 0)
(do-selection struct (+ i 1)) (do-selection struct (+ i 1))
@ -196,32 +309,297 @@ it around flattened out.
(error selector-name "expected <~a>, got ~e" 'name struct)])) (error selector-name "expected <~a>, got ~e" 'name struct)]))
(define (lazy-contract-name ctc) (define (lazy-contract-name ctc)
(let ([list-of-subcontracts (list (contract-get ctc selector-indicies) ...)]) (do-contract-name 'struct/c
(cond 'struct/dc
[(andmap contract? list-of-subcontracts) (list (contract-get ctc selector-indicies) ...)
(apply build-compound-type-name 'struct/c list-of-subcontracts)] '(fields ...)
[else (contract-get ctc field-count)))
(let ([dots (string->symbol "...")])
(apply build-compound-type-name 'struct/dc
(map (λ (field ctc)
(if (contract? ctc)
(build-compound-type-name field ctc)
(build-compound-type-name field dots)))
'(fields ...)
list-of-subcontracts)))])))
(define-values (contract-type contract-maker contract-predicate contract-get contract-set) (define-values (contract-type contract-maker contract-predicate contract-get contract-set)
(make-struct-type 'contract-name (make-struct-type 'contract-name
#f #f
field-count (+ field-count 1) ;; extra field is for synthesized attribute ctcs
;; it is a list whose first element is
;; a procedure (called once teh attrs are known) that
;; indicates if the test passes. the rest of the elements are
;; procedures that build the attrs
;; this field is #f when there is no synthesized attrs
0 ;; auto-field-k 0 ;; auto-field-k
'() ;; auto-field-v '() ;; auto-field-v
(list (cons proj-prop lazy-contract-proj) (list (cons proj-prop lazy-contract-proj)
(cons name-prop lazy-contract-name) (cons name-prop lazy-contract-name)
(cons first-order-prop (λ (ctc) predicate)) (cons first-order-prop (λ (ctc) predicate))
(cons stronger-prop stronger-lazy-contract?)))))))])) (cons stronger-prop stronger-lazy-contract?))))
(define-for-syntax (build-enforcer opt/i opt/info name stx clauses
helper-id-var helper-info helper-freev
enforcer-id-var)
(define (make-free-vars free-vars freev)
(let loop ([i 0]
[stx null]
[free-vars free-vars])
(cond
[(null? free-vars) (reverse stx)]
[else (loop (+ i 1)
(cons (with-syntax ((var (car free-vars))
(freev freev)
(j (+ i 2)))
(syntax (var (opt-wrap-get stct j)))) stx)
(cdr free-vars))])))
(let*-values ([(inner-val) #'val]
[(clauses lifts superlifts stronger-ribs)
(build-enforcer-clauses opt/i
(make-opt/info #'ctc
inner-val
#'pos
#'neg
#'src-info
#'orig-str
(opt/info-free-vars opt/info)
(opt/info-recf opt/info)
(opt/info-base-pred opt/info)
(opt/info-this opt/info)
(opt/info-that opt/info)
(opt/info-sv-index opt/info))
name
stx
clauses
(list (syntax f-x) ...)
(list (list (syntax f-xs) ...) ...)
helper-id-var
helper-info
helper-freev)])
(with-syntax ([(clause (... ...)) clauses]
[enforcer-id enforcer-id-var]
[helper-id helper-id-var]
[free-vars (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
[(saved-lifts (... ...)) (lifts-to-save lifts)])
(values
#`(λ (stct f-x ...)
(let* ([info (opt-wrap-get stct 1)]
[enforcer (opt-contract/info-enforcer info)]
[ctc (opt-contract/info-contract info)]
[pos (opt-contract/info-pos info)]
[neg (opt-contract/info-neg info)]
[src-info (opt-contract/info-src-info info)]
[orig-str (opt-contract/info-orig-str info)])
(let free-vars
#,(bind-lifts
lifts
#`(let-syntax #,(if (opt/info-recf opt/info)
(#`[#,(opt/info-recf opt/info)
(lambda (stx)
(syntax-case stx ()
[(f val args ((... ...) (... ...)))
#'(helper-id val
info
args
((... ...) (... ...))
saved-lifts (... ...))]))])
#`())
(let* (clause (... ...))
(values f-x ...)))))))
lifts
superlifts
stronger-ribs))))
;;
;; struct/dc opter
;;
(define/opter (struct/dc opt/i opt/info stx)
(syntax-case stx ()
[(_ clause (... ...))
(let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer)))))
(helper-id-var (car (generate-temporaries (syntax (helper)))))
(contract/info-var (car (generate-temporaries (syntax (contract/info))))))
(let-values ([(enforcer lifts superlifts stronger-ribs)
(build-enforcer opt/i
opt/info
'struct/dc
stx
(syntax (clause (... ...)))
helper-id-var
#'info
#'freev
enforcer-id-var)])
(let ([to-save (append (opt/info-free-vars opt/info)
(lifts-to-save lifts))])
(with-syntax ((val (opt/info-val opt/info))
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(ctc (opt/info-contract opt/info))
(base-pred (or (opt/info-base-pred opt/info) #'(λ (x) #f)))
(enforcer-id enforcer-id-var)
(helper-id helper-id-var)
(contract/info contract/info-var)
((j (... ...)) (let loop ([i 2]
[lst to-save])
(cond
[(null? lst) null]
[else (cons i (loop (+ i 1) (cdr lst)))])))
((free-var (... ...)) to-save))
(values
(syntax (helper-id val contract/info free-var (... ...)))
lifts
(append
superlifts
(list (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
[(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)]
[(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)]
[(stronger-indexes (... ...)) (build-list (length stronger-ribs)
(λ (x) (+ x 2)))]
[(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)])
(cons #'is-stronger?
#'(λ (val i free-var (... ...))
(cond
[(= i 0) #f]
[(and (opt-wrap-predicate val)
(opt-wrap-get val 0))
(let ([stronger-this-var stronger-var]
(... ...)
;; this computation is bogus
;; it only works if the stronger vars and the things
;; saved in the wrapper are the same
[stronger-that-var (opt-wrap-get val stronger-indexes)]
(... ...))
(or (and
;; make sure this is the same contract -- if not,
;; the rest of this test is bogus and may fail at runtime
(eq? enforcer-id (opt-contract/info-enforcer
(opt-wrap-get val 1)))
stronger-exps
(... ...))
(is-stronger? (opt-wrap-get val 0)
(- i 1)
free-var (... ...))))]
[else #f]))))
(cons
helper-id-var
(syntax
(λ (val info free-var (... ...))
(let ([ctc (opt-contract/info-contract info)]
[pos (opt-contract/info-pos info)]
[neg (opt-contract/info-neg info)]
[src-info (opt-contract/info-src-info info)]
[orig-str (opt-contract/info-orig-str info)])
(cond
;; FIXME terribly broken
[(base-pred val) val]
[else
(begin
(unless (or (wrap-predicate val)
(opt-wrap-predicate val)
(raw-predicate val))
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, got ~e"
((name-get ctc) ctc)
val))
(cond
;; this is where the optimized stronger needs to be called.
[(is-stronger? val 5 free-var (... ...))
val]
;; ALLOCATE OPT-WRAP
[else
(let ([w (opt-wrap-maker val info)])
(opt-wrap-set w j free-var) (... ...)
w)]))])))))
(cons enforcer-id-var enforcer)))
(list (cons contract/info-var
(syntax
(make-opt-contract/info ctc
enforcer-id
pos
neg
src-info
orig-str))))
#f
#f
stronger-ribs)))))]))
)))]))
(define (do-contract-name name/c name/dc list-of-subcontracts fields attrs)
(cond
[(and (andmap contract? list-of-subcontracts) (not attrs))
(apply build-compound-type-name name/c list-of-subcontracts)]
[else
(let ([fields
(map (λ (field ctc)
(if (contract? ctc)
(build-compound-type-name field ctc)
(build-compound-type-name field '...)))
fields
list-of-subcontracts)])
(cond
[attrs
(apply build-compound-type-name
name/dc
(append fields
(list 'where)
(map (λ (x) `(,(car x) ...))
(reverse (cdr attrs)))
(list 'and '...)))]
[else (apply build-compound-type-name name/dc fields)]))]))
(define-struct contract/info (contract pos neg src-info orig-str)) (define-struct contract/info (contract pos neg src-info orig-str))
(define-struct opt-contract/info (contract enforcer pos neg src-info orig-str))
;; parents : (listof wrap-parent)
;; vals : hash-table[symbol -o> (union (make-unknown proc[field-vals -> any]) any)
;; test : proc[vals-hash-table -> boolean]
(define-struct synth-info (parents vals test))
(define-struct unknown (proc))
(define secret (gensym))
(define (synthesized-value wrap key)
(unless (wrap-parent-predicate wrap)
(error 'synthesized-value "expected struct value with contract as first argument, got ~e" wrap))
(let ([ans (hash-table-get (synth-info-vals (wrap-parent-get wrap 0))
key
secret)])
(when (eq? ans secret)
(error 'synthesized-value "the key ~e is not mapped in ~e" key wrap))
ans))
(define (check-synth-info-test stct synth-info contract/info)
(unless ((synth-info-test synth-info) (synth-info-vals synth-info))
(raise-contract-error
stct
(contract/info-src-info contract/info)
(contract/info-pos contract/info)
(contract/info-orig-str contract/info)
"failed `and' clause, got ~e" stct)))
(define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor)
(make-struct-type-property 'evaluate-attr-prop))
(define-values (wrap-parent-type wrap-parent-maker wrap-parent-predicate wrap-parent-get wrap-parent-set)
(make-struct-type 'wrap-parent
#f ;; parent
0 ;; fields
1 ;; auto fields
))
(define (update-parent-links parent ctc-field-val)
(when (wrap-parent-predicate ctc-field-val)
(let ([old (wrap-parent-get ctc-field-val 0)])
(when old
;; add in new parent
(wrap-parent-set ctc-field-val 0
(make-synth-info
(cons parent (synth-info-parents old))
(synth-info-vals old)
(synth-info-test old)))))))
(define max-cache-size 5) (define max-cache-size 5)
(define lazy-depth-to-look 5) (define lazy-depth-to-look 5)
@ -265,4 +643,4 @@ test-case:
|# |#
) )

30
collects/mzlib/private/contract-guts.ss
View File

@ -193,16 +193,21 @@
(define (raise-contract-error val src-info blame contract-sexp fmt . args) (define (raise-contract-error val src-info blame contract-sexp fmt . args)
(raise (raise
(make-exn:fail:contract2 (make-exn:fail:contract2
((contract-violation->string) (string->immutable-string
val src-info blame contract-sexp (apply format fmt args)) ((contract-violation->string) val
src-info
blame
contract-sexp
(apply format fmt args)))
(current-continuation-marks) (current-continuation-marks)
(if src-info (if src-info
(list (make-srcloc (syntax-source src-info) (list (make-srcloc
(syntax-line src-info) (syntax-source src-info)
(syntax-column src-info) (syntax-line src-info)
(syntax-position src-info) (syntax-column src-info)
(syntax-span src-info))) (syntax-position src-info)
'())))) (syntax-span src-info)))
'()))))
(define print-contract-liner (define print-contract-liner
(let ([default (pretty-print-print-line)]) (let ([default (pretty-print-print-line)])
@ -308,7 +313,12 @@
(error 'flat-contract-predicate "expected a flat contract, got ~e" x)) (error 'flat-contract-predicate "expected a flat contract, got ~e" x))
((flat-get x) x)) ((flat-get x) x))
(define (flat-contract? x) (flat-pred? x)) (define (flat-contract? x) (flat-pred? x))
(define (contract-name ctc) ((name-get ctc) ctc)) (define (contract-name ctc)
(if (and (procedure? ctc)
(procedure-arity-includes? ctc 1))
(or (object-name ctc)
'unknown)
((name-get ctc) ctc)))
(define (contract? x) (proj-pred? x)) (define (contract? x) (proj-pred? x))
(define (contract-proc ctc) ((proj-get ctc) ctc)) (define (contract-proc ctc) ((proj-get ctc) ctc))
@ -444,4 +454,4 @@
(define (flat-contract/predicate? pred) (define (flat-contract/predicate? pred)
(or (flat-contract? pred) (or (flat-contract? pred)
(and (procedure? pred) (and (procedure? pred)
(procedure-arity-includes? pred 1))))) (procedure-arity-includes? pred 1)))))

179
collects/mzlib/private/contract-opt-guts.ss
View File

@ -1,56 +1,48 @@
(module contract-opt-guts mzscheme (module contract-opt-guts mzscheme
(require "contract-guts.ss") (require (lib "private/boundmap.ss" "syntax")
(lib "list.ss")
"contract-guts.ss")
(require-for-template mzscheme)
(provide get-opter reg-opter! opter (provide get-opter reg-opter! opter
interleave-lifts
make-opt-contract make-opt/info
orig-ctc-prop orig-ctc-pred? orig-ctc-get opt/info-contract
opt/info-val
make-lifts interleave-lifts) opt/info-pos
opt/info-neg
opt/info-src-info
opt/info-orig-str
opt/info-free-vars
opt/info-recf
opt/info-base-pred
opt/info-this
opt/info-that
opt/info-sv-index
sv-index
inc-sv-index!
opt/info-swap-blame)
(define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get)
(make-struct-type-property 'original-contract))
;; optimized contracts
;;
;; getting the name of an optimized contract is slow, but it is only
;; called when blame is raised (thankfully).
;;
;; note that lifts, partials, flat, and unknown are all built into the
;; projection itself and should not be exposed to the outside anyhow.
(define-struct/prop opt-contract (proj orig-ctc)
((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc)))
(name-prop (λ (ctc) ((name-get ((orig-ctc-get ctc) ctc)) ((orig-ctc-get ctc) ctc))))
(orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc))))
(stronger-prop (λ (this that)
#f)))) ;; TODO, how to do this?
;; a hash table of opters ;; a hash table of opters
(define opters-table (define opters-table
(make-hash-table 'equal)) (make-module-identifier-mapping))
;; get-opter : syntax -> opter ;; get-opter : syntax -> opter
(define (get-opter ctc) (define (get-opter ctc)
(hash-table-get opters-table ctc #f)) (module-identifier-mapping-get opters-table ctc (λ () #f)))
;; opter : (union symbol identifier) -> opter ;; opter : (union symbol identifier) -> opter
(define (opter ctc) (define (opter ctc)
(if (or (identifier? ctc) (symbol? ctc)) (if (identifier? ctc)
(let ((key (if (syntax? ctc) (syntax-e ctc) ctc))) (get-opter ctc)
(get-opter key)) (error 'opter "the argument must be a bound identifier, got ~e" ctc)))
(error 'opter "the argument must either be an identifier or a syntax object of an identifier, got ~e" ctc)))
;; reg-opter! : symbol opter -> ;; reg-opter! : symbol opter ->
(define (reg-opter! ctc opter) (define (reg-opter! ctc opter)
(hash-table-put! opters-table ctc opter)) (module-identifier-mapping-put! opters-table ctc opter))
;; make-lifts : list -> syntax
;; converts a list of lifted-var lifted-expr pairs into a syntax object
;; suitable for use in a let.
(define (make-lifts lst)
(map (λ (x) (with-syntax ((var (car x))
(e (cdr x)))
(syntax (var e)))) lst))
;; interleave-lifts : list list -> list ;; interleave-lifts : list list -> list
;; interleaves a list of variables names and a list of sexps into a list of ;; interleaves a list of variables names and a list of sexps into a list of
@ -60,4 +52,115 @@
(if (null? vars) null (if (null? vars) null
(cons (cons (car vars) (car sexps)) (cons (cons (car vars) (car sexps))
(interleave-lifts (cdr vars) (cdr sexps)))) (interleave-lifts (cdr vars) (cdr sexps))))
(error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps)))) (error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps)))
;; struct for color-keeping across opters
(define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that sv-index))
;; sv-index : opt/info -> int
(define (sv-index info)
(unbox (opt/info-sv-index info)))
;; inc-sv-index! : opt/info int -> unit
(define (inc-sv-index! info n)
(let ((old (unbox (opt/info-sv-index info))))
(set-box! (opt/info-sv-index info) (+ old n))))
;; opt/info-swap-blame : opt/info -> opt/info
;; swaps pos and neg
(define (opt/info-swap-blame info)
(let ((ctc (opt/info-contract info))
(val (opt/info-val info))
(pos (opt/info-neg info))
(neg (opt/info-pos info))
(src-info (opt/info-src-info info))
(orig-str (opt/info-orig-str info))
(free-vars (opt/info-free-vars info))
(recf (opt/info-recf info))
(base-pred (opt/info-base-pred info))
(this (opt/info-this info))
(that (opt/info-that info))
(sv-index (opt/info-sv-index info)))
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that sv-index)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; stronger helper functions
;;
;; new-stronger-var : identifier (identifier identifier -> exp) -> stronger-rib
;; the second identifier should be bound (in a lift) to an expression whose value has to be saved.
;; The ids passed to cogen are expected to be bound to two contracts' values of that expression, when
;; those contracts are being compared for strongerness
(define (new-stronger-var id cogen)
(with-syntax ([(var-this var-that) (generate-temporaries (list id id))])
(make-stronger-rib (syntax var-this)
(syntax var-that)
id
(cogen (syntax var-this)
(syntax var-that)))))
(define empty-stronger '())
(define-struct stronger-rib (this-var that-var save-id stronger-exp))
(provide new-stronger-var
(struct stronger-rib (this-var that-var save-id stronger-exp)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; lifting helper functions
;;
(provide lift/binding lift/effect empty-lifts bind-lifts bind-superlifts lifts-to-save)
;; lift/binding : syntax[expression] identifier lifts -> (values syntax lifts)
;; adds a new id to `lifts' that is bound to `e'. Returns the
;; variable that was bound
;; values that are lifted are also saved in the wrapper to make sure that the rhs's are evaluated at the right time.
(define (lift/binding e id-hint lifts)
(syntax-case e ()
[x
(or (identifier? e)
(number? (syntax-e e))
(boolean? (syntax-e e)))
(values e lifts)]
#;
[x
(identifier? e)
(values e
(snoc (cons e e) lifts))]
[else
(let ([x (car (generate-temporaries (list id-hint)))])
(values x
(snoc (cons x e) lifts)))]))
;; lift/effect : syntax[expression] lifts -> lifts
;; adds a new lift to `lifts' that is evaluated for effect. no variable returned
(define (lift/effect e lifts)
(let ([x (car (generate-temporaries '(lift/effect)))])
(snoc (cons #f e) lifts)))
(define (snoc x l) (append l (list x)))
;; empty-lifts : lifts
;; the initial lifts
(define empty-lifts '())
(define (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*))
(define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec))
(define (do-bind-lifts lifts stx binding-form)
(if (null? lifts)
stx
(with-syntax ([((lifts-x . lift-e) ...) lifts])
(with-syntax ([(lifts-x ...) (map (λ (x) (if (identifier? x) x (car (generate-temporaries '(junk)))))
(syntax->list (syntax (lifts-x ...))))]
[binding-form binding-form])
#`(binding-form ([lifts-x lift-e] ...)
#,stx)))))
(define (lifts-to-save lifts) (filter values (map car lifts)))
)

249
collects/mzlib/private/contract-opt.ss
View File

@ -1,25 +1,31 @@
(module contract-opt mzscheme (module contract-opt mzscheme
(require "contract-guts.ss" (require "contract-guts.ss"
"contract-opt-guts.ss") (lib "etc.ss"))
(require-for-syntax "contract-opt-guts.ss" (require-for-syntax "contract-opt-guts.ss"
(lib "etc.ss")
(lib "list.ss")) (lib "list.ss"))
(provide opt/c define/opter) (provide opt/c define/opter define/osc opt-stronger-vars-ref)
;; define/opter : id -> syntax ;; define/opter : id -> syntax
;; ;;
;; Takes an expression which is to be expected of the following signature: ;; Takes an expression which is to be expected of the following signature:
;; ;;
;; opter : id id syntax -> ;; opter : id id syntax list-of-ids ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) ;; syntax syntax-list syntax-list syntax-list (union syntax #f) (union syntax #f) syntax
;;
;; ;;
;; It takes in an identifier for pos, neg, and the original syntax. An identifier ;; It takes in an identifier for pos, neg, and the original syntax. An identifier
;; that can be used to call the opt/i function is also implicitly passed into ;; that can be used to call the opt/i function is also implicitly passed into
;; every opter. ;; every opter. A list of free-variables is implicitly passed if the calling context
;; was define/osc otherwise it is null.
;; ;;
;; Every opter needs to return: ;; Every opter needs to return:
;; - the optimized syntax ;; - the optimized syntax
;; - lifted variables: a list of (id, sexp) pairs ;; - 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 ;; - partially applied contracts: a list of (id, sexp) pairs
;; - if the contract being optimized is flat, ;; - if the contract being optimized is flat,
;; then an sexp that evals to bool, ;; then an sexp that evals to bool,
@ -30,51 +36,240 @@
;; then #f (that is, it is not unknown) ;; then #f (that is, it is not unknown)
;; else the symbol of the lifted variable ;; else the symbol of the lifted variable
;; This is used for contracts with subcontracts (like cons) doing checks. ;; This is used for contracts with subcontracts (like cons) doing checks.
;; - a list of stronger-ribs
(define-syntax (define/opter stx) (define-syntax (define/opter stx)
(syntax-case stx () (syntax-case stx ()
[(_ (for opt/i pos neg stx) expr ...) [(_ (for opt/i opt/info stx) expr ...)
(if (identifier? #'for) (if (identifier? #'for)
#'(begin #'(begin
(begin-for-syntax (begin-for-syntax
(reg-opter! (reg-opter!
'for #'for
(λ (opt/i pos neg stx) (λ (opt/i opt/info stx)
expr ...))) expr ...)))
#t) #t)
(error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))])) (error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))]))
;;
;; opt/unknown : opt/i id id syntax
;;
(define-for-syntax (opt/unknown opt/i opt/info uctc)
(let* ((lift-var (car (generate-temporaries (syntax (lift)))))
(partial-var (car (generate-temporaries (syntax (partial)))))
(partial-flat-var (car (generate-temporaries (syntax (partial-flat))))))
(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)
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))
(cons
partial-flat-var
(with-syntax ((lift-var lift-var))
(syntax (if (flat-pred? lift-var)
((flat-get lift-var) lift-var)
(lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s"
lift-var
x)))))))
(with-syntax ([val (opt/info-val opt/info)]
[partial-flat-var partial-flat-var])
#'(partial-flat-var val))
lift-var
null)))
;;
;; 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)
(val (opt/info-val opt/info))
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(syntax (let ((ctc stx))
((((proj-get ctc) ctc) pos neg src-info orig-str) val))))
null
null
null
#f
#f
null
null))
;; make-stronger : list-of-(union syntax #f) -> syntax
(define-for-syntax (make-stronger strongers)
(let ((filtered (filter (λ (x) (not (eq? x #f))) strongers)))
(if (null? filtered)
#t
(with-syntax (((stronger ...) strongers))
(syntax (and stronger ...))))))
;; opt/c : syntax -> syntax ;; opt/c : syntax -> syntax
;; opt/c is an optimization routine that takes in an sexp containing ;; opt/c is an optimization routine that takes in an sexp containing
;; contract combinators and attempts to "unroll" those combinators to save ;; contract combinators and attempts to "unroll" those combinators to save
;; on things such as closure allocation time. ;; on things such as closure allocation time.
(define-syntax (opt/c stx) (define-syntax (opt/c stx)
;; opt/i : id id 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 (opt/i pos neg stx) (define (opt/i opt/info stx)
(syntax-case stx () (syntax-case stx (if)
[(ctc arg ...) [(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc)) (and (identifier? #'ctc) (opter #'ctc))
((opter #'ctc) opt/i pos neg stx)] ((opter #'ctc) opt/i opt/info stx)]
[argless-ctc [argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc)) (and (identifier? #'argless-ctc) (opter #'argless-ctc))
((opter #'argless-ctc) opt/i pos neg stx)] ((opter #'argless-ctc) opt/i opt/info stx)]
[else [else
(if (opter 'unknown) (opt/unknown opt/i opt/info stx)]))
((opter 'unknown) opt/i pos neg stx)
(error 'opt/c "opt libraries not loaded properly"))]))
(syntax-case stx () (syntax-case stx ()
[(_ e) [(_ e)
(let-values ([(next lifts partials _ __) (opt/i #'pos #'neg #'e)]) (let*-values ([(info) (make-opt/info #'ctc
#'val
#'pos
#'neg
#'src-info
#'orig-str
null
#f
#f
#'this
#'that
(box 0))]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
(with-syntax ((next next))
(bind-superlifts
superlifts
(bind-lifts
lifts
#`(make-opt-contract
(λ (ctc)
(λ (pos neg src-info orig-str)
#,(bind-lifts
partials
#`(λ (val)
next))))
(λ () e)
(λ (this that) #f)
(vector)
(begin-lifted (box #f)))))))]))
;; define/osc : syntax -> syntax
;; define/osc allows you define optimized recursive contracts, and must be used
;; to define struct contracts.
(define-syntax (define/osc stx)
;; opt/i : id opt/info syntax ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
;;
;; this is different from opt/i only in the aspect that it calls the recursive-call opter
;; if it recognizes a recursive call.
(define (opt/i opt/info stx)
(syntax-case stx ()
[(ctc arg ...)
(and (identifier? #'ctc) (or (opter #'ctc)
(module-identifier=? (opt/info-recf opt/info) #'ctc)))
(if (module-identifier=? (opt/info-recf opt/info) #'ctc)
;; this is a recursive call
(opt/recursive-call opt/info stx)
((opter #'ctc) opt/i opt/info stx))]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
((opter #'argless-ctc) opt/i opt/info stx)]
[else
(opt/unknown opt/i opt/info stx)]))
(syntax-case stx ()
[(_ (f arg ...) base-pred e)
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'pos
#'neg
#'src-info
#'orig-str
(syntax->list (syntax (arg ...)))
#'f
#'base-pred
#'this
#'that
(box 0))]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
(with-syntax ((next next) (with-syntax ((next next)
(lifts (make-lifts lifts)) ((superlift ...) (map (λ (x) (with-syntax ((var (car x))
(partials (make-lifts partials)) (e (cdr x)))
(stx stx)) (syntax (define var e)))) superlifts))
(syntax (make-opt-contract ((stronger-this-var ...) (map stronger-rib-this-var stronger-ribs))
(λ (ctc) ((stronger-that-var ...) (map stronger-rib-that-var stronger-ribs))
(let* lifts ((stronger-exps ...) (map stronger-rib-stronger-exp stronger-ribs))
(λ (pos neg src-info orig-str) ((stronger-indexes ...) (build-list (length stronger-ribs) values))
(let partials ((stronger-var ...) (map stronger-rib-save-id stronger-ribs)))
(λ (val) next))))) #`(begin
(λ () e)))))]))) ;; superlifts are defines
superlift ...
(define (f arg ...)
#,(bind-lifts
lifts
#`(make-opt-contract
(λ (ctc)
(λ (pos neg src-info orig-str)
#,(bind-lifts
partials
#`(λ (val) (if (base-pred val)
val
next)))))
(λ () e)
(λ (this that)
(let ([stronger-that-var (vector-ref (opt-contract-stronger-vars that) stronger-indexes)]
...
[stronger-this-var (vector-ref (opt-contract-stronger-vars this) stronger-indexes)]
...)
(and stronger-exps ...)))
(vector stronger-var ...)
(begin-lifted (box #f))))))))]))
;; optimized contracts
;;
;; getting the name of an optimized contract is slow, but it is only
;; called when blame is raised (thankfully).
;;
;; note that lifts, partials, flat, and unknown are all built into the
;; projection itself and should not be exposed to the outside anyhow.
(define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get)
(make-struct-type-property 'original-contract))
(define-struct/prop opt-contract (proj orig-ctc stronger stronger-vars stamp)
((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc)))
;; I think provide/contract and contract calls this, so we are in effect allocating
;; the original once
(name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc))))
(orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc))))
(stronger-prop (λ (this that)
(and (opt-contract? that)
(eq? (opt-contract-stamp this) (opt-contract-stamp that))
((opt-contract-stronger this) this that))))))
;; opt-stronger-vars-ref : int opt-contract -> any
(define (opt-stronger-vars-ref i ctc)
(let ((v (opt-contract-stronger-vars ctc)))
(vector-ref v i))))

432
collects/mzlib/private/contract.ss
View File

@ -279,18 +279,13 @@ add struct contracts for immutable structs?
[predicate-id (list-ref struct-info 2)] [predicate-id (list-ref struct-info 2)]
[selector-ids (reverse (list-ref struct-info 3))] [selector-ids (reverse (list-ref struct-info 3))]
[mutator-ids (reverse (list-ref struct-info 4))] [mutator-ids (reverse (list-ref struct-info 4))]
[parent-struct-count (let ([parent-info (extract-parent-struct-info struct-name-position)]) [all-parent-struct-count/names (get-field-counts/struct-names struct-name provide-stx)]
(and parent-info [parent-struct-count (if (null? all-parent-struct-count/names)
(let ([fields (cadddr parent-info)]) #f
(cond (let ([pp (cdr all-parent-struct-count/names)])
[(null? fields) 0] (if (null? pp)
[(not (car (last-pair fields))) #f
(raise-syntax-error (car (car pp)))))]
'provide/contract
"cannot determine the number of fields in super struct"
provide-stx
struct-name)]
[else (length fields)]))))]
[field-contract-ids (map (λ (field-name) [field-contract-ids (map (λ (field-name)
(a:mangle-id provide-stx (a:mangle-id provide-stx
"provide/contract-field-contract" "provide/contract-field-contract"
@ -364,6 +359,52 @@ add struct contracts for immutable structs?
provide-stx provide-stx
struct-name)) struct-name))
;; make sure the field names are right.
(let* ([relative-counts (let loop ([c (map car all-parent-struct-count/names)])
(cond
[(null? c) null]
[(null? (cdr c)) c]
[else (cons (- (car c) (cadr c))
(loop (cdr c)))]))]
[names (map cdr all-parent-struct-count/names)]
[maker-name (format "~a" (syntax-e constructor-id))]
[struct-name (substring maker-name 5 (string-length maker-name))])
(let loop ([count (car relative-counts)]
[name (car names)]
[counts (cdr relative-counts)]
[names (cdr names)]
[selector-strs (reverse (map (λ (x) (format "~a" (syntax-e x))) selector-ids))]
[field-names (reverse field-names)])
(cond
[(or (null? counts) (null? names) (null? selector-strs) (null? field-names))
(void)]
[(zero? count)
(loop (car counts) (car names) (cdr counts) (cdr names)
selector-strs
field-names)]
[else
(let* ([selector-str (car selector-strs)]
[field-name (car field-names)]
[field-name-should-be
(substring selector-str
(+ (string-length name) 1)
(string-length selector-str))]
[field-name-is (format "~a" (syntax-e field-name))])
(unless (equal? field-name-should-be field-name-is)
(raise-syntax-error 'provide/contract
(format "expected field name to be ~a, but found ~a"
field-name-should-be
field-name-is)
provide-stx
field-name))
(loop (- count 1)
name
counts
names
(cdr selector-strs)
(cdr field-names)))])))
(with-syntax ([((selector-codes selector-new-names) ...) (with-syntax ([((selector-codes selector-new-names) ...)
(filter (filter
(λ (x) x) (λ (x) x)
@ -434,19 +475,18 @@ add struct contracts for immutable structs?
[super-id (if (boolean? super-id) [super-id (if (boolean? super-id)
super-id super-id
(with-syntax ([super-id super-id]) (with-syntax ([super-id super-id])
(syntax (cert #'super-id))))]) (syntax ((syntax-local-certifier) #'super-id))))])
(syntax (begin (syntax (begin
(provide (rename id-rename struct-name)) (provide (rename id-rename struct-name))
(define-syntax id-rename (define-syntax id-rename
(let ([cert (syntax-local-certifier #t)]) (list-immutable ((syntax-local-certifier) #'-struct:struct-name)
(list-immutable (cert #'-struct:struct-name) ((syntax-local-certifier) #'constructor-new-name)
(cert #'constructor-new-name) ((syntax-local-certifier) #'predicate-new-name)
(cert #'predicate-new-name) (list-immutable ((syntax-local-certifier) #'rev-selector-new-names) ...
(list-immutable (cert #'rev-selector-new-names) ... ((syntax-local-certifier) #'rev-selector-old-names) ...)
(cert #'rev-selector-old-names) ...) (list-immutable ((syntax-local-certifier) #'rev-mutator-new-names) ...
(list-immutable (cert #'rev-mutator-new-names) ... ((syntax-local-certifier) #'rev-mutator-old-names) ...)
(cert #'rev-mutator-old-names) ...) super-id)))))]
super-id))))))]
[struct:struct-name struct:struct-name] [struct:struct-name struct:struct-name]
[-struct:struct-name -struct:struct-name] [-struct:struct-name -struct:struct-name]
[struct-name struct-name] [struct-name struct-name]
@ -454,7 +494,7 @@ add struct contracts for immutable structs?
(syntax/loc stx (syntax/loc stx
(begin (begin
struct-code struct-code
(define field-contract-ids field-contracts) ... (define field-contract-ids (verify-contract field-contracts)) ...
selector-codes ... selector-codes ...
mutator-codes ... mutator-codes ...
predicate-code predicate-code
@ -487,6 +527,37 @@ add struct contracts for immutable structs?
(loop (cdr l1) (loop (cdr l1)
(+ i 1)))]))) (+ i 1)))])))
;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number))
;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs
(define (get-field-counts/struct-names struct-name provide-stx)
(let loop ([parent-info-id struct-name])
(let ([parent-info
(and (identifier? parent-info-id)
(syntax-local-value parent-info-id (λ () #f)))])
(cond
[(boolean? parent-info) null]
[else
(let ([fields (list-ref parent-info 3)]
[constructor (list-ref parent-info 1)])
(cond
[(and (not (null? fields))
(not (car (last-pair fields))))
(raise-syntax-error
'provide/contract
"cannot determine the number of fields in super struct"
provide-stx
struct-name)]
[else
(cons (cons (length fields) (constructor->struct-name constructor))
(loop (list-ref parent-info 5)))]))]))))
(define (constructor->struct-name stx)
(and stx
(let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))])
(and m
(cadr m)))))
;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) ;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
(define (extract-parent-struct-info stx) (define (extract-parent-struct-info stx)
(syntax-case stx () (syntax-case stx ()
@ -497,7 +568,8 @@ add struct contracts for immutable structs?
(raise-syntax-error 'provide/contract (raise-syntax-error 'provide/contract
"expected a struct name" "expected a struct name"
provide-stx provide-stx
(syntax b))))] (syntax b))))
(syntax b)]
[a #f])) [a #f]))
;; extract-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) ;; extract-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
@ -575,7 +647,7 @@ add struct contracts for immutable structs?
(provide (rename id-rename external-name)) (provide (rename id-rename external-name))
(define pos-module-source (module-source-as-symbol #'pos-stx)) (define pos-module-source (module-source-as-symbol #'pos-stx))
(define contract-id ctrct) (define contract-id (verify-contract ctrct))
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-provide/contract-transformer (quote-syntax contract-id)
@ -594,6 +666,13 @@ add struct contracts for immutable structs?
(begin (begin
bodies ...))))])) bodies ...))))]))
(define (verify-contract x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x))
x)
(define (make-pc-struct-type struct-name struct:struct-name . ctcs) (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
(let-values ([(struct:struct-name _make _pred _get _set) (let-values ([(struct:struct-name _make _pred _get _set)
@ -643,7 +722,8 @@ add struct contracts for immutable structs?
(contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))]
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
(syntax/loc stx (syntax/loc stx
(contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e))])) (begin
(contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))]))
(define (contract/proc a-contract-raw name pos-blame neg-blame src-info) (define (contract/proc a-contract-raw name pos-blame neg-blame src-info)
(unless (or (contract? a-contract-raw) (unless (or (contract? a-contract-raw)
@ -988,66 +1068,119 @@ add struct contracts for immutable structs?
;; ;;
;; or/c opter ;; or/c opter
;; ;;
(define/opter (or/c opt/i pos neg stx) (define/opter (or/c opt/i opt/info stx)
;; FIXME code duplication
(define (opt/or-unknown uctc)
(let* ((lift-var (car (generate-temporaries (syntax (lift)))))
(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)
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))))
#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)
(superlift-from-hos null)
(partial-from-hos null)) (partial-from-hos null))
(let-values ([(opt-ps lift-ps partial-ps hos ho-ctc) (let-values ([(opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc)
(let loop ([ps ps] (let loop ([ps ps]
[next-ps null] [next-ps null]
[lift-ps null] [lift-ps null]
[superlift-ps null]
[partial-ps null] [partial-ps null]
[stronger-ribs null]
[hos null] [hos null]
[ho-ctc #f]) [ho-ctc #f])
(cond (cond
[(null? ps) (values next-ps lift-ps partial-ps (reverse hos) ho-ctc)] [(null? ps) (values next-ps
lift-ps
superlift-ps
partial-ps
stronger-ribs
(reverse hos)
ho-ctc)]
[else [else
(let-values ([(next lift partial flat _) (let-values ([(next lift superlift partial flat _ this-stronger-ribs)
(opt/i pos neg (car ps))]) (opt/i opt/info (car ps))])
(if flat (if flat
(loop (cdr ps) (loop (cdr ps)
(cons flat next-ps) (cons flat next-ps)
(append lift-ps lift) (append lift-ps lift)
(append superlift-ps superlift)
(append partial-ps partial) (append partial-ps partial)
(append this-stronger-ribs stronger-ribs)
hos hos
ho-ctc) ho-ctc)
(if (< (length hos) 1) (if (< (length hos) 1)
(loop (cdr ps) (loop (cdr ps)
next-ps next-ps
(append lift-ps lift) (append lift-ps lift)
(append superlift-ps superlift)
(append partial-ps partial) (append partial-ps partial)
(append this-stronger-ribs stronger-ribs)
(cons (car ps) hos) (cons (car ps) hos)
next) next)
(loop (cdr ps) (loop (cdr ps)
next-ps next-ps
lift-ps lift-ps
superlift-ps
partial-ps partial-ps
stronger-ribs
(cons (car ps) hos) (cons (car ps) hos)
ho-ctc))))]))]) ho-ctc))))]))])
(with-syntax ((next-ps (with-syntax (((opt-p ...) opt-ps)) (with-syntax ((next-ps
(syntax (or #f opt-p ...))))) (with-syntax (((opt-p ...) (reverse opt-ps)))
(syntax (or opt-p ...)))))
(values (values
(cond (cond
[(null? hos) (with-syntax ((pos pos)) [(null? hos)
(syntax (with-syntax ([val (opt/info-val opt/info)]
(if next-ps val [pos (opt/info-pos opt/info)]
(raise-contract-error val src-info pos orig-str [src-info (opt/info-src-info opt/info)]
"none of the branches of the or/c matched"))))] [orig-str (opt/info-orig-str opt/info)])
(syntax
(if next-ps
val
(raise-contract-error val src-info pos orig-str
"none of the branches of the or/c matched"))))]
[(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc)) [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
(syntax (syntax
(if next-ps val ho-ctc)))] (if next-ps val ho-ctc)))]
[(> (length hos) 1) ;; FIXME something's not right with this case.
(let-values ([(next-hos lift-hos partial-hos _ __) [(> (length hos) 1)
((opter 'unknown) opt/i pos neg (cons #'or/c hos))]) (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! lift-from-hos lift-hos)
(set! superlift-from-hos superlift-hos)
(set! partial-from-hos partial-hos) (set! partial-from-hos partial-hos)
(with-syntax ((next-hos next-hos)) (with-syntax ((next-hos next-hos))
(syntax (syntax
(if next-ps val next-hos))))]) (if next-ps val next-hos))))])
(append lift-ps lift-from-hos) (append lift-ps lift-from-hos)
(append superlift-ps superlift-from-hos)
(append partial-ps partial-from-hos) (append partial-ps partial-from-hos)
(if (null? hos) (syntax next-ps) #f) (if (null? hos) (syntax next-ps) #f)
#f))))) #f
stronger-ribs)))))
(syntax-case stx (or/c) (syntax-case stx (or/c)
[(or/c p ...) [(or/c p ...)
@ -1179,58 +1312,136 @@ add struct contracts for immutable structs?
;; ;;
;; between/c opter helper ;; between/c opter helper
;; ;;
(define-for-syntax (opt/between-ctc pos stx low high op checker)
(let* ((lift-vars (generate-temporaries (syntax (low high error-check))))
(lift-low (car lift-vars))
(lift-high (cadr lift-vars)))
(with-syntax ((pos pos)
(op op)
(n lift-low)
(m lift-high))
(values
(syntax (if (and (number? val) (op n val m)) val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val)))
(interleave-lifts
lift-vars
(list low
high
(cond
[(eq? checker 'between/c) #'(check-between/c n m)]
[(eq? checker '>/c) #'(check-unary-between/c '>/c n)]
[(eq? checker '>=/c) #'(check-unary-between/c '>=/c n)]
[(eq? checker '</c) #'(check-unary-between/c '</c m)]
[(eq? checker '<=/c) #'(check-unary-between/c '<=/c m)])))
null
(syntax (and (number? val) (op n val m)))
#f))))
;; ;;
;; between/c and friends' opters ;; between/c opters
;; ;;
;; note that the checkers are used by both optimized and normal contracts. ;; note that the checkers are used by both optimized and normal contracts.
;; ;;
(define/opter (between/c opt/i pos neg stx) (define/opter (between/c opt/i opt/info stx)
(syntax-case stx (between/c) (syntax-case stx (between/c)
[(between/c low high) (opt/between-ctc pos stx #'low #'high #'<= 'between/c)])) [(between/c low high)
(define/opter (>/c opt/i pos neg stx) (let*-values ([(lift-low lifts1) (lift/binding #'low 'between-low empty-lifts)]
(syntax-case stx (>/c) [(lift-high lifts2) (lift/binding #'high 'between-high lifts1)])
[(>/c low) (opt/between-ctc pos stx #'low #'+inf.0 #'< '>/c)])) (with-syntax ([n lift-low]
(define/opter (>=/c opt/i pos neg stx) [m lift-high])
(let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)])
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(this (opt/info-this opt/info))
(that (opt/info-that opt/info)))
(values
(syntax (if (and (number? val) (<= n val m))
val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val)))
lifts3
null
null
(syntax (and (number? val) (<= n val m)))
#f
(list (new-stronger-var
lift-low
(λ (this that)
(with-syntax ([this this]
[that that])
(syntax (<= that this)))))
(new-stronger-var
lift-high
(λ (this that)
(with-syntax ([this this]
[that that])
(syntax (<= this that)))))))))))]))
(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg)
(with-syntax ([comparison comparison])
(let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)])
(with-syntax ([m lift-low])
(let ([lifts3 (lift/effect (check-arg #'m) lifts2)])
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(this (opt/info-this opt/info))
(that (opt/info-that opt/info)))
(values
(syntax (if (and (number? val) (comparison val m))
val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val)))
lifts3
null
null
(syntax (and (number? val) (comparison val m)))
#f
(list (new-stronger-var
lift-low
(λ (this that)
(with-syntax ([this this]
[that that])
(syntax (comparison this that)))))))))))))
(define/opter (>=/c opt/i opt/info stx)
(syntax-case stx (>=/c) (syntax-case stx (>=/c)
[(>=/c low) (opt/between-ctc pos stx #'low #'+inf.0 #'<= '>=/c)])) [(>=/c low)
(define/opter (</c opt/i pos neg stx) (single-comparison-opter
(syntax-case stx (</c) opt/info
[(</c high) (opt/between-ctc pos stx #'-inf.0 #'high #'< '</c)])) stx
(define/opter (<=/c opt/i pos neg stx) (λ (m) (with-syntax ([m m])
#'(check-unary-between/c '>=/c m)))
#'>=
#'low)]))
(define/opter (<=/c opt/i opt/info stx)
(syntax-case stx (<=/c) (syntax-case stx (<=/c)
[(<=/c high) (opt/between-ctc pos stx #'-inf.0 #'high #'<= '<=/c)])) [(<=/c high)
(single-comparison-opter
opt/info
stx
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '<=/c m)))
#'<=
#'high)]))
(define/opter (>/c opt/i opt/info stx)
(syntax-case stx (>/c)
[(>/c low)
(single-comparison-opter
opt/info
stx
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '>/c m)))
#'>
#'low)]))
(define/opter (</c opt/i opt/info stx)
(syntax-case stx (</c)
[(</c high)
(single-comparison-opter
opt/info
stx
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '</c m)))
#'<
#'high)]))
(define (</c x) (define (</c x)
(flat-named-contract (flat-named-contract
@ -1404,21 +1615,26 @@ add struct contracts for immutable structs?
;; ;;
;; cons/c opter ;; cons/c opter
;; ;;
(define/opter (cons/c opt/i pos neg 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 partials-hdp flat-hdp unknown-hdp) (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd)
(opt/i pos neg hdp)] (opt/i opt/info hdp)]
[(next-tlp lifts-tlp partials-tlp flat-tlp unknown-tlp) [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl)
(opt/i pos neg tlp)] (opt/i opt/info tlp)]
[(error-check) (car (generate-temporaries (syntax (error-check))))]) [(error-check) (car (generate-temporaries (syntax (error-check))))])
(with-syntax ((next (with-syntax ((flat-hdp flat-hdp) (with-syntax ((next (with-syntax ((flat-hdp flat-hdp)
(flat-tlp flat-tlp)) (flat-tlp flat-tlp)
(val (opt/info-val opt/info)))
(syntax (syntax
(and (pair? val) (and (pair? val)
(let ((val (car val))) flat-hdp) (let ((val (car val))) flat-hdp)
(let ((val (cdr val))) flat-tlp)))))) (let ((val (cdr val))) flat-tlp))))))
(values (values
(with-syntax ((pos pos)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(syntax (if next (syntax (if next
val val
(raise-contract-error (raise-contract-error
@ -1451,9 +1667,11 @@ add struct contracts for immutable structs?
(unless check (unless check
(error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e"
hdp tlp))))))) hdp tlp)))))))
(append superlifts-hdp superlifts-tlp)
(append partials-hdp partials-tlp) (append partials-hdp partials-tlp)
(syntax (if next #t #f)) (syntax (if next #t #f))
#f)))) #f
(append stronger-ribs-hd stronger-ribs-tl)))))
(syntax-case stx (cons/c) (syntax-case stx (cons/c)
[(cons/c hdp tlp) [(cons/c hdp tlp)
@ -1540,15 +1758,20 @@ add struct contracts for immutable structs?
;; ;;
;; cons-immutable/c opter ;; cons-immutable/c opter
;; ;;
(define/opter (cons-immutable/c opt/i pos neg stx) (define/opter (cons-immutable/c opt/i opt/info stx)
(define (opt/cons-immutable-ctc hdp tlp) (define (opt/cons-immutable-ctc hdp tlp)
(let-values ([(next-hdp lifts-hdp partials-hdp flat-hdp unknown-hdp) (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd)
(opt/i pos neg hdp)] (opt/i opt/info hdp)]
[(next-tlp lifts-tlp partials-tlp flat-tlp unknown-tlp) [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl)
(opt/i pos neg tlp)]) (opt/i opt/info tlp)])
(with-syntax ((check (syntax (and (immutable? val) (pair? val))))) (with-syntax ((check (with-syntax ((val (opt/info-val opt/info)))
(syntax (and (immutable? val) (pair? val))))))
(values (values
(with-syntax ((pos pos) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(next-hdp next-hdp) (next-hdp next-hdp)
(next-tlp next-tlp)) (next-tlp next-tlp))
(syntax (if check (syntax (if check
@ -1563,15 +1786,18 @@ add struct contracts for immutable structs?
((name-get ctc) ctc) ((name-get ctc) ctc)
val)))) val))))
(append lifts-hdp lifts-tlp) (append lifts-hdp lifts-tlp)
(append superlifts-hdp superlifts-tlp)
(append partials-hdp partials-tlp) (append partials-hdp partials-tlp)
(if (and flat-hdp flat-tlp) (if (and flat-hdp flat-tlp)
(with-syntax ((flat-hdp flat-hdp) (with-syntax ((val (opt/info-val opt/info))
(flat-hdp flat-hdp)
(flat-tlp flat-tlp)) (flat-tlp flat-tlp))
(syntax (if (and check (syntax (if (and check
(let ((val (car val))) flat-hdp) (let ((val (car val))) flat-hdp)
(let ((val (cdr val))) flat-tlp)) #t #f))) (let ((val (cdr val))) flat-tlp)) #t #f)))
#f) #f)
#f)))) #f
(append stronger-ribs-hd stronger-ribs-tl)))))
(syntax-case stx (cons-immutable/c) (syntax-case stx (cons-immutable/c)
[(cons-immutable/c hdp tlp) (opt/cons-immutable-ctc #'hdp #'tlp)])) [(cons-immutable/c hdp tlp) (opt/cons-immutable-ctc #'hdp #'tlp)]))

1607
collects/tests/mzscheme/contract-test.ss
View File

File diff suppressed because it is too large Load Diff