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

removed links to old mzlib stuff and mzscheme module from the contract library (but not from all the libraries it depends on)

Browse Source 
svn: r8023
This commit is contained in:
Robby Findler 2007-12-16 00:20:18 +00:00
parent 1b7c6a9d32
commit 8a7cdad926
13 changed files with 5861 additions and 5896 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

149
collects/scheme/contract.ss
View File

@ -1,64 +1,63 @@
#lang scheme/base
(module contract mzscheme
(require "private/contract.ss"
"private/contract-arrow.ss"
"private/contract-guts.ss"
"private/contract-ds.ss"
"private/contract-opt-guts.ss"
"private/contract-opt.ss"
"private/contract-basic-opters.ss")
(require "private/contract.ss"
"private/contract-arrow.ss"
"private/contract-guts.ss"
"private/contract-ds.ss"
"private/contract-opt-guts.ss"
"private/contract-opt.ss"
"private/contract-basic-opters.ss")
(provide
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
(all-from-except "private/contract-ds.ss"
lazy-depth-to-look)
(provide
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
(except-out (all-from-out "private/contract-ds.ss")
lazy-depth-to-look)
(except-out (all-from-out "private/contract-arrow.ss")
check-procedure)
(except-out (all-from-out "private/contract.ss")
check-between/c
check-unary-between/c))
(all-from-except "private/contract-arrow.ss"
check-procedure)
(all-from-except "private/contract.ss"
check-between/c
check-unary-between/c))
;; from contract-guts.ss
(provide any
and/c
any/c
none/c
make-none/c
guilty-party
contract-violation->string
contract?
contract-name
contract-proc
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
contract-first-order-passes?
;; below need docs
make-proj-contract
contract-stronger?
coerce-contract
flat-contract/predicate?
;; from contract-guts.ss
build-compound-type-name
raise-contract-error
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
first-order-prop first-order-get))
(provide any
and/c
any/c
none/c
make-none/c
guilty-party
contract-violation->string
contract?
contract-name
contract-proc
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
contract-first-order-passes?
;; below need docs
make-proj-contract
contract-stronger?
coerce-contract
flat-contract/predicate?
build-compound-type-name
raise-contract-error
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
first-order-prop first-order-get)
;; ======================================================================
;; The alternate implementation disables contracts. Its useful mainly to
@ -68,12 +67,12 @@
#;
(module contract mzscheme
(define-syntax provide/contract
(syntax-rules ()
[(_ elem ...)
(begin (provide-one elem) ...)]))
(define-syntax provide-one
(syntax-rules (struct rename)
[(_ (struct (id par-id) ([field . rest] ...)))
@ -84,7 +83,7 @@
(provide (rename id1 id2))]
[(_ (id c))
(provide id)]))
(define-syntax (provide-struct stx)
(syntax-case stx ()
[(_ id par-id . rest)
@ -98,9 +97,9 @@
(- len 1))))))]
[ids (lambda (l) (let loop ([l l])
(cond
[(null? l) null]
[(car l) (cons (car l) (loop (cdr l)))]
[else (loop (cdr l))])))])
[(null? l) null]
[(car l) (cons (car l) (loop (cdr l)))]
[else (loop (cdr l))])))])
(if (and info
p-info
(list? info)
@ -117,32 +116,32 @@
(raise-syntax-error
#f
(cond
[(not info) "cannot find struct info"]
[(not p-info) "cannot find parent-struct info"]
[else (format "struct or parent-struct info has unexpected shape: ~e and ~e"
info p-info)])
[(not info) "cannot find struct info"]
[(not p-info) "cannot find parent-struct info"]
[else (format "struct or parent-struct info has unexpected shape: ~e and ~e"
info p-info)])
#'id)))]))
(define-syntax define-contract-struct
(syntax-rules ()
[(_ . rest) (define-struct . rest)]))
(define-syntax define/contract
(syntax-rules ()
[(_ id c expr) (define id expr)]))
(define-syntax contract
(syntax-rules ()
[(_ c expr . rest) expr]))
(provide provide/contract
define-contract-struct
define/contract
contract)
(define mk*
(lambda args (lambda (x) x)))
(define-syntax mk
(syntax-rules ()
[(_ id) (begin
@ -150,7 +149,7 @@
(provide id))]
[(_ id ...)
(begin (mk id) ...)]))
(mk ->
->*
opt->
@ -166,7 +165,7 @@
union
listof
is-a?/c)
(define-syntax symbols
(syntax-rules ()
[(_ sym ...)

335
collects/scheme/private/contract-arr-checks.ss
View File

@ -1,182 +1,182 @@
(module contract-arr-checks mzscheme
(provide (all-defined))
(require (lib "list.ss")
"contract-guts.ss")
#lang scheme/base
(define empty-case-lambda/c
(flat-named-contract '(case->)
(λ (x) (and (procedure? x) (null? (procedure-arity x))))))
;; ----------------------------------------
;; Checks and error functions used in macro expansions
;; procedure-accepts-and-more? : procedure number -> boolean
;; returns #t if val accepts dom-length arguments and
;; any number of arguments more than dom-length.
;; returns #f otherwise.
(define (procedure-accepts-and-more? val dom-length)
(let ([arity (procedure-arity val)])
(cond
[(number? arity) #f]
[(arity-at-least? arity)
(<= (arity-at-least-value arity) dom-length)]
[else
(let ([min-at-least (let loop ([ars arity]
[acc #f])
(cond
[(null? ars) acc]
[else (let ([ar (car ars)])
(cond
[(arity-at-least? ar)
(if (and acc
(< acc (arity-at-least-value ar)))
(loop (cdr ars) acc)
(loop (cdr ars) (arity-at-least-value ar)))]
[(number? ar)
(loop (cdr ars) acc)]))]))])
(and min-at-least
(begin
(let loop ([counts (sort (filter number? arity) >=)])
(unless (null? counts)
(let ([count (car counts)])
(cond
[(= (+ count 1) min-at-least)
(set! min-at-least count)
(loop (cdr counts))]
[(< count min-at-least)
(void)]
[else (loop (cdr counts))]))))
(<= min-at-least dom-length))))])))
(define (check->* f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-arity-includes? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count
f)))
(provide (all-defined-out))
(require "contract-guts.ss")
(define (check->*/more f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-accepts-and-more? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e"
arity-count
(if (= 1 arity-count) "" "s")
f)))
(define empty-case-lambda/c
(flat-named-contract '(case->)
(λ (x) (and (procedure? x) (null? (procedure-arity x))))))
;; ----------------------------------------
;; Checks and error functions used in macro expansions
;; procedure-accepts-and-more? : procedure number -> boolean
;; returns #t if val accepts dom-length arguments and
;; any number of arguments more than dom-length.
;; returns #f otherwise.
(define (procedure-accepts-and-more? val dom-length)
(let ([arity (procedure-arity val)])
(cond
[(number? arity) #f]
[(arity-at-least? arity)
(<= (arity-at-least-value arity) dom-length)]
[else
(let ([min-at-least (let loop ([ars arity]
[acc #f])
(cond
[(null? ars) acc]
[else (let ([ar (car ars)])
(cond
[(arity-at-least? ar)
(if (and acc
(< acc (arity-at-least-value ar)))
(loop (cdr ars) acc)
(loop (cdr ars) (arity-at-least-value ar)))]
[(number? ar)
(loop (cdr ars) acc)]))]))])
(and min-at-least
(begin
(let loop ([counts (sort (filter number? arity) >=)])
(unless (null? counts)
(let ([count (car counts)])
(cond
[(= (+ count 1) min-at-least)
(set! min-at-least count)
(loop (cdr counts))]
[(< count min-at-least)
(void)]
[else (loop (cdr counts))]))))
(<= min-at-least dom-length))))])))
(define (check->* f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-arity-includes? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count
f)))
(define (check->*/more f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-accepts-and-more? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e"
arity-count
(if (= 1 arity-count) "" "s")
f)))
(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(unless pre-expr
(raise-contract-error val
src-info
blame
orig-str
"pre-condition expression failure")))
(define (check-post-expr->pp/h val post-expr src-info blame orig-str)
(unless post-expr
(raise-contract-error val
src-info
blame
orig-str
"post-condition expression failure")))
(define (check-procedure val dom-length src-info blame orig-str)
(unless (and (procedure? val)
(procedure-arity-includes? val dom-length))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments, given: ~e"
dom-length
val)))
(define ((check-procedure? arity) val)
(and (procedure? val)
(procedure-arity-includes? val arity)))
(define ((check-procedure/more? arity) val)
(and (procedure? val)
(procedure-accepts-and-more? val arity)))
(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(unless pre-expr
(raise-contract-error val
src-info
blame
orig-str
"pre-condition expression failure")))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-arity-includes? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-post-expr->pp/h val post-expr src-info blame orig-str)
(unless post-expr
(raise-contract-error val
src-info
blame
orig-str
"post-condition expression failure")))
(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-accepts-and-more? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure val dom-length src-info blame orig-str)
(unless (and (procedure? val)
(procedure-arity-includes? val dom-length))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments, given: ~e"
dom-length
val)))
(define (check-procedure/more val dom-length src-info blame orig-str)
(unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
dom-length
dom-length
val)))
(define ((check-procedure? arity) val)
(and (procedure? val)
(procedure-arity-includes? val arity)))
(define ((check-procedure/more? arity) val)
(and (procedure? val)
(procedure-accepts-and-more? val arity)))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-arity-includes? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-accepts-and-more? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure/more val dom-length src-info blame orig-str)
(unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e"
dom-length
dom-length
val)))
(define (check-rng-procedure who rng-x arity)
(unless (and (procedure? rng-x)
(procedure-arity-includes? rng-x arity))
(error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
arity
rng-x)))
(define (check-rng-procedure who rng-x arity)
(unless (and (procedure? rng-x)
(procedure-arity-includes? rng-x arity))
(error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
arity
rng-x)))
(define (check-rng-procedure/more rng-mk-x arity)
(unless (and (procedure? rng-mk-x)
(procedure-accepts-and-more? rng-mk-x arity))
(error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
arity
rng-mk-x)))
(define (check-rng-procedure/more rng-mk-x arity)
(unless (and (procedure? rng-mk-x)
(procedure-accepts-and-more? rng-mk-x arity))
(error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
arity
rng-mk-x)))
(define (check-rng-lengths results rng-contracts)
(unless (= (length results) (length rng-contracts))
(error '->d*
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
(length results) (length rng-contracts))))
(define (check-rng-lengths results rng-contracts)
(unless (= (length results) (length rng-contracts))
(error '->d*
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
(length results) (length rng-contracts))))
#|
#|
test cases for procedure-accepts-and-more?
@ -195,4 +195,3 @@
(not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
|#
)

2101
collects/scheme/private/contract-arr-obj-helpers.ss
View File

File diff suppressed because it is too large Load Diff

881
collects/scheme/private/contract-arrow.ss
View File

