suzanne.soy/compatibility
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

original commit: 8a7cdad926e8c3c9a8fa81f6f6966dcd453b6019
This commit is contained in:
Robby Findler 2007-12-16 00:20:18 +00:00
parent a23d25b76e
commit f0aa868ce8
4 changed files with 1772 additions and 1804 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

@ -1,21 +1,22 @@
(module contract-arr-obj-helpers mzscheme #lang scheme/base
(require (lib "stx.ss" "syntax") (require syntax/stx
(lib "name.ss" "syntax")) syntax/name)
(require-for-template mzscheme (require (for-syntax scheme/base))
"contract-guts.ss" (require (for-template scheme/base)
"contract-arr-checks.ss") (for-template "contract-guts.ss")
(for-template "contract-arr-checks.ss"))
(provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h (provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h
->pp/h ->pp-rest/h ->pp/h ->pp-rest/h
make-case->/proc make-case->/proc
make-opt->/proc make-opt->*/proc) make-opt->/proc make-opt->*/proc)
;; make-/proc : boolean ;; make-/proc : boolean
;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) ;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
;; syntax ;; syntax
;; -> (syntax -> syntax) ;; -> (syntax -> syntax)
(define (make-/proc method-proc? /h stx) (define (make-/proc method-proc? /h stx)
(let-values ([(arguments-check build-proj check-val first-order-check wrapper) (let-values ([(arguments-check build-proj check-val first-order-check wrapper)
(/h method-proc? stx)]) (/h method-proc? stx)])
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
@ -42,7 +43,7 @@
proj-code) proj-code)
first-order-check)))))))))) first-order-check))))))))))
(define (make-case->/proc method-proc? stx inferred-name-stx select/h) (define (make-case->/proc method-proc? stx inferred-name-stx select/h)
(syntax-case stx () (syntax-case stx ()
;; if there are no cases, this contract should only accept the "empty" case-lambda. ;; if there are no cases, this contract should only accept the "empty" case-lambda.
@ -78,14 +79,14 @@
proj-code) proj-code)
first-order-check)))))))))])) first-order-check)))))))))]))
(define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx) (define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx)
(syntax-case stx (any) (syntax-case stx (any)
[(_ (reqs ...) (opts ...) any) [(_ (reqs ...) (opts ...) any)
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx select/h case-arr-stx arr-stx)] (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx select/h case-arr-stx arr-stx)]
[(_ (reqs ...) (opts ...) res) [(_ (reqs ...) (opts ...) res)
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx select/h case-arr-stx arr-stx)])) (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx select/h case-arr-stx arr-stx)]))
(define (make-opt->*/proc method-proc? stx inferred-name-stx select/h case-arr-stx arr-stx) (define (make-opt->*/proc method-proc? stx inferred-name-stx select/h case-arr-stx arr-stx)
(syntax-case stx (any) (syntax-case stx (any)
[(_ (reqs ...) (opts ...) any) [(_ (reqs ...) (opts ...) any)
(let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
@ -156,15 +157,15 @@
...) ...)
expanded-case->)))))))])) expanded-case->)))))))]))
;; exactract-argument-lists : syntax -> (listof syntax) ;; exactract-argument-lists : syntax -> (listof syntax)
(define (extract-argument-lists stx) (define (extract-argument-lists stx)
(map (lambda (x) (map (lambda (x)
(syntax-case x () (syntax-case x ()
[(arg-list body) (syntax arg-list)])) [(arg-list body) (syntax arg-list)]))
(syntax->list stx))) (syntax->list stx)))
;; ensure-cases-disjoint : syntax syntax[list] -> void ;; ensure-cases-disjoint : syntax syntax[list] -> void
(define (ensure-cases-disjoint stx cases) (define (ensure-cases-disjoint stx cases)
(let ([individual-cases null] (let ([individual-cases null]
[dot-min #f]) [dot-min #f])
(for-each (lambda (case) (for-each (lambda (case)
@ -197,9 +198,9 @@
(set! dot-min new-dot-min)]))]))) (set! dot-min new-dot-min)]))])))
cases))) cases)))
;; get-case : syntax -> (union number (cons number 'more)) ;; get-case : syntax -> (union number (cons number 'more))
(define (get-case stx) (define (get-case stx)
(let ([ilist (syntax-object->datum stx)]) (let ([ilist (syntax->datum stx)])
(if (list? ilist) (if (list? ilist)
(length ilist) (length ilist)
(cons (cons
@ -210,19 +211,19 @@
'more)))) 'more))))
;; case->/h : boolean ;; case->/h : boolean
;; syntax ;; syntax
;; (listof syntax) ;; (listof syntax)
;; select/h ;; select/h
;; -> (values (syntax -> syntax) ;; -> (values (syntax -> syntax)
;; (syntax -> syntax) ;; (syntax -> syntax)
;; (syntax -> syntax) ;; (syntax -> syntax)
;; (syntax syntax -> syntax) ;; (syntax syntax -> syntax)
;; (syntax -> syntax) ;; (syntax -> syntax)
;; (syntax -> syntax)) ;; (syntax -> syntax))
;; like the other /h functions, but composes the wrapper functions ;; like the other /h functions, but composes the wrapper functions
;; together and combines the cases of the case-lambda into a single list. ;; together and combines the cases of the case-lambda into a single list.
(define (case->/h method-proc? orig-stx cases select/h) (define (case->/h method-proc? orig-stx cases select/h)
(let loop ([cases cases] (let loop ([cases cases]
[name-ids '()]) [name-ids '()])
(cond (cond
@ -268,8 +269,8 @@
[cases (wrappers args)]) [cases (wrappers args)])
(syntax (case . cases)))))))]))) (syntax (case . cases)))))))])))
;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
(define (ensure-no-duplicates stx form-name names) (define (ensure-no-duplicates stx form-name names)
(let ([ht (make-hash-table)]) (let ([ht (make-hash-table)])
(for-each (lambda (name) (for-each (lambda (name)
(let ([key (syntax-e name)]) (let ([key (syntax-e name)])
@ -281,68 +282,68 @@
(hash-table-put! ht key #t))) (hash-table-put! ht key #t)))
names))) names)))
;; method-specifier? : syntax -> boolean ;; method-specifier? : syntax -> boolean
;; returns #t if x is the syntax for a valid method specifier ;; returns #t if x is the syntax for a valid method specifier
(define (method-specifier? x) (define (method-specifier? x)
(or (eq? 'public (syntax-e x)) (or (eq? 'public (syntax-e x))
(eq? 'override (syntax-e x)))) (eq? 'override (syntax-e x))))
;; prefix-super : syntax[identifier] -> syntax[identifier] ;; prefix-super : syntax[identifier] -> syntax[identifier]
;; adds super- to the front of the identifier ;; adds super- to the front of the identifier
(define (prefix-super stx) (define (prefix-super stx)
(datum->syntax-object (datum->syntax
#'here #'here
(string->symbol (string->symbol
(format (format
"super-~a" "super-~a"
(syntax-object->datum (syntax->datum
stx))))) stx)))))
;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier] ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier]
;; given the syntax for a method name, constructs the name of a method ;; given the syntax for a method name, constructs the name of a method
;; that returns the super's contract for the original method. ;; that returns the super's contract for the original method.
(define (method-name->contract-method-name stx) (define (method-name->contract-method-name stx)
(datum->syntax-object (datum->syntax
#'here #'here
(string->symbol (string->symbol
(format (format
"ACK_DONT_GUESS_ME-super-contract-~a" "ACK_DONT_GUESS_ME-super-contract-~a"
(syntax-object->datum (syntax->datum
stx))))) stx)))))
;; Each of the /h functions builds six pieces of syntax: ;; Each of the /h functions builds six pieces of syntax:
;; - [arguments-check] ;; - [arguments-check]
;; code that binds the contract values to names and ;; code that binds the contract values to names and
;; does error checking for the contract specs ;; does error checking for the contract specs
;; (were the arguments all contracts?) ;; (were the arguments all contracts?)
;; - [build-proj] ;; - [build-proj]
;; code that partially applies the input contracts to build the projection ;; code that partially applies the input contracts to build the projection
;; - [check-val] ;; - [check-val]
;; code that does error checking on the contract'd value itself ;; code that does error checking on the contract'd value itself
;; (is it a function of the right arity?) ;; (is it a function of the right arity?)
;; - [first-order-check] ;; - [first-order-check]
;; predicate function that does the first order check and returns a boolean ;; predicate function that does the first order check and returns a boolean
;; (is it a function of the right arity?) ;; (is it a function of the right arity?)
;; - [pos-wrapper] ;; - [pos-wrapper]
;; a piece of syntax that has the arguments to the wrapper ;; a piece of syntax that has the arguments to the wrapper
;; and the body of the wrapper. ;; and the body of the wrapper.
;; - [neg-wrapper] ;; - [neg-wrapper]
;; a piece of syntax that has the arguments to the wrapper ;; a piece of syntax that has the arguments to the wrapper
;; and the body of the wrapper. ;; and the body of the wrapper.
;; the first function accepts a body expression and wraps ;; the first function accepts a body expression and wraps
;; the body expression with checks. In addition, it ;; the body expression with checks. In addition, it
;; adds a let that binds the contract exprssions to names ;; adds a let that binds the contract exprssions to names
;; the results of the other functions mention these names. ;; the results of the other functions mention these names.
;; the second and third function's input syntax should be five ;; the second and third function's input syntax should be five
;; names: val, blame, src-info, orig-str, name-id ;; names: val, blame, src-info, orig-str, name-id
;; the fourth function returns a syntax list with two elements, ;; the fourth function returns a syntax list with two elements,
;; the argument list (to be used as the first arg to lambda, ;; the argument list (to be used as the first arg to lambda,
;; or as a case-lambda clause) and the body of the function. ;; or as a case-lambda clause) and the body of the function.
;; They are combined into a lambda for the -> ->* ->d ->d* macros, ;; They are combined into a lambda for the -> ->* ->d ->d* macros,
;; and combined into a case-lambda for the case-> macro. ;; and combined into a case-lambda for the case-> macro.
;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->/h method-proc? stx) (define (->/h method-proc? stx)
(syntax-case stx () (syntax-case stx ()
[(_) (raise-syntax-error '-> "expected at least one argument" stx)] [(_) (raise-syntax-error '-> "expected at least one argument" stx)]
[(_ dom ... rng) [(_ dom ... rng)
@ -480,8 +481,8 @@
(let ([res-x (val (dom-projection-x arg-x) ...)]) (let ([res-x (val (dom-projection-x arg-x) ...)])
(rng-projection-x res-x))))))))])))])) (rng-projection-x res-x))))))))])))]))
;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->*/h method-proc? stx) (define (->*/h method-proc? stx)
(syntax-case stx (any) (syntax-case stx (any)
[(_ (dom ...) (rng ...)) [(_ (dom ...) (rng ...))
(->/h method-proc? (syntax (-> dom ... (values rng ...))))] (->/h method-proc? (syntax (-> dom ... (values rng ...))))]
@ -621,8 +622,8 @@
... ...
(dom-projection-rest-x arg-rest-x))))))))])) (dom-projection-rest-x arg-rest-x))))))))]))
;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d/h method-proc? stx) (define (->d/h method-proc? stx)
(syntax-case stx () (syntax-case stx ()
[(_) (raise-syntax-error '->d "expected at least one argument" stx)] [(_) (raise-syntax-error '->d "expected at least one argument" stx)]
[(_ dom ... rng) [(_ dom ... rng)
@ -679,8 +680,8 @@
orig-str) orig-str)
(val arg-x ...))))))))))])) (val arg-x ...))))))))))]))
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d*/h method-proc? stx) (define (->d*/h method-proc? stx)
(syntax-case stx () (syntax-case stx ()
[(_ (dom ...) rng-mk) [(_ (dom ...) rng-mk)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
@ -828,8 +829,8 @@
rng-contracts rng-contracts
results))))))))))))])) results))))))))))))]))
;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->r/h method-proc? stx) (define (->r/h method-proc? stx)
(syntax-case stx () (syntax-case stx ()
[(_ ([x dom] ...) rng) [(_ ([x dom] ...) rng)
(syntax-case* (syntax rng) (any values) module-or-top-identifier=? (syntax-case* (syntax rng) (any values) module-or-top-identifier=?
@ -851,11 +852,11 @@
[_ [_
(->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])])) (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])]))
;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx)) (define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx))
;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->r-pp/h method-proc? name stx) (define (->r-pp/h method-proc? name stx)
(syntax-case stx () (syntax-case stx ()
[(_ ([x dom] ...) pre-expr . result-stuff) [(_ ([x dom] ...) pre-expr . result-stuff)
(and (andmap identifier? (syntax->list (syntax (x ...)))) (and (andmap identifier? (syntax->list (syntax (x ...))))
@ -961,11 +962,11 @@
[(_ x dom pre-expr . result-stuff) [(_ x dom pre-expr . result-stuff)
(raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))]))
;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx)) (define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx))
;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->r-pp-rest/h method-proc? name stx) (define (->r-pp-rest/h method-proc? name stx)
(syntax-case stx () (syntax-case stx ()
[(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff)
(and (identifier? (syntax rest-x)) (and (identifier? (syntax rest-x))
@ -1084,8 +1085,8 @@
[(_ x dom rest-x rest-dom rng . result-stuff) [(_ x dom rest-x rest-dom rng . result-stuff)
(raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))]))
;; set-inferred-name-from : syntax syntax -> syntax ;; set-inferred-name-from : syntax syntax -> syntax
(define (set-inferred-name-from with-name to-be-named) (define (set-inferred-name-from with-name to-be-named)
(let ([name (syntax-local-infer-name with-name)]) (let ([name (syntax-local-infer-name with-name)])
(cond (cond
[(identifier? name) [(identifier? name)
@ -1098,14 +1099,14 @@
(syntax (let ([name rhs]) name)))] (syntax (let ([name rhs]) name)))]
[else to-be-named]))) [else to-be-named])))
;; generate-indicies : syntax[list] -> (cons number (listof number)) ;; generate-indicies : syntax[list] -> (cons number (listof number))
;; given a syntax list of length `n', returns a list containing ;; given a syntax list of length `n', returns a list containing
;; the number n followed by th numbers from 0 to n-1 ;; the number n followed by th numbers from 0 to n-1
(define (generate-indicies stx) (define (generate-indicies stx)
(let ([n (length (syntax->list stx))]) (let ([n (length (syntax->list stx))])
(cons n (cons n
(let loop ([i n]) (let loop ([i n])
(cond (cond
[(zero? i) null] [(zero? i) null]
[else (cons (- n i) [else (cons (- n i)
(loop (- i 1)))])))))) (loop (- i 1)))])))))

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

@ -1,15 +1,16 @@
(module contract-arrow mzscheme #lang scheme/base
(require (lib "etc.ss") (require (lib "etc.ss")
"contract-guts.ss" "contract-guts.ss"
"contract-arr-checks.ss" "contract-arr-checks.ss"
"contract-opt.ss") "contract-opt.ss")
(require-for-syntax "contract-opt-guts.ss" (require (for-syntax scheme/base)
"contract-helpers.ss" (for-syntax "contract-opt-guts.ss")
"contract-arr-obj-helpers.ss" (for-syntax "contract-helpers.ss")
(lib "stx.ss" "syntax") (for-syntax "contract-arr-obj-helpers.ss")
(lib "name.ss" "syntax")) (for-syntax (lib "stx.ss" "syntax"))
(for-syntax (lib "name.ss" "syntax")))
(provide -> (provide ->
->d ->d
->* ->*
->d* ->d*
@ -22,7 +23,7 @@
unconstrained-domain-> unconstrained-domain->
check-procedure) check-procedure)
(define-syntax (unconstrained-domain-> stx) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
[(_ rngs ...) [(_ rngs ...)
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))] (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
@ -47,14 +48,14 @@
"expected a procedure"))))) "expected a procedure")))))
procedure?))))])) procedure?))))]))
;; FIXME: need to pass in the name of the contract combinator. ;; FIXME: need to pass in the name of the contract combinator.
(define (build--> name doms doms-rest rngs rng-any? func) (define (build--> name doms doms-rest rngs rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)] [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))]) [doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
(make--> rng-any? doms/c doms-rest/c rngs/c func))) (make--> rng-any? doms/c doms-rest/c rngs/c func)))
(define-struct/prop -> (rng-any? doms dom-rest rngs func) (define-struct/prop -> (rng-any? doms dom-rest rngs func)
((proj-prop (λ (ctc) ((proj-prop (λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x)) (let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc) (if (->-dom-rest ctc)
@ -104,7 +105,7 @@
(->-rngs this) (->-rngs this)
(->-rngs that))))))) (->-rngs that)))))))
(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs) (define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
(cond (cond
[doms-rest [doms-rest
(build-compound-type-name (build-compound-type-name
@ -123,31 +124,7 @@
[else (apply build-compound-type-name 'values rngs)])]) [else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))])) (apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(define arity-one-wrapper (define-syntax-set (-> ->*)
(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) (define (->/proc stx)
(let-values ([(stx _1 _2) (->/proc/main stx)]) (let-values ([(stx _1 _2) (->/proc/main stx)])
stx)) stx))
@ -168,25 +145,11 @@
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)] (let* ([lst (syntax->list #'args)]
[len (and lst (length lst))]) [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 (syntax
(lambda (chk dom-names ... rng-names ...) (lambda (chk dom-names ... rng-names ...)
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))))]) inner-lambda))))])
(values (values
(syntax (build--> '-> (syntax (build--> '->
(list dom-ctcs ...) (list dom-ctcs ...)
@ -300,7 +263,7 @@
inner-args/body inner-args/body
(syntax (dom-x ... rst-x)))))))]))) (syntax (dom-x ... rst-x)))))))])))
(define-for-syntax (select/h stx err-name ctxt-stx) (define-for-syntax (select/h stx err-name ctxt-stx)
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
[(-> . args) ->/h] [(-> . args) ->/h]
[(->* . args) ->*/h] [(->* . args) ->*/h]
@ -312,19 +275,19 @@
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] [(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)])) [_ (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 (->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 (->r stx) (make-/proc #f ->r/h stx))
(define-syntax (->pp stx) (make-/proc #f ->pp/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 (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h)) (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 select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->)) (define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
;; ;;
;; arrow opter ;; arrow opter
;; ;;
(define/opter (-> opt/i opt/info stx) (define/opter (-> opt/i opt/info stx)
(define (opt/arrow-ctc doms rngs) (define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))] (generate-temporaries rngs))]
@ -458,4 +421,4 @@
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
[(-> dom ... rng) [(-> dom ... rng)
(opt/arrow-ctc (syntax->list (syntax (dom ...))) (opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))]))) (list #'rng))]))

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

@ -1,23 +1,22 @@
(module contract-object mzscheme #lang scheme/base
(require (lib "etc.ss") (require "contract-arrow.ss"
"contract-arrow.ss"
"contract-guts.ss" "contract-guts.ss"
"class-internal.ss" "class-internal.ss"
"contract-arr-checks.ss") "contract-arr-checks.ss")
(require-for-syntax "contract-helpers.ss" (require (for-syntax scheme/base
"contract-arr-obj-helpers.ss" "contract-helpers.ss"
(lib "list.ss")) "contract-arr-obj-helpers.ss"))
(provide mixin-contract (provide mixin-contract
make-mixin-contract make-mixin-contract
is-a?/c is-a?/c
subclass?/c subclass?/c
implementation?/c implementation?/c
object-contract) object-contract)
(define-syntax-set (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->*/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)) (define (obj->d/proc stx) (make-/proc #t ->d/h stx))
@ -45,7 +44,7 @@
(define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->)) (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 (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->))
(define (object-contract/proc stx) (λ (stx)
;; name : syntax ;; name : syntax
;; ctc-stx : syntax[evals to a contract] ;; ctc-stx : syntax[evals to a contract]
@ -204,7 +203,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->r/proc obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rng)) (syntax (->r ([this any/c] [x dom] ...) rng))
@ -214,7 +213,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->r/proc obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng)) (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
@ -226,7 +225,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->pp/proc obj->pp/proc
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff)) (syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
@ -238,7 +237,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))) (andmap identifier? (syntax->list (syntax (x ...)))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->pp-rest/proc obj->pp-rest/proc
(syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff)) (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] ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
(define (build-methods-stx mtds) (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)] (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
[names (map mtd-name mtds)] [names (map mtd-name mtds)]
[i 0]) [i 0])
@ -279,7 +284,7 @@
rest-ids ... rest-ids ...
last-var)))))]))) last-var)))))])))
(syntax->list arg-spec-stxs))] (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)]) (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
(cons (syntax (lambda (field-ref) (let ([name proc]) name))) (cons (syntax (lambda (field-ref) (let ([name proc]) name)))
(loop (cdr arg-spec-stxss) (loop (cdr arg-spec-stxss)
@ -364,10 +369,10 @@
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ... (field/app-var (get-field field-name val)) ...
)))))) ))))))
#f)))))))]))) #f)))))))]))))
(define (check-object val src-info blame orig-str) (define (check-object val src-info blame orig-str)
(unless (object? val) (unless (object? val)
(raise-contract-error val (raise-contract-error val
src-info src-info
@ -376,7 +381,7 @@
"expected an object, got ~e" "expected an object, got ~e"
val))) val)))
(define (check-method val method-name val-mtd-names src-info blame orig-str) (define (check-method val method-name val-mtd-names src-info blame orig-str)
(unless (memq method-name val-mtd-names) (unless (memq method-name val-mtd-names)
(raise-contract-error val (raise-contract-error val
src-info src-info
@ -385,7 +390,7 @@
"expected an object with method ~s" "expected an object with method ~s"
method-name))) method-name)))
(define (field-error val field-name src-info blame orig-str) (define (field-error val field-name src-info blame orig-str)
(raise-contract-error val (raise-contract-error val
src-info src-info
blame blame
@ -393,13 +398,13 @@
"expected an object with field ~s" "expected an object with field ~s"
field-name)) field-name))
(define (make-mixin-contract . %/<%>s) (define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?) ((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s))) (apply and/c (map sub/impl?/c %/<%>s)))
. ->d . . ->d .
subclass?/c)) subclass?/c))
(define (subclass?/c %) (define (subclass?/c %)
(unless (class? %) (unless (class? %)
(error 'subclass?/c "expected <class>, given: ~e" %)) (error 'subclass?/c "expected <class>, given: ~e" %))
(let ([name (object-name %)]) (let ([name (object-name %)])
@ -407,7 +412,7 @@
`(subclass?/c ,(or name 'unknown%)) `(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %))))) (lambda (x) (subclass? x %)))))
(define (implementation?/c <%>) (define (implementation?/c <%>)
(unless (interface? <%>) (unless (interface? <%>)
(error 'implementation?/c "expected <interface>, given: ~e" <%>)) (error 'implementation?/c "expected <interface>, given: ~e" <%>))
(let ([name (object-name <%>)]) (let ([name (object-name <%>)])
@ -415,13 +420,13 @@
`(implementation?/c ,(or name 'unknown<%>)) `(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>))))) (lambda (x) (implementation? x <%>)))))
(define (sub/impl?/c %/<%>) (define (sub/impl?/c %/<%>)
(cond (cond
[(interface? %/<%>) (implementation?/c %/<%>)] [(interface? %/<%>) (implementation?/c %/<%>)]
[(class? %/<%>) (subclass?/c %/<%>)] [(class? %/<%>) (subclass?/c %/<%>)]
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) [else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
(define (is-a?/c <%>) (define (is-a?/c <%>)
(unless (or (interface? <%>) (unless (or (interface? <%>)
(class? <%>)) (class? <%>))
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>)) (error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
@ -435,4 +440,4 @@
[else `(is-a?/c unknown<%>)]) [else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>))))) (lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . ->d . subclass?/c))) (define mixin-contract (class? . ->d . subclass?/c))