removed links to old mzlib stuff and mzscheme module from the contract library (but not from all the libraries it depends on)
svn: r8023 original commit: 8a7cdad926e8c3c9a8fa81f6f6966dcd453b6019
This commit is contained in:
Robby Findler
parent
a23d25b76e
commit
f0aa868ce8
|
|
@ -1,20 +1,20 @@
|
|||
(module contract-arr-checks mzscheme
|
||||
(provide (all-defined))
|
||||
(require (lib "list.ss")
|
||||
"contract-guts.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(define empty-case-lambda/c
|
||||
(provide (all-defined-out))
|
||||
(require "contract-guts.ss")
|
||||
|
||||
(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
|
||||
;; ----------------------------------------
|
||||
;; 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)
|
||||
;; 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]
|
||||
|
|
@ -48,7 +48,7 @@
|
|||
[else (loop (cdr counts))]))))
|
||||
(<= min-at-least dom-length))))])))
|
||||
|
||||
(define (check->* f arity-count)
|
||||
(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)
|
||||
|
|
@ -57,7 +57,7 @@
|
|||
arity-count
|
||||
f)))
|
||||
|
||||
(define (check->*/more f arity-count)
|
||||
(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)
|
||||
|
|
@ -68,7 +68,7 @@
|
|||
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
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
|
|
@ -76,7 +76,7 @@
|
|||
orig-str
|
||||
"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
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
|
|
@ -84,7 +84,7 @@
|
|||
orig-str
|
||||
"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)
|
||||
(procedure-arity-includes? val dom-length))
|
||||
(raise-contract-error
|
||||
|
|
@ -96,15 +96,15 @@
|
|||
dom-length
|
||||
val)))
|
||||
|
||||
(define ((check-procedure? arity) val)
|
||||
(define ((check-procedure? arity) val)
|
||||
(and (procedure? val)
|
||||
(procedure-arity-includes? val arity)))
|
||||
|
||||
(define ((check-procedure/more? arity) val)
|
||||
(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)
|
||||
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
|
|
@ -123,7 +123,7 @@
|
|||
(procedure-arity 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)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
|
|
@ -142,7 +142,7 @@
|
|||
(procedure-arity 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)
|
||||
(procedure-accepts-and-more? val dom-length))
|
||||
(raise-contract-error
|
||||
|
|
@ -156,27 +156,27 @@
|
|||
val)))
|
||||
|
||||
|
||||
(define (check-rng-procedure who rng-x arity)
|
||||
(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)
|
||||
(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)
|
||||
(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)))
|
||||
|
||||
|#
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,21 +1,22 @@
|
|||
(module contract-arr-obj-helpers mzscheme
|
||||
(require (lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax"))
|
||||
#lang scheme/base
|
||||
(require syntax/stx
|
||||
syntax/name)
|
||||
|
||||
(require-for-template mzscheme
|
||||
"contract-guts.ss"
|
||||
"contract-arr-checks.ss")
|
||||
(require (for-syntax scheme/base))
|
||||
(require (for-template scheme/base)
|
||||
(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
|
||||
make-case->/proc
|
||||
make-opt->/proc make-opt->*/proc)
|
||||
|
||||
;; make-/proc : boolean
|
||||
;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
|
||||
;; syntax
|
||||
;; -> (syntax -> syntax)
|
||||
(define (make-/proc method-proc? /h stx)
|
||||
;; make-/proc : boolean
|
||||
;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
|
||||
;; syntax
|
||||
;; -> (syntax -> syntax)
|
||||
(define (make-/proc method-proc? /h stx)
|
||||
(let-values ([(arguments-check build-proj check-val first-order-check wrapper)
|
||||
(/h method-proc? stx)])
|
||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
|
||||
|
|
@ -42,7 +43,7 @@
|
|||
proj-code)
|
||||
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 ()
|
||||
|
||||
;; if there are no cases, this contract should only accept the "empty" case-lambda.
|
||||
|
|
@ -78,14 +79,14 @@
|
|||
proj-code)
|
||||
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)
|
||||
[(_ (reqs ...) (opts ...) any)
|
||||
(make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx select/h case-arr-stx arr-stx)]
|
||||
[(_ (reqs ...) (opts ...) res)
|
||||
(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)
|
||||
[(_ (reqs ...) (opts ...) any)
|
||||
(let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
|
||||
|
|
@ -156,15 +157,15 @@
|
|||
...)
|
||||
expanded-case->)))))))]))
|
||||
|
||||
;; exactract-argument-lists : syntax -> (listof syntax)
|
||||
(define (extract-argument-lists stx)
|
||||
;; exactract-argument-lists : syntax -> (listof syntax)
|
||||
(define (extract-argument-lists stx)
|
||||
(map (lambda (x)
|
||||
(syntax-case x ()
|
||||
[(arg-list body) (syntax arg-list)]))
|
||||
(syntax->list stx)))
|
||||
|
||||
;; ensure-cases-disjoint : syntax syntax[list] -> void
|
||||
(define (ensure-cases-disjoint stx cases)
|
||||
;; ensure-cases-disjoint : syntax syntax[list] -> void
|
||||
(define (ensure-cases-disjoint stx cases)
|
||||
(let ([individual-cases null]
|
||||
[dot-min #f])
|
||||
(for-each (lambda (case)
|
||||
|
|
@ -197,9 +198,9 @@
|
|||
(set! dot-min new-dot-min)]))])))
|
||||
cases)))
|
||||
|
||||
;; get-case : syntax -> (union number (cons number 'more))
|
||||
(define (get-case stx)
|
||||
(let ([ilist (syntax-object->datum stx)])
|
||||
;; get-case : syntax -> (union number (cons number 'more))
|
||||
(define (get-case stx)
|
||||
(let ([ilist (syntax->datum stx)])
|
||||
(if (list? ilist)
|
||||
(length ilist)
|
||||
(cons
|
||||
|
|
@ -210,19 +211,19 @@
|
|||
'more))))
|
||||
|
||||
|
||||
;; case->/h : boolean
|
||||
;; syntax
|
||||
;; (listof syntax)
|
||||
;; select/h
|
||||
;; -> (values (syntax -> syntax)
|
||||
;; (syntax -> syntax)
|
||||
;; (syntax -> syntax)
|
||||
;; (syntax syntax -> syntax)
|
||||
;; (syntax -> syntax)
|
||||
;; (syntax -> syntax))
|
||||
;; like the other /h functions, but composes the wrapper functions
|
||||
;; together and combines the cases of the case-lambda into a single list.
|
||||
(define (case->/h method-proc? orig-stx cases select/h)
|
||||
;; case->/h : boolean
|
||||
;; syntax
|
||||
;; (listof syntax)
|
||||
;; select/h
|
||||
;; -> (values (syntax -> syntax)
|
||||
;; (syntax -> syntax)
|
||||
;; (syntax -> syntax)
|
||||
;; (syntax syntax -> syntax)
|
||||
;; (syntax -> syntax)
|
||||
;; (syntax -> syntax))
|
||||
;; like the other /h functions, but composes the wrapper functions
|
||||
;; together and combines the cases of the case-lambda into a single list.
|
||||
(define (case->/h method-proc? orig-stx cases select/h)
|
||||
(let loop ([cases cases]
|
||||
[name-ids '()])
|
||||
(cond
|
||||
|
|
@ -268,8 +269,8 @@
|
|||
[cases (wrappers args)])
|
||||
(syntax (case . cases)))))))])))
|
||||
|
||||
;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
|
||||
(define (ensure-no-duplicates stx form-name names)
|
||||
;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
|
||||
(define (ensure-no-duplicates stx form-name names)
|
||||
(let ([ht (make-hash-table)])
|
||||
(for-each (lambda (name)
|
||||
(let ([key (syntax-e name)])
|
||||
|
|
@ -281,68 +282,68 @@
|
|||
(hash-table-put! ht key #t)))
|
||||
names)))
|
||||
|
||||
;; method-specifier? : syntax -> boolean
|
||||
;; returns #t if x is the syntax for a valid method specifier
|
||||
(define (method-specifier? x)
|
||||
;; method-specifier? : syntax -> boolean
|
||||
;; returns #t if x is the syntax for a valid method specifier
|
||||
(define (method-specifier? x)
|
||||
(or (eq? 'public (syntax-e x))
|
||||
(eq? 'override (syntax-e x))))
|
||||
|
||||
;; prefix-super : syntax[identifier] -> syntax[identifier]
|
||||
;; adds super- to the front of the identifier
|
||||
(define (prefix-super stx)
|
||||
(datum->syntax-object
|
||||
;; prefix-super : syntax[identifier] -> syntax[identifier]
|
||||
;; adds super- to the front of the identifier
|
||||
(define (prefix-super stx)
|
||||
(datum->syntax
|
||||
#'here
|
||||
(string->symbol
|
||||
(format
|
||||
"super-~a"
|
||||
(syntax-object->datum
|
||||
(syntax->datum
|
||||
stx)))))
|
||||
|
||||
;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier]
|
||||
;; given the syntax for a method name, constructs the name of a method
|
||||
;; that returns the super's contract for the original method.
|
||||
(define (method-name->contract-method-name stx)
|
||||
(datum->syntax-object
|
||||
;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier]
|
||||
;; given the syntax for a method name, constructs the name of a method
|
||||
;; that returns the super's contract for the original method.
|
||||
(define (method-name->contract-method-name stx)
|
||||
(datum->syntax
|
||||
#'here
|
||||
(string->symbol
|
||||
(format
|
||||
"ACK_DONT_GUESS_ME-super-contract-~a"
|
||||
(syntax-object->datum
|
||||
(syntax->datum
|
||||
stx)))))
|
||||
|
||||
;; Each of the /h functions builds six pieces of syntax:
|
||||
;; - [arguments-check]
|
||||
;; code that binds the contract values to names and
|
||||
;; does error checking for the contract specs
|
||||
;; (were the arguments all contracts?)
|
||||
;; - [build-proj]
|
||||
;; code that partially applies the input contracts to build the projection
|
||||
;; - [check-val]
|
||||
;; code that does error checking on the contract'd value itself
|
||||
;; (is it a function of the right arity?)
|
||||
;; - [first-order-check]
|
||||
;; predicate function that does the first order check and returns a boolean
|
||||
;; (is it a function of the right arity?)
|
||||
;; - [pos-wrapper]
|
||||
;; a piece of syntax that has the arguments to the wrapper
|
||||
;; and the body of the wrapper.
|
||||
;; - [neg-wrapper]
|
||||
;; a piece of syntax that has the arguments to the wrapper
|
||||
;; and the body of the wrapper.
|
||||
;; the first function accepts a body expression and wraps
|
||||
;; the body expression with checks. In addition, it
|
||||
;; adds a let that binds the contract exprssions to names
|
||||
;; the results of the other functions mention these names.
|
||||
;; the second and third function's input syntax should be five
|
||||
;; names: val, blame, src-info, orig-str, name-id
|
||||
;; the fourth function returns a syntax list with two elements,
|
||||
;; the argument list (to be used as the first arg to lambda,
|
||||
;; or as a case-lambda clause) and the body of the function.
|
||||
;; They are combined into a lambda for the -> ->* ->d ->d* macros,
|
||||
;; and combined into a case-lambda for the case-> macro.
|
||||
;; Each of the /h functions builds six pieces of syntax:
|
||||
;; - [arguments-check]
|
||||
;; code that binds the contract values to names and
|
||||
;; does error checking for the contract specs
|
||||
;; (were the arguments all contracts?)
|
||||
;; - [build-proj]
|
||||
;; code that partially applies the input contracts to build the projection
|
||||
;; - [check-val]
|
||||
;; code that does error checking on the contract'd value itself
|
||||
;; (is it a function of the right arity?)
|
||||
;; - [first-order-check]
|
||||
;; predicate function that does the first order check and returns a boolean
|
||||
;; (is it a function of the right arity?)
|
||||
;; - [pos-wrapper]
|
||||
;; a piece of syntax that has the arguments to the wrapper
|
||||
;; and the body of the wrapper.
|
||||
;; - [neg-wrapper]
|
||||
;; a piece of syntax that has the arguments to the wrapper
|
||||
;; and the body of the wrapper.
|
||||
;; the first function accepts a body expression and wraps
|
||||
;; the body expression with checks. In addition, it
|
||||
;; adds a let that binds the contract exprssions to names
|
||||
;; the results of the other functions mention these names.
|
||||
;; the second and third function's input syntax should be five
|
||||
;; names: val, blame, src-info, orig-str, name-id
|
||||
;; the fourth function returns a syntax list with two elements,
|
||||
;; the argument list (to be used as the first arg to lambda,
|
||||
;; or as a case-lambda clause) and the body of the function.
|
||||
;; They are combined into a lambda for the -> ->* ->d ->d* macros,
|
||||
;; and combined into a case-lambda for the case-> macro.
|
||||
|
||||
;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->/h method-proc? stx)
|
||||
;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->/h method-proc? stx)
|
||||
(syntax-case stx ()
|
||||
[(_) (raise-syntax-error '-> "expected at least one argument" stx)]
|
||||
[(_ dom ... rng)
|
||||
|
|
@ -480,8 +481,8 @@
|
|||
(let ([res-x (val (dom-projection-x arg-x) ...)])
|
||||
(rng-projection-x res-x))))))))])))]))
|
||||
|
||||
;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->*/h method-proc? stx)
|
||||
;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->*/h method-proc? stx)
|
||||
(syntax-case stx (any)
|
||||
[(_ (dom ...) (rng ...))
|
||||
(->/h method-proc? (syntax (-> dom ... (values rng ...))))]
|
||||
|
|
@ -621,8 +622,8 @@
|
|||
...
|
||||
(dom-projection-rest-x arg-rest-x))))))))]))
|
||||
|
||||
;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->d/h method-proc? stx)
|
||||
;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->d/h method-proc? stx)
|
||||
(syntax-case stx ()
|
||||
[(_) (raise-syntax-error '->d "expected at least one argument" stx)]
|
||||
[(_ dom ... rng)
|
||||
|
|
@ -679,8 +680,8 @@
|
|||
orig-str)
|
||||
(val arg-x ...))))))))))]))
|
||||
|
||||
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->d*/h method-proc? stx)
|
||||
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->d*/h method-proc? stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (dom ...) rng-mk)
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
|
|
@ -828,8 +829,8 @@
|
|||
rng-contracts
|
||||
results))))))))))))]))
|
||||
|
||||
;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->r/h method-proc? stx)
|
||||
;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->r/h method-proc? stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([x dom] ...) rng)
|
||||
(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)))])]))
|
||||
|
||||
;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx))
|
||||
;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(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))
|
||||
(define (->r-pp/h method-proc? name stx)
|
||||
;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->r-pp/h method-proc? name stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([x dom] ...) pre-expr . result-stuff)
|
||||
(and (andmap identifier? (syntax->list (syntax (x ...))))
|
||||
|
|
@ -961,11 +962,11 @@
|
|||
[(_ x dom pre-expr . result-stuff)
|
||||
(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))
|
||||
(define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx))
|
||||
;; ->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))
|
||||
|
||||
;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->r-pp-rest/h method-proc? name stx)
|
||||
;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->r-pp-rest/h method-proc? name stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff)
|
||||
(and (identifier? (syntax rest-x))
|
||||
|
|
@ -1084,8 +1085,8 @@
|
|||
[(_ x dom rest-x rest-dom rng . result-stuff)
|
||||
(raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))]))
|
||||
|
||||
;; set-inferred-name-from : syntax syntax -> syntax
|
||||
(define (set-inferred-name-from with-name to-be-named)
|
||||
;; set-inferred-name-from : syntax syntax -> syntax
|
||||
(define (set-inferred-name-from with-name to-be-named)
|
||||
(let ([name (syntax-local-infer-name with-name)])
|
||||
(cond
|
||||
[(identifier? name)
|
||||
|
|
@ -1098,14 +1099,14 @@
|
|||
(syntax (let ([name rhs]) name)))]
|
||||
[else to-be-named])))
|
||||
|
||||
;; generate-indicies : syntax[list] -> (cons number (listof number))
|
||||
;; given a syntax list of length `n', returns a list containing
|
||||
;; the number n followed by th numbers from 0 to n-1
|
||||
(define (generate-indicies stx)
|
||||
;; generate-indicies : syntax[list] -> (cons number (listof number))
|
||||
;; given a syntax list of length `n', returns a list containing
|
||||
;; the number n followed by th numbers from 0 to n-1
|
||||
(define (generate-indicies stx)
|
||||
(let ([n (length (syntax->list stx))])
|
||||
(cons n
|
||||
(let loop ([i n])
|
||||
(cond
|
||||
[(zero? i) null]
|
||||
[else (cons (- n i)
|
||||
(loop (- i 1)))]))))))
|
||||
(loop (- i 1)))])))))
|
||||
|
|
@ -1,15 +1,16 @@
|
|||
(module contract-arrow mzscheme
|
||||
(require (lib "etc.ss")
|
||||
#lang scheme/base
|
||||
(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"))
|
||||
(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 ->
|
||||
(provide ->
|
||||
->d
|
||||
->*
|
||||
->d*
|
||||
|
|
@ -22,7 +23,7 @@
|
|||
unconstrained-domain->
|
||||
check-procedure)
|
||||
|
||||
(define-syntax (unconstrained-domain-> stx)
|
||||
(define-syntax (unconstrained-domain-> stx)
|
||||
(syntax-case stx ()
|
||||
[(_ rngs ...)
|
||||
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
|
||||
|
|
@ -47,14 +48,14 @@
|
|||
"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)
|
||||
;; 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)
|
||||
(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)
|
||||
|
|
@ -104,7 +105,7 @@
|
|||
(->-rngs this)
|
||||
(->-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
|
||||
[doms-rest
|
||||
(build-compound-type-name
|
||||
|
|
@ -123,31 +124,7 @@
|
|||
[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-syntax-set (-> ->*)
|
||||
(define (->/proc stx)
|
||||
(let-values ([(stx _1 _2) (->/proc/main stx)])
|
||||
stx))
|
||||
|
|
@ -168,25 +145,11 @@
|
|||
(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)))))])
|
||||
inner-lambda))))])
|
||||
(values
|
||||
(syntax (build--> '->
|
||||
(list dom-ctcs ...)
|
||||
|
|
@ -300,7 +263,7 @@
|
|||
inner-args/body
|
||||
(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)
|
||||
[(-> . args) ->/h]
|
||||
[(->* . args) ->*/h]
|
||||
|
|
@ -312,19 +275,19 @@
|
|||
[(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-> #'->))
|
||||
(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)
|
||||
;;
|
||||
;; 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))]
|
||||
|
|
@ -458,4 +421,4 @@
|
|||
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
|
||||
[(-> dom ... rng)
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(list #'rng))])))
|
||||
(list #'rng))]))
|
||||
|
|
|
|||
|
|
@ -1,23 +1,22 @@
|
|||
(module contract-object mzscheme
|
||||
(require (lib "etc.ss")
|
||||
"contract-arrow.ss"
|
||||
#lang scheme/base
|
||||
(require "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"))
|
||||
(require (for-syntax scheme/base
|
||||
"contract-helpers.ss"
|
||||
"contract-arr-obj-helpers.ss"))
|
||||
|
||||
(provide mixin-contract
|
||||
(provide mixin-contract
|
||||
make-mixin-contract
|
||||
is-a?/c
|
||||
subclass?/c
|
||||
implementation?/c
|
||||
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->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 stx select/h #'case-> #'->))
|
||||
|
||||
(define (object-contract/proc stx)
|
||||
(λ (stx)
|
||||
|
||||
;; name : syntax
|
||||
;; ctc-stx : syntax[evals to a contract]
|
||||
|
|
@ -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)
|
||||
|
|
@ -364,10 +369,10 @@
|
|||
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
|
||||
(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)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
|
|
@ -376,7 +381,7 @@
|
|||
"expected an object, got ~e"
|
||||
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)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
|
|
@ -385,7 +390,7 @@
|
|||
"expected an object with method ~s"
|
||||
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
|
||||
src-info
|
||||
blame
|
||||
|
|
@ -393,13 +398,13 @@
|
|||
"expected an object with field ~s"
|
||||
field-name))
|
||||
|
||||
(define (make-mixin-contract . %/<%>s)
|
||||
(define (make-mixin-contract . %/<%>s)
|
||||
((and/c (flat-contract class?)
|
||||
(apply and/c (map sub/impl?/c %/<%>s)))
|
||||
. ->d .
|
||||
subclass?/c))
|
||||
|
||||
(define (subclass?/c %)
|
||||
(define (subclass?/c %)
|
||||
(unless (class? %)
|
||||
(error 'subclass?/c "expected <class>, given: ~e" %))
|
||||
(let ([name (object-name %)])
|
||||
|
|
@ -407,7 +412,7 @@
|
|||
`(subclass?/c ,(or name 'unknown%))
|
||||
(lambda (x) (subclass? x %)))))
|
||||
|
||||
(define (implementation?/c <%>)
|
||||
(define (implementation?/c <%>)
|
||||
(unless (interface? <%>)
|
||||
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
|
||||
(let ([name (object-name <%>)])
|
||||
|
|
@ -415,13 +420,13 @@
|
|||
`(implementation?/c ,(or name 'unknown<%>))
|
||||
(lambda (x) (implementation? x <%>)))))
|
||||
|
||||
(define (sub/impl?/c %/<%>)
|
||||
(define (sub/impl?/c %/<%>)
|
||||
(cond
|
||||
[(interface? %/<%>) (implementation?/c %/<%>)]
|
||||
[(class? %/<%>) (subclass?/c %/<%>)]
|
||||
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
|
||||
|
||||
(define (is-a?/c <%>)
|
||||
(define (is-a?/c <%>)
|
||||
(unless (or (interface? <%>)
|
||||
(class? <%>))
|
||||
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
|
||||
|
|
@ -435,4 +440,4 @@
|
|||
[else `(is-a?/c unknown<%>)])
|
||||
(lambda (x) (is-a? x <%>)))))
|
||||
|
||||
(define mixin-contract (class? . ->d . subclass?/c)))
|
||||
(define mixin-contract (class? . ->d . subclass?/c))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user