@ -1,461 +1,424 @@
(module contract-arrow mzscheme
(require (lib "etc.ss")
"contract-guts.ss"
"contract-arr-checks.ss"
"contract-opt.ss")
(require-for-syntax "contract-opt-guts.ss"
"contract-helpers.ss"
"contract-arr-obj-helpers.ss"
(lib "stx.ss" "syntax")
(lib "name.ss" "syntax"))
#lang scheme/base
(require (lib "etc.ss")
"contract-guts.ss"
"contract-arr-checks.ss"
"contract-opt.ss")
(require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss")
(for-syntax "contract-helpers.ss")
(for-syntax "contract-arr-obj-helpers.ss")
(for-syntax (lib "stx.ss" "syntax"))
(for-syntax (lib "name.ss" "syntax")))
(provide ->
->d
->*
->d*
->r
->pp
->pp-rest
case->
opt->
opt->*
unconstrained-domain->
check-procedure)
(define-syntax (unconstrained-domain-> stx)
(syntax-case stx ()
[(_ rngs ...)
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
[(proj-x ...) (generate-temporaries #'(rngs ...))]
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
(make-proj-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
(λ (pos-blame neg-blame src-info orig-str)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
(λ (val)
(if (procedure? val)
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected a procedure")))))
procedure?))))]))
;; FIXME: need to pass in the name of the contract combinator.
(define (build--> name doms doms-rest rngs rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
(make--> rng-any? doms/c doms-rest/c rngs/c func)))
(define-struct/prop -> (rng-any? doms dom-rest rngs func)
((proj-prop (λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc)))
(->-doms ctc)))]
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
[func (->-func ctc)]
[dom-length (length (->-doms ctc))]
[check-proc
(if (->-dom-rest ctc)
check-procedure/more
check-procedure)])
(lambda (pos-blame neg-blame src-info orig-str)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
doms/c)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
rngs/c)])
(apply func
(λ (val) (check-proc val dom-length src-info pos-blame orig-str))
(append partial-doms partial-ranges)))))))
(name-prop (λ (ctc) (single-arrow-name-maker
(->-doms ctc)
(->-dom-rest ctc)
(->-rng-any? ctc)
(->-rngs ctc))))
(first-order-prop
(λ (ctc)
(let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc)
(λ (x)
(and (procedure? x)
(procedure-accepts-and-more? x l)))
(λ (x)
(and (procedure? x)
(procedure-arity-includes? x l)))))))
(stronger-prop
(λ (this that)
(and (->? that)
(= (length (->-doms that))
(length (->-doms this)))
(andmap contract-stronger?
(->-doms that)
(->-doms this))
(= (length (->-rngs that))
(length (->-rngs this)))
(andmap contract-stronger?
(->-rngs this)
(->-rngs that)))))))
(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
(cond
[doms-rest
(build-compound-type-name
'->*
(apply build-compound-type-name doms/c)
doms-rest
(cond
[rng-any? 'any]
[else (apply build-compound-type-name rngs)]))]
[else
(let ([rng-name
(cond
[rng-any? 'any]
[(null? rngs) '(values)]
[(null? (cdr rngs)) (car rngs)]
[else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(define arity-one-wrapper
(lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1)))))))
(define arity-two-wrapper
(lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2)))))))
(define arity-three-wrapper
(lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8)))))))
(define arity-four-wrapper
(lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16)))))))
(define arity-five-wrapper
(lambda (chk a27 b28 c29 d30 e31 r32)
(lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26)))))))
(define arity-six-wrapper
(lambda (chk a39 b40 c41 d42 e43 f44 r45)
(lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38)))))))
(define arity-seven-wrapper
(lambda (chk a53 b54 c55 d56 e57 f58 g59 r60)
(lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52)))))))
(define-syntax-set (-> ->*)
(define (->/proc stx)
(let-values ([(stx _1 _2) (->/proc/main stx)])
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->/proc/main stx)
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)])
(with-syntax ([(args body) inner-args/body])
(with-syntax ([(dom-names ...) dom-names]
[(rng-names ...) rng-names]
[(dom-ctcs ...) dom-ctcs]
[(rng-ctcs ...) rng-ctcs]
[inner-lambda
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body)))]
[use-any? use-any?])
(with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)]
[len (and lst (length lst))])
(if (and #f ;; this optimization disables the names so is turned off for now
lst
(not (syntax-e #'use-any?))
(= len (length (syntax->list #'(dom-names ...))))
(= 1 (length (syntax->list #'(rng-names ...))))
(<= 1 len 7))
(case len
[(1) #'arity-one-wrapper]
[(2) #'arity-two-wrapper]
[(3) #'arity-three-wrapper]
[(4) #'arity-four-wrapper]
[(5) #'arity-five-wrapper]
[(6) #'arity-six-wrapper]
[(7) #'arity-seven-wrapper])
(syntax
(lambda (chk dom-names ... rng-names ...)
(lambda (val)
(chk val)
inner-lambda)))))])
(values
(syntax (build--> '->
(list dom-ctcs ...)
#f
(list rng-ctcs ...)
use-any?
outer-lambda))
inner-args/body
(syntax (dom-names ... rng-names ...))))))))
(define (->-helper stx)
(syntax-case* stx (-> any values) module-or-top-identifier=?
[(-> doms ... any)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(ignored) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (ignored))
(syntax (doms ...))
(syntax (any/c))
(syntax ((args ...) (val (dom-ctc args) ...)))
#t))]
[(-> doms ... (values rngs ...))
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc ...))
(syntax (doms ...))
(syntax (rngs ...))
(syntax ((args ...)
(let-values ([(rng-x ...) (val (dom-ctc args) ...)])
(values (rng-ctc rng-x) ...))))
#f))]
[(_ doms ... rng)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-ctc) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc))
(syntax (doms ...))
(syntax (rng))
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...))))
#f))]))
(define (->*/proc stx)
(let-values ([(stx _1 _2) (->*/proc/main stx)])
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->*/proc/main stx)
(syntax-case* stx (->* any) module-or-top-identifier=?
[(->* (doms ...) any)
(->/proc/main (syntax (-> doms ... any)))]
[(->* (doms ...) (rngs ...))
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
[(->* (doms ...) rst (rngs ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
(values (rng-x rng-args) ...))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x rng-x ...)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list rngs ...)
#f
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x rng-x ...)))))))]
[(->* (doms ...) rst any)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(apply val (dom-x args) ... (rst-x rest-arg))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x ignored)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list any/c)
#t
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x)))))))])))
(define-for-syntax (select/h stx err-name ctxt-stx)
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
[(-> . args) ->/h]
[(->* . args) ->*/h]
[(->d . args) ->d/h]
[(->d* . args) ->d*/h]
[(->r . args) ->r/h]
[(->pp . args) ->pp/h]
[(->pp-rest . args) ->pp-rest/h]
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
(define-syntax (->d stx) (make-/proc #f ->d/h stx))
(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
(define-syntax (->r stx) (make-/proc #f ->r/h stx))
(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
(provide ->
->d
->*
->d*
->r
->pp
->pp-rest
case->
opt->
opt->*
unconstrained-domain->
check-procedure)
;;
;; arrow opter
;;
(define/opter (-> opt/i opt/info stx)
(define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
(let loop ([vars rng-vars]
[rngs rngs]
[next-rngs null]
[lifts-rngs null]
[superlifts-rngs null]
[partials-rngs null]
[stronger-ribs null])
(cond
[(null? rngs) (values (reverse next-rngs)
lifts-rngs
superlifts-rngs
partials-rngs
stronger-ribs)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i opt/info (car rngs))])
(loop (cdr vars)
(cdr rngs)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-rngs)
(append lifts-rngs lift)
(append superlifts-rngs superlift)
(append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(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)
((rng-arg ...) rng-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars))
((next-rng ...) next-rngs))
(syntax (begin
(check-procedure val dom-len src-info pos orig-str)
(λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...))))))
(append lifts-doms lifts-rngs)
(append superlifts-doms superlifts-rngs)
(append partials-doms partials-rngs)
#f
#f
(append stronger-ribs-dom stronger-ribs-rng))))
(define (opt/arrow-any-ctc doms)
(let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else
(let-values ([(next lift superlift partial flat _ this-stronger-ribs)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(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)
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val dom-len src-info pos orig-str)
(λ (dom-arg ...)
(val next-dom ...)))))
lifts-doms
superlifts-doms
partials-doms
#f
#f
stronger-ribs-dom)))
(syntax-case* stx (-> values any) module-or-top-identifier=?
[(-> dom ... (values rng ...))
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...))))]
[(-> dom ... any)
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
[(-> dom ... rng)
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))])))
(define-syntax (unconstrained-domain-> stx)
(syntax-case stx ()
[(_ rngs ...)
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
[(proj-x ...) (generate-temporaries #'(rngs ...))]
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
(make-proj-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
(λ (pos-blame neg-blame src-info orig-str)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
(λ (val)
(if (procedure? val)
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected a procedure")))))
procedure?))))]))
;; FIXME: need to pass in the name of the contract combinator.
(define (build--> name doms doms-rest rngs rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
(make--> rng-any? doms/c doms-rest/c rngs/c func)))
(define-struct/prop -> (rng-any? doms dom-rest rngs func)
((proj-prop (λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc)))
(->-doms ctc)))]
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
[func (->-func ctc)]
[dom-length (length (->-doms ctc))]
[check-proc
(if (->-dom-rest ctc)
check-procedure/more
check-procedure)])
(lambda (pos-blame neg-blame src-info orig-str)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
doms/c)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
rngs/c)])
(apply func
(λ (val) (check-proc val dom-length src-info pos-blame orig-str))
(append partial-doms partial-ranges)))))))
(name-prop (λ (ctc) (single-arrow-name-maker
(->-doms ctc)
(->-dom-rest ctc)
(->-rng-any? ctc)
(->-rngs ctc))))
(first-order-prop
(λ (ctc)
(let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc)
(λ (x)
(and (procedure? x)
(procedure-accepts-and-more? x l)))
(λ (x)
(and (procedure? x)
(procedure-arity-includes? x l)))))))
(stronger-prop
(λ (this that)
(and (->? that)
(= (length (->-doms that))
(length (->-doms this)))
(andmap contract-stronger?
(->-doms that)
(->-doms this))
(= (length (->-rngs that))
(length (->-rngs this)))
(andmap contract-stronger?
(->-rngs this)
(->-rngs that)))))))
(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
(cond
[doms-rest
(build-compound-type-name
'->*
(apply build-compound-type-name doms/c)
doms-rest
(cond
[rng-any? 'any]
[else (apply build-compound-type-name rngs)]))]
[else
(let ([rng-name
(cond
[rng-any? 'any]
[(null? rngs) '(values)]
[(null? (cdr rngs)) (car rngs)]
[else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(define-syntax-set (-> ->*)
(define (->/proc stx)
(let-values ([(stx _1 _2) (->/proc/main stx)])
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->/proc/main stx)
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)])
(with-syntax ([(args body) inner-args/body])
(with-syntax ([(dom-names ...) dom-names]
[(rng-names ...) rng-names]
[(dom-ctcs ...) dom-ctcs]
[(rng-ctcs ...) rng-ctcs]
[inner-lambda
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body)))]
[use-any? use-any?])
(with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)]
[len (and lst (length lst))])
(syntax
(lambda (chk dom-names ... rng-names ...)
(lambda (val)
(chk val)
inner-lambda))))])
(values
(syntax (build--> '->
(list dom-ctcs ...)
#f
(list rng-ctcs ...)
use-any?
outer-lambda))
inner-args/body
(syntax (dom-names ... rng-names ...))))))))
(define (->-helper stx)
(syntax-case* stx (-> any values) module-or-top-identifier=?
[(-> doms ... any)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(ignored) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (ignored))
(syntax (doms ...))
(syntax (any/c))
(syntax ((args ...) (val (dom-ctc args) ...)))
#t))]
[(-> doms ... (values rngs ...))
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc ...))
(syntax (doms ...))
(syntax (rngs ...))
(syntax ((args ...)
(let-values ([(rng-x ...) (val (dom-ctc args) ...)])
(values (rng-ctc rng-x) ...))))
#f))]
[(_ doms ... rng)
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
[(rng-ctc) (generate-temporaries (syntax (rng)))])
(values (syntax (dom-ctc ...))
(syntax (rng-ctc))
(syntax (doms ...))
(syntax (rng))
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...))))
#f))]))
(define (->*/proc stx)
(let-values ([(stx _1 _2) (->*/proc/main stx)])
stx))
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define (->*/proc/main stx)
(syntax-case* stx (->* any) module-or-top-identifier=?
[(->* (doms ...) any)
(->/proc/main (syntax (-> doms ... any)))]
[(->* (doms ...) (rngs ...))
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
[(->* (doms ...) rst (rngs ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
(values (rng-x rng-args) ...))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x rng-x ...)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list rngs ...)
#f
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x rng-x ...)))))))]
[(->* (doms ...) rst any)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
[(args ...) (generate-temporaries (syntax (doms ...)))]
[(rst-x) (generate-temporaries (syntax (rst)))]
[(rest-arg) (generate-temporaries (syntax (rst)))])
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(apply val (dom-x args) ... (rst-x rest-arg))))])
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
(add-name-prop
(syntax-local-infer-name stx)
(syntax (lambda args body))))])
(with-syntax ([outer-lambda
(syntax
(lambda (chk dom-x ... rst-x ignored)
(lambda (val)
(chk val)
inner-lambda)))])
(values (syntax (build--> '->*
(list doms ...)
rst
(list any/c)
#t
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x)))))))])))
(define-for-syntax (select/h stx err-name ctxt-stx)
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
[(-> . args) ->/h]
[(->* . args) ->*/h]
[(->d . args) ->d/h]
[(->d* . args) ->d*/h]
[(->r . args) ->r/h]
[(->pp . args) ->pp/h]
[(->pp-rest . args) ->pp-rest/h]
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
(define-syntax (->d stx) (make-/proc #f ->d/h stx))
(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
(define-syntax (->r stx) (make-/proc #f ->r/h stx))
(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
;;
;; arrow opter
;;
(define/opter (-> opt/i opt/info stx)
(define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
(let loop ([vars rng-vars]
[rngs rngs]
[next-rngs null]
[lifts-rngs null]
[superlifts-rngs null]
[partials-rngs null]
[stronger-ribs null])
(cond
[(null? rngs) (values (reverse next-rngs)
lifts-rngs
superlifts-rngs
partials-rngs
stronger-ribs)]
[else
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
(opt/i opt/info (car rngs))])
(loop (cdr vars)
(cdr rngs)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-rngs)
(append lifts-rngs lift)
(append superlifts-rngs superlift)
(append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(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)
((rng-arg ...) rng-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars))
((next-rng ...) next-rngs))
(syntax (begin
(check-procedure val dom-len src-info pos orig-str)
(λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...))))))
(append lifts-doms lifts-rngs)
(append superlifts-doms superlifts-rngs)
(append partials-doms partials-rngs)
#f
#f
(append stronger-ribs-dom stronger-ribs-rng))))
(define (opt/arrow-any-ctc doms)
(let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
[lifts-doms null]
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs)]
[else
(let-values ([(next lift superlift partial flat _ this-stronger-ribs)
(opt/i (opt/info-swap-blame opt/info) (car doms))])
(loop (cdr vars)
(cdr doms)
(cons (with-syntax ((next next)
(car-vars (car vars)))
(syntax (let ((val car-vars)) next)))
next-doms)
(append lifts-doms lift)
(append superlifts-doms superlift)
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(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)
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val dom-len src-info pos orig-str)
(λ (dom-arg ...)
(val next-dom ...)))))
lifts-doms
superlifts-doms
partials-doms
#f
#f
stronger-ribs-dom)))
(syntax-case* stx (-> values any) module-or-top-identifier=?
[(-> dom ... (values rng ...))
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...))))]
[(-> dom ... any)
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
[(-> dom ... rng)
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))]))

