refactored the contract system so that contracts do not depend on the class system, and now the class contracts are exported from class.ss
svn: r7357
This commit is contained in:
Robby Findler
parent
bd7d167466
commit
bd93217061
|
|
@ -8,7 +8,8 @@
|
|||
"private/standard-urls.ss"
|
||||
|
||||
"private/link.ss"
|
||||
(lib "contract.ss"))
|
||||
(lib "contract.ss")
|
||||
(lib "class.ss"))
|
||||
|
||||
(helpdesk-platform 'internal-browser-simple)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
(module class mzscheme
|
||||
|
||||
;; povide contracts for objects
|
||||
(require "private/contract-object.ss")
|
||||
(provide (all-from "private/contract-object.ss"))
|
||||
|
||||
;; All of the implementation is actually in private/class-internal.ss,
|
||||
;; which provides extra (private) functionality to contract.ss.
|
||||
(require "private/class-internal.ss")
|
||||
|
|
|
|||
|
|
@ -21,7 +21,8 @@
|
|||
|
||||
;; from contract-guts.ss
|
||||
|
||||
(provide and/c
|
||||
(provide any
|
||||
and/c
|
||||
any/c
|
||||
none/c
|
||||
make-none/c
|
||||
|
|
|
|||
198
collects/mzlib/private/contract-arr-checks.ss
Normal file
198
collects/mzlib/private/contract-arr-checks.ss
Normal file
|
|
@ -0,0 +1,198 @@
|
|||
(module contract-arr-checks mzscheme
|
||||
(provide (all-defined))
|
||||
(require (lib "list.ss")
|
||||
"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
|
||||
|
||||
;; 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-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/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))))
|
||||
|
||||
#|
|
||||
|
||||
test cases for procedure-accepts-and-more?
|
||||
|
||||
(and (procedure-accepts-and-more? (lambda (x . y) 1) 3)
|
||||
(procedure-accepts-and-more? (lambda (x . y) 1) 2)
|
||||
(procedure-accepts-and-more? (lambda (x . y) 1) 1)
|
||||
(not (procedure-accepts-and-more? (lambda (x . y) 1) 0))
|
||||
|
||||
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3)
|
||||
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2)
|
||||
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1)
|
||||
(not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0))
|
||||
|
||||
(procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2)
|
||||
(procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1)
|
||||
(not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
|
||||
|
||||
|#
|
||||
)
|
||||
1121
collects/mzlib/private/contract-arr-obj-helpers.ss
Normal file
1121
collects/mzlib/private/contract-arr-obj-helpers.ss
Normal file
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -45,8 +45,11 @@
|
|||
|
||||
;; for opters
|
||||
check-flat-contract
|
||||
check-flat-named-contract)
|
||||
check-flat-named-contract
|
||||
any)
|
||||
|
||||
(define-syntax (any stx)
|
||||
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
|
||||
|
||||
;; define-struct/prop is a define-struct-like macro that
|
||||
;; also allows properties to be defined
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(module contract-helpers mzscheme
|
||||
|
||||
|
||||
(provide module-source-as-symbol build-src-loc-string
|
||||
mangle-id mangle-id-for-maker
|
||||
build-struct-names
|
||||
|
|
@ -7,15 +7,9 @@
|
|||
add-name-prop
|
||||
all-but-last
|
||||
known-good-contract?)
|
||||
|
||||
|
||||
(require (lib "main-collects.ss" "setup"))
|
||||
|
||||
(define (known-good-contract? id)
|
||||
(and (identifier? id)
|
||||
(ormap (λ (x) (module-identifier=? x id))
|
||||
(list #'integer?
|
||||
#'boolean?
|
||||
#'number?))))
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(define (add-name-prop name stx)
|
||||
(cond
|
||||
|
|
@ -74,7 +68,7 @@
|
|||
[(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]
|
||||
|
|
@ -84,9 +78,9 @@
|
|||
[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)))))
|
||||
|
||||
(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))]
|
||||
|
|
@ -97,8 +91,8 @@
|
|||
[pos (format "~a" pos)]
|
||||
[else #f])])
|
||||
(if (and source location)
|
||||
(string-append source ":" location)
|
||||
(or location source))))
|
||||
(string-append source ":" location)
|
||||
(or location source))))
|
||||
|
||||
(define o (current-output-port))
|
||||
|
||||
|
|
@ -148,4 +142,139 @@
|
|||
(let loop ([i 0])
|
||||
(cond
|
||||
[(= i n) '()]
|
||||
[else (cons i (loop (+ i 1)))]))))
|
||||
[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))))
|
||||
|
|
|
|||
429
collects/mzlib/private/contract-object.ss
Normal file
429
collects/mzlib/private/contract-object.ss
Normal file
|
|
@ -0,0 +1,429 @@
|
|||
(module contract-object mzscheme
|
||||
(require (lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
"contract-arrow.ss"
|
||||
"contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
"contract-opt-guts.ss"
|
||||
"class-internal.ss"
|
||||
"contract-arr-checks.ss")
|
||||
|
||||
(require-for-syntax "contract-opt-guts.ss"
|
||||
"contract-helpers.ss"
|
||||
"contract-arr-obj-helpers.ss"
|
||||
(lib "list.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax"))
|
||||
|
||||
(provide mixin-contract
|
||||
make-mixin-contract
|
||||
is-a?/c
|
||||
subclass?/c
|
||||
implementation?/c
|
||||
object-contract)
|
||||
|
||||
(define-syntax-set (object-contract)
|
||||
|
||||
(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))
|
||||
(define (obj->r/proc stx) (make-/proc #t ->r/h stx))
|
||||
(define (obj->pp/proc stx) (make-/proc #t ->pp/h stx))
|
||||
(define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx))
|
||||
(define (obj-case->/proc stx) (make-case->/proc #t stx stx))
|
||||
|
||||
(define (obj-opt->/proc stx) (make-opt->/proc #t stx))
|
||||
(define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx))
|
||||
|
||||
(define (object-contract/proc stx)
|
||||
|
||||
;; name : syntax
|
||||
;; ctc-stx : syntax[evals to a contract]
|
||||
;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda)
|
||||
(define-struct mtd (name ctc-stx mtd-arg-stx))
|
||||
|
||||
;; name : syntax
|
||||
;; ctc-stx : syntax[evals to a contract]
|
||||
(define-struct fld (name ctc-stx))
|
||||
|
||||
;; expand-field/mtd-spec : stx -> (union mtd fld)
|
||||
(define (expand-field/mtd-spec f/m-stx)
|
||||
(syntax-case f/m-stx (field)
|
||||
[(field field-name ctc)
|
||||
(identifier? (syntax field-name))
|
||||
(make-fld (syntax field-name) (syntax ctc))]
|
||||
[(field field-name ctc)
|
||||
(raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))]
|
||||
[(mtd-name ctc)
|
||||
(identifier? (syntax mtd-name))
|
||||
(let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))])
|
||||
(make-mtd (syntax mtd-name)
|
||||
ctc-stx
|
||||
proc-stx))]
|
||||
[(mtd-name ctc)
|
||||
(raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))]
|
||||
[_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)]))
|
||||
|
||||
;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg])
|
||||
(define (expand-mtd-contract mtd-stx)
|
||||
(syntax-case mtd-stx (case-> opt-> opt->*)
|
||||
[(case-> cases ...)
|
||||
(let loop ([cases (syntax->list (syntax (cases ...)))]
|
||||
[ctc-stxs null]
|
||||
[args-stxs null])
|
||||
(cond
|
||||
[(null? cases)
|
||||
(values
|
||||
(with-syntax ([(x ...) (reverse ctc-stxs)])
|
||||
(obj-case->/proc (syntax (case-> x ...))))
|
||||
(with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))])
|
||||
(syntax (x ...))))]
|
||||
[else
|
||||
(let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))])
|
||||
(loop (cdr cases)
|
||||
(cons ctc-stx ctc-stxs)
|
||||
(cons mtd-args args-stxs)))]))]
|
||||
[(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...))
|
||||
(values
|
||||
(obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...))))
|
||||
(generate-opt->vars (syntax (req-contracts ...))
|
||||
(syntax (opt-contracts ...))))]
|
||||
[(opt->* (req-contracts ...) (opt-contracts ...) any)
|
||||
(values
|
||||
(obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any)))
|
||||
(generate-opt->vars (syntax (req-contracts ...))
|
||||
(syntax (opt-contracts ...))))]
|
||||
[(opt-> (req-contracts ...) (opt-contracts ...) res-contract)
|
||||
(values
|
||||
(obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract)))
|
||||
(generate-opt->vars (syntax (req-contracts ...))
|
||||
(syntax (opt-contracts ...))))]
|
||||
[else
|
||||
(let-values ([(x y z) (expand-mtd-arrow mtd-stx)])
|
||||
(values (x y) z))]))
|
||||
|
||||
;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs]
|
||||
(define (generate-opt->vars req-stx opt-stx)
|
||||
(with-syntax ([(req-vars ...) (generate-temporaries req-stx)]
|
||||
[(ths) (generate-temporaries (syntax (ths)))])
|
||||
(let loop ([opt-vars (generate-temporaries opt-stx)])
|
||||
(cond
|
||||
[(null? opt-vars) (list (syntax (ths req-vars ...)))]
|
||||
[else (with-syntax ([(opt-vars ...) opt-vars]
|
||||
[(rests ...) (loop (cdr opt-vars))])
|
||||
(syntax ((ths req-vars ... opt-vars ...)
|
||||
rests ...)))]))))
|
||||
|
||||
;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg])
|
||||
(define (expand-mtd-arrow mtd-stx)
|
||||
(syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
|
||||
[(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
|
||||
[(-> args ...)
|
||||
;; this case cheats a little bit --
|
||||
;; (args ...) contains the right number of arguments
|
||||
;; to the method because it also contains one arg for the result! urgh.
|
||||
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
|
||||
(values obj->/proc
|
||||
(syntax (-> any/c args ...))
|
||||
(syntax ((arg-vars ...)))))]
|
||||
[(->* (doms ...) (rngs ...))
|
||||
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(this-var) (generate-temporaries (syntax (this-var)))])
|
||||
(values obj->*/proc
|
||||
(syntax (->* (any/c doms ...) (rngs ...)))
|
||||
(syntax ((this-var args-vars ...)))))]
|
||||
[(->* (doms ...) rst (rngs ...))
|
||||
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rst-var) (generate-temporaries (syntax (rst)))]
|
||||
[(this-var) (generate-temporaries (syntax (this-var)))])
|
||||
(values obj->*/proc
|
||||
(syntax (->* (any/c doms ...) rst (rngs ...)))
|
||||
(syntax ((this-var args-vars ... . rst-var)))))]
|
||||
[(->* x ...)
|
||||
(raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)]
|
||||
[(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)]
|
||||
[(->d doms ... rng-proc)
|
||||
(let ([doms-val (syntax->list (syntax (doms ...)))])
|
||||
(values
|
||||
obj->d/proc
|
||||
(with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
|
||||
[arity-count (length doms-val)])
|
||||
(syntax
|
||||
(->d any/c doms ...
|
||||
(let ([f rng-proc])
|
||||
(check->* f arity-count)
|
||||
(lambda (_this-var arg-vars ...)
|
||||
(f arg-vars ...))))))
|
||||
(with-syntax ([(args-vars ...) (generate-temporaries doms-val)])
|
||||
(syntax ((this-var args-vars ...))))))]
|
||||
[(->d* (doms ...) rng-proc)
|
||||
(values
|
||||
obj->d*/proc
|
||||
(let ([doms-val (syntax->list (syntax (doms ...)))])
|
||||
(with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
|
||||
[arity-count (length doms-val)])
|
||||
(syntax (->d* (any/c doms ...)
|
||||
(let ([f rng-proc])
|
||||
(check->* f arity-count)
|
||||
(lambda (_this-var arg-vars ...)
|
||||
(f arg-vars ...)))))))
|
||||
(with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(this-var) (generate-temporaries (syntax (this-var)))])
|
||||
(syntax ((this-var args-vars ...)))))]
|
||||
[(->d* (doms ...) rst-ctc rng-proc)
|
||||
(let ([doms-val (syntax->list (syntax (doms ...)))])
|
||||
(values
|
||||
obj->d*/proc
|
||||
(with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
|
||||
[(rest-var) (generate-temporaries (syntax (rst-ctc)))]
|
||||
[arity-count (length doms-val)])
|
||||
(syntax (->d* (any/c doms ...)
|
||||
rst-ctc
|
||||
(let ([f rng-proc])
|
||||
(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 ...)))]
|
||||
[(rst-var) (generate-temporaries (syntax (rst-ctc)))]
|
||||
[(this-var) (generate-temporaries (syntax (this-var)))])
|
||||
(syntax ((this-var args-vars ... . rst-var))))))]
|
||||
[(->d* x ...)
|
||||
(raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)]
|
||||
|
||||
[(->r ([x dom] ...) rng)
|
||||
(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)])
|
||||
(values
|
||||
obj->r/proc
|
||||
(syntax (->r ([this any/c] [x dom] ...) rng))
|
||||
(syntax ((this-var arg-vars ...)))))]
|
||||
|
||||
[(->r ([x dom] ...) rest-x rest-dom rng)
|
||||
(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)])
|
||||
(values
|
||||
obj->r/proc
|
||||
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
|
||||
(syntax ((this-var arg-vars ... . rest-var)))))]
|
||||
|
||||
[(->r . x)
|
||||
(raise-syntax-error 'object-contract "malformed ->r declaration")]
|
||||
[(->pp ([x dom] ...) . other-stuff)
|
||||
(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)])
|
||||
(values
|
||||
obj->pp/proc
|
||||
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
|
||||
(syntax ((this-var arg-vars ...)))))]
|
||||
[(->pp . x)
|
||||
(raise-syntax-error 'object-contract "malformed ->pp declaration")]
|
||||
[(->pp-rest ([x dom] ...) rest-id . other-stuff)
|
||||
(and (identifier? (syntax id))
|
||||
(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)])
|
||||
(values
|
||||
obj->pp-rest/proc
|
||||
(syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff))
|
||||
(syntax ((this-var arg-vars ... . rest-id)))))]
|
||||
[(->pp-rest . x)
|
||||
(raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
|
||||
[else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
|
||||
|
||||
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
|
||||
(define (build-methods-stx mtds)
|
||||
(let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
|
||||
[names (map mtd-name mtds)]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? arg-spec-stxss) null]
|
||||
[else (let ([arg-spec-stxs (car arg-spec-stxss)])
|
||||
(with-syntax ([(cases ...)
|
||||
(map (lambda (arg-spec-stx)
|
||||
(with-syntax ([i i])
|
||||
(syntax-case arg-spec-stx ()
|
||||
[(this rest-ids ...)
|
||||
(syntax
|
||||
((this rest-ids ...)
|
||||
((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))]
|
||||
[else
|
||||
(let-values ([(this rest-ids last-var)
|
||||
(let ([lst (syntax->improper-list arg-spec-stx)])
|
||||
(values (car lst)
|
||||
(all-but-last (cdr lst))
|
||||
(cdr (last-pair lst))))])
|
||||
(with-syntax ([this this]
|
||||
[(rest-ids ...) rest-ids]
|
||||
[last-var last-var])
|
||||
(syntax
|
||||
((this rest-ids ... . last-var)
|
||||
(apply (field-ref this i)
|
||||
(wrapper-object-wrapped this)
|
||||
rest-ids ...
|
||||
last-var)))))])))
|
||||
(syntax->list arg-spec-stxs))]
|
||||
[name (string->symbol (format "~a method" (syntax-object->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)
|
||||
(cdr names)
|
||||
(+ i 1))))))])))
|
||||
|
||||
(define (syntax->improper-list stx)
|
||||
(define (se->il se)
|
||||
(cond
|
||||
[(pair? se) (sp->il se)]
|
||||
[else se]))
|
||||
(define (stx->il stx)
|
||||
(se->il (syntax-e stx)))
|
||||
(define (sp->il p)
|
||||
(cond
|
||||
[(null? (cdr p)) p]
|
||||
[(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))]
|
||||
[(syntax? (cdr p))
|
||||
(let ([un (syntax-e (cdr p))])
|
||||
(if (pair? un)
|
||||
(cons (car p) (sp->il un))
|
||||
p))]))
|
||||
(stx->il stx))
|
||||
|
||||
(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)])
|
||||
(with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
|
||||
[(method-name ...) (map mtd-name mtds)]
|
||||
[(method-ctc-var ...) (generate-temporaries mtds)]
|
||||
[(method-var ...) (generate-temporaries mtds)]
|
||||
[(method/app-var ...) (generate-temporaries mtds)]
|
||||
[(methods ...) (build-methods-stx mtds)]
|
||||
|
||||
[(field-ctc-stx ...) (map fld-ctc-stx flds)]
|
||||
[(field-name ...) (map fld-name flds)]
|
||||
[(field-ctc-var ...) (generate-temporaries flds)]
|
||||
[(field-var ...) (generate-temporaries flds)]
|
||||
[(field/app-var ...) (generate-temporaries flds)])
|
||||
(syntax
|
||||
(let ([method-ctc-var method-ctc-stx]
|
||||
...
|
||||
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
|
||||
...)
|
||||
(let ([method-var (contract-proc method-ctc-var)]
|
||||
...
|
||||
[field-var (contract-proc field-ctc-var)]
|
||||
...)
|
||||
(let ([cls (make-wrapper-class 'wrapper-class
|
||||
'(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)
|
||||
...)
|
||||
|
||||
(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)
|
||||
(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)))
|
||||
|
|
@ -22,7 +22,6 @@ improve method arity mismatch contract violation error messages?
|
|||
(require (lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "pconvert.ss")
|
||||
"contract-arrow.ss"
|
||||
"contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
|
|
@ -116,36 +115,35 @@ improve method arity mismatch contract violation error messages?
|
|||
#;
|
||||
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
||||
(make-set!-transformer
|
||||
(let ([saved-id #f])
|
||||
(let ([saved-id-table (make-hash-table)])
|
||||
(λ (stx)
|
||||
(unless saved-id
|
||||
(with-syntax ([contract-id contract-id]
|
||||
[id id]
|
||||
[pos-module-source pos-module-source])
|
||||
(set! saved-id
|
||||
(syntax-local-introduce
|
||||
(syntax-local-lift-expression
|
||||
#'(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'name)
|
||||
(quote-syntax name)))))))
|
||||
|
||||
(with-syntax ([saved-id (syntax-local-introduce saved-id)])
|
||||
(syntax-case stx (set!)
|
||||
[(set! id body) (raise-syntax-error
|
||||
#f
|
||||
"cannot set! provide/contract identifier"
|
||||
stx
|
||||
(syntax id))]
|
||||
[(name arg ...)
|
||||
(syntax/loc stx
|
||||
(saved-id
|
||||
arg
|
||||
...))]
|
||||
[name
|
||||
(identifier? (syntax name))
|
||||
(syntax saved-id)]))))))
|
||||
(let ([key (syntax-local-lift-context)])
|
||||
(unless (hash-table-get saved-id-table key #f)
|
||||
(with-syntax ([contract-id contract-id]
|
||||
[id id]
|
||||
[pos-module-source pos-module-source])
|
||||
(hash-table-put!
|
||||
saved-id-table
|
||||
key
|
||||
(syntax-local-introduce
|
||||
(syntax-local-lift-expression
|
||||
#'(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'name)
|
||||
(quote-syntax id)))))))
|
||||
|
||||
(with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))])
|
||||
(syntax-case stx (set!)
|
||||
[(set! id body) (raise-syntax-error
|
||||
#f
|
||||
"cannot set! provide/contract identifier"
|
||||
stx
|
||||
(syntax id))]
|
||||
[(name arg ...) (syntax/loc stx (saved-id arg ...))]
|
||||
[name
|
||||
(identifier? (syntax name))
|
||||
(syntax saved-id)])))))))
|
||||
|
||||
;; (define/contract id contract expr)
|
||||
;; defines `id' with `contract'; initially binding
|
||||
|
|
@ -1285,6 +1283,24 @@ improve method arity mismatch contract violation error messages?
|
|||
(error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e"
|
||||
elems))
|
||||
(make-one-of/c elems))
|
||||
|
||||
(define (one-of-pc x)
|
||||
(cond
|
||||
[(symbol? x)
|
||||
`',x]
|
||||
[(null? x)
|
||||
''()]
|
||||
[(void? x)
|
||||
'(void)]
|
||||
[(or (char? x)
|
||||
(boolean? x)
|
||||
(keyword? x)
|
||||
(number? x))
|
||||
x]
|
||||
[(eq? x (letrec ([x x]) x))
|
||||
'(letrec ([x x]) x)]
|
||||
[else (error 'one-of-pc "undef ~s" x)]))
|
||||
|
||||
|
||||
(define-struct/prop one-of/c (elems)
|
||||
((proj-prop flat-proj)
|
||||
|
|
@ -1295,7 +1311,7 @@ improve method arity mismatch contract violation error messages?
|
|||
'symbols]
|
||||
[else
|
||||
'one-of/c])
|
||||
,@(map print-convert elems)))))
|
||||
,@(map one-of-pc elems)))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (one-of/c? that)
|
||||
|
|
|
|||
|
|
@ -109,7 +109,7 @@
|
|||
(if (string? obj)
|
||||
(make-java-string string)
|
||||
(begin
|
||||
(c:contract (c:object-contract
|
||||
(c:contract (object-contract
|
||||
(clone (c:-> c:any/c))
|
||||
(equals-java.lang.Object (c:-> c:any/c c:any/c))
|
||||
(finalize (c:-> c:any/c))
|
||||
|
|
@ -1019,7 +1019,7 @@
|
|||
guard-convert-Throwable static-Throwable/c)
|
||||
|
||||
(define (wrap-convert-assert-Throwable obj p n s c)
|
||||
(c:contract (c:object-contract
|
||||
(c:contract (object-contract
|
||||
(init-cause (c:-> c:any/c c:any/c))
|
||||
(get-message (c:-> c:any/c))
|
||||
(get-cause (c:-> c:any/c))
|
||||
|
|
|
|||
|
|
@ -992,10 +992,10 @@
|
|||
|
||||
;methods->contract: (list method-record) -> sexp
|
||||
(define (methods->contract methods)
|
||||
`(c:object-contract ,@(map (lambda (m)
|
||||
`(object-contract ,@(map (lambda (m)
|
||||
`(,(build-identifier (mangle-method-name (method-record-name m)
|
||||
(method-record-atypes m)))
|
||||
(c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c)))
|
||||
(c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c)))
|
||||
methods)))
|
||||
|
||||
;method->check/error: method-record -> sexp
|
||||
|
|
@ -2128,11 +2128,11 @@
|
|||
`(c:union (c:is-a?/c object%) string?)
|
||||
(cond
|
||||
((method-contract? (unknown-ref-access type))
|
||||
`(c:object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type))))
|
||||
,(type->contract (unknown-ref-access type) from-dynamic?))))
|
||||
`(object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type))))
|
||||
,(type->contract (unknown-ref-access type) from-dynamic?))))
|
||||
((field-contract? (unknown-ref-access type))
|
||||
`(c:object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f"))
|
||||
,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?)))))))
|
||||
`(object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f"))
|
||||
,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?)))))))
|
||||
((method-contract? type)
|
||||
`(c:-> ,@(map (lambda (a) (type->contract a from-dynamic?)) (method-contract-args type))
|
||||
,(type->contract (method-contract-return type) from-dynamic? #t)))
|
||||
|
|
|
|||
|
|
@ -4366,6 +4366,8 @@ so that propagation occurs.
|
|||
(test-name 'printable/c printable/c)
|
||||
(test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c))
|
||||
(test-name '(one-of/c 1 2 3) (one-of/c 1 2 3))
|
||||
(test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))
|
||||
(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)))
|
||||
|
||||
(test-name '(subclass?/c class:c%)
|
||||
(let ([c% (class object% (super-new))]) (subclass?/c c%)))
|
||||
|
|
@ -5169,7 +5171,22 @@ so that propagation occurs.
|
|||
(define-syntax (unit-body stx)
|
||||
f f
|
||||
#'1)))))
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract22
|
||||
'(begin
|
||||
(eval '(module provide/contract22a mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(provide/contract [make-bound-identifier-mapping integer?])
|
||||
(define make-bound-identifier-mapping 1)))
|
||||
(eval '(module provide/contract22b mzscheme
|
||||
(require-for-syntax provide/contract22a)
|
||||
|
||||
(define-syntax (unit-body stx)
|
||||
make-bound-identifier-mapping)
|
||||
|
||||
(define-syntax (f stx)
|
||||
make-bound-identifier-mapping)))))
|
||||
|
||||
(contract-error-test
|
||||
#'(begin
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(module mrpict mzscheme
|
||||
(require (lib "unit.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(require (lib "mred-sig.ss" "mred")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user