Added struct/dc and cleaned up a bunch of stuff in the contract
library (mostly in opt/c) Specifically: - add inlining declaration for ->i helper function - modernized the opt/c contracts and improved them so that mutually recursive define-opt/c functions recognize each other instead of bailing out to the slow path. - added =/c as an optimized contract - improve the error message for the between and comparison opt contracts - adjust the blame struct so the name is created lazily, since opt/c contracts just stick a copy o the contract into the thunk that creates the name and we don't want to run those effects twice if we can help it.
This commit is contained in:
Robby Findler
parent
fdb70316f1
commit
5e03c7cf99
|
|
@ -7,6 +7,7 @@
|
|||
"misc.rkt"
|
||||
"blame.rkt"
|
||||
syntax/location
|
||||
racket/performance-hint
|
||||
(for-syntax racket/base
|
||||
racket/stxparam-exptime
|
||||
"arr-i-parse.rkt"
|
||||
|
|
@ -623,9 +624,10 @@
|
|||
(λ args (apply arg-checker args)))
|
||||
impersonator-prop:contracted ctc))))))))
|
||||
|
||||
(define (un-dep ctc obj blame)
|
||||
(let ([ctc (coerce-contract '->i ctc)])
|
||||
(((contract-projection ctc) blame) obj)))
|
||||
(begin-encourage-inline
|
||||
(define (un-dep ctc obj blame)
|
||||
(let ([ctc (coerce-contract '->i ctc)])
|
||||
(((contract-projection ctc) blame) obj))))
|
||||
|
||||
(define-for-syntax (mk-used-indy-vars an-istx)
|
||||
(let ([vars (make-free-identifier-mapping)])
|
||||
|
|
|
|||
|
|
@ -569,13 +569,14 @@ v4 todo:
|
|||
|
||||
(define-struct (chaperone-> base->) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection (->-proj chaperone-procedure)
|
||||
#:name ->-name
|
||||
#:first-order ->-first-order
|
||||
#:stronger ->-stronger?
|
||||
#:generate ->-generate
|
||||
#:exercise ->-exercise))
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection (->-proj chaperone-procedure)
|
||||
#:name ->-name
|
||||
#:first-order ->-first-order
|
||||
#:stronger ->-stronger?
|
||||
#:generate ->-generate
|
||||
#:exercise ->-exercise)))
|
||||
|
||||
(define-struct (impersonator-> base->) ()
|
||||
#:property prop:contract
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ improve method arity mismatch contract violation error messages?
|
|||
(check-source-location! 'contract loc)
|
||||
(let ([new-val
|
||||
(((contract-projection c)
|
||||
(make-blame loc name (contract-name c) pos neg #t))
|
||||
(make-blame loc name (λ () (contract-name c)) pos neg #t))
|
||||
v)])
|
||||
(if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
|
||||
(procedure? new-val)
|
||||
|
|
|
|||
|
|
@ -18,12 +18,7 @@
|
|||
(blame (opt/info-blame opt/info)))
|
||||
(syntax (if (pred val)
|
||||
val
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, given: ~e"
|
||||
(contract-name ctc)
|
||||
val))))
|
||||
(raise-opt/pred-error blame val 'pred))))
|
||||
null
|
||||
null
|
||||
null
|
||||
|
|
@ -32,33 +27,24 @@
|
|||
null
|
||||
#t)))
|
||||
|
||||
(define (raise-opt/pred-error blame val pred-name)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected ~a"
|
||||
pred-name))
|
||||
|
||||
;;
|
||||
;; built-in predicate opters
|
||||
;;
|
||||
(define/opter (null? opt/i opt/info stx)
|
||||
(syntax-case stx (null?)
|
||||
[null? (opt/pred opt/info #'null?)]))
|
||||
(define/opter (boolean? opt/i opt/info stx)
|
||||
(syntax-case stx (boolean?)
|
||||
[boolean? (opt/pred opt/info #'boolean?)]))
|
||||
(define/opter (string? opt/i opt/info stx)
|
||||
(syntax-case stx (string?)
|
||||
[string? (opt/pred opt/info #'string?)]))
|
||||
(define/opter (integer? opt/i opt/info stx)
|
||||
(syntax-case stx (integer?)
|
||||
[integer? (opt/pred opt/info #'integer?)]))
|
||||
(define/opter (char? opt/i opt/info stx)
|
||||
(syntax-case stx (char?)
|
||||
[char? (opt/pred opt/info #'char?)]))
|
||||
(define/opter (number? opt/i opt/info stx)
|
||||
(syntax-case stx (number?)
|
||||
[number? (opt/pred opt/info #'number?)]))
|
||||
(define/opter (pair? opt/i opt/info stx)
|
||||
(syntax-case stx (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)]))
|
||||
(define/opter (null? opt/i opt/info stx) (opt/pred opt/info #'null?))
|
||||
(define/opter (boolean? opt/i opt/info stx) (opt/pred opt/info #'boolean?))
|
||||
(define/opter (string? opt/i opt/info stx) (opt/pred opt/info #'string?))
|
||||
(define/opter (integer? opt/i opt/info stx) (opt/pred opt/info #'integer?))
|
||||
(define/opter (char? opt/i opt/info stx) (opt/pred opt/info #'char?))
|
||||
(define/opter (number? opt/i opt/info stx) (opt/pred opt/info #'number?))
|
||||
(define/opter (pair? opt/i opt/info stx) (opt/pred opt/info #'pair?))
|
||||
(define/opter (not opt/i opt/info stx) (opt/pred opt/info #'not))
|
||||
|
||||
;;
|
||||
;; any/c
|
||||
|
|
@ -78,9 +64,7 @@
|
|||
;;
|
||||
;; false/c
|
||||
;;
|
||||
(define/opter (false/c opt/i opt/info stx)
|
||||
(syntax-case stx (false/c)
|
||||
[false/c (opt/pred opt/info #'not)]))
|
||||
(define/opter (false/c opt/i opt/info stx) (opt/pred opt/info #'not))
|
||||
|
||||
;;
|
||||
;; flat-contract helper
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/srcloc racket/pretty setup/path-to-relative)
|
||||
|
||||
(provide blame?
|
||||
|
|
@ -35,10 +34,12 @@
|
|||
(hash/recur (blame-original? b))))
|
||||
|
||||
(define-struct blame
|
||||
[source value contract positive negative original?]
|
||||
[source value build-name positive negative original?]
|
||||
#:property prop:equal+hash
|
||||
(list blame=? blame-hash blame-hash))
|
||||
|
||||
(define (blame-contract b) ((blame-build-name b)))
|
||||
|
||||
(define (blame-swap b)
|
||||
(struct-copy
|
||||
blame b
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
build-clauses
|
||||
build-enforcer-clauses
|
||||
generate-arglists
|
||||
(struct-out contract-struct-transformer))
|
||||
(struct-out contract-struct-transformer)
|
||||
defeat-inlining)
|
||||
|
||||
(require racket/struct-info "opt-guts.rkt")
|
||||
(require (for-template racket/base))
|
||||
|
|
@ -47,19 +48,7 @@ which are then called when the contract's fields are explored
|
|||
"expected a field name and a contract together"
|
||||
stx
|
||||
clause)]))]))]
|
||||
[all-ac-ids (generate-temporaries field-names)]
|
||||
[defeat-inlining
|
||||
;; makes the procedure confusing enough so that
|
||||
;; inlining doesn't consider it. this makes the
|
||||
;; call to procedure-closure-contents-eq? work
|
||||
;; properly
|
||||
(λ (e)
|
||||
(let loop ([n 30])
|
||||
(if (zero? n)
|
||||
e
|
||||
#`(if (zero? (random 1))
|
||||
#,(loop (- n 1))
|
||||
(/ 1 0)))))])
|
||||
[all-ac-ids (generate-temporaries field-names)])
|
||||
(let loop ([clauses (syntax->list clauses)]
|
||||
[ac-ids all-ac-ids]
|
||||
[prior-ac-ids '()]
|
||||
|
|
@ -112,6 +101,18 @@ which are then called when the contract's fields are explored
|
|||
[_
|
||||
(raise-syntax-error name "expected name/identifier binding" stx clause)]))]))]))))
|
||||
|
||||
;; makes the procedure confusing enough so that
|
||||
;; inlining doesn't consider it. this makes the
|
||||
;; call to procedure-closure-contents-eq? work
|
||||
;; properly
|
||||
(define (defeat-inlining e)
|
||||
(let loop ([n 30])
|
||||
(if (zero? n)
|
||||
e
|
||||
#`(if (zero? (random 1))
|
||||
#,(loop (- n 1))
|
||||
(/ 1 0)))))
|
||||
|
||||
(define (build-clauses/where name stx clauses field-names maker-args)
|
||||
(with-syntax ([(field-names ...) field-names])
|
||||
(let loop ([clauses clauses]
|
||||
|
|
@ -143,7 +144,9 @@ which are then called when the contract's fields are explored
|
|||
(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) (free-identifier=? (opt/info-recf opt/info) #'f))
|
||||
(and (identifier? #'f)
|
||||
(opt/info-recf opt/info)
|
||||
(free-identifier=? (opt/info-recf opt/info) #'f))
|
||||
(values
|
||||
#`(f #,id arg ...)
|
||||
null
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ it around flattened out.
|
|||
"blame.rkt"
|
||||
"opt.rkt"
|
||||
"misc.rkt")
|
||||
(require (for-syntax scheme/base)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax "ds-helpers.rkt")
|
||||
(for-syntax "helpers.rkt")
|
||||
(for-syntax "opt-guts.rkt"))
|
||||
|
|
@ -367,8 +367,7 @@ it around flattened out.
|
|||
[enforcer-id enforcer-id-var]
|
||||
[helper-id helper-id-var]
|
||||
[((free-var free-var-val) (... ...))
|
||||
(make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
|
||||
[(saved-lifts (... ...)) (lifts-to-save lifts)])
|
||||
(make-free-vars (append (opt/info-free-vars opt/info)) #'freev)])
|
||||
(values
|
||||
#`(λ (stct f-x ...)
|
||||
(let ((free-var free-var-val) (... ...))
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
(apply raise-blame-error
|
||||
(make-blame (unpack-source src)
|
||||
(unpack-name src)
|
||||
name
|
||||
(λ () name)
|
||||
(unpack-blame pos)
|
||||
"<<unknown party>>"
|
||||
#t)
|
||||
|
|
@ -47,7 +47,7 @@
|
|||
(lambda (pos neg src name [original? #t])
|
||||
(proj (make-blame (unpack-source src)
|
||||
(unpack-name src)
|
||||
name
|
||||
(λ () name)
|
||||
(unpack-blame (if original? pos neg))
|
||||
(unpack-blame (if original? neg pos))
|
||||
original?)))))
|
||||
|
|
|
|||
|
|
@ -178,11 +178,12 @@
|
|||
|
||||
(define-struct (chaperone-single-or/c single-or/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
#:stronger single-or/c-stronger?))
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
#:stronger single-or/c-stronger?)))
|
||||
|
||||
(define-struct (impersonator-single-or/c single-or/c) ()
|
||||
#:property prop:contract
|
||||
|
|
@ -264,11 +265,12 @@
|
|||
|
||||
(define-struct (chaperone-multi-or/c multi-or/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
#:stronger multi-or/c-stronger?))
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
#:stronger multi-or/c-stronger?)))
|
||||
|
||||
(define-struct (impersonator-multi-or/c multi-or/c) ()
|
||||
#:property prop:contract
|
||||
|
|
@ -376,11 +378,12 @@
|
|||
#:stronger and-stronger?))
|
||||
(define-struct (chaperone-and/c base-and/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?)))
|
||||
(define-struct (impersonator-and/c base-and/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
|
|
@ -763,10 +766,11 @@
|
|||
|
||||
(struct chaperone-list/c generic-list/c ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name list/c-name-proc
|
||||
#:first-order list/c-first-order
|
||||
#:projection list/c-chaperone/other-projection))
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:name list/c-name-proc
|
||||
#:first-order list/c-first-order
|
||||
#:projection list/c-chaperone/other-projection)))
|
||||
|
||||
(struct higher-order-list/c generic-list/c ()
|
||||
#:property prop:contract
|
||||
|
|
|
|||
|
|
@ -131,14 +131,21 @@
|
|||
;; 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 (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*-values))
|
||||
(define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec-values))
|
||||
|
||||
(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)))))
|
||||
(with-syntax ([(lifts-x ...) (map (λ (x) (cond
|
||||
[(identifier? x) (list x)]
|
||||
[(let ([lst (syntax->list x)])
|
||||
(and lst
|
||||
(andmap identifier? lst)))
|
||||
x]
|
||||
[else
|
||||
(generate-temporaries '(junk))]))
|
||||
(syntax->list (syntax (lifts-x ...))))]
|
||||
[binding-form binding-form])
|
||||
#`(binding-form ([lifts-x lift-e] ...)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require "prop.rkt"
|
||||
"misc.rkt"
|
||||
"blame.rkt"
|
||||
racket/stxparam)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax "opt-guts.rkt")
|
||||
|
|
@ -10,18 +11,23 @@
|
|||
opt/direct
|
||||
begin-lifted)
|
||||
|
||||
;; define/opter : id -> syntax
|
||||
;; (define/opter (<contract-combinator> opt/i opt/info stx) body)
|
||||
;;
|
||||
;; Takes an expression which is to be expected of the following signature:
|
||||
;; An opter is to a function with the following signature:
|
||||
;;
|
||||
;; opter : id id syntax list-of-ids ->
|
||||
;; syntax syntax-list syntax-list syntax-list (union syntax #f) (union syntax #f) syntax
|
||||
;;
|
||||
;; 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)
|
||||
;;
|
||||
;; It takes in an identifier for pos, neg, and the original syntax. An identifier
|
||||
;; that can be used to call the opt/i function is also implicitly passed into
|
||||
;; every opter. A list of free-variables is implicitly passed if the calling context
|
||||
;; was define/osc otherwise it is null.
|
||||
;; 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
|
||||
|
|
@ -40,6 +46,7 @@
|
|||
;; 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 indicating if this contract is a chaperone contract
|
||||
(define-syntax (define/opter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (for opt/i opt/info stx) expr ...)
|
||||
|
|
@ -82,6 +89,55 @@
|
|||
(with-syntax (((stronger ...) strongers))
|
||||
(syntax (and stronger ...))))))
|
||||
|
||||
(define-for-syntax (coerecable-constant? konst)
|
||||
(syntax-case konst (quote)
|
||||
['x
|
||||
(identifier? #'x)
|
||||
#t]
|
||||
[other
|
||||
(let ([o (syntax-e #'other)])
|
||||
(or (boolean? o)
|
||||
(char? o)
|
||||
(null? o)
|
||||
(string? o)
|
||||
(bytes? o)
|
||||
(number? o)))]))
|
||||
|
||||
(define-for-syntax (opt-constant-contract konst opt/info)
|
||||
(define v (opt/info-val opt/info))
|
||||
(define-values (predicate word)
|
||||
(cond
|
||||
[(and (pair? konst) (eq? (car konst) 'quote))
|
||||
(values #`(eq? #,konst #,v)
|
||||
"eq?")]
|
||||
[(or (boolean? konst) (char? konst) (null? konst))
|
||||
(values #`(eq? #,konst #,v)
|
||||
"eq?")]
|
||||
[(or (string? konst) (bytes? konst))
|
||||
(values #`(equal? #,konst #,v)
|
||||
"equal?")]
|
||||
[(number? konst)
|
||||
(values #`(and (number? #,v) (= #,konst #,v))
|
||||
"=")]))
|
||||
(values
|
||||
#`(if #,predicate
|
||||
#,v
|
||||
(opt-constant-contract-failure #,(opt/info-blame opt/info) #,v #,word #,konst))
|
||||
null
|
||||
null
|
||||
null
|
||||
predicate
|
||||
#f
|
||||
null
|
||||
#t))
|
||||
|
||||
(define (opt-constant-contract-failure blame val compare should-be)
|
||||
(raise-blame-error blame val "expected a value ~a to ~e" compare should-be))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct define-opt/recursive-fn (transformer internal-fn)
|
||||
#:property prop:procedure 0))
|
||||
|
||||
;; opt/i : id opt/info syntax ->
|
||||
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
|
||||
(define-for-syntax (opt/i opt/info stx)
|
||||
|
|
@ -95,11 +151,13 @@
|
|||
((opter #'argless-ctc) opt/i opt/info stx)]
|
||||
[(f arg ...)
|
||||
(and (identifier? #'f)
|
||||
(syntax-parameter-value #'define/opt-recursive-fn)
|
||||
(free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
|
||||
#'f))
|
||||
(define-opt/recursive-fn? (syntax-local-value #'f (λ () #f))))
|
||||
(values
|
||||
#`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
|
||||
#`(#,(define-opt/recursive-fn-internal-fn (syntax-local-value #'f))
|
||||
#,(opt/info-contract opt/info)
|
||||
#,(opt/info-blame opt/info)
|
||||
#,(opt/info-val opt/info)
|
||||
arg ...)
|
||||
null
|
||||
null
|
||||
null
|
||||
|
|
@ -107,7 +165,16 @@
|
|||
#f
|
||||
null
|
||||
#t)]
|
||||
[konst
|
||||
(coerecable-constant? #'konst)
|
||||
(opt-constant-contract (syntax->datum #'konst) opt/info)]
|
||||
[else
|
||||
(log-info (format "warning in ~a:~a: opt/c doesn't know the contract ~s"
|
||||
(syntax-source stx)
|
||||
(if (syntax-line stx)
|
||||
(format "~a:~a" (syntax-line stx) (syntax-column stx))
|
||||
(format ":~a" (syntax-position stx)))
|
||||
(syntax->datum stx)))
|
||||
(opt/unknown opt/i opt/info stx)]))
|
||||
|
||||
;; top-level-unknown? : syntax -> boolean
|
||||
|
|
@ -120,11 +187,12 @@
|
|||
[argless-ctc
|
||||
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
|
||||
#f]
|
||||
[konst
|
||||
(coerecable-constant? #'konst)
|
||||
#f]
|
||||
[(f arg ...)
|
||||
(and (identifier? #'f)
|
||||
(syntax-parameter-value #'define/opt-recursive-fn)
|
||||
(free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
|
||||
#'f))
|
||||
(define-opt/recursive-fn? (syntax-local-value #'f (λ () #f))))
|
||||
#f]
|
||||
[else
|
||||
#t]))
|
||||
|
|
@ -135,16 +203,12 @@
|
|||
;; on things such as closure allocation time.
|
||||
(define-syntax (opt/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
(if (top-level-unknown? #'e)
|
||||
#'e
|
||||
#'(opt/c e ()))]
|
||||
[(_ e (opt-recursive-args ...))
|
||||
[(_ e)
|
||||
(let*-values ([(info) (make-opt/info #'ctc
|
||||
#'val
|
||||
#'blame
|
||||
#f
|
||||
(syntax->list #'(opt-recursive-args ...))
|
||||
'()
|
||||
#f
|
||||
#f
|
||||
#'this
|
||||
|
|
@ -158,18 +222,9 @@
|
|||
#`(make-opt-contract
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
#,(if (syntax-parameter-value #'define/opt-recursive-fn)
|
||||
(with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)])
|
||||
(bind-superlifts
|
||||
(cons
|
||||
(cons (syntax-parameter-value #'define/opt-recursive-fn)
|
||||
#'(λ (val opt-recursive-args ...) next))
|
||||
partials)
|
||||
#'(λ (val)
|
||||
(f val opt-recursive-args ...))))
|
||||
(bind-superlifts
|
||||
partials
|
||||
#`(λ (val) next)))))
|
||||
#,(bind-superlifts
|
||||
partials
|
||||
#`(λ (val) next))))
|
||||
(λ () e)
|
||||
(λ (this that) #f)
|
||||
(vector)
|
||||
|
|
@ -209,14 +264,64 @@
|
|||
[(_ expr)
|
||||
(syntax-local-lift-expression #'expr)]))
|
||||
|
||||
(define-syntax-parameter define/opt-recursive-fn #f)
|
||||
|
||||
(define-syntax (define-opt/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id args ...) body)
|
||||
#'(define (id args ...)
|
||||
(syntax-parameterize ([define/opt-recursive-fn #'id])
|
||||
(opt/c body (args ...))))]))
|
||||
[(_ (id args ...) e)
|
||||
(with-syntax ([(f1 f2)
|
||||
(generate-temporaries (list (format "~a-f1" (syntax-e #'id))
|
||||
(format "~a-f2" (syntax-e #'id))))])
|
||||
#`(begin
|
||||
(define-syntax id
|
||||
(define-opt/recursive-fn
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[f
|
||||
(identifier? #'f)
|
||||
#'f1]
|
||||
[(f . call-args)
|
||||
(with-syntax ([app (datum->syntax stx '#%app)])
|
||||
#'(app f1 . call-args))]))
|
||||
#'f2))
|
||||
(define-values (f1 f2) (opt/c-helper f1 f2 (id args ...) e))))]))
|
||||
|
||||
(define-syntax (opt/c-helper stx)
|
||||
(syntax-case stx ()
|
||||
[(_ f1 f2 (id args ...) e)
|
||||
(let*-values ([(info) (make-opt/info #'ctc
|
||||
#'val
|
||||
#'blame
|
||||
#f
|
||||
(syntax->list #'(args ...))
|
||||
#f
|
||||
#f
|
||||
#'this
|
||||
#'that)]
|
||||
[(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)])
|
||||
(with-syntax ([next next])
|
||||
#`(let ()
|
||||
(define (f2 ctc blame val args ...)
|
||||
#,(bind-superlifts
|
||||
superlifts
|
||||
(bind-lifts
|
||||
lifts
|
||||
(bind-superlifts
|
||||
partials
|
||||
#'next))))
|
||||
(define (f1 args ...)
|
||||
#,(bind-superlifts
|
||||
superlifts
|
||||
(bind-lifts
|
||||
lifts
|
||||
#`(make-opt-contract
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(f2 ctc blame val args ...))))
|
||||
(λ () e)
|
||||
(λ (this that) #f)
|
||||
(vector)
|
||||
(begin-lifted (box #f))))))
|
||||
(values f1 f2))))]))
|
||||
|
||||
;; optimized contracts
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
"blame.rkt"
|
||||
"misc.rkt"
|
||||
"arrow.rkt"
|
||||
"struct.rkt"
|
||||
(for-syntax racket/base
|
||||
syntax/stx
|
||||
"opt-guts.rkt"))
|
||||
|
|
@ -106,7 +107,8 @@
|
|||
val
|
||||
"none of the branches of the or/c matched"))))]
|
||||
[(= (length hos) 1)
|
||||
(with-syntax ((ho-ctc ho-ctc))
|
||||
(with-syntax ([ho-ctc ho-ctc]
|
||||
[val (opt/info-val opt/info)])
|
||||
(syntax
|
||||
(if next-ps val ho-ctc)))]
|
||||
;; FIXME something's not right with this case.
|
||||
|
|
@ -153,12 +155,8 @@
|
|||
(values
|
||||
(syntax (if (and (number? val) (<= n val m))
|
||||
val
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, given: ~e"
|
||||
(contract-name ctc)
|
||||
val)))
|
||||
(raise-opt-between/c-error
|
||||
blame val n m)))
|
||||
lifts3
|
||||
null
|
||||
null
|
||||
|
|
@ -178,6 +176,14 @@
|
|||
(syntax (<= this that))))))
|
||||
#t)))))]))
|
||||
|
||||
(define (raise-opt-between/c-error blame val lo hi)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected a number between ~a and ~a, given: ~e"
|
||||
lo hi
|
||||
val))
|
||||
|
||||
(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)])
|
||||
|
|
@ -192,12 +198,7 @@
|
|||
(syntax
|
||||
(if (and (real? val) (comparison val m))
|
||||
val
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected: ~s, given: ~e"
|
||||
(contract-name ctc)
|
||||
val)))
|
||||
(raise-opt-single-comparison-opter-error blame val comparison m)))
|
||||
lifts3
|
||||
null
|
||||
null
|
||||
|
|
@ -211,6 +212,26 @@
|
|||
(syntax (comparison this that))))))
|
||||
#t)))))))
|
||||
|
||||
(define (raise-opt-single-comparison-opter-error blame val comparison m)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected a number ~a ~a, given: ~e"
|
||||
(object-name comparison) m
|
||||
val))
|
||||
|
||||
|
||||
(define/opter (=/c opt/i opt/info stx)
|
||||
(syntax-case stx (=/c)
|
||||
[(=/c x)
|
||||
(single-comparison-opter
|
||||
opt/info
|
||||
stx
|
||||
(λ (m) (with-syntax ([m m])
|
||||
#'(check-unary-between/c '=/c m)))
|
||||
#'=
|
||||
#'x)]))
|
||||
|
||||
(define/opter (>=/c opt/i opt/info stx)
|
||||
(syntax-case stx (>=/c)
|
||||
[(>=/c low)
|
||||
|
|
|
|||
|
|
@ -29,7 +29,9 @@
|
|||
|
||||
make-contract
|
||||
make-chaperone-contract
|
||||
make-flat-contract)
|
||||
make-flat-contract
|
||||
|
||||
skip-projection-wrapper?)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
@ -167,6 +169,8 @@
|
|||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define skip-projection-wrapper? (make-parameter #f))
|
||||
|
||||
(define ((build-property mk default-name projection-wrapper)
|
||||
#:name [get-name #f]
|
||||
#:first-order [get-first-order #f]
|
||||
|
|
@ -179,7 +183,9 @@
|
|||
[get-first-order (or get-first-order get-any?)]
|
||||
[get-projection
|
||||
(cond
|
||||
[get-projection (projection-wrapper get-projection)]
|
||||
[get-projection (if (skip-projection-wrapper?)
|
||||
get-projection
|
||||
(projection-wrapper get-projection))]
|
||||
[else (get-first-order-projection
|
||||
get-name get-first-order)])]
|
||||
[stronger (or stronger weakest)])
|
||||
|
|
@ -299,4 +305,3 @@
|
|||
|
||||
(define make-flat-contract
|
||||
(build-contract make-make-flat-contract 'anonymous-flat-contract))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,14 +2,19 @@
|
|||
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
racket/struct-info)
|
||||
racket/struct-info
|
||||
"opt-guts.rkt"
|
||||
(only-in "ds-helpers.rkt" defeat-inlining))
|
||||
syntax/location
|
||||
racket/list
|
||||
"guts.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt"
|
||||
"misc.rkt")
|
||||
"misc.rkt"
|
||||
"opt.rkt")
|
||||
|
||||
(provide struct/c)
|
||||
(provide struct/c
|
||||
(rename-out [-struct/dc struct/dc]))
|
||||
|
||||
(define-syntax (struct/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -95,32 +100,37 @@
|
|||
(for ([p (in-list flat-imm-pos-projs)]
|
||||
[ref (in-list flat-imm-refs)])
|
||||
(p (ref val)))
|
||||
|
||||
;; While gathering up the selectors and the appropriate projections,
|
||||
;; we go ahead and apply the projection to check the first order properties.
|
||||
(let ([combined-imm-refs
|
||||
(for/list ([p (in-list chap-imm-pos-projs)]
|
||||
[ref (in-list chap-imm-refs)])
|
||||
(p (ref val))
|
||||
(list ref (λ (s v) (p v))))]
|
||||
[combined-mut-refs
|
||||
(for/list ([p (in-list mut-pos-projs)]
|
||||
[ref (in-list mut-refs)])
|
||||
(p (ref val))
|
||||
(list ref (λ (s v) (p v))))]
|
||||
[combined-mut-sets
|
||||
(for/list ([p (in-list mut-neg-projs)]
|
||||
[set (in-list mut-sets)])
|
||||
(list set (λ (s v) (p v))))])
|
||||
(apply chaperone-struct val
|
||||
(flatten (list combined-imm-refs combined-mut-refs combined-mut-sets
|
||||
impersonator-prop:contracted ctc))))))))))
|
||||
(let ([chaperone-args (list impersonator-prop:contracted ctc)])
|
||||
|
||||
;; combined-imm-refs
|
||||
(for ([p (in-list chap-imm-pos-projs)]
|
||||
[ref (in-list chap-imm-refs)])
|
||||
(p (ref val))
|
||||
(set! chaperone-args (list* ref (λ (s v) (p v)) chaperone-args)))
|
||||
|
||||
;; combined-mut-refs
|
||||
(for ([p (in-list mut-pos-projs)]
|
||||
[ref (in-list mut-refs)])
|
||||
(p (ref val))
|
||||
(set! chaperone-args (list* ref (λ (s v) (p v)) chaperone-args)))
|
||||
|
||||
;; combined-mut-sets
|
||||
(for ([p (in-list mut-neg-projs)]
|
||||
[set (in-list mut-sets)])
|
||||
(set! chaperone-args (list* set (λ (s v) (p v)) chaperone-args)))
|
||||
|
||||
(apply chaperone-struct val chaperone-args))))))))
|
||||
|
||||
(define-struct (chaperone-struct/c base-struct/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name struct/c-name
|
||||
#:first-order struct/c-first-order
|
||||
#:projection chaperone-struct/c-proj))
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:name struct/c-name
|
||||
#:first-order struct/c-first-order
|
||||
#:projection chaperone-struct/c-proj)))
|
||||
|
||||
(define (impersonator-struct/c-proj ctc)
|
||||
(let-values ([(flat-imms chap-imms)
|
||||
|
|
@ -234,3 +244,359 @@
|
|||
(make-chaperone-struct/c struct-name predicate immutables mutables)]
|
||||
[else
|
||||
(make-impersonator-struct/c struct-name predicate immutables mutables)]))
|
||||
|
||||
(define unique (box #f))
|
||||
(define (un-dep ctc obj blame immutable-field)
|
||||
(let ([ctc (coerce-contract 'struct/dc ctc)])
|
||||
(when immutable-field
|
||||
(check-chaperone-contract immutable-field ctc))
|
||||
(((contract-projection ctc) blame) obj)))
|
||||
|
||||
(define (struct/dc-name ctc)
|
||||
'struct/dc)
|
||||
(define (struct/dc-first-order ctc)
|
||||
(struct/dc-pred ctc))
|
||||
|
||||
(define (struct/dc-proj ctc)
|
||||
(define pred? (struct/dc-pred ctc))
|
||||
(define mk-proj ((struct/dc-apply-proj ctc) ctc))
|
||||
(λ (blame)
|
||||
(define proj (mk-proj blame))
|
||||
(λ (v)
|
||||
(cond
|
||||
[(and (struct/dc-imp-prop-pred? v)
|
||||
(contract-stronger? (struct/dc-imp-prop-get v) ctc))
|
||||
v]
|
||||
[else
|
||||
(unless (pred? v)
|
||||
(raise-blame-error blame v "expected a ~a"
|
||||
(struct/dc-struct-name ctc)))
|
||||
(proj v)]))))
|
||||
|
||||
(define (struct/dc-stronger? this that)
|
||||
(and (struct/dc? that)
|
||||
(eq? (struct/dc-pred this)
|
||||
(struct/dc-pred that))
|
||||
(let loop ([this-procs/ctcs (struct/dc-procs/ctcs this)]
|
||||
[that-procs/ctcs (struct/dc-procs/ctcs that)])
|
||||
(cond
|
||||
[(and (null? this-procs/ctcs) (null? that-procs/ctcs)) #t]
|
||||
[(and (pair? this-procs/ctcs) (pair? that-procs/ctcs))
|
||||
(define fst-this (car this-procs/ctcs))
|
||||
(define fst-that (car that-procs/ctcs))
|
||||
(cond
|
||||
[(and (contract-struct? fst-this) (contract-struct? fst-that))
|
||||
(and (contract-stronger? fst-this fst-that)
|
||||
(loop (cdr this-procs/ctcs) (cdr that-procs/ctcs)))]
|
||||
[(and (procedure? fst-this) (procedure? fst-that))
|
||||
(and (procedure-closure-contents-eq? fst-this fst-that)
|
||||
(loop (cdr this-procs/ctcs) (cdr that-procs/ctcs)))]
|
||||
[else #f])]
|
||||
[else #f]))))
|
||||
|
||||
(define-struct struct/dc (apply-proj procs/ctcs pred struct-name here)
|
||||
#:property prop:chaperone-contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:name struct/dc-name
|
||||
#:first-order struct/dc-first-order
|
||||
#:projection struct/dc-proj
|
||||
#:stronger struct/dc-stronger?)))
|
||||
|
||||
(define-for-syntax (get-struct-info id stx)
|
||||
(define inf (syntax-local-value id (λ () #f)))
|
||||
(unless (struct-info? inf)
|
||||
(raise-syntax-error 'struct/dc "expected a struct" stx id))
|
||||
(define the-info (extract-struct-info inf))
|
||||
(unless (list-ref the-info 2)
|
||||
(raise-syntax-error 'struct/dc
|
||||
"expected a struct with a known predicate"
|
||||
stx id))
|
||||
the-info)
|
||||
|
||||
(define-values (struct/dc-imp-prop-desc
|
||||
struct/dc-imp-prop-pred?
|
||||
struct/dc-imp-prop-get)
|
||||
(make-impersonator-property 'struct/dc))
|
||||
|
||||
|
||||
(define-for-syntax (clause->chap-proc struct-id info stx clause-stx)
|
||||
(define sel-id (syntax-case clause-stx ()
|
||||
[(sel-id . rest) #'sel-id]))
|
||||
(define (add-prefix id)
|
||||
(datum->syntax id
|
||||
(string->symbol (format "~a-~a"
|
||||
(syntax-e sel-id)
|
||||
(syntax-e id)))))
|
||||
(define immutable-field
|
||||
(for/or ([mutator (in-list (list-ref info 4))]
|
||||
[selector (in-list (list-ref info 3))])
|
||||
(cond
|
||||
[(and (not mutator) (not selector))
|
||||
;; end, with some hidden info
|
||||
;; just assume not immutable
|
||||
#f]
|
||||
[else
|
||||
(and (not mutator)
|
||||
(let ([id (id->sel-id struct-id sel-id)])
|
||||
(and (free-identifier=? id selector)
|
||||
id)))])))
|
||||
(define (add-immutable-check ctc-id stx)
|
||||
(if immutable-field
|
||||
(list stx
|
||||
#`(check-chaperone-contract '#,immutable-field #,ctc-id))
|
||||
(list stx)))
|
||||
|
||||
(syntax-case clause-stx ()
|
||||
;; with caching
|
||||
[(sel-id #:lazy (id ...) exp)
|
||||
(with-syntax ([(sel-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))])
|
||||
(with-syntax ([dep-proc (add-prefix #'dep-proc)])
|
||||
#`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp))))
|
||||
(begin)
|
||||
(begin)
|
||||
(begin)
|
||||
(let ([cached unique])
|
||||
(λ (strct fld)
|
||||
(if (eq? cached unique)
|
||||
(begin
|
||||
(set! cached (un-dep (dep-proc (sel-id strct) ...) fld blame '#,immutable-field))
|
||||
cached)
|
||||
cached))))))]
|
||||
[(sel-id (id ...) exp)
|
||||
(with-syntax ([(sel-proc-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))])
|
||||
(with-syntax ([dep-proc (add-prefix #'dep-proc)])
|
||||
#`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp))))
|
||||
(begin)
|
||||
(begin)
|
||||
(un-dep (dep-proc (sel-proc-id v) ...) (#,(id->sel-id struct-id #'sel-id) v) blame '#,immutable-field)
|
||||
(λ (strct fld)
|
||||
(un-dep (dep-proc (sel-proc-id strct) ...) fld blame '#,immutable-field)))))]
|
||||
[(sel-id #:lazy exp)
|
||||
(with-syntax ([ctc (add-prefix #'ctc)]
|
||||
[blame-to-proj (add-prefix #'blame-to-proj)]
|
||||
[proj (add-prefix #'proj)])
|
||||
#`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp)))
|
||||
(define blame-to-proj (contract-struct-projection ctc))
|
||||
(define proj (blame-to-proj blame))
|
||||
(begin)
|
||||
(let ([cached unique])
|
||||
(λ (strct fld)
|
||||
(if (eq? cached unique)
|
||||
(begin
|
||||
(set! cached (proj fld))
|
||||
cached)
|
||||
cached)))))]
|
||||
[(sel-id exp)
|
||||
(with-syntax ([ctc (add-prefix #'ctc)]
|
||||
[blame-to-proj (add-prefix #'blame-to-proj)]
|
||||
[proj (add-prefix #'proj)])
|
||||
#`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp)))
|
||||
(define blame-to-proj (contract-struct-projection ctc))
|
||||
(define proj (blame-to-proj blame))
|
||||
(proj (#,(id->sel-id struct-id #'sel-id) v))
|
||||
(if (flat-contract? ctc)
|
||||
(λ (strct fld) fld)
|
||||
(λ (strct fld) (proj fld)))))]
|
||||
[_ (raise-syntax-error #f "malformed clause" stx clause-stx)]))
|
||||
|
||||
(define (check-chaperone-contract immutable-field ctc)
|
||||
(unless (chaperone-contract? ctc)
|
||||
(error 'struct/dc "expected a chaperone contract for the immutable field ~a, got ~e"
|
||||
immutable-field
|
||||
ctc)))
|
||||
|
||||
(define-for-syntax (id->sel-id struct-id id)
|
||||
(datum->syntax
|
||||
id
|
||||
(string->symbol
|
||||
(format "~a-~a"
|
||||
(syntax-e struct-id)
|
||||
(syntax-e id)))))
|
||||
|
||||
(define-syntax (-struct/dc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ struct-id clause ...)
|
||||
(let ()
|
||||
(define info (get-struct-info #'struct-id stx))
|
||||
(with-syntax ([(((before-ctc-bound ...) after-ctc-bound after-blame-bound first-order-check chap-proc) ...)
|
||||
(for/list ([clause (in-list (syntax->list #'(clause ...)))])
|
||||
(clause->chap-proc #'struct-id info stx clause))])
|
||||
(with-syntax ([(id ...) (syntax-case #'((before-ctc-bound ...) ...) ()
|
||||
[(((define id exp) . whatever) ...) #'(id ...)])]
|
||||
[(selectors+chap-procs ...)
|
||||
(apply
|
||||
append
|
||||
(for/list ([clause (in-list (syntax->list #'(clause ...)))]
|
||||
[chap-proc (in-list (syntax->list #'(chap-proc ...)))])
|
||||
(list (id->sel-id
|
||||
#'struct-id
|
||||
(syntax-case clause ()
|
||||
[(x . rest) #'x]))
|
||||
chap-proc)))])
|
||||
#`(let ()
|
||||
before-ctc-bound ... ...
|
||||
(letrec ([me
|
||||
(make-struct/dc
|
||||
(λ (ctc)
|
||||
after-ctc-bound ...
|
||||
(λ (blame)
|
||||
after-blame-bound ...
|
||||
(λ (v)
|
||||
first-order-check ...
|
||||
(chaperone-struct
|
||||
v
|
||||
selectors+chap-procs ...
|
||||
struct/dc-imp-prop-desc
|
||||
me))))
|
||||
(list id ...)
|
||||
#,(list-ref info 2)
|
||||
'struct-id
|
||||
(quote-module-name))])
|
||||
me)))))]))
|
||||
|
||||
(define/opter (-struct/dc opt/i opt/info stx)
|
||||
(syntax-case stx ()
|
||||
[(_ struct-id clause ...)
|
||||
(let ()
|
||||
(define info (get-struct-info #'struct-id stx))
|
||||
(cond
|
||||
[(ormap values (list-ref info 4))
|
||||
;; any mutable struct, just give up (could generate impersonator code, but
|
||||
;; would have to check that the compiled subcontracts are all chaperones/flats)
|
||||
(opt/unknown opt/i opt/info stx)]
|
||||
[else
|
||||
(define-values (s-chap-code s-flat-code s-lifts s-super-lifts s-partially-applied can-be-optimized? stronger-ribs chaperone?)
|
||||
(for/fold ([s-chap-code '()]
|
||||
[s-flat-code '()]
|
||||
[s-lifts '()]
|
||||
[s-super-lifts '()]
|
||||
[s-partially-applied '()]
|
||||
[can-be-optimized? #t]
|
||||
[stronger-ribs '()]
|
||||
[chaperone? #t])
|
||||
([clause (in-list (syntax->list #'(clause ...)))])
|
||||
|
||||
(define-values (sel-id lazy? dep-vars exp)
|
||||
(syntax-case clause ()
|
||||
[(sel-id #:lazy exp) (values #'sel-id #t #f #'exp)]
|
||||
[(sel-id exp) (values #'sel-id #f #f #'exp)]
|
||||
[(sel-id #:lazy (dep-id ...) exp) (values #'sel-id #t #'(dep-id ...) #'exp)]
|
||||
[(sel-id (dep-id ...) exp) (values #'sel-id #f #'(dep-id ...) #'exp)]))
|
||||
|
||||
(define-values (this-code
|
||||
this-lifts this-super-lifts this-partially-applied
|
||||
this-flat? this-can-be-optimized? this-stronger-ribs
|
||||
this-chaperone?)
|
||||
(opt/i opt/info exp))
|
||||
|
||||
(values (cond
|
||||
[(and this-flat? (not lazy?) (not dep-vars))
|
||||
s-chap-code]
|
||||
[else
|
||||
(with-syntax ([(strct cache) (generate-temporaries '(struct cache))]
|
||||
[proc-name (string->symbol
|
||||
(format "~a-~a-chap/dep"
|
||||
(syntax-e #'struct-id)
|
||||
(syntax-e sel-id)))])
|
||||
(list* (cond
|
||||
[dep-vars
|
||||
(with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var))
|
||||
(syntax->list dep-vars))]
|
||||
[(dep-var ...) dep-vars])
|
||||
(with-syntax ([this-code+lifts
|
||||
#`(let ([dep-var (sel strct)] ...)
|
||||
#,(bind-superlifts
|
||||
this-super-lifts
|
||||
(bind-lifts
|
||||
this-lifts
|
||||
(bind-lifts
|
||||
this-partially-applied
|
||||
this-code))))])
|
||||
(if lazy?
|
||||
#`(let ([cache unique])
|
||||
(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
(cond
|
||||
[(eq? cache unique)
|
||||
(set! cache this-code+lifts)
|
||||
cache]
|
||||
[else cache]))])
|
||||
proc-name))
|
||||
#`(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
this-code+lifts)])
|
||||
proc-name))))]
|
||||
[else
|
||||
(if lazy?
|
||||
#`(let ([cache unique])
|
||||
(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
(cond
|
||||
[(eq? cache unique)
|
||||
(set! cache #,this-code)
|
||||
cache]
|
||||
[else cache]))])
|
||||
proc-name))
|
||||
#`(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
#,this-code)])
|
||||
proc-name))])
|
||||
(id->sel-id #'struct-id sel-id)
|
||||
s-chap-code))])
|
||||
(cond
|
||||
[lazy?
|
||||
s-flat-code]
|
||||
[dep-vars
|
||||
(with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var))
|
||||
(syntax->list dep-vars))]
|
||||
[(dep-var ...) dep-vars])
|
||||
(cons #` (let ([dep-var (sel #,(opt/info-val opt/info))] ...)
|
||||
(let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id)
|
||||
#,(opt/info-val opt/info))])
|
||||
#,this-code))
|
||||
s-flat-code))]
|
||||
[else
|
||||
(cons #`(let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id)
|
||||
#,(opt/info-val opt/info))])
|
||||
#,this-code)
|
||||
s-flat-code)])
|
||||
(if dep-vars s-lifts (append this-lifts s-lifts))
|
||||
(if dep-vars s-super-lifts (append this-super-lifts s-super-lifts))
|
||||
(if dep-vars s-partially-applied (append this-partially-applied s-partially-applied))
|
||||
(and this-can-be-optimized? can-be-optimized?)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and this-chaperone? chaperone?))))
|
||||
(with-syntax ([(stronger-prop-desc stronger-prop-pred? stronger-prop-get)
|
||||
(syntax-local-lift-values-expression
|
||||
3
|
||||
#'(make-impersonator-property 'struct/dc-stronger-prop))]
|
||||
[(free-var ...) (opt/info-free-vars opt/info)]
|
||||
[(index ...) (build-list (length (opt/info-free-vars opt/info)) values)]
|
||||
[pred? (list-ref info 2)])
|
||||
(values #`(if (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
|
||||
#,@(reverse s-flat-code) ;; built the last backwards, so reverse it here
|
||||
(chaperone-struct
|
||||
#,(opt/info-val opt/info)
|
||||
#,@(reverse s-chap-code) ;; built the last backwards, so reverse it here
|
||||
stronger-prop-desc
|
||||
(vector free-var ...)))
|
||||
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))
|
||||
s-lifts
|
||||
s-super-lifts
|
||||
s-partially-applied
|
||||
#f ;; flat sexp
|
||||
can-be-optimized?
|
||||
stronger-ribs
|
||||
#t ;;chaperone?
|
||||
))]))]))
|
||||
|
||||
(define (struct/dc-error blame obj what)
|
||||
(raise-blame-error blame obj
|
||||
"expected a struct of type ~a"
|
||||
what))
|
||||
|
|
|
|||
|
|
@ -385,7 +385,46 @@ Contracts for mutable fields may be impersonator contracts.
|
|||
If all fields are immutable and the @racket[contract-expr]s evaluate
|
||||
to flat contracts, a flat contract is produced. If all the
|
||||
@racket[contract-expr]s are chaperone contracts, a chaperone contract is
|
||||
produced. Otherwise, an impersonator contract is produced.}
|
||||
produced. Otherwise, an impersonator contract is produced.
|
||||
}
|
||||
|
||||
|
||||
@defform/subs[(struct/dc struct-id field-spec ...)
|
||||
([field-spec [field-id contract-expr]
|
||||
[field-id #:lazy contract-expr]
|
||||
[field-id (dep-field-id ...) contract-expr]
|
||||
[field-id (dep-field-id ...) #:lazy contract-expr]])]{
|
||||
Produces a contract that recognizes instances of the structure
|
||||
type named by @racket[struct-id], and whose field values match the
|
||||
contracts produced by the @racket[field-spec]s.
|
||||
|
||||
Each @racket[field-spec] can specify if the field is check lazily
|
||||
(only when a selector is applied) or not via the @racket[#:lazy]
|
||||
keyword. If the @racket[field-spec] lists the names of other fields,
|
||||
then the contract depends on values in those fields, and the @racket[contract-expr]
|
||||
expression is evaluated each time a selector is applied, building a new contract
|
||||
for the fields based on the values of the @racket[dep-field-id] fields.
|
||||
|
||||
Contracts for immutable fields must be either flat or chaperone contracts.
|
||||
Contracts for mutable fields may be impersonator contracts.
|
||||
If all fields are immutable and the @racket[contract-expr]s evaluate
|
||||
to flat contracts, a flat contract is produced. If all the
|
||||
@racket[contract-expr]s are chaperone contracts, a chaperone contract is
|
||||
produced. Otherwise, an impersonator contract is produced.
|
||||
|
||||
For example, the function @racket[bst/c] below
|
||||
returns a contract for binary search trees whose values
|
||||
are all between @racket[lo] and @racket[hi].
|
||||
|
||||
@racketblock[(struct bt (val left right))
|
||||
(define (bst/c lo hi)
|
||||
(or/c #f
|
||||
(struct/dc bt
|
||||
[val (between/c lo hi)]
|
||||
[left (val) (bst lo val)]
|
||||
[right (val) (bst val hi)])))]
|
||||
|
||||
}
|
||||
|
||||
|
||||
@defproc[(parameter/c [c contract?]) contract?]{
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
(define (contract-error-test name exp exn-ok?)
|
||||
(test #t
|
||||
name
|
||||
(contract-eval `(with-handlers ((exn? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))
|
||||
(contract-eval `(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))
|
||||
|
||||
(define (contract-syntax-error-test name exp [reg #rx""])
|
||||
(test #t
|
||||
|
|
@ -8632,6 +8632,270 @@
|
|||
(set-s-a! v* 4))))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ; ; ;;;
|
||||
; ;;; ;;; ; ;;;
|
||||
; ;;;; ;;;; ;;; ;;;; ;;; ;;; ;;;; ; ;; ;;; ;;;
|
||||
; ;;; ;; ;;;; ;;;;;;;; ;;; ;;;;; ;;;; ; ;;;;;;; ;;;;;
|
||||
; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; ;;; ;;; ;;; ;;
|
||||
; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ; ;;; ;;; ;;;
|
||||
; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ; ;;; ;;; ;;; ;;
|
||||
; ;; ;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ; ;;;;;;; ;;;;;
|
||||
; ;;;; ;;; ;;; ;; ;;; ;;; ;;; ; ;; ;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-1
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s
|
||||
[a () number?]
|
||||
[b (a) boolean?])
|
||||
(s 1 #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-2
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s
|
||||
[a () number?]
|
||||
[b (a) (>=/c a)])
|
||||
(s 1 2)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-3
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s
|
||||
[a () number?]
|
||||
[b (a) (>=/c a)])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-3b
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s
|
||||
[a () number?]
|
||||
[b (a) (<=/c a)])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-4
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s
|
||||
[a number?]
|
||||
[b (a) (>=/c a)])
|
||||
(s 1 2)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-5
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(s-b (contract (struct/dc s
|
||||
[a () number?]
|
||||
[b (a) (>=/c a)])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-6
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(define-opt/c (f z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (f a)]))
|
||||
|
||||
(s-a (contract (f 11)
|
||||
(s 12 (s 13 #f))
|
||||
'pos
|
||||
'neg)))
|
||||
12)
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-7
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(define-opt/c (f z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (f a)]))
|
||||
|
||||
(s-a (s-b (contract (f 11)
|
||||
(s 12 (s 13 #f))
|
||||
'pos
|
||||
'neg))))
|
||||
13)
|
||||
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-8
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(define-opt/c (f z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (f a)]))
|
||||
(s-b (s-b (contract (f 11)
|
||||
(s 12 (s 13 #f))
|
||||
'pos
|
||||
'neg)))))
|
||||
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-9
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
|
||||
(define-opt/c (g z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (>=/c (+ a 1))]))
|
||||
|
||||
(s-a (contract (g 10)
|
||||
(s 12 (s 14 #f))
|
||||
'pos
|
||||
'neg)))
|
||||
12)
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-10
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
|
||||
(define-opt/c (g z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (>=/c (+ a 1))]))
|
||||
|
||||
(s-b (contract (g 10)
|
||||
(s 12 14)
|
||||
'pos
|
||||
'neg)))
|
||||
14)
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-11
|
||||
'(let ()
|
||||
|
||||
(struct s (a b))
|
||||
|
||||
(define-opt/c (g z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (>=/c (+ a 1))]))
|
||||
|
||||
(s-b (contract (g 11)
|
||||
(s 12 10)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-12
|
||||
'(let ()
|
||||
(struct kons (hd tl) #:transparent)
|
||||
(define (unknown-function a) (=/c a))
|
||||
(define-opt/c (f a b)
|
||||
(or/c not
|
||||
(struct/dc kons
|
||||
[hd (unknown-function a)]
|
||||
[tl #:lazy () (or/c #f (f b a))])))
|
||||
(kons-hd (kons-tl (contract (f 1 2)
|
||||
(kons 1 (kons 2 #f))
|
||||
'pos
|
||||
'neg))))
|
||||
2)
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-13
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (struct/dc s
|
||||
[a #:lazy integer?])
|
||||
(s #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-14
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (struct/dc s
|
||||
[a #:lazy (-> integer? integer?)])
|
||||
(s #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-15
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (struct/dc s
|
||||
[a integer?])
|
||||
(s #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-16
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (struct/dc s
|
||||
[a (-> integer? integer?)])
|
||||
(s #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-17
|
||||
'(let ()
|
||||
(struct s (q a))
|
||||
(contract (struct/dc s
|
||||
[q integer?]
|
||||
[a #:lazy (q) (<=/c a)])
|
||||
(s 1 #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-18
|
||||
'(let ()
|
||||
(struct s (q a))
|
||||
(contract (struct/dc s
|
||||
[q integer?]
|
||||
[a (q) (<=/c q)])
|
||||
(s 1 #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-19
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a (new-∃/c 'α)]))
|
||||
exn:fail?)
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
@ -9411,6 +9675,18 @@
|
|||
#f)))))
|
||||
178)
|
||||
|
||||
(test/spec-passed/result
|
||||
'd-o/c27
|
||||
'(let ()
|
||||
(define-opt/c (f x)
|
||||
(and/c (>=/c x)
|
||||
(g x)))
|
||||
(define-opt/c (g x)
|
||||
(<=/c x))
|
||||
(contract (f 11) 11 'pos 'neg))
|
||||
11)
|
||||
|
||||
|
||||
;;
|
||||
;; end of define-opt/c
|
||||
;;
|
||||
|
|
@ -9802,6 +10078,19 @@ so that propagation occurs.
|
|||
(ctest #t contract? 1)
|
||||
(ctest #t contract? (-> 1 1))
|
||||
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b integer?])))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b integer?])))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b (a) (>=/c a)])))
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b (a) (>=/c a)])))
|
||||
|
||||
(test-flat-contract '(and/c number? integer?) 1 3/2)
|
||||
|
||||
(test-flat-contract '(not/c integer?) #t 1)
|
||||
|
|
@ -10426,7 +10715,56 @@ so that propagation occurs.
|
|||
(,test #t contract-stronger? (mk-c 1) (mk-c 2)))))
|
||||
|
||||
|
||||
(contract-eval
|
||||
`(let ()
|
||||
|
||||
(struct s (a b))
|
||||
(struct t (a b))
|
||||
|
||||
(,test #f contract-stronger?
|
||||
(struct/dc s
|
||||
[a (>=/c 1)]
|
||||
[b (>=/c 2)])
|
||||
(struct/dc s
|
||||
[a (>=/c 2)]
|
||||
[b (>=/c 3)]))
|
||||
(,test #t contract-stronger?
|
||||
(struct/dc s
|
||||
[a (>=/c 2)]
|
||||
[b (>=/c 3)])
|
||||
(struct/dc s
|
||||
[a (>=/c 1)]
|
||||
[b (>=/c 2)]))
|
||||
|
||||
(,test #f contract-stronger?
|
||||
(struct/dc s
|
||||
[a number?]
|
||||
[b number?])
|
||||
(struct/dc t
|
||||
[a number?]
|
||||
[b number?]))
|
||||
|
||||
(,test #f contract-stronger?
|
||||
(struct/dc t
|
||||
[a number?]
|
||||
[b number?])
|
||||
(struct/dc s
|
||||
[a number?]
|
||||
[b number?]))
|
||||
|
||||
(define (mk c)
|
||||
(struct/dc s
|
||||
[a (>=/c c)]
|
||||
[b (a) (>=/c a)]))
|
||||
(define one (mk 1))
|
||||
(define two (mk 2))
|
||||
(,test #f contract-stronger? one two)
|
||||
(,test #t contract-stronger? two one)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user