250
collects/scheme/private/contract-basic-opters.ss
View File

@ -1,130 +1,132 @@
(module contract-basic-opters mzscheme
(require "contract-guts.ss"
"contract-opt.ss"
"contract.ss")
(require-for-syntax "contract-opt-guts.ss")
;;
;; opt/pred helper
;;
(define-for-syntax (opt/pred opt/info pred)
(with-syntax ((pred pred))
(values
#lang scheme/base
(require "contract-guts.ss"
"contract-opt.ss"
"contract.ss")
(require (for-syntax scheme/base
"contract-opt-guts.ss"))
;;
;; opt/pred helper
;;
(define-for-syntax (opt/pred opt/info pred)
(with-syntax ((pred pred))
(values
(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 (pred val)
val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val))))
null
null
null
(syntax (pred val))
#f
null)))
;;
;; 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 (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)]))
;;
;; any/c
;;
(define/opter (any/c opt/i opt/info stx)
(syntax-case stx (any/c)
[any/c (values
(opt/info-val opt/info)
null
null
null
#'#t
#f
null)]))
;;
;; 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
;;
(define-for-syntax (opt/flat-ctc opt/info pred checker)
(syntax-case pred (null? number? integer? boolean? pair? not)
;; Better way of doing this?
[null? (opt/pred opt/info pred)]
[number? (opt/pred opt/info pred)]
[integer? (opt/pred opt/info pred)]
[boolean? (opt/pred opt/info pred)]
[pair? (opt/pred opt/info pred)]
[pred
(let* ((lift-vars (generate-temporaries (syntax (pred error-check))))
(lift-pred (car lift-vars)))
(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 (pred val)
val
(raise-contract-error
(orig-str (opt/info-orig-str opt/info))
(lift-pred lift-pred))
(values
(syntax (if (lift-pred val)
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val))))
null
null
null
(syntax (pred val))
#f
null)))
;;
;; 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 (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)]))
;;
;; any/c
;;
(define/opter (any/c opt/i opt/info stx)
(syntax-case stx (any/c)
[any/c (values
(opt/info-val opt/info)
null
null
null
#'#t
#f
null)]))
;;
;; false/c
;;
(define/opter (false/c opt/i opt/info stx)
(syntax-case stx (false/c)
[false/c (opt/pred opt/info #'not)]))
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val)))
(interleave-lifts
lift-vars
(list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)]
[(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])))
null
null
(syntax (lift-pred val))
#f
null)))]))
;;
;; flat-contract helper
;;
(define-for-syntax (opt/flat-ctc opt/info pred checker)
(syntax-case pred (null? number? integer? boolean? pair? not)
;; Better way of doing this?
[null? (opt/pred opt/info pred)]
[number? (opt/pred opt/info pred)]
[integer? (opt/pred opt/info pred)]
[boolean? (opt/pred opt/info pred)]
[pair? (opt/pred opt/info pred)]
[pred
(let* ((lift-vars (generate-temporaries (syntax (pred error-check))))
(lift-pred (car lift-vars)))
(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))
(values
(syntax (if (lift-pred val)
val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val)))
(interleave-lifts
lift-vars
(list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)]
[(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])))
null
null
(syntax (lift-pred val))
#f
null)))]))
;;
;; flat-contract and friends
;;
(define/opter (flat-contract opt/i opt/info stx)
(syntax-case stx (flat-contract)
[(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)]))
(define/opter (flat-named-contract opt/i opt/info stx)
(syntax-case stx (flat-named-contract)
[(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)])))
;;
;; flat-contract and friends
;;
(define/opter (flat-contract opt/i opt/info stx)
(syntax-case stx (flat-contract)
[(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)]))
(define/opter (flat-named-contract opt/i opt/info stx)
(syntax-case stx (flat-named-contract)
[(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)]))

708
collects/scheme/private/contract-ds-helpers.ss
View File

@ -1,13 +1,13 @@
(module contract-ds-helpers mzscheme
(provide ensure-well-formed
build-func-params
build-clauses
build-enforcer-clauses
generate-arglists)
(require (lib "list.ss")
"contract-opt-guts.ss")
(require-for-template mzscheme)
#lang scheme/base
(provide ensure-well-formed
build-func-params
build-clauses
build-enforcer-clauses
generate-arglists)
(require "contract-opt-guts.ss")
(require (for-template scheme/base)
(for-syntax scheme/base))
#|
@ -32,356 +32,354 @@ which are then called when the contract's fields are explored
|#
(define (build-clauses name coerce-contract stx clauses)
(let* ([field-names
(let loop ([clauses (syntax->list clauses)])
(cond
[(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
"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 20])
(if (zero? n)
e
#`(if (zero? (random 1))
#,(loop (- n 1))
(/ 1 0)))))])
(let loop ([clauses (syntax->list clauses)]
[ac-ids all-ac-ids]
[prior-ac-ids '()]
[maker-args '()])
(cond
[(null? clauses)
(with-syntax ([(maker-args ...) (reverse maker-args)])
(syntax ((maker-args ... #f)
())))]
[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))
(define (build-clauses name coerce-contract stx clauses)
(let* ([field-names
(let loop ([clauses (syntax->list clauses)])
(cond
[(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
"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 20])
(if (zero? n)
e
#`(if (zero? (random 1))
#,(loop (- n 1))
(/ 1 0)))))])
(let loop ([clauses (syntax->list clauses)]
[ac-ids all-ac-ids]
[prior-ac-ids '()]
[maker-args '()])
(cond
[(null? clauses)
(with-syntax ([(maker-args ...) (reverse maker-args)])
(syntax ((maker-args ... #f)
())))]
[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 #`(#,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 id 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 #,id arg ...)
null
null
null
#f
#f
null)]
[else (opt/i (opt/info-change-val id opt/info)
stx)]))
(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)]))]))]))))
(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-var (car let-vars)]
[arglist (car arglists)]
[ac-id (car ac-ids)])
(syntax-case clause ()
[(id (x ...) ctc-exp)
(and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...)))))
(let*-values ([(next lifts superlifts partials _ _2 _3)
(opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg)
(with-syntax ([val (opt/info-val opt/info)]
[(new-let-bindings ...)
(match-up/bind (reverse prior-ac-ids)
(syntax (x ...))
field-names
arglist)])
#`(#,let-var
#,(bind-lifts
superlifts
#`(let (new-let-bindings ...)
#,(bind-lifts
(append lifts partials)
next)))))])
(loop (cdr clauses)
(cdr let-vars)
(cdr arglists)
(cdr ac-ids)
(cons (car ac-ids) prior-ac-ids)
(cons maker-arg maker-args)
lifts-ps
superlifts-ps
stronger-ribs-ps))]
[(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))
(let*-values ([(next lifts superlifts partials _ __ stronger-ribs)
(opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg)
(with-syntax ((val (opt/info-val opt/info)))
#`(#,let-var
#,(bind-lifts
partials
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)
(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))
;; produces the list of arguments to the dependent contract
;; functions, given the names of some variables.
;; eg: (generate-arglists '(x y z w))
;; = (list '() '(x) '(x y) '(x y z))
(define (generate-arglists vars)
(reverse
(let loop ([vars (reverse vars)])
(cond
[(null? vars) null]
[else (cons (reverse (cdr vars))
(loop (cdr vars)))]))))
(define (match-up/bind prior-ac-ids used-field-names field-names rhss)
(let ([used-field-ids (syntax->list used-field-names)])
(let loop ([prior-ac-ids prior-ac-ids]
[field-names field-names]
[rhss rhss])
(cond
[(null? prior-ac-ids) null]
[else (let* ([ac-id (car prior-ac-ids)]
[field-name (car field-names)]
[id-used
(ormap (λ (used-field-id)
(and (eq? (syntax-e field-name) (syntax-e used-field-id))
used-field-id))
used-field-ids)])
(if id-used
(cons (with-syntax ([id id-used]
[arg (car rhss)])
#'[id arg])
(loop (cdr prior-ac-ids)
(cdr field-names)
(cdr rhss)))
(loop (cdr prior-ac-ids)
(cdr field-names)
(cdr rhss))))]))))
(define (match-up prior-ac-ids used-field-names field-names)
(let ([used-field-ids (syntax->list used-field-names)])
(let loop ([prior-ac-ids prior-ac-ids]
[field-names field-names])
(cond
[(null? prior-ac-ids) null]
[else (let* ([ac-id (car prior-ac-ids)]
[field-name (car field-names)]
[id-used
(ormap (λ (used-field-id)
(and (eq? (syntax-e field-name) (syntax-e used-field-id))
used-field-id))
used-field-ids)])
(if id-used
(cons id-used
(loop (cdr prior-ac-ids)
(cdr field-names)))
(cons (car (generate-temporaries '(ignored-arg)))
(loop (cdr prior-ac-ids)
(cdr field-names)))))]))))
(define (sort-wrt name stx ids current-order-field-names desired-order-field-names)
(let ([id/user-specs (map cons ids current-order-field-names)]
[ht (make-hash-table)])
(let loop ([i 0]
[orig-field-names desired-order-field-names])
(unless (null? orig-field-names)
(hash-table-put! ht (syntax-e (car orig-field-names)) i)
(loop (+ i 1) (cdr orig-field-names))))
(let* ([lookup
(λ (id-pr)
(let ([id (car id-pr)]
[use-field-name (cdr id-pr)])
(hash-table-get ht
(syntax-e use-field-name)
(λ ()
(raise-syntax-error name "unknown field name" stx use-field-name)))))]
[cmp (λ (x y) (<= (lookup x) (lookup y)))]
[sorted-id/user-specs (sort id/user-specs cmp)])
(map car sorted-id/user-specs))))
(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 (find-matching all-ac-ids chosen-ids field-names)
(map (λ (chosen-id)
(let* ([chosen-sym (syntax-e chosen-id)]
[id (ormap (λ (ac-id field-name)
(and (eq? (syntax-e field-name) chosen-sym)
ac-id))
all-ac-ids
field-names)])
(unless id
(error 'find-matching "could not find matching for ~s" chosen-id))
id))
(syntax->list chosen-ids)))
(define (build-func-params ids)
(let ([temps (generate-temporaries ids)])
(let loop ([ids (syntax->list ids)]
[temps temps]
[can-refer-to '()])
(cond
[(null? ids) null]
[else (cons
(append (reverse can-refer-to) temps)
(loop (cdr ids)
(cdr temps)
(cons (car ids) can-refer-to)))]))))
(define (ensure-well-formed stx field-count)
(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 id stx)
(syntax-case stx ()
[(_ [id exp] ...)
(and (andmap identifier? (syntax->list (syntax (id ...))))
(equal? (length (syntax->list (syntax (id ...))))
field-count))
(void)]
[(_ [id exp] ...)
(andmap identifier? (syntax->list (syntax (id ...))))
(raise-syntax-error 'struct/dc
(format "expected ~a clauses, but found ~a"
field-count
(length (syntax->list (syntax (id ...)))))
stx)]
[(_ [id exp] ...)
(for-each
(λ (id) (unless (identifier? id) (raise-syntax-error 'struct/dc "expected identifier" stx id)))
(syntax->list (syntax (id ...))))])))
[(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))
(values
#`(f #,id arg ...)
null
null
null
#f
#f
null)]
[else (opt/i (opt/info-change-val id 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-var (car let-vars)]
[arglist (car arglists)]
[ac-id (car ac-ids)])
(syntax-case clause ()
[(id (x ...) ctc-exp)
(and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...)))))
(let*-values ([(next lifts superlifts partials _ _2 _3)
(opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg)
(with-syntax ([val (opt/info-val opt/info)]
[(new-let-bindings ...)
(match-up/bind (reverse prior-ac-ids)
(syntax (x ...))
field-names
arglist)])
#`(#,let-var
#,(bind-lifts
superlifts
#`(let (new-let-bindings ...)
#,(bind-lifts
(append lifts partials)
next)))))])
(loop (cdr clauses)
(cdr let-vars)
(cdr arglists)
(cdr ac-ids)
(cons (car ac-ids) prior-ac-ids)
(cons maker-arg maker-args)
lifts-ps
superlifts-ps
stronger-ribs-ps))]
[(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))
(let*-values ([(next lifts superlifts partials _ __ stronger-ribs)
(opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg)
(with-syntax ((val (opt/info-val opt/info)))
#`(#,let-var
#,(bind-lifts
partials
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)
(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))
;; produces the list of arguments to the dependent contract
;; functions, given the names of some variables.
;; eg: (generate-arglists '(x y z w))
;; = (list '() '(x) '(x y) '(x y z))
(define (generate-arglists vars)
(reverse
(let loop ([vars (reverse vars)])
(cond
[(null? vars) null]
[else (cons (reverse (cdr vars))
(loop (cdr vars)))]))))
(define (match-up/bind prior-ac-ids used-field-names field-names rhss)
(let ([used-field-ids (syntax->list used-field-names)])
(let loop ([prior-ac-ids prior-ac-ids]
[field-names field-names]
[rhss rhss])
(cond
[(null? prior-ac-ids) null]
[else (let* ([ac-id (car prior-ac-ids)]
[field-name (car field-names)]
[id-used
(ormap (λ (used-field-id)
(and (eq? (syntax-e field-name) (syntax-e used-field-id))
used-field-id))
used-field-ids)])
(if id-used
(cons (with-syntax ([id id-used]
[arg (car rhss)])
#'[id arg])
(loop (cdr prior-ac-ids)
(cdr field-names)
(cdr rhss)))
(loop (cdr prior-ac-ids)
(cdr field-names)
(cdr rhss))))]))))
(define (match-up prior-ac-ids used-field-names field-names)
(let ([used-field-ids (syntax->list used-field-names)])
(let loop ([prior-ac-ids prior-ac-ids]
[field-names field-names])
(cond
[(null? prior-ac-ids) null]
[else (let* ([ac-id (car prior-ac-ids)]
[field-name (car field-names)]
[id-used
(ormap (λ (used-field-id)
(and (eq? (syntax-e field-name) (syntax-e used-field-id))
used-field-id))
used-field-ids)])
(if id-used
(cons id-used
(loop (cdr prior-ac-ids)
(cdr field-names)))
(cons (car (generate-temporaries '(ignored-arg)))
(loop (cdr prior-ac-ids)
(cdr field-names)))))]))))
(define (sort-wrt name stx ids current-order-field-names desired-order-field-names)
(let ([id/user-specs (map cons ids current-order-field-names)]
[ht (make-hash-table)])
(let loop ([i 0]
[orig-field-names desired-order-field-names])
(unless (null? orig-field-names)
(hash-table-put! ht (syntax-e (car orig-field-names)) i)
(loop (+ i 1) (cdr orig-field-names))))
(let* ([lookup
(λ (id-pr)
(let ([id (car id-pr)]
[use-field-name (cdr id-pr)])
(hash-table-get ht
(syntax-e use-field-name)
(λ ()
(raise-syntax-error name "unknown field name" stx use-field-name)))))]
[cmp (λ (x y) (<= (lookup x) (lookup y)))]
[sorted-id/user-specs (sort id/user-specs cmp)])
(map car sorted-id/user-specs))))
(define (find-matching all-ac-ids chosen-ids field-names)
(map (λ (chosen-id)
(let* ([chosen-sym (syntax-e chosen-id)]
[id (ormap (λ (ac-id field-name)
(and (eq? (syntax-e field-name) chosen-sym)
ac-id))
all-ac-ids
field-names)])
(unless id
(error 'find-matching "could not find matching for ~s" chosen-id))
id))
(syntax->list chosen-ids)))
(define (build-func-params ids)
(let ([temps (generate-temporaries ids)])
(let loop ([ids (syntax->list ids)]
[temps temps]
[can-refer-to '()])
(cond
[(null? ids) null]
[else (cons
(append (reverse can-refer-to) temps)
(loop (cdr ids)
(cdr temps)
(cons (car ids) can-refer-to)))]))))
(define (ensure-well-formed stx field-count)
(syntax-case stx ()
[(_ [id exp] ...)
(and (andmap identifier? (syntax->list (syntax (id ...))))
(equal? (length (syntax->list (syntax (id ...))))
field-count))
(void)]
[(_ [id exp] ...)
(andmap identifier? (syntax->list (syntax (id ...))))
(raise-syntax-error 'struct/dc
(format "expected ~a clauses, but found ~a"
field-count
(length (syntax->list (syntax (id ...)))))
stx)]
[(_ [id exp] ...)
(for-each
(λ (id) (unless (identifier? id) (raise-syntax-error 'struct/dc "expected identifier" stx id)))
(syntax->list (syntax (id ...))))]))

1071
collects/scheme/private/contract-ds.ss
View File

File diff suppressed because it is too large Load Diff

914
collects/scheme/private/contract-guts.ss
View File

@ -1,463 +1,465 @@
(module contract-guts mzscheme
(require "contract-helpers.ss"
(lib "pretty.ss"))
#lang scheme/base
(require-for-syntax "contract-helpers.ss")
(provide raise-contract-error
guilty-party
contract-violation->string
coerce-contract
flat-contract/predicate?
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
(require "contract-helpers.ss"
scheme/pretty)
build-compound-type-name
and/c
any/c
none/c
make-none/c
contract?
contract-name
contract-proc
make-proj-contract
build-flat-contract
define-struct/prop
contract-stronger?
(require (for-syntax scheme/base
"contract-helpers.ss"))
contract-first-order-passes?
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
flat-proj
first-order-prop
first-order-get
;; for opters
check-flat-contract
check-flat-named-contract
any)
(define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
(provide raise-contract-error
guilty-party
contract-violation->string
coerce-contract
flat-contract/predicate?
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
build-compound-type-name
and/c
any/c
none/c
make-none/c
contract?
contract-name
contract-proc
make-proj-contract
build-flat-contract
define-struct/prop
contract-stronger?
contract-first-order-passes?
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
flat-proj
first-order-prop
first-order-get
;; for opters
check-flat-contract
check-flat-named-contract
any)
;; define-struct/prop is a define-struct-like macro that
;; also allows properties to be defined
;; it contains copied code (build-struct-names) in order to avoid
;; a module cycle
(define-syntax (define-struct/prop stx)
(let ()
(syntax-case stx ()
[(_ name (field ...) ((property value) ...))
(andmap identifier? (syntax->list (syntax (field ...))))
(let ([struct-names (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#f
#t
stx)]
[struct-names/bangers (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#t
#f
stx)]
[field-count/val (length (syntax->list (syntax (field ...))))])
(with-syntax ([struct:-name (list-ref struct-names 0)]
[struct-maker (list-ref struct-names 1)]
[predicate (list-ref struct-names 2)]
[(count ...) (nums-up-to field-count/val)]
[(selectors ...) (cdddr struct-names)]
[(bangers ...) (cdddr struct-names/bangers)]
[field-count field-count/val]
[(field-indicies ...) (nums-up-to (length (syntax->list (syntax (field ...)))))])
(syntax
(begin
(define-values (struct:-name struct-maker predicate get set)
(make-struct-type 'name
#f ;; super
field-count
0 ;; auto-field-k
'()
(list (cons property value) ...)))
(define selectors (make-struct-field-accessor get count 'field))
...
(define bangers (make-struct-field-mutator set count 'field))
...))))])))
(define-values (proj-prop proj-pred? raw-proj-get)
(make-struct-type-property 'contract-projection))
(define-values (name-prop name-pred? name-get)
(make-struct-type-property 'contract-name))
(define-values (stronger-prop stronger-pred? stronger-get)
(make-struct-type-property 'contract-stronger-than))
(define-values (flat-prop flat-pred? flat-get)
(make-struct-type-property 'contract-flat))
(define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
(define-values (first-order-prop first-order-pred? first-order-get)
(make-struct-type-property 'contract-first-order))
(define (contract-first-order-passes? c v)
(cond
[(first-order-pred? c) (((first-order-get c) c) v)]
[(and (procedure? c)
(procedure-arity-includes? c 1))
;; flat contract as a predicate
(c v)]
[(flat-pred? c) (((flat-get c) c) v)]
[else (error 'contract-first-order-passes?
"expected a contract as first argument, got ~e, other arg ~e" c v)]))
(define (proj-get ctc)
(cond
[(proj-pred? ctc)
(raw-proj-get ctc)]
[else (error 'proj-get "unknown ~e" ctc)]))
;; contract-stronger? : contract contract -> boolean
;; indicates if one contract is stronger (ie, likes fewer values) than another
;; this is not a total order.
(define (contract-stronger? a b)
(let ([a-ctc (coerce-contract 'contract-stronger? a)]
[b-ctc (coerce-contract 'contract-stronger? b)])
((stronger-get a-ctc) a-ctc b-ctc)))
;; coerce-contract : id (union contract? procedure-arity-1) -> contract
;; contract-proc = sym sym stx -> alpha -> alpha
;; returns the procedure for the contract after extracting it from the
;; struct. Coerces the argument to a flat contract if it is procedure, but first.
(define (coerce-contract name x)
(cond
[(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)]
[else
(error name
"expected contract or procedure of arity 1, got ~e"
x)]))
(define-values (make-exn:fail:contract2
exn:fail:contract2?
exn:fail:contract2-srclocs
guilty-party)
(let-values ([(exn:fail:contract2
make-exn:fail:contract2
exn:fail:contract2?
get
set)
(parameterize ([current-inspector (make-inspector)])
(make-struct-type 'exn:fail:contract2
struct:exn:fail:contract
2
0
#f
(list (cons prop:exn:srclocs
(lambda (x)
(exn:fail:contract2-srclocs x))))))])
(values
make-exn:fail:contract2
exn:fail:contract2?
(lambda (x) (get x 0))
(lambda (x) (get x 1)))))
(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
(let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp
(let ([one-line (format "~s" contract-sexp)])
(if (< (string-length one-line) 30)
(string-append one-line " ")
(let ([sp (open-output-string)])
(newline sp)
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50])
(pretty-print contract-sexp sp))
(get-output-string sp))))]
[specific-blame
(let ([datum (syntax-object->datum src-info)])
(if (symbol? datum)
(format "on ~a" datum)
""))])
(string-append (format "~a~a broke the contract ~a~a; "
blame-src
to-blame
formatted-contract-sexp
specific-blame)
msg)))
(define contract-violation->string (make-parameter default-contract-violation->string))
(define (raise-contract-error val src-info blame contract-sexp fmt . args)
(raise
(make-exn:fail:contract2
(string->immutable-string
((contract-violation->string) val
src-info
blame
contract-sexp
(apply format fmt args)))
(current-continuation-marks)
(if src-info
(list (make-srcloc
(syntax-source src-info)
(syntax-line src-info)
(syntax-column src-info)
(syntax-position src-info)
(syntax-span src-info)))
'())
blame)))
(define print-contract-liner
(let ([default (pretty-print-print-line)])
(λ (line port ol cols)
(+ (default line port ol cols)
(if line
(begin (display " " port)
2)
0)))))
;; src-info-as-string : (union syntax #f) -> string
(define (src-info-as-string src-info)
(if (syntax? src-info)
(let ([src-loc-str (build-src-loc-string src-info)])
(if src-loc-str
(string-append src-loc-str ": ")
""))
""))
;
;
;
;
;
; ; ;
; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;;
; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;;
;
;
;
;; contract = (make-contract sexp
;; (sym
;; sym
;; (union syntax #f)
;; string
;; ->
;; (alpha -> alpha)))
;; the first arg to make-contract builds the name of the contract. The
;; path records how the violation occurs
;;
;; generic contract container;
;; the first arg to proc is a symbol representing the name of the positive blame
;; the second arg to proc is the symbol representing the name of the negative blame
;; the third argument to proc is the src-info.
;; the fourth argumet is a textual representation of the original contract
;;
;; the argument to the result function is the value to test.
;; (the result function is the projection)
;;
(define (flat-proj ctc)
(let ([pred? ((flat-get ctc) ctc)])
(λ (pos neg src-info orig-str)
(λ (val)
(if (pred? val)
val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val))))))
(define (double-any-curried-proj ctc) double-any-curred-proj2)
(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values)
(define-values (make-flat-contract
make-proj-contract)
(let ()
(define-struct/prop proj-contract (the-name proj first-order-proc)
((proj-prop (λ (ctc) (proj-contract-proj ctc)))
(name-prop (λ (ctc) (proj-contract-the-name ctc)))
(first-order-prop (λ (ctc) (or (proj-contract-first-order-proc ctc)
(λ (x) #t))))
(stronger-prop (λ (this that)
(and (proj-contract? that)
(procedure-closure-contents-eq?
(proj-contract-proj this)
(proj-contract-proj that)))))))
(define-struct/prop flat-contract (the-name predicate)
((proj-prop flat-proj)
(stronger-prop (λ (this that)
(and (flat-contract? that)
(procedure-closure-contents-eq? (flat-contract-predicate this)
(flat-contract-predicate that)))))
(name-prop (λ (ctc) (flat-contract-the-name ctc)))
(flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
(values make-flat-contract
make-proj-contract)))
(define (flat-contract-predicate x)
(unless (flat-contract? x)
(error 'flat-contract-predicate "expected a flat contract, got ~e" x))
((flat-get x) x))
(define (flat-contract? x) (flat-pred? x))
(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-proc ctc) ((proj-get ctc) ctc))
(define (check-flat-contract predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-contract
"expected procedure of arity 1 as argument, given ~e"
predicate)))
(define (flat-contract predicate)
(check-flat-contract predicate)
(let ([pname (object-name predicate)])
(if pname
(flat-named-contract pname predicate)
(flat-named-contract '??? predicate))))
(define (check-flat-named-contract predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-named-contract
"expected procedure of arity 1 as second argument, given ~e"
predicate)))
(define (flat-named-contract name predicate)
(check-flat-named-contract predicate)
(build-flat-contract name predicate))
(define (build-flat-contract name predicate) (make-flat-contract name predicate))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs)
(let loop ([subs fs])
(cond
[(null? subs)
'()]
[else (let ([sub (car subs)])
(cond
[(contract? sub)
(let ([mk-sub-name (contract-name sub)])
`(,mk-sub-name ,@(loop (cdr subs))))]
[else `(,sub ,@(loop (cdr subs)))]))])))
(define (and-proj ctc)
(let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
(lambda (pos neg src-info orig-str)
(let ([projs (map (λ (c) (c pos neg src-info orig-str)) mk-pos-projs)])
(let loop ([projs (cdr projs)]
[proj (car projs)])
(cond
[(null? projs) proj]
[else (loop (cdr projs)
(let ([f (car projs)])
(λ (v) (proj (f v)))))]))))))
(define-struct/prop and/c (ctcs)
((proj-prop and-proj)
(name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))))
(first-order-prop (λ (ctc)
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
(λ (x)
(andmap (λ (f) (f x)) tests)))))
(stronger-prop
(λ (this that)
(and (and/c? that)
(let ([this-ctcs (and/c-ctcs this)]
[that-ctcs (and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))))
;; define-struct/prop is a define-struct-like macro that
;; also allows properties to be defined
;; it contains copied code (build-struct-names) in order to avoid
;; a module cycle
(define-syntax (define-struct/prop stx)
(let ()
(define (and/c . fs)
(for-each
(lambda (x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'and/c "expected procedures of arity 1 or <contract>s, given: ~e" x)))
fs)
(cond
[(null? fs) any/c]
[(andmap flat-contract/predicate? fs)
(let* ([to-predicate
(lambda (x)
(if (flat-contract? x)
(flat-contract-predicate x)
x))]
[contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
[pred
(let loop ([pred (to-predicate (car fs))]
[preds (cdr fs)])
(cond
[(null? preds) pred]
[else
(let* ([fst (to-predicate (car preds))])
(loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))])
and/c-contract?)
(cdr preds)))]))])
(flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
[else
(let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
(make-and/c contracts))]))
(define-struct/prop any/c ()
((proj-prop double-any-curried-proj)
(stronger-prop (λ (this that) (any/c? that)))
(name-prop (λ (ctc) 'any/c))
(first-order-prop (λ (ctc) (λ (val) #t)))
(flat-prop (λ (ctc) (λ (x) #t)))))
(define any/c (make-any/c))
(define (none-curried-proj ctc)
(λ (pos-blame neg-blame src-info orig-str)
(λ (val)
(raise-contract-error
val
src-info
pos-blame
orig-str
"~s accepts no values, given: ~e"
(none/c-name ctc)
val))))
(syntax-case stx ()
[(_ name (field ...) ((property value) ...))
(andmap identifier? (syntax->list (syntax (field ...))))
(let ([struct-names (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#f
#t
stx)]
[struct-names/bangers (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#t
#f
stx)]
[field-count/val (length (syntax->list (syntax (field ...))))])
(with-syntax ([struct:-name (list-ref struct-names 0)]
[struct-maker (list-ref struct-names 1)]
[predicate (list-ref struct-names 2)]
[(count ...) (nums-up-to field-count/val)]
[(selectors ...) (cdddr struct-names)]
[(bangers ...) (cdddr struct-names/bangers)]
[field-count field-count/val]
[(field-indicies ...) (nums-up-to (length (syntax->list (syntax (field ...)))))])
(syntax
(begin
(define-values (struct:-name struct-maker predicate get set)
(make-struct-type 'name
#f ;; super
field-count
0 ;; auto-field-k
'()
(list (cons property value) ...)))
(define selectors (make-struct-field-accessor get count 'field))
...
(define bangers (make-struct-field-mutator set count 'field))
...))))])))
(define-struct/prop none/c (name)
((proj-prop none-curried-proj)
(stronger-prop (λ (this that) #t))
(name-prop (λ (ctc) (none/c-name ctc)))
(first-order-prop (λ (ctc) (λ (val) #f)))
(flat-prop (λ (ctc) (λ (x) #f)))))
(define none/c (make-none/c 'none/c))
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1)))))
(define-values (proj-prop proj-pred? raw-proj-get)
(make-struct-type-property 'contract-projection))
(define-values (name-prop name-pred? name-get)
(make-struct-type-property 'contract-name))
(define-values (stronger-prop stronger-pred? stronger-get)
(make-struct-type-property 'contract-stronger-than))
(define-values (flat-prop flat-pred? flat-get)
(make-struct-type-property 'contract-flat))
(define-values (first-order-prop first-order-pred? first-order-get)
(make-struct-type-property 'contract-first-order))
(define (contract-first-order-passes? c v)
(cond
[(first-order-pred? c) (((first-order-get c) c) v)]
[(and (procedure? c)
(procedure-arity-includes? c 1))
;; flat contract as a predicate
(c v)]
[(flat-pred? c) (((flat-get c) c) v)]
[else (error 'contract-first-order-passes?
"expected a contract as first argument, got ~e, other arg ~e" c v)]))
(define (proj-get ctc)
(cond
[(proj-pred? ctc)
(raw-proj-get ctc)]
[else (error 'proj-get "unknown ~e" ctc)]))
;; contract-stronger? : contract contract -> boolean
;; indicates if one contract is stronger (ie, likes fewer values) than another
;; this is not a total order.
(define (contract-stronger? a b)
(let ([a-ctc (coerce-contract 'contract-stronger? a)]
[b-ctc (coerce-contract 'contract-stronger? b)])
((stronger-get a-ctc) a-ctc b-ctc)))
;; coerce-contract : id (union contract? procedure-arity-1) -> contract
;; contract-proc = sym sym stx -> alpha -> alpha
;; returns the procedure for the contract after extracting it from the
;; struct. Coerces the argument to a flat contract if it is procedure, but first.
(define (coerce-contract name x)
(cond
[(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)]
[else
(error name
"expected contract or procedure of arity 1, got ~e"
x)]))
(define-values (make-exn:fail:contract2
exn:fail:contract2?
exn:fail:contract2-srclocs
guilty-party)
(let-values ([(exn:fail:contract2
make-exn:fail:contract2
exn:fail:contract2?
get
set)
(parameterize ([current-inspector (make-inspector)])
(make-struct-type 'exn:fail:contract2
struct:exn:fail:contract
2
0
#f
(list (cons prop:exn:srclocs
(lambda (x)
(exn:fail:contract2-srclocs x))))))])
(values
make-exn:fail:contract2
exn:fail:contract2?
(lambda (x) (get x 0))
(lambda (x) (get x 1)))))
(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
(let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp
(let ([one-line (format "~s" contract-sexp)])
(if (< (string-length one-line) 30)
(string-append one-line " ")
(let ([sp (open-output-string)])
(newline sp)
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50])
(pretty-print contract-sexp sp))
(get-output-string sp))))]
[specific-blame
(let ([datum (syntax->datum src-info)])
(if (symbol? datum)
(format "on ~a" datum)
""))])
(string-append (format "~a~a broke the contract ~a~a; "
blame-src
to-blame
formatted-contract-sexp
specific-blame)
msg)))
(define contract-violation->string (make-parameter default-contract-violation->string))
(define (raise-contract-error val src-info blame contract-sexp fmt . args)
(raise
(make-exn:fail:contract2
(string->immutable-string
((contract-violation->string) val
src-info
blame
contract-sexp
(apply format fmt args)))
(current-continuation-marks)
(if src-info
(list (make-srcloc
(syntax-source src-info)
(syntax-line src-info)
(syntax-column src-info)
(syntax-position src-info)
(syntax-span src-info)))
'())
blame)))
(define print-contract-liner
(let ([default (pretty-print-print-line)])
(λ (line port ol cols)
(+ (default line port ol cols)
(if line
(begin (display " " port)
2)
0)))))
;; src-info-as-string : (union syntax #f) -> string
(define (src-info-as-string src-info)
(if (syntax? src-info)
(let ([src-loc-str (build-src-loc-string src-info)])
(if src-loc-str
(string-append src-loc-str ": ")
""))
""))
;
;
;
;
;
; ; ;
; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;;
; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;;
;
;
;
;; contract = (make-contract sexp
;; (sym
;; sym
;; (union syntax #f)
;; string
;; ->
;; (alpha -> alpha)))
;; the first arg to make-contract builds the name of the contract. The
;; path records how the violation occurs
;;
;; generic contract container;
;; the first arg to proc is a symbol representing the name of the positive blame
;; the second arg to proc is the symbol representing the name of the negative blame
;; the third argument to proc is the src-info.
;; the fourth argumet is a textual representation of the original contract
;;
;; the argument to the result function is the value to test.
;; (the result function is the projection)
;;
(define (flat-proj ctc)
(let ([pred? ((flat-get ctc) ctc)])
(λ (pos neg src-info orig-str)
(λ (val)
(if (pred? val)
val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val))))))
(define (double-any-curried-proj ctc) double-any-curred-proj2)
(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values)
(define-values (make-flat-contract
make-proj-contract)
(let ()
(define-struct/prop proj-contract (the-name proj first-order-proc)
((proj-prop (λ (ctc) (proj-contract-proj ctc)))
(name-prop (λ (ctc) (proj-contract-the-name ctc)))
(first-order-prop (λ (ctc) (or (proj-contract-first-order-proc ctc)
(λ (x) #t))))
(stronger-prop (λ (this that)
(and (proj-contract? that)
(procedure-closure-contents-eq?
(proj-contract-proj this)
(proj-contract-proj that)))))))
(define-struct/prop flat-contract (the-name predicate)
((proj-prop flat-proj)
(stronger-prop (λ (this that)
(and (flat-contract? that)
(procedure-closure-contents-eq? (flat-contract-predicate this)
(flat-contract-predicate that)))))
(name-prop (λ (ctc) (flat-contract-the-name ctc)))
(flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
(values make-flat-contract
make-proj-contract)))
(define (flat-contract-predicate x)
(unless (flat-contract? x)
(error 'flat-contract-predicate "expected a flat contract, got ~e" x))
((flat-get x) x))
(define (flat-contract? x) (flat-pred? x))
(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-proc ctc) ((proj-get ctc) ctc))
(define (check-flat-contract predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-contract
"expected procedure of arity 1 as argument, given ~e"
predicate)))
(define (flat-contract predicate)
(check-flat-contract predicate)
(let ([pname (object-name predicate)])
(if pname
(flat-named-contract pname predicate)
(flat-named-contract '??? predicate))))
(define (check-flat-named-contract predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-named-contract
"expected procedure of arity 1 as second argument, given ~e"
predicate)))
(define (flat-named-contract name predicate)
(check-flat-named-contract predicate)
(build-flat-contract name predicate))
(define (build-flat-contract name predicate) (make-flat-contract name predicate))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs)
(let loop ([subs fs])
(cond
[(null? subs)
'()]
[else (let ([sub (car subs)])
(cond
[(contract? sub)
(let ([mk-sub-name (contract-name sub)])
`(,mk-sub-name ,@(loop (cdr subs))))]
[else `(,sub ,@(loop (cdr subs)))]))])))
(define (and-proj ctc)
(let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
(lambda (pos neg src-info orig-str)
(let ([projs (map (λ (c) (c pos neg src-info orig-str)) mk-pos-projs)])
(let loop ([projs (cdr projs)]
[proj (car projs)])
(cond
[(null? projs) proj]
[else (loop (cdr projs)
(let ([f (car projs)])
(λ (v) (proj (f v)))))]))))))
(define-struct/prop and/c (ctcs)
((proj-prop and-proj)
(name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))))
(first-order-prop (λ (ctc)
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
(λ (x)
(andmap (λ (f) (f x)) tests)))))
(stronger-prop
(λ (this that)
(and (and/c? that)
(let ([this-ctcs (and/c-ctcs this)]
[that-ctcs (and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))))
(define (and/c . fs)
(for-each
(lambda (x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'and/c "expected procedures of arity 1 or <contract>s, given: ~e" x)))
fs)
(cond
[(null? fs) any/c]
[(andmap flat-contract/predicate? fs)
(let* ([to-predicate
(lambda (x)
(if (flat-contract? x)
(flat-contract-predicate x)
x))]
[contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
[pred
(let loop ([pred (to-predicate (car fs))]
[preds (cdr fs)])
(cond
[(null? preds) pred]
[else
(let* ([fst (to-predicate (car preds))])
(loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))])
and/c-contract?)
(cdr preds)))]))])
(flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
[else
(let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
(make-and/c contracts))]))
(define-struct/prop any/c ()
((proj-prop double-any-curried-proj)
(stronger-prop (λ (this that) (any/c? that)))
(name-prop (λ (ctc) 'any/c))
(first-order-prop (λ (ctc) (λ (val) #t)))
(flat-prop (λ (ctc) (λ (x) #t)))))
(define any/c (make-any/c))
(define (none-curried-proj ctc)
(λ (pos-blame neg-blame src-info orig-str)
(λ (val)
(raise-contract-error
val
src-info
pos-blame
orig-str
"~s accepts no values, given: ~e"
(none/c-name ctc)
val))))
(define-struct/prop none/c (name)
((proj-prop none-curried-proj)
(stronger-prop (λ (this that) #t))
(name-prop (λ (ctc) (none/c-name ctc)))
(first-order-prop (λ (ctc) (λ (val) #f)))
(flat-prop (λ (ctc) (λ (x) #f)))))
(define none/c (make-none/c 'none/c))
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1))))

550
collects/scheme/private/contract-helpers.ss
View File

@ -1,286 +1,286 @@
(module contract-helpers mzscheme
(provide module-source-as-symbol build-src-loc-string
mangle-id mangle-id-for-maker
build-struct-names
nums-up-to
add-name-prop
all-but-last
known-good-contract?)
(require (lib "main-collects.ss" "setup"))
(require-for-template mzscheme)
(define (add-name-prop name stx)
(cond
[(identifier? name)
(syntax-property stx 'inferred-name (syntax-e name))]
[(symbol? name)
(syntax-property stx 'inferred-name name)]
[else stx]))
;; mangle-id : syntax string syntax ... -> syntax
;; constructs a mangled name of an identifier from an identifier
;; the name isn't fresh, so `id' combined with `ids' must already be unique.
(define (mangle-id main-stx prefix id . ids)
(datum->syntax-object
#lang scheme/base
(provide module-source-as-symbol build-src-loc-string
mangle-id mangle-id-for-maker
build-struct-names
nums-up-to
add-name-prop
all-but-last
known-good-contract?)
(require setup/main-collects
(for-template scheme/base))
(define (add-name-prop name stx)
(cond
[(identifier? name)
(syntax-property stx 'inferred-name (syntax-e name))]
[(symbol? name)
(syntax-property stx 'inferred-name name)]
[else stx]))
;; mangle-id : syntax string syntax ... -> syntax
;; constructs a mangled name of an identifier from an identifier
;; the name isn't fresh, so `id' combined with `ids' must already be unique.
(define (mangle-id main-stx prefix id . ids)
(datum->syntax
#f
(string->symbol
(string-append
prefix
(format
"-~a~a"
(syntax->datum id)
(apply
string-append
(map
(lambda (id)
(format "-~a" (syntax->datum id)))
ids)))))))
(define (mangle-id-for-maker main-stx prefix id . ids)
(let ([id-w/out-make (regexp-replace #rx"^make-" (format "~a" (syntax->datum id)) "")])
(datum->syntax
#f
(string->symbol
(string-append
"make-"
prefix
(format
"-~a~a"
(syntax-object->datum id)
id-w/out-make
(apply
string-append
(map
(lambda (id)
(format "-~a" (syntax-object->datum id)))
ids)))))))
(define (mangle-id-for-maker main-stx prefix id . ids)
(let ([id-w/out-make (regexp-replace #rx"^make-" (format "~a" (syntax-object->datum id)) "")])
(datum->syntax-object
#f
(string->symbol
(string-append
"make-"
prefix
(format
"-~a~a"
id-w/out-make
(apply
string-append
(map
(lambda (id)
(format "-~a" (syntax-object->datum id)))
ids))))))))
;; (cons X (listof X)) -> (listof X)
;; returns the elements of `l', minus the last element
;; special case: if l is an improper list, it leaves off
;; the contents of the last cdr (ie, making a proper list
;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2)
(define (all-but-last l)
(format "-~a" (syntax->datum id)))
ids))))))))
;; (cons X (listof X)) -> (listof X)
;; returns the elements of `l', minus the last element
;; special case: if l is an improper list, it leaves off
;; the contents of the last cdr (ie, making a proper list
;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2)
(define (all-but-last l)
(cond
[(null? l) (error 'all-but-last "bad input")]
[(not (pair? l)) '()]
[(null? (cdr l)) null]
[(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))]
[else (list (car l))]))
;; helper for build-src-loc-string
(define (source->name src)
(let* ([bs (cond [(bytes? src) src]
[(path? src) (path->bytes src)]
[(string? src) (string->bytes/locale src)]
[else #f])]
[r (and bs (path->main-collects-relative bs))])
(and bs
(bytes->string/locale (if (and (pair? r) (eq? 'collects (car r)))
(bytes-append #"<collects>/" (cdr r))
bs)))))
;; build-src-loc-string : syntax -> (union #f string)
(define (build-src-loc-string stx)
(let* ([source (source->name (syntax-source stx))]
[line (syntax-line stx)]
[col (syntax-column stx)]
[pos (syntax-position stx)]
[location (cond [(and line col) (format "~a:~a" line col)]
[pos (format "~a" pos)]
[else #f])])
(if (and source location)
(string-append source ":" location)
(or location source))))
(define o (current-output-port))
;; module-source-as-symbol : syntax -> symbol
;; constructs a symbol for use in the blame error messages
;; when blaming the module where stx's occurs.
(define (module-source-as-symbol stx)
(let ([src-module (syntax-source-module stx)])
(cond
[(null? l) (error 'all-but-last "bad input")]
[(not (pair? l)) '()]
[(null? (cdr l)) null]
[(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))]
[else (list (car l))]))
;; helper for build-src-loc-string
(define (source->name src)
(let* ([bs (cond [(bytes? src) src]
[(path? src) (path->bytes src)]
[(string? src) (string->bytes/locale src)]
[else #f])]
[r (and bs (path->main-collects-relative bs))])
(and bs
(bytes->string/locale (if (and (pair? r) (eq? 'collects (car r)))
(bytes-append #"<collects>/" (cdr r))
bs)))))
;; build-src-loc-string : syntax -> (union #f string)
(define (build-src-loc-string stx)
(let* ([source (source->name (syntax-source stx))]
[line (syntax-line stx)]
[col (syntax-column stx)]
[pos (syntax-position stx)]
[location (cond [(and line col) (format "~a:~a" line col)]
[pos (format "~a" pos)]
[else #f])])
(if (and source location)
(string-append source ":" location)
(or location source))))
(define o (current-output-port))
;; module-source-as-symbol : syntax -> symbol
;; constructs a symbol for use in the blame error messages
;; when blaming the module where stx's occurs.
(define (module-source-as-symbol stx)
(let ([src-module (syntax-source-module stx)])
(cond
[(symbol? src-module) src-module]
[(module-path-index? src-module)
(let-values ([(path base) (module-path-index-split src-module)])
;; we dont' normalize here, because we don't
;; want to assume that the collection paths
;; are set or the file system can be accessed.
(if path
(string->symbol
(if (and (pair? path)
(eq? (car path) 'quote)
(pair? (cdr path))
(null? (cddr path)))
(format "'~s" (cadr path))
(format "~s" path)))
'top-level))]
[else 'top-level])))
(define build-struct-names
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
(let ([name (symbol->string (syntax-e name-stx))]
[fields (map symbol->string (map syntax-e fields))]
[+ string-append])
(map (lambda (s)
(datum->syntax-object name-stx (string->symbol s) srcloc-stx))
(append
(list
(+ "struct:" name)
(+ "make-" name)
(+ name "?"))
(let loop ([l fields])
(if (null? l)
null
(append
(if omit-sel?
null
(list (+ name "-" (car l))))
(if omit-set?
null
(list (+ "set-" name "-" (car l) "!")))
(loop (cdr l))))))))))
(define (nums-up-to n)
(let loop ([i 0])
(cond
[(= i n) '()]
[else (cons i (loop (+ i 1)))])))
(define known-good-ids
(list #'absolute-path?
#'bound-identifier=?
#'box?
#'byte-pregexp?
#'byte-regexp?
#'byte?
#'bytes-converter?
#'bytes=?
#'bytes?
#'channel?
#'char-alphabetic?
#'char-blank?
#'char-graphic?
#'char-iso-control?
#'char-lower-case?
#'char-numeric?
#'char-punctuation?
#'char-symbolic?
#'char-title-case?
#'char-upper-case?
#'char-whitespace?
#'compiled-expression?
#'compiled-module-expression?
#'complete-path?
#'continuation-mark-set?
#'continuation-prompt-available?
#'custodian-box?
#'custodian-memory-accounting-available?
#'custodian?
#'directory-exists?
#'ephemeron?
#'evt?
#'exn:break?
#'exn:fail:contract:arity?
#'exn:fail:contract:continuation?
#'exn:fail:contract:divide-by-zero?
#'exn:fail:contract:variable?
#'exn:fail:contract?
#'exn:fail:filesystem:exists?
#'exn:fail:filesystem:version?
#'exn:fail:filesystem?
#'exn:fail:network?
#'exn:fail:out-of-memory?
#'exn:fail:read:eof?
#'exn:fail:read:non-char?
#'exn:fail:read?
#'exn:fail:syntax?
#'exn:fail:unsupported?
#'exn:fail:user?
#'exn:fail?
#'exn?
#'file-exists?
#'file-stream-port?
#'free-identifier=?
#'handle-evt?
#'hash-table?
#'identifier?
#'immutable?
#'inspector?
#'keyword?
#'link-exists?
#'module-identifier=?
#'module-path-index?
#'module-provide-protected?
#'module-template-identifier=?
#'module-transformer-identifier=?
#'namespace?
#'parameter-procedure=?
#'parameter?
#'parameterization?
#'path-for-some-system?
#'path-string?
#'path?
#'port-closed?
#'port-provides-progress-evts?
#'port-writes-atomic?
#'port-writes-special?
#'port?
#'pregexp?
#'primitive-closure?
#'primitive?
#'procedure-arity-includes?
#'procedure-closure-contents-eq?
#'procedure-struct-type?
#'promise?
#'pseudo-random-generator?
#'regexp-match?
#'regexp?
#'relative-path?
#'rename-transformer?
#'security-guard?
#'semaphore-try-wait?
#'semaphore?
#'set!-transformer?
#'special-comment?
#'string-locale-ci=?
#'string-locale=?
#'struct-accessor-procedure?
#'struct-constructor-procedure?
#'struct-mutator-procedure?
#'struct-predicate-procedure?
#'struct-type-property?
#'struct-type?
#'struct?
#'subprocess?
#'syntax-graph?
#'syntax-original?
#'syntax-transforming?
#'syntax?
#'system-big-endian?
#'tcp-accept-ready?
#'tcp-listener?
#'tcp-port?
#'terminal-port?
#'thread-cell?
#'thread-dead?
#'thread-group?
#'thread-running?
#'thread?
#'udp-bound?
#'udp-connected?
#'udp?
#'void?
#'weak-box?
#'will-executor?
#'arity-at-least?
#'exn:srclocs?
#'srcloc?))
(define (known-good-contract? id)
(and (identifier? id)
(ormap (λ (x) (module-identifier=? x id))
known-good-ids))))
[(symbol? src-module) src-module]
[(module-path-index? src-module)
(let-values ([(path base) (module-path-index-split src-module)])
;; we dont' normalize here, because we don't
;; want to assume that the collection paths
;; are set or the file system can be accessed.
(if path
(string->symbol
(if (and (pair? path)
(eq? (car path) 'quote)
(pair? (cdr path))
(null? (cddr path)))
(format "'~s" (cadr path))
(format "~s" path)))
'top-level))]
[else 'top-level])))
(define build-struct-names
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
(let ([name (symbol->string (syntax-e name-stx))]
[fields (map symbol->string (map syntax-e fields))]
[+ string-append])
(map (lambda (s)
(datum->syntax name-stx (string->symbol s) srcloc-stx))
(append
(list
(+ "struct:" name)
(+ "make-" name)
(+ name "?"))
(let loop ([l fields])
(if (null? l)
null
(append
(if omit-sel?
null
(list (+ name "-" (car l))))
(if omit-set?
null
(list (+ "set-" name "-" (car l) "!")))
(loop (cdr l))))))))))
(define (nums-up-to n)
(let loop ([i 0])
(cond
[(= i n) '()]
[else (cons i (loop (+ i 1)))])))
(define known-good-ids
(list #'absolute-path?
#'bound-identifier=?
#'box?
#'byte-pregexp?
#'byte-regexp?
#'byte?
#'bytes-converter?
#'bytes=?
#'bytes?
#'channel?
#'char-alphabetic?
#'char-blank?
#'char-graphic?
#'char-iso-control?
#'char-lower-case?
#'char-numeric?
#'char-punctuation?
#'char-symbolic?
#'char-title-case?
#'char-upper-case?
#'char-whitespace?
#'compiled-expression?
#'compiled-module-expression?
#'complete-path?
#'continuation-mark-set?
#'continuation-prompt-available?
#'custodian-box?
#'custodian-memory-accounting-available?
#'custodian?
#'directory-exists?
#'ephemeron?
#'evt?
#'exn:break?
#'exn:fail:contract:arity?
#'exn:fail:contract:continuation?
#'exn:fail:contract:divide-by-zero?
#'exn:fail:contract:variable?
#'exn:fail:contract?
#'exn:fail:filesystem:exists?
#'exn:fail:filesystem:version?
#'exn:fail:filesystem?
#'exn:fail:network?
#'exn:fail:out-of-memory?
#'exn:fail:read:eof?
#'exn:fail:read:non-char?
#'exn:fail:read?
#'exn:fail:syntax?
#'exn:fail:unsupported?
#'exn:fail:user?
#'exn:fail?
#'exn?
#'file-exists?
#'file-stream-port?
#'free-identifier=?
#'handle-evt?
#'hash-table?
#'identifier?
#'immutable?
#'inspector?
#'keyword?
#'link-exists?
#'module-identifier=?
#'module-path-index?
#'module-provide-protected?
#'module-template-identifier=?
#'module-transformer-identifier=?
#'namespace?
#'parameter-procedure=?
#'parameter?
#'parameterization?
#'path-for-some-system?
#'path-string?
#'path?
#'port-closed?
#'port-provides-progress-evts?
#'port-writes-atomic?
#'port-writes-special?
#'port?
#'pregexp?
#'primitive-closure?
#'primitive?
#'procedure-arity-includes?
#'procedure-closure-contents-eq?
#'procedure-struct-type?
#'promise?
#'pseudo-random-generator?
#'regexp-match?
#'regexp?
#'relative-path?
#'rename-transformer?
#'security-guard?
#'semaphore-try-wait?
#'semaphore?
#'set!-transformer?
#'special-comment?
#'string-locale-ci=?
#'string-locale=?
#'struct-accessor-procedure?
#'struct-constructor-procedure?
#'struct-mutator-procedure?
#'struct-predicate-procedure?
#'struct-type-property?
#'struct-type?
#'struct?
#'subprocess?
#'syntax-graph?
#'syntax-original?
#'syntax-transforming?
#'syntax?
#'system-big-endian?
#'tcp-accept-ready?
#'tcp-listener?
#'tcp-port?
#'terminal-port?
#'thread-cell?
#'thread-dead?
#'thread-group?
#'thread-running?
#'thread?
#'udp-bound?
#'udp-connected?
#'udp?
#'void?
#'weak-box?
#'will-executor?
#'arity-at-least?
#'exn:srclocs?
#'srcloc?))
(define (known-good-contract? id)
(and (identifier? id)
(ormap (λ (x) (free-identifier=? x id))
known-good-ids)))

259
collects/scheme/private/contract-object.ss
View File

@ -1,23 +1,22 @@
(module contract-object mzscheme
(require (lib "etc.ss")
"contract-arrow.ss"
"contract-guts.ss"
"class-internal.ss"
"contract-arr-checks.ss")
(require-for-syntax "contract-helpers.ss"
"contract-arr-obj-helpers.ss"
(lib "list.ss"))
(provide mixin-contract
make-mixin-contract
is-a?/c
subclass?/c
implementation?/c
object-contract)
(define-syntax-set (object-contract)
#lang scheme/base
(require "contract-arrow.ss"
"contract-guts.ss"
"class-internal.ss"
"contract-arr-checks.ss")
(require (for-syntax scheme/base
"contract-helpers.ss"
"contract-arr-obj-helpers.ss"))
(provide mixin-contract
make-mixin-contract
is-a?/c
subclass?/c
implementation?/c
object-contract)
(define-syntax object-contract
(let ()
(define (obj->/proc stx) (make-/proc #t ->/h stx))
(define (obj->*/proc stx) (make-/proc #t ->*/h stx))
(define (obj->d/proc stx) (make-/proc #t ->d/h stx))
@ -41,11 +40,11 @@
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
(define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->))
(define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->))
(define (object-contract/proc stx)
(λ (stx)
;; name : syntax
;; ctc-stx : syntax[evals to a contract]
@ -161,7 +160,7 @@
(syntax
(->d any/c doms ...
(let ([f rng-proc])
(check->* f arity-count)
(check->* f arity-count)
(lambda (_this-var arg-vars ...)
(f arg-vars ...))))))
(with-syntax ([(args-vars ...) (generate-temporaries doms-val)])
@ -174,7 +173,7 @@
[arity-count (length doms-val)])
(syntax (->d* (any/c doms ...)
(let ([f rng-proc])
(check->* f arity-count)
(check->* f arity-count)
(lambda (_this-var arg-vars ...)
(f arg-vars ...)))))))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
@ -190,7 +189,7 @@
(syntax (->d* (any/c doms ...)
rst-ctc
(let ([f rng-proc])
(check->*/more f arity-count)
(check->*/more f arity-count)
(lambda (_this-var arg-vars ... . rest-var)
(apply f arg-vars ... rest-var))))))
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
@ -204,7 +203,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rng))
@ -214,7 +213,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
@ -226,7 +225,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->pp/proc
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
@ -238,7 +237,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->pp-rest/proc
(syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff))
@ -249,6 +248,12 @@
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
(define (build-methods-stx mtds)
(define (last-pair l)
(cond
[(not (pair? (cdr l))) l]
[else (last-pair (cdr l))]))
(let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
[names (map mtd-name mtds)]
[i 0])
@ -279,7 +284,7 @@
rest-ids ...
last-var)))))])))
(syntax->list arg-spec-stxs))]
[name (string->symbol (format "~a method" (syntax-object->datum (car names))))])
[name (string->symbol (format "~a method" (syntax->datum (car names))))])
(with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
(cons (syntax (lambda (field-ref) (let ([name proc]) name)))
(loop (cdr arg-spec-stxss)
@ -307,8 +312,8 @@
(syntax-case stx ()
[(_ field/mtd-specs ...)
(let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))]
[mtds (filter mtd? mtd/flds)]
[flds (filter fld? mtd/flds)])
[mtds (filter mtd? mtd/flds)]
[flds (filter fld? mtd/flds)])
(with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
[(method-name ...) (map mtd-name mtds)]
[(method-ctc-var ...) (generate-temporaries mtds)]
@ -334,105 +339,105 @@
'(method-name ...)
(list methods ...)
'(field-name ...))])
(make-proj-contract
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (pos-blame neg-blame src-info orig-str)
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)]
...
[field/app-var (field-var pos-blame neg-blame src-info orig-str)]
...)
(let ([field-names-list '(field-name ...)])
(lambda (val)
(check-object val src-info pos-blame orig-str)
(let ([val-mtd-names
(interface->method-names
(object-interface
val))])
(void)
(check-method val 'method-name val-mtd-names src-info pos-blame orig-str)
(make-proj-contract
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (pos-blame neg-blame src-info orig-str)
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)]
...
[field/app-var (field-var pos-blame neg-blame src-info orig-str)]
...)
(unless (field-bound? field-name val)
(field-error val 'field-name src-info pos-blame orig-str)) ...
(let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(make-object cls
val
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ...
))))))
#f)))))))])))
(let ([field-names-list '(field-name ...)])
(lambda (val)
(check-object val src-info pos-blame orig-str)
(let ([val-mtd-names
(interface->method-names
(object-interface
val))])
(void)
(check-method val 'method-name val-mtd-names src-info pos-blame orig-str)
...)
(unless (field-bound? field-name val)
(field-error val 'field-name src-info pos-blame orig-str)) ...
(let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(make-object cls
val
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ...
))))))
#f)))))))]))))
(define (check-object val src-info blame orig-str)
(unless (object? val)
(raise-contract-error val
src-info
blame
orig-str
"expected an object, got ~e"
val)))
(define (check-method val method-name val-mtd-names src-info blame orig-str)
(unless (memq method-name val-mtd-names)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with method ~s"
method-name)))
(define (field-error val field-name src-info blame orig-str)
(define (check-object val src-info blame orig-str)
(unless (object? val)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with field ~s"
field-name))
(define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s)))
. ->d .
subclass?/c))
(define (subclass?/c %)
(unless (class? %)
(error 'subclass?/c "expected <class>, given: ~e" %))
(let ([name (object-name %)])
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %)))))
(define (implementation?/c <%>)
(unless (interface? <%>)
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>)))))
(define (sub/impl?/c %/<%>)
(cond
[(interface? %/<%>) (implementation?/c %/<%>)]
[(class? %/<%>) (subclass?/c %/<%>)]
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
"expected an object, got ~e"
val)))
(define (is-a?/c <%>)
(unless (or (interface? <%>)
(class? <%>))
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
(cond
[name
`(is-a?/c ,name)]
[(class? <%>)
`(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . ->d . subclass?/c)))
(define (check-method val method-name val-mtd-names src-info blame orig-str)
(unless (memq method-name val-mtd-names)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with method ~s"
method-name)))
(define (field-error val field-name src-info blame orig-str)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with field ~s"
field-name))
(define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s)))
. ->d .
subclass?/c))
(define (subclass?/c %)
(unless (class? %)
(error 'subclass?/c "expected <class>, given: ~e" %))
(let ([name (object-name %)])
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %)))))
(define (implementation?/c <%>)
(unless (interface? <%>)
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>)))))
(define (sub/impl?/c %/<%>)
(cond
[(interface? %/<%>) (implementation?/c %/<%>)]
[(class? %/<%>) (subclass?/c %/<%>)]
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
(define (is-a?/c <%>)
(unless (or (interface? <%>)
(class? <%>))
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
(cond
[name
`(is-a?/c ,name)]
[(class? <%>)
`(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . ->d . subclass?/c))

315
collects/scheme/private/contract-opt-guts.ss
View File

@ -1,162 +1,161 @@
(module contract-opt-guts mzscheme
(require (lib "private/boundmap.ss" "syntax")
(lib "list.ss"))
(require-for-template mzscheme)
(provide get-opter reg-opter! opter
interleave-lifts
make-opt/info
opt/info-contract
opt/info-val
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-swap-blame
opt/info-change-val)
;; a hash table of opters
(define opters-table
(make-module-identifier-mapping))
;; get-opter : syntax -> opter
(define (get-opter ctc)
(module-identifier-mapping-get opters-table ctc (λ () #f)))
;; opter : (union symbol identifier) -> opter
(define (opter ctc)
(if (identifier? ctc)
(get-opter ctc)
(error 'opter "the argument must be a bound identifier, got ~e" ctc)))
;; reg-opter! : symbol opter ->
(define (reg-opter! ctc opter)
(module-identifier-mapping-put! opters-table ctc opter))
;; interleave-lifts : list list -> list
;; interleaves a list of variables names and a list of sexps into a list of
;; (var sexp) pairs.
(define (interleave-lifts vars sexps)
(if (= (length vars) (length sexps))
(if (null? vars) null
(cons (cons (car vars) (car sexps))
(interleave-lifts (cdr vars) (cdr sexps))))
(error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps)))
#lang scheme/base
(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts
(for-template scheme/base)
(for-syntax scheme/base))
(provide get-opter reg-opter! opter
interleave-lifts
make-opt/info
opt/info-contract
opt/info-val
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-swap-blame
opt/info-change-val)
;; a hash table of opters
(define opters-table
(make-module-identifier-mapping))
;; get-opter : syntax -> opter
(define (get-opter ctc)
(module-identifier-mapping-get opters-table ctc (λ () #f)))
;; opter : (union symbol identifier) -> opter
(define (opter ctc)
(if (identifier? ctc)
(get-opter ctc)
(error 'opter "the argument must be a bound identifier, got ~e" ctc)))
;; reg-opter! : symbol opter ->
(define (reg-opter! ctc opter)
(module-identifier-mapping-put! opters-table ctc opter))
;; interleave-lifts : list list -> list
;; interleaves a list of variables names and a list of sexps into a list of
;; (var sexp) pairs.
(define (interleave-lifts vars sexps)
(if (= (length vars) (length sexps))
(if (null? vars) null
(cons (cons (car vars) (car sexps))
(interleave-lifts (cdr vars) (cdr 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))
;; 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)))
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that)))
;; opt/info-change-val : identifier opt/info -> opt/info
;; changes the name of the variable that the value-to-be-contracted is bound to
(define (opt/info-change-val val info)
(let ((ctc (opt/info-contract 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)))
(make-opt/info ctc val neg pos src-info orig-str free-vars recf base-pred this that)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; stronger helper functions
;;
;; 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))
;; 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)))))
;; 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)))
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that)))
;; opt/info-change-val : identifier opt/info -> opt/info
;; changes the name of the variable that the value-to-be-contracted is bound to
(define (opt/info-change-val val info)
(let ((ctc (opt/info-contract 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)))
(make-opt/info ctc val neg pos src-info orig-str free-vars recf base-pred this that)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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-out stronger-rib))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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)]
[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)))
(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)]
[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)))
)

454
collects/scheme/private/contract-opt.ss
View File

@ -1,232 +1,232 @@
(module contract-opt mzscheme
(require "contract-guts.ss"
(lib "stxparam.ss")
(lib "etc.ss"))
(require-for-syntax "contract-opt-guts.ss"
(lib "etc.ss")
(lib "stxparam.ss")
(lib "list.ss"))
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref)
;; define/opter : id -> syntax
;;
;; Takes an expression which is to be expected of the following signature:
;;
;; opter : id id syntax list-of-ids ->
;; 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.
;;
;; Every opter needs to return:
;; - the optimized syntax
;; - lifted variables: a list of (id, sexp) pairs
;; - super-lifted variables: functions or the such defined at the toplevel of the
;; calling context of the opt routine.
;; Currently this is only used for struct contracts.
;; - partially applied contracts: a list of (id, sexp) pairs
;; - if the contract being optimized is flat,
;; then an sexp that evals to bool,
;; else #f
;; This is used in conjunction with optimizing flat contracts into one boolean
;; expression when optimizing or/c.
;; - if the contract can be optimized,
;; then #f (that is, it is not unknown)
;; else the symbol of the lifted variable
;; This is used for contracts with subcontracts (like cons) doing checks.
;; - a list of stronger-ribs
(define-syntax (define/opter stx)
(syntax-case stx ()
[(_ (for opt/i opt/info stx) expr ...)
(if (identifier? #'for)
#'(begin
(begin-for-syntax
(reg-opter!
#'for
(λ (opt/i opt/info stx)
expr ...)))
#t)
(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)
#lang scheme/base
(require "contract-guts.ss"
scheme/stxparam
(lib "etc.ss"))
(require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss")
(for-syntax (lib "etc.ss"))
(for-syntax scheme/stxparam))
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref)
;; define/opter : id -> syntax
;;
;; Takes an expression which is to be expected of the following signature:
;;
;; opter : id id syntax list-of-ids ->
;; 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.
;;
;; Every opter needs to return:
;; - the optimized syntax
;; - lifted variables: a list of (id, sexp) pairs
;; - super-lifted variables: functions or the such defined at the toplevel of the
;; calling context of the opt routine.
;; Currently this is only used for struct contracts.
;; - partially applied contracts: a list of (id, sexp) pairs
;; - if the contract being optimized is flat,
;; then an sexp that evals to bool,
;; else #f
;; This is used in conjunction with optimizing flat contracts into one boolean
;; expression when optimizing or/c.
;; - if the contract can be optimized,
;; then #f (that is, it is not unknown)
;; else the symbol of the lifted variable
;; This is used for contracts with subcontracts (like cons) doing checks.
;; - a list of stronger-ribs
(define-syntax (define/opter stx)
(syntax-case stx ()
[(_ (for opt/i opt/info stx) expr ...)
(if (identifier? #'for)
#'(begin
(begin-for-syntax
(reg-opter!
#'for
(λ (opt/i opt/info stx)
expr ...)))
(void))
(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 ((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))))
(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
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 ...))))))
(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/c : syntax -> syntax
;; opt/c is an optimization routine that takes in an sexp containing
;; contract combinators and attempts to "unroll" those combinators to save
;; on things such as closure allocation time.
(define-syntax (opt/c stx)
;; opt/i : id opt/info syntax ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
(define (opt/i opt/info stx)
(syntax-case stx (if)
[(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc))
((opter #'ctc) opt/i opt/info stx)]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
((opter #'argless-ctc) opt/i opt/info stx)]
[(f arg ...)
(and (identifier? #'f)
(syntax-parameter-value #'define/opt-recursive-fn)
(module-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
#'f))
(values
#`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
null
null
null
#f
#f
null)]
[else
(opt/unknown opt/i opt/info stx)]))
(syntax-case stx ()
[(_ e) #'(opt/c e ())]
[(_ e (opt-recursive-args ...))
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'pos
#'neg
#'src-info
#'orig-str
(syntax->list #'(opt-recursive-args ...))
#f
#f
#'this
#'that)]
[(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)
#,(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 ...))))
;;
;; 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 is an optimization routine that takes in an sexp containing
;; contract combinators and attempts to "unroll" those combinators to save
;; on things such as closure allocation time.
(define-syntax (opt/c stx)
;; opt/i : id opt/info syntax ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
(define (opt/i opt/info stx)
(syntax-case stx (if)
[(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc))
((opter #'ctc) opt/i opt/info stx)]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
((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))
(values
#`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
null
null
null
#f
#f
null)]
[else
(opt/unknown opt/i opt/info stx)]))
(syntax-case stx ()
[(_ e) #'(opt/c e ())]
[(_ e (opt-recursive-args ...))
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'pos
#'neg
#'src-info
#'orig-str
(syntax->list #'(opt-recursive-args ...))
#f
#f
#'this
#'that)]
[(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)
#,(if (syntax-parameter-value #'define/opt-recursive-fn)
(with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)])
(bind-superlifts
partials
#`(λ (val) next)))))
(λ () e)
(λ (this that) #f)
(vector)
(begin-lifted (box #f)))))))]))
(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)))))
(λ () e)
(λ (this that) #f)
(vector)
(begin-lifted (box #f)))))))]))
(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 ...))))]))
;; 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))))
(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 ...))))]))
;; 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)))

3770
collects/scheme/private/contract.ss
View File

File diff suppressed because it is too large Load Diff