moved class, contracts, serialize, and traits into scheme/ and changed the class and contract interface so that contracts no longer depend on the class system (instead its the other way around)
svn: r8017 original commit: 9a0498b44d41b5d4ae5ae4227ef3c260911af964
This commit is contained in:
Robby Findler
parent
101f8e8cfd
commit
a23d25b76e
|
|
@ -1,44 +1,3 @@
|
|||
(module class mzscheme
|
||||
|
||||
;; All of the implementation is actually in private/class-internal.ss,
|
||||
;; which provides extra (private) functionality to contract.ss.
|
||||
(require "private/class-internal.ss")
|
||||
|
||||
(provide class class* class/derived
|
||||
define-serializable-class define-serializable-class*
|
||||
class?
|
||||
mixin
|
||||
interface interface?
|
||||
object% object? externalizable<%>
|
||||
object=?
|
||||
new make-object instantiate
|
||||
send send/apply send* class-field-accessor class-field-mutator with-method
|
||||
get-field field-bound? field-names
|
||||
private* public* pubment*
|
||||
override* overment*
|
||||
augride* augment*
|
||||
public-final* override-final* augment-final*
|
||||
define/private define/public define/pubment
|
||||
define/override define/overment
|
||||
define/augride define/augment
|
||||
define/public-final define/override-final define/augment-final
|
||||
define-local-member-name define-member-name
|
||||
member-name-key generate-member-key
|
||||
member-name-key? member-name-key=? member-name-key-hash-code
|
||||
generic make-generic send-generic
|
||||
is-a? subclass? implementation? interface-extension?
|
||||
object-interface object-info object->vector
|
||||
object-method-arity-includes?
|
||||
method-in-interface? interface->method-names class->interface class-info
|
||||
(struct exn:fail:object ())
|
||||
make-primitive-class
|
||||
|
||||
;; "keywords":
|
||||
private public override augment
|
||||
pubment overment augride
|
||||
public-final override-final augment-final
|
||||
field init init-field init-rest
|
||||
rename-super rename-inner inherit inherit/super inherit/inner inherit-field
|
||||
this super inner
|
||||
super-make-object super-instantiate super-new
|
||||
inspect))
|
||||
(require scheme/private/class-internal)
|
||||
(provide-public-names))
|
||||
|
|
@ -1,180 +1,10 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract)
|
||||
(provide (all-from-out scheme/contract))
|
||||
|
||||
(module contract mzscheme
|
||||
;; provide contracts for objects
|
||||
(require scheme/private/contract-object)
|
||||
(provide (all-from-out scheme/private/contract-object))
|
||||
|
||||
|
||||
;; povide contracts for objects
|
||||
(require "private/contract-object.ss")
|
||||
(provide (all-from "private/contract-object.ss"))
|
||||
|
||||
(require "private/contract.ss"
|
||||
"private/contract-arrow.ss"
|
||||
"private/contract-guts.ss"
|
||||
"private/contract-ds.ss"
|
||||
"private/contract-opt-guts.ss"
|
||||
"private/contract-opt.ss"
|
||||
"private/contract-basic-opters.ss")
|
||||
|
||||
(provide
|
||||
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
|
||||
(all-from-except "private/contract-ds.ss"
|
||||
lazy-depth-to-look)
|
||||
|
||||
(all-from-except "private/contract-arrow.ss"
|
||||
check-procedure)
|
||||
(all-from-except "private/contract.ss"
|
||||
check-between/c
|
||||
check-unary-between/c))
|
||||
|
||||
;; from contract-guts.ss
|
||||
|
||||
(provide any
|
||||
and/c
|
||||
any/c
|
||||
none/c
|
||||
make-none/c
|
||||
|
||||
guilty-party
|
||||
contract-violation->string
|
||||
|
||||
contract?
|
||||
contract-name
|
||||
contract-proc
|
||||
|
||||
flat-contract?
|
||||
flat-contract
|
||||
flat-contract-predicate
|
||||
flat-named-contract
|
||||
|
||||
contract-first-order-passes?
|
||||
|
||||
;; below need docs
|
||||
|
||||
make-proj-contract
|
||||
|
||||
contract-stronger?
|
||||
|
||||
coerce-contract
|
||||
flat-contract/predicate?
|
||||
|
||||
build-compound-type-name
|
||||
raise-contract-error
|
||||
|
||||
proj-prop proj-pred? proj-get
|
||||
name-prop name-pred? name-get
|
||||
stronger-prop stronger-pred? stronger-get
|
||||
flat-prop flat-pred? flat-get
|
||||
first-order-prop first-order-get))
|
||||
|
||||
|
||||
;; ======================================================================
|
||||
;; The alternate implementation disables contracts. Its useful mainly to
|
||||
;; measure the cost of contracts. It's not necessarily complete, but it
|
||||
;; works well enough for starting DrScheme.
|
||||
|
||||
#;
|
||||
(module contract mzscheme
|
||||
|
||||
(define-syntax provide/contract
|
||||
(syntax-rules ()
|
||||
[(_ elem ...)
|
||||
(begin (provide-one elem) ...)]))
|
||||
|
||||
(define-syntax provide-one
|
||||
(syntax-rules (struct rename)
|
||||
[(_ (struct (id par-id) ([field . rest] ...)))
|
||||
(provide-struct id par-id (field ...))]
|
||||
[(_ (struct id ([field . rest] ...)))
|
||||
(provide (struct id (field ...)))]
|
||||
[(_ (rename id1 id2 c))
|
||||
(provide (rename id1 id2))]
|
||||
[(_ (id c))
|
||||
(provide id)]))
|
||||
|
||||
(define-syntax (provide-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id par-id . rest)
|
||||
(let ([info (syntax-local-value #'id (lambda () #f))]
|
||||
[p-info (syntax-local-value #'par-id (lambda () #f))]
|
||||
[prefix (lambda (l n)
|
||||
(let loop ([l l][len (length l)])
|
||||
(if (= n len)
|
||||
null
|
||||
(cons (car l) (loop (cdr l)
|
||||
(- len 1))))))]
|
||||
[ids (lambda (l) (let loop ([l l])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(car l) (cons (car l) (loop (cdr l)))]
|
||||
[else (loop (cdr l))])))])
|
||||
(if (and info
|
||||
p-info
|
||||
(list? info)
|
||||
(list? p-info)
|
||||
(= (length info) 6)
|
||||
(= (length p-info) 6))
|
||||
#`(provide #,@(append
|
||||
(list #'id
|
||||
(list-ref info 0)
|
||||
(list-ref info 1)
|
||||
(list-ref info 2))
|
||||
(ids (prefix (list-ref info 3) (length (list-ref p-info 3))))
|
||||
(ids (prefix (list-ref info 4) (length (list-ref p-info 4))))))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(cond
|
||||
[(not info) "cannot find struct info"]
|
||||
[(not p-info) "cannot find parent-struct info"]
|
||||
[else (format "struct or parent-struct info has unexpected shape: ~e and ~e"
|
||||
info p-info)])
|
||||
#'id)))]))
|
||||
|
||||
(define-syntax define-contract-struct
|
||||
(syntax-rules ()
|
||||
[(_ . rest) (define-struct . rest)]))
|
||||
|
||||
(define-syntax define/contract
|
||||
(syntax-rules ()
|
||||
[(_ id c expr) (define id expr)]))
|
||||
|
||||
(define-syntax contract
|
||||
(syntax-rules ()
|
||||
[(_ c expr . rest) expr]))
|
||||
|
||||
(provide provide/contract
|
||||
define-contract-struct
|
||||
define/contract
|
||||
contract)
|
||||
|
||||
(define mk*
|
||||
(lambda args (lambda (x) x)))
|
||||
|
||||
(define-syntax mk
|
||||
(syntax-rules ()
|
||||
[(_ id) (begin
|
||||
(define-syntax (id stx) (quote-syntax mk*))
|
||||
(provide id))]
|
||||
[(_ id ...)
|
||||
(begin (mk id) ...)]))
|
||||
|
||||
(mk ->
|
||||
->*
|
||||
opt->
|
||||
case->
|
||||
->r
|
||||
or/c
|
||||
and/c
|
||||
any/c
|
||||
flat-named-contract
|
||||
flat-contract
|
||||
flat-contract-predicate
|
||||
object-contract
|
||||
union
|
||||
listof
|
||||
is-a?/c)
|
||||
|
||||
(define-syntax symbols
|
||||
(syntax-rules ()
|
||||
[(_ sym ...)
|
||||
(lambda (v) (memq v '(sym ...)))]))
|
||||
(provide symbols)
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@
|
|||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
;; core [de]serializer:
|
||||
"private/serialize.ss")
|
||||
(lib "private/serialize.ss" "scheme"))
|
||||
|
||||
(provide define-serializable-struct
|
||||
define-serializable-struct/versions
|
||||
|
||||
;; core [de]serializer:
|
||||
(all-from "private/serialize.ss"))
|
||||
(all-from (lib "private/serialize.ss" "scheme")))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; define-serializable-struct
|
||||
|
|
|
|||
|
|
@ -1,729 +1,3 @@
|
|||
(module trait mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "struct.ss"))
|
||||
(require-for-syntax (lib "list.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
(lib "kerncase.ss" "syntax")
|
||||
;; This should be part of a public expand-time API
|
||||
;; exported by the class system:
|
||||
(only (lib "classidmap.ss" "mzlib" "private")
|
||||
generate-class-expand-context))
|
||||
|
||||
(provide (rename :trait trait)
|
||||
trait?
|
||||
trait->mixin
|
||||
trait-sum
|
||||
trait-exclude trait-exclude-field
|
||||
trait-alias
|
||||
trait-rename trait-rename-field)
|
||||
|
||||
;; A trait is a list of supplied methods.
|
||||
;; Each supplied method is:
|
||||
;; * an external name
|
||||
;; * supplies inherit?
|
||||
;; * supplies super?
|
||||
;; * supplies inner?
|
||||
;; * overrides?
|
||||
;; * augments?
|
||||
;; * list of required methods (external names) for inherit
|
||||
;; * list of required methods (external names) for super
|
||||
;; * list of required methods (external names) for inner
|
||||
;; * list of required methods (external names) for inherit-fields
|
||||
;; * a mixin patameterized by all external names
|
||||
;; * an indrection mixin for supers
|
||||
|
||||
(define-struct trait (methods fields))
|
||||
|
||||
(define-struct method (name inherit? super? inner?
|
||||
override? augment?
|
||||
need-inherit need-super need-inner need-field
|
||||
make-mixin
|
||||
make-super-indirection-mixin))
|
||||
|
||||
(define-struct feeld (name make-mixin))
|
||||
|
||||
(define-syntax (:trait stx)
|
||||
;; The main compiler (helpers are below):
|
||||
(define (main stx)
|
||||
(syntax-case stx ()
|
||||
[(_ clause ...)
|
||||
(let* ([clauses (syntax->list #'(clause ...))]
|
||||
[expanded-clauses (expand-body clauses)])
|
||||
;; Pull out declared names:
|
||||
(let-values ([(publics pubments
|
||||
overrides augments augrides overments
|
||||
inherits inherits/super inherits/inner
|
||||
inherit-fields)
|
||||
(extract expanded-clauses
|
||||
(map syntax->list
|
||||
(syntax->list
|
||||
#'((public public-final)
|
||||
(pubment)
|
||||
(override override-final)
|
||||
(augment augment-final)
|
||||
(augride)
|
||||
(overment)
|
||||
(inherit) (inherit/super) (inherit/inner)
|
||||
(inherit-field)))))]
|
||||
[(fields)
|
||||
(extract-fields expanded-clauses)])
|
||||
;; Every declaration implies direct use for other declarations:
|
||||
(let* ([to-inherit
|
||||
(append publics pubments
|
||||
overrides augments augrides overments
|
||||
inherits inherits/super inherits/inner)]
|
||||
[to-inherit-fields
|
||||
(append fields inherit-fields)]
|
||||
[decls
|
||||
(append to-inherit-fields to-inherit)])
|
||||
;; Check distinct delcarations:
|
||||
(check-distinct-external-names to-inherit)
|
||||
(check-distinct-external-names to-inherit-fields)
|
||||
(check-distinct-internal-names decls)
|
||||
|
||||
;; Some declarations imply use via `super' or `inner':
|
||||
(let ([to-super (append overrides inherits/super)]
|
||||
[to-inner (append augments pubments inherits/inner)])
|
||||
|
||||
(let ([to-inherit-only
|
||||
(filter (lambda (n)
|
||||
(not (or (ormap (lambda (n2) (internal-identifier=? n n2))
|
||||
to-super)
|
||||
(ormap (lambda (n2) (internal-identifier=? n n2))
|
||||
to-inner))))
|
||||
to-inherit)])
|
||||
|
||||
;; Current method-making function with respect to the
|
||||
;; common part:
|
||||
(let* ([bindings (make-bindings expanded-clauses)]
|
||||
[compose-method (compose-method-with-requirements
|
||||
bindings
|
||||
to-inherit-only to-super to-inner
|
||||
to-inherit-fields)])
|
||||
|
||||
;; Build a mixin and `method' record for each declaration:
|
||||
(with-syntax ([(method ...)
|
||||
(append
|
||||
(map (compose-method #'override #t #f #f #f #f #f) publics)
|
||||
(map (compose-method #'overment #t #t #f #f #f #f) pubments)
|
||||
(map (compose-method #'override #t #t #f #t #f #f) overrides)
|
||||
(map (compose-method #'overment #t #f #f #t #f #t) overments)
|
||||
(map (compose-method #'augment #t #f #t #f #t #f) augments)
|
||||
(map (compose-method #'augride #t #f #f #f #t #f) augrides))]
|
||||
[(field ...)
|
||||
(map (compose-field bindings) fields)])
|
||||
|
||||
(bound-identifier-mapping-for-each
|
||||
bindings
|
||||
(lambda (key val)
|
||||
(when val
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"definition has no corresponding declaration (e.g., public)"
|
||||
stx
|
||||
key))))
|
||||
|
||||
;; Combine the result into a trait:
|
||||
#'(make-trait (list method ...)
|
||||
(list field ...)))))))))]))
|
||||
|
||||
(define (expand-body clauses)
|
||||
;; For now, we expand naively: no support for internal define-syntax,
|
||||
;; and no shadowing of syntax with method definitions.
|
||||
(let ([stop-forms
|
||||
(append
|
||||
(syntax->list
|
||||
#'(private
|
||||
public public-final pubment
|
||||
override override-final augment augment-final augride overment
|
||||
inherit inherit/super inherit/inner
|
||||
this super inner
|
||||
field inherit-field))
|
||||
(kernel-form-identifier-list))]
|
||||
[expand-context (generate-class-expand-context)])
|
||||
(let loop ([l clauses])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[else (let ([e (local-expand (car l)
|
||||
expand-context
|
||||
stop-forms)])
|
||||
(syntax-case e (begin define-values)
|
||||
[(begin expr ...)
|
||||
(loop (append
|
||||
(syntax->list (syntax (expr ...)))
|
||||
(cdr l)))]
|
||||
[(define-values (id) rhs)
|
||||
(cons e (loop (cdr l)))]
|
||||
[(field (id expr) ...)
|
||||
(if (andmap (lambda (id)
|
||||
(or (identifier? id)
|
||||
(syntax-case id ()
|
||||
[(a b)
|
||||
(and (identifier? #'a)
|
||||
(identifier? #'b))]
|
||||
[_else #f])))
|
||||
(syntax->list #'(id ...)))
|
||||
(cons e (loop (cdr l)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax"
|
||||
e))]
|
||||
[(id . rest)
|
||||
(ormap (lambda (x) (module-identifier=? x #'id))
|
||||
(syntax->list
|
||||
#'(public public-final pubment
|
||||
override override-final augment augment-final augride overment
|
||||
inherit inherit/super inherit/inner
|
||||
inherit-field)))
|
||||
(let ([l2 (syntax->list #'rest)])
|
||||
(if (and l2
|
||||
(andmap (lambda (i)
|
||||
(or (identifier? i)
|
||||
(syntax-case i ()
|
||||
[(a b)
|
||||
(and (identifier? #'a)
|
||||
(identifier? #'b))]
|
||||
[_else #f])))
|
||||
l2))
|
||||
(cons e (loop (cdr l)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (inside trait)"
|
||||
e)))]
|
||||
[(define-values . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax"
|
||||
e)]
|
||||
[(field . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax"
|
||||
e)]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not allowed in a trait"
|
||||
e)]))]))))
|
||||
|
||||
(define (extract expanded-clauses keyword-mapping)
|
||||
(let loop ([l expanded-clauses]
|
||||
[results (map (lambda (x) null) keyword-mapping)])
|
||||
(cond
|
||||
[(null? l) (apply values results)]
|
||||
[else
|
||||
(let ([kw (stx-car (car l))])
|
||||
(if (or (module-identifier=? kw #'define-values)
|
||||
(module-identifier=? kw #'field))
|
||||
(loop (cdr l) results)
|
||||
(loop (cdr l)
|
||||
(let iloop ([mapping keyword-mapping]
|
||||
[results results])
|
||||
(if (ormap (lambda (x) (module-identifier=? kw x))
|
||||
(car mapping))
|
||||
(cons (append (stx->list (stx-cdr (car l)))
|
||||
(car results))
|
||||
(cdr results))
|
||||
(cons (car results)
|
||||
(iloop (cdr mapping)
|
||||
(cdr results))))))))])))
|
||||
|
||||
(define (extract-fields expanded-clauses)
|
||||
(apply
|
||||
append
|
||||
(map (lambda (clause)
|
||||
(syntax-case clause (field)
|
||||
[(field [id expr] ...)
|
||||
(syntax->list #'(id ...))]
|
||||
[_else null]))
|
||||
expanded-clauses)))
|
||||
|
||||
(define (make-bindings expanded-clauses)
|
||||
(let ([boundmap (make-bound-identifier-mapping)])
|
||||
(for-each (lambda (clause)
|
||||
(syntax-case clause (define-values field)
|
||||
[(define-values (id) rhs)
|
||||
(bound-identifier-mapping-put! boundmap #'id #'rhs)]
|
||||
[(field [id expr] ...)
|
||||
(for-each (lambda (id expr)
|
||||
(bound-identifier-mapping-put! boundmap (internal-name id) expr))
|
||||
(syntax->list #'(id ...))
|
||||
(syntax->list #'(expr ...)))]
|
||||
[_else (void)]))
|
||||
expanded-clauses)
|
||||
boundmap))
|
||||
|
||||
(define (internal-identifier=? a b)
|
||||
(bound-identifier=? (internal-name a) (internal-name b)))
|
||||
|
||||
(define (internal-name decl)
|
||||
(if (identifier? decl)
|
||||
decl
|
||||
(stx-car decl)))
|
||||
|
||||
(define (external-name decl)
|
||||
(if (identifier? decl)
|
||||
decl
|
||||
(stx-car (stx-cdr decl))))
|
||||
|
||||
(define (check-distinct-names method-decls
|
||||
what which
|
||||
make-identifier-mapping
|
||||
identifier-mapping-get
|
||||
identifier-mapping-set!)
|
||||
(let ([idmap (make-identifier-mapping)])
|
||||
(for-each (lambda (decl)
|
||||
(let ([ext-id (which decl)])
|
||||
(when (identifier-mapping-get
|
||||
idmap ext-id
|
||||
(lambda ()
|
||||
(identifier-mapping-set!
|
||||
idmap ext-id
|
||||
#t)
|
||||
#f))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "duplicate definition of ~a name in trait"
|
||||
what)
|
||||
ext-id))))
|
||||
method-decls)))
|
||||
|
||||
(define (check-distinct-external-names method-decls)
|
||||
(check-distinct-names method-decls
|
||||
"external" external-name
|
||||
make-module-identifier-mapping
|
||||
module-identifier-mapping-get
|
||||
module-identifier-mapping-put!))
|
||||
|
||||
(define (check-distinct-internal-names method-decls)
|
||||
(check-distinct-names method-decls
|
||||
"internal" internal-name
|
||||
make-bound-identifier-mapping
|
||||
bound-identifier-mapping-get
|
||||
bound-identifier-mapping-put!))
|
||||
|
||||
(define (((compose-method-with-requirements binding-map
|
||||
to-inherit to-super to-inner
|
||||
to-inherit-field)
|
||||
keyword inherit? super? inner? override? augment? always-deep?)
|
||||
name)
|
||||
(let ([impl (bound-identifier-mapping-get binding-map (internal-name name))]
|
||||
[to-inherit (if always-deep?
|
||||
(filter (lambda (n) (not (internal-identifier=? n name)))
|
||||
to-inherit)
|
||||
to-inherit)])
|
||||
(with-syntax ([(to-inherit ...) to-inherit]
|
||||
[(to-super ...) to-super]
|
||||
[(to-inner ...) to-inner]
|
||||
[(to-inherit-field ...) to-inherit-field]
|
||||
[(to-inherit-ext ...) (map external-name to-inherit)]
|
||||
[(to-super-ext ...) (map external-name to-super)]
|
||||
[(to-inner-ext ...) (map external-name to-inner)]
|
||||
[(to-inherit-field-ext ...) (map external-name to-inherit-field)]
|
||||
[(to-inherit-arg ...) (generate-temporaries to-inherit)]
|
||||
[(to-super-arg ...) (generate-temporaries to-super)]
|
||||
[(to-inner-arg ...) (generate-temporaries to-inner)]
|
||||
[(to-inherit-field-arg ...) (generate-temporaries to-inherit-field)]
|
||||
[impl impl]
|
||||
[declare keyword]
|
||||
[this-method (if always-deep?
|
||||
name
|
||||
#'this-method)]
|
||||
[wrap-super-indirect (if override?
|
||||
#'values
|
||||
#'omit)]
|
||||
[wrap-inner-indirect (if augment?
|
||||
#'values
|
||||
#'omit)])
|
||||
;; for tracking unused bindings at the end:
|
||||
(bound-identifier-mapping-put! binding-map (internal-name name) #f)
|
||||
;; generate method:
|
||||
#`(make-method
|
||||
(member-name-key #,(external-name name))
|
||||
#,inherit? #,super? #,inner? #,override? #,augment?
|
||||
(list (member-name-key to-inherit-ext) ...)
|
||||
(list (member-name-key to-super-ext) ...)
|
||||
(list (member-name-key to-inner-ext) ...)
|
||||
(list (member-name-key to-inherit-field-ext) ...)
|
||||
(lambda (this-method-arg to-inherit-arg ...
|
||||
to-super-arg ...
|
||||
to-inner-arg ...
|
||||
to-inherit-field-arg ...)
|
||||
(define-member-name this-method this-method-arg)
|
||||
(define-member-name to-inherit-ext to-inherit-arg) ...
|
||||
(define-member-name to-super-ext to-super-arg) ...
|
||||
(define-member-name to-inner-ext to-inner-arg) ...
|
||||
(define-member-name to-inherit-field-ext to-inherit-field-arg) ...
|
||||
(lambda (%)
|
||||
(class %
|
||||
(inherit to-inherit ...)
|
||||
(inherit/super to-super ...)
|
||||
(inherit/inner to-inner ...)
|
||||
(inherit-field to-inherit-field ...)
|
||||
(declare this-method)
|
||||
(define this-method (let ([#,(internal-name name) impl])
|
||||
#,(internal-name name)))
|
||||
(super-new))))
|
||||
;; For `super' call indirections:
|
||||
(wrap-super-indirect
|
||||
(lambda (name-arg super-name-arg)
|
||||
(define-member-name name name-arg)
|
||||
(define-member-name super-name super-name-arg)
|
||||
(lambda (%)
|
||||
(class %
|
||||
(override name)
|
||||
(inherit/super super-name)
|
||||
(define name (similar-lambda impl (super super-name)))
|
||||
(super-new)))))))))
|
||||
|
||||
(define ((compose-field binding-map) name)
|
||||
(let ([impl (bound-identifier-mapping-get binding-map (internal-name name))])
|
||||
;; for tracking unused bindings at the end:
|
||||
(bound-identifier-mapping-put! binding-map (internal-name name) #f)
|
||||
;; generate method:
|
||||
#`(make-feeld
|
||||
(member-name-key #,(external-name name))
|
||||
(lambda (name-arg)
|
||||
(define-member-name #,(external-name name) name-arg)
|
||||
(lambda (%)
|
||||
(class %
|
||||
(field [#,name #,impl])
|
||||
(super-new)))))))
|
||||
|
||||
(main stx))
|
||||
|
||||
(define-syntax (similar-lambda stx)
|
||||
;; Try to get arity the same:
|
||||
(syntax-case stx (lambda)
|
||||
[(_ (lambda (id ...) . __) (new-body ...))
|
||||
#'(lambda (id ...) (new-body ... id ...))]
|
||||
;; Generic case:
|
||||
[(_ method-lambda (new-body ...))
|
||||
#'(lambda args (new-body ... . args))]))
|
||||
|
||||
(define-syntax (omit stx) #'#f)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; trait->mixin
|
||||
|
||||
(define (trait->mixin t)
|
||||
(let ([methods (trait-methods t)])
|
||||
|
||||
;; If a needed inherit, super, or inner is not immediately satisified,
|
||||
;; we can just leave it to the superclass.
|
||||
;; But we can't expect a super and have it introduced as non-overriding.
|
||||
;; We need to check in trait-sum, trait-alias, etc., because we'll
|
||||
;; have to use dummy introductions when stacking up the mixins, and
|
||||
;; there might be no error otherwise.
|
||||
|
||||
;; Order the mixins. If M1 super-calls M2 and we have an override
|
||||
;; for M2, then try to mix M2 later. Similarly, if M1 inner-calls M2
|
||||
;; and we have an augment for M2, try to mix M2 earlier.
|
||||
;; We'll have to break cycles by inserting indirections, but we can't
|
||||
;; do that for `inner'; consequently, an `inner' from M1 to M2
|
||||
;; might land at an implementation in the same trait!
|
||||
;; For simplicty, we sort right now by just all augments first
|
||||
;; and all overrides last. In the common case where methods
|
||||
;; only self-call supers and inners, that will work fine.
|
||||
(let loop ([methods (sort methods
|
||||
(lambda (a b)
|
||||
(or (method-augment? a)
|
||||
(method-override? b))))]
|
||||
;; Start by adding mixins for fields. Then continue
|
||||
;; by mixing a dummy method for each public/pubment
|
||||
;; method. We'll override it, but having it here at the start
|
||||
;; means that the methods can refer to each other via
|
||||
;; `inherit'.
|
||||
[mixin (let loop ([methods methods]
|
||||
[mixin (let loop ([mixin (lambda (%) %)]
|
||||
[fields (trait-fields t)])
|
||||
(cond
|
||||
[(null? fields) mixin]
|
||||
[else (let ([mix ((feeld-make-mixin (car fields))
|
||||
(feeld-name (car fields)))])
|
||||
(loop (lambda (%) (mix (mixin %)))
|
||||
(cdr fields)))]))])
|
||||
(cond
|
||||
[(null? methods) mixin]
|
||||
[else (let ([method (car methods)])
|
||||
(loop (cdr methods)
|
||||
(if (or (method-override? method)
|
||||
(method-augment? method))
|
||||
mixin
|
||||
(introduce-into-mixin
|
||||
(method-name method)
|
||||
mixin))))]))]
|
||||
[super-indirections null])
|
||||
(cond
|
||||
[(null? methods)
|
||||
;; No more methods to add, so just insert needed
|
||||
;; super indirections (as accumulated when adding
|
||||
;; methods before):
|
||||
(let loop ([indirections super-indirections]
|
||||
[mixin mixin])
|
||||
(cond
|
||||
[(null? indirections) mixin]
|
||||
[else (let ([method (list-ref (car indirections) 2)])
|
||||
(loop (cdr indirections)
|
||||
(let ([mix ((method-make-super-indirection-mixin method)
|
||||
(method-name method)
|
||||
(cadar indirections))])
|
||||
(lambda (%) (mix (mixin %))))))]))]
|
||||
[else
|
||||
;; Add one method:
|
||||
(let*-values ([(method) (car methods)]
|
||||
;; Rename method, in case we need a super
|
||||
;; indirection:
|
||||
[(name)
|
||||
(if (and (method-override? method)
|
||||
(ormap (lambda (m)
|
||||
(ormap (lambda (n)
|
||||
(same-name? n (method-name method)))
|
||||
(method-need-super m)))
|
||||
(cdr methods)))
|
||||
(generate-member-key)
|
||||
(method-name method))]
|
||||
;; Build the base mixin:
|
||||
[(next-mixin) (apply
|
||||
(method-make-mixin method)
|
||||
name
|
||||
(append
|
||||
(method-need-inherit method)
|
||||
(method-need-super method)
|
||||
(method-need-inner method)
|
||||
(method-need-field method)))])
|
||||
(loop (cdr methods)
|
||||
(lambda (%) (next-mixin (mixin %)))
|
||||
(if (eq? name (method-name method))
|
||||
super-indirections
|
||||
(cons (list (method-name method)
|
||||
name
|
||||
method)
|
||||
super-indirections))))]))))
|
||||
|
||||
(define (introduce-into-mixin name mixin)
|
||||
(define-member-name m name)
|
||||
(lambda (%)
|
||||
(class (mixin %)
|
||||
(define/public (m) 'inroduce-stub)
|
||||
(super-new))))
|
||||
|
||||
(define same-name? member-name-key=?)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; sum, exclude, alias
|
||||
|
||||
(define (validate-trait who t)
|
||||
;; Methods:
|
||||
(let ([ht (make-hash-table)])
|
||||
;; Build up table and check for duplicates:
|
||||
(for-each (lambda (m)
|
||||
(let* ([name (method-name m)]
|
||||
[key (member-name-key-hash-code name)])
|
||||
(let ([l (hash-table-get ht key null)])
|
||||
(when (ormap (lambda (n) (member-name-key=? (car n) name))
|
||||
l)
|
||||
(raise-mismatch-error
|
||||
who
|
||||
"result would include multiple declarations of a method: "
|
||||
name))
|
||||
(hash-table-put! ht key (cons (cons name m) l)))))
|
||||
(trait-methods t))
|
||||
;; Check consistency of expectations and provisions:
|
||||
(let* ([find (lambda (name)
|
||||
(let ([l (hash-table-get ht (member-name-key-hash-code name) null)])
|
||||
(ormap (lambda (n)
|
||||
(and (member-name-key=? (car n) name)
|
||||
(cdr n)))
|
||||
l)))]
|
||||
[check (lambda (super? inner?)
|
||||
(lambda (name)
|
||||
(let ([m (find name)])
|
||||
(when m
|
||||
(when (and super?
|
||||
(not (method-override? m)))
|
||||
(raise-mismatch-error
|
||||
who
|
||||
(string-append
|
||||
"result would include both a super requirement and"
|
||||
" a non-overriding declaration for method: ")
|
||||
name))
|
||||
|
||||
(when (and inner?
|
||||
(not (method-inner? m)))
|
||||
(raise-mismatch-error
|
||||
who
|
||||
(string-append
|
||||
"result would include both an inner requirement and"
|
||||
" a non-augmentable declaration for method: ")
|
||||
name))))))])
|
||||
(for-each (lambda (m)
|
||||
(for-each (check #t #f)
|
||||
(method-need-super m))
|
||||
(for-each (check #f #t)
|
||||
(method-need-inner m)))
|
||||
(trait-methods t))))
|
||||
;; Fields:
|
||||
(let ([ht (make-hash-table)])
|
||||
;; Build up table and check for duplicates:
|
||||
(for-each (lambda (f)
|
||||
(let* ([name (feeld-name f)]
|
||||
[key (member-name-key-hash-code name)])
|
||||
(let ([l (hash-table-get ht key null)])
|
||||
(when (ormap (lambda (n) (member-name-key=? (car n) name))
|
||||
l)
|
||||
(raise-mismatch-error
|
||||
who
|
||||
"result would include multiple declarations of a field: "
|
||||
name))
|
||||
(hash-table-put! ht key (cons (cons name f) l)))))
|
||||
(trait-fields t)))
|
||||
;; Return validated trait:
|
||||
t)
|
||||
|
||||
(define (trait-sum . ts)
|
||||
(for-each (lambda (t)
|
||||
(unless (trait? t)
|
||||
(raise-type-error 'trait-sum "trait" t)))
|
||||
ts)
|
||||
(validate-trait
|
||||
'trait-sum
|
||||
(make-trait (apply
|
||||
append
|
||||
(map trait-methods ts))
|
||||
(apply
|
||||
append
|
||||
(map trait-fields ts)))))
|
||||
|
||||
(define (:trait-exclude t name)
|
||||
(unless (trait? t)
|
||||
(raise-type-error 'trait-exclude "trait" t))
|
||||
(let ([new-methods
|
||||
(filter (lambda (m)
|
||||
(not (member-name-key=? (method-name m) name)))
|
||||
(trait-methods t))])
|
||||
(when (= (length new-methods)
|
||||
(length (trait-methods t)))
|
||||
(raise-mismatch-error
|
||||
'trait-exclude
|
||||
"method not in trait: " name))
|
||||
(make-trait new-methods (trait-fields t))))
|
||||
|
||||
(define (:trait-exclude-field t name)
|
||||
(unless (trait? t)
|
||||
(raise-type-error 'trait-exclude-field "trait" t))
|
||||
(let ([new-fields
|
||||
(filter (lambda (m)
|
||||
(not (member-name-key=? (feeld-name m) name)))
|
||||
(trait-fields t))])
|
||||
(when (= (length new-fields)
|
||||
(length (trait-fields t)))
|
||||
(raise-mismatch-error
|
||||
'trait-exclude
|
||||
"field not in trait: " name))
|
||||
(make-trait (trait-methods t) new-fields)))
|
||||
|
||||
(define-syntax define-trait-exclude
|
||||
(syntax-rules ()
|
||||
[(_ trait-exclude :trait-exclude)
|
||||
(define-syntax (trait-exclude stx)
|
||||
(syntax-case stx ()
|
||||
[(_ t name)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for a method name"
|
||||
stx
|
||||
#'name))
|
||||
#'(:trait-exclude t (member-name-key name)))]))]))
|
||||
|
||||
(define-trait-exclude trait-exclude :trait-exclude)
|
||||
(define-trait-exclude trait-exclude-field :trait-exclude-field)
|
||||
|
||||
(define (:trait-alias t name new-name)
|
||||
(unless (trait? t)
|
||||
(raise-type-error 'trait-alias "trait" t))
|
||||
(let ([m (ormap (lambda (m)
|
||||
(and (member-name-key=? (method-name m) name)
|
||||
m))
|
||||
(trait-methods t))])
|
||||
(unless m
|
||||
(raise-mismatch-error
|
||||
'trait-alias
|
||||
"method not in trait: " name))
|
||||
(validate-trait
|
||||
'trait-alias
|
||||
(make-trait
|
||||
(cons (copy-struct method m
|
||||
[method-name new-name])
|
||||
(trait-methods t))
|
||||
(trait-fields t)))))
|
||||
|
||||
(define (:trait-rename t name new-name)
|
||||
(unless (trait? t)
|
||||
(raise-type-error 'trait-rename "trait" t))
|
||||
(let ([rename (lambda (n)
|
||||
(if (same-name? n name)
|
||||
new-name
|
||||
n))])
|
||||
(validate-trait
|
||||
'trait-rename
|
||||
(make-trait
|
||||
(map (lambda (m)
|
||||
(copy-struct method m
|
||||
[method-name (rename (method-name m))]
|
||||
[method-need-inherit (map rename (method-need-inherit m))]
|
||||
[method-need-super (map rename (method-need-super m))]
|
||||
[method-need-inner (map rename (method-need-inner m))]))
|
||||
(trait-methods t))
|
||||
(trait-fields t)))))
|
||||
|
||||
(define (:trait-rename-field t name new-name)
|
||||
(unless (trait? t)
|
||||
(raise-type-error 'trait-rename-field "trait" t))
|
||||
(let ([rename (lambda (n)
|
||||
(if (same-name? n name)
|
||||
new-name
|
||||
n))])
|
||||
(validate-trait
|
||||
'trait-rename
|
||||
(make-trait
|
||||
(map (lambda (m)
|
||||
(copy-struct method m
|
||||
[method-need-field (map rename (method-need-field m))]))
|
||||
(trait-methods t))
|
||||
(map (lambda (f)
|
||||
(copy-struct feeld f
|
||||
[feeld-name (rename (feeld-name f))]))
|
||||
(trait-fields t))))))
|
||||
|
||||
(define-syntax define-trait-alias
|
||||
(syntax-rules ()
|
||||
[(_ trait-alias :trait-alias)
|
||||
(define-syntax (trait-alias stx)
|
||||
(syntax-case stx ()
|
||||
[(_ t name new-name)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for a method name"
|
||||
stx
|
||||
#'name))
|
||||
(unless (identifier? #'new-name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for a method name"
|
||||
stx
|
||||
#'new-name))
|
||||
#'(:trait-alias t (member-name-key name) (member-name-key new-name)))]))]))
|
||||
|
||||
(define-trait-alias trait-alias :trait-alias)
|
||||
(define-trait-alias trait-rename :trait-rename)
|
||||
(define-trait-alias trait-rename-field :trait-rename-field)
|
||||
|
||||
;; ----------------------------------------;
|
||||
)
|
||||
(module trait scheme/base
|
||||
(require scheme/trait)
|
||||
(provide (all-from-out scheme/trait)))
|
||||
|
|
|
|||
198
collects/scheme/private/contract-arr-checks.ss
Normal file
198
collects/scheme/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)))
|
||||
|
||||
|#
|
||||
)
|
||||
1111
collects/scheme/private/contract-arr-obj-helpers.ss
Normal file
1111
collects/scheme/private/contract-arr-obj-helpers.ss
Normal file
File diff suppressed because it is too large
Load Diff
461
collects/scheme/private/contract-arrow.ss
Normal file
461
collects/scheme/private/contract-arrow.ss
Normal file
|
|
@ -0,0 +1,461 @@
|
|||
(module contract-arrow mzscheme
|
||||
(require (lib "etc.ss")
|
||||
"contract-guts.ss"
|
||||
"contract-arr-checks.ss"
|
||||
"contract-opt.ss")
|
||||
(require-for-syntax "contract-opt-guts.ss"
|
||||
"contract-helpers.ss"
|
||||
"contract-arr-obj-helpers.ss"
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax"))
|
||||
|
||||
(provide ->
|
||||
->d
|
||||
->*
|
||||
->d*
|
||||
->r
|
||||
->pp
|
||||
->pp-rest
|
||||
case->
|
||||
opt->
|
||||
opt->*
|
||||
unconstrained-domain->
|
||||
check-procedure)
|
||||
|
||||
(define-syntax (unconstrained-domain-> stx)
|
||||
(syntax-case stx ()
|
||||
[(_ rngs ...)
|
||||
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(proj-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(res-x ...) (generate-temporaries #'(rngs ...))])
|
||||
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
|
||||
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(λ args
|
||||
(let-values ([(res-x ...) (apply val args)])
|
||||
(values (p-app-x res-x) ...)))
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected a procedure")))))
|
||||
procedure?))))]))
|
||||
|
||||
;; FIXME: need to pass in the name of the contract combinator.
|
||||
(define (build--> name doms doms-rest rngs rng-any? func)
|
||||
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
|
||||
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
|
||||
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
|
||||
(make--> rng-any? doms/c doms-rest/c rngs/c func)))
|
||||
|
||||
(define-struct/prop -> (rng-any? doms dom-rest rngs func)
|
||||
((proj-prop (λ (ctc)
|
||||
(let* ([doms/c (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest ctc)
|
||||
(append (->-doms ctc) (list (->-dom-rest ctc)))
|
||||
(->-doms ctc)))]
|
||||
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[check-proc
|
||||
(if (->-dom-rest ctc)
|
||||
check-procedure/more
|
||||
check-procedure)])
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms/c)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs/c)])
|
||||
(apply func
|
||||
(λ (val) (check-proc val dom-length src-info pos-blame orig-str))
|
||||
(append partial-doms partial-ranges)))))))
|
||||
(name-prop (λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs ctc))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([l (length (->-doms ctc))])
|
||||
(if (->-dom-rest ctc)
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-accepts-and-more? x l)))
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x l)))))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs that)))))))
|
||||
|
||||
(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
|
||||
(cond
|
||||
[doms-rest
|
||||
(build-compound-type-name
|
||||
'->*
|
||||
(apply build-compound-type-name doms/c)
|
||||
doms-rest
|
||||
(cond
|
||||
[rng-any? 'any]
|
||||
[else (apply build-compound-type-name rngs)]))]
|
||||
[else
|
||||
(let ([rng-name
|
||||
(cond
|
||||
[rng-any? 'any]
|
||||
[(null? rngs) '(values)]
|
||||
[(null? (cdr rngs)) (car rngs)]
|
||||
[else (apply build-compound-type-name 'values rngs)])])
|
||||
(apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
|
||||
|
||||
(define arity-one-wrapper
|
||||
(lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1)))))))
|
||||
|
||||
(define arity-two-wrapper
|
||||
(lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2)))))))
|
||||
|
||||
(define arity-three-wrapper
|
||||
(lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8)))))))
|
||||
|
||||
(define arity-four-wrapper
|
||||
(lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16)))))))
|
||||
|
||||
(define arity-five-wrapper
|
||||
(lambda (chk a27 b28 c29 d30 e31 r32)
|
||||
(lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26)))))))
|
||||
|
||||
(define arity-six-wrapper
|
||||
(lambda (chk a39 b40 c41 d42 e43 f44 r45)
|
||||
(lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38)))))))
|
||||
|
||||
(define arity-seven-wrapper
|
||||
(lambda (chk a53 b54 c55 d56 e57 f58 g59 r60)
|
||||
(lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52)))))))
|
||||
|
||||
(define-syntax-set (-> ->*)
|
||||
(define (->/proc stx)
|
||||
(let-values ([(stx _1 _2) (->/proc/main stx)])
|
||||
stx))
|
||||
|
||||
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
||||
(define (->/proc/main stx)
|
||||
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)])
|
||||
(with-syntax ([(args body) inner-args/body])
|
||||
(with-syntax ([(dom-names ...) dom-names]
|
||||
[(rng-names ...) rng-names]
|
||||
[(dom-ctcs ...) dom-ctcs]
|
||||
[(rng-ctcs ...) rng-ctcs]
|
||||
[inner-lambda
|
||||
(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
(syntax (lambda args body)))]
|
||||
[use-any? use-any?])
|
||||
(with-syntax ([outer-lambda
|
||||
(let* ([lst (syntax->list #'args)]
|
||||
[len (and lst (length lst))])
|
||||
(if (and #f ;; this optimization disables the names so is turned off for now
|
||||
lst
|
||||
(not (syntax-e #'use-any?))
|
||||
(= len (length (syntax->list #'(dom-names ...))))
|
||||
(= 1 (length (syntax->list #'(rng-names ...))))
|
||||
(<= 1 len 7))
|
||||
(case len
|
||||
[(1) #'arity-one-wrapper]
|
||||
[(2) #'arity-two-wrapper]
|
||||
[(3) #'arity-three-wrapper]
|
||||
[(4) #'arity-four-wrapper]
|
||||
[(5) #'arity-five-wrapper]
|
||||
[(6) #'arity-six-wrapper]
|
||||
[(7) #'arity-seven-wrapper])
|
||||
(syntax
|
||||
(lambda (chk dom-names ... rng-names ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))))])
|
||||
(values
|
||||
(syntax (build--> '->
|
||||
(list dom-ctcs ...)
|
||||
#f
|
||||
(list rng-ctcs ...)
|
||||
use-any?
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-names ... rng-names ...))))))))
|
||||
|
||||
(define (->-helper stx)
|
||||
(syntax-case* stx (-> any values) module-or-top-identifier=?
|
||||
[(-> doms ... any)
|
||||
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(ignored) (generate-temporaries (syntax (rng)))])
|
||||
(values (syntax (dom-ctc ...))
|
||||
(syntax (ignored))
|
||||
(syntax (doms ...))
|
||||
(syntax (any/c))
|
||||
(syntax ((args ...) (val (dom-ctc args) ...)))
|
||||
#t))]
|
||||
[(-> doms ... (values rngs ...))
|
||||
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
||||
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
|
||||
(values (syntax (dom-ctc ...))
|
||||
(syntax (rng-ctc ...))
|
||||
(syntax (doms ...))
|
||||
(syntax (rngs ...))
|
||||
(syntax ((args ...)
|
||||
(let-values ([(rng-x ...) (val (dom-ctc args) ...)])
|
||||
(values (rng-ctc rng-x) ...))))
|
||||
#f))]
|
||||
[(_ doms ... rng)
|
||||
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rng-ctc) (generate-temporaries (syntax (rng)))])
|
||||
(values (syntax (dom-ctc ...))
|
||||
(syntax (rng-ctc))
|
||||
(syntax (doms ...))
|
||||
(syntax (rng))
|
||||
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...))))
|
||||
#f))]))
|
||||
|
||||
(define (->*/proc stx)
|
||||
(let-values ([(stx _1 _2) (->*/proc/main stx)])
|
||||
stx))
|
||||
|
||||
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
||||
(define (->*/proc/main stx)
|
||||
(syntax-case* stx (->* any) module-or-top-identifier=?
|
||||
[(->* (doms ...) any)
|
||||
(->/proc/main (syntax (-> doms ... any)))]
|
||||
[(->* (doms ...) (rngs ...))
|
||||
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
|
||||
[(->* (doms ...) rst (rngs ...))
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rst-x) (generate-temporaries (syntax (rst)))]
|
||||
[(rest-arg) (generate-temporaries (syntax (rst)))]
|
||||
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
||||
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
||||
(let ([inner-args/body
|
||||
(syntax ((args ... . rest-arg)
|
||||
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
|
||||
(values (rng-x rng-args) ...))))])
|
||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||
(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
(syntax (lambda args body))))])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-x ... rst-x rng-x ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list rngs ...)
|
||||
#f
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
||||
[(->* (doms ...) rst any)
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rst-x) (generate-temporaries (syntax (rst)))]
|
||||
[(rest-arg) (generate-temporaries (syntax (rst)))])
|
||||
(let ([inner-args/body
|
||||
(syntax ((args ... . rest-arg)
|
||||
(apply val (dom-x args) ... (rst-x rest-arg))))])
|
||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||
(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
(syntax (lambda args body))))])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-x ... rst-x ignored)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list any/c)
|
||||
#t
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x)))))))])))
|
||||
|
||||
(define-for-syntax (select/h stx err-name ctxt-stx)
|
||||
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
|
||||
[(-> . args) ->/h]
|
||||
[(->* . args) ->*/h]
|
||||
[(->d . args) ->d/h]
|
||||
[(->d* . args) ->d*/h]
|
||||
[(->r . args) ->r/h]
|
||||
[(->pp . args) ->pp/h]
|
||||
[(->pp-rest . args) ->pp-rest/h]
|
||||
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
|
||||
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
|
||||
|
||||
(define-syntax (->d stx) (make-/proc #f ->d/h stx))
|
||||
(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
|
||||
(define-syntax (->r stx) (make-/proc #f ->r/h stx))
|
||||
(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
|
||||
(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
|
||||
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
|
||||
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
|
||||
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
|
||||
|
||||
;;
|
||||
;; arrow opter
|
||||
;;
|
||||
(define/opter (-> opt/i opt/info stx)
|
||||
(define (opt/arrow-ctc doms rngs)
|
||||
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
|
||||
(generate-temporaries rngs))]
|
||||
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifts-doms null]
|
||||
[superlifts-doms null]
|
||||
[partials-doms null]
|
||||
[stronger-ribs null])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms)
|
||||
lifts-doms
|
||||
superlifts-doms
|
||||
partials-doms
|
||||
stronger-ribs)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
|
||||
(opt/i (opt/info-swap-blame opt/info) (car doms))])
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifts-doms lift)
|
||||
(append superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)))]))]
|
||||
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
|
||||
(let loop ([vars rng-vars]
|
||||
[rngs rngs]
|
||||
[next-rngs null]
|
||||
[lifts-rngs null]
|
||||
[superlifts-rngs null]
|
||||
[partials-rngs null]
|
||||
[stronger-ribs null])
|
||||
(cond
|
||||
[(null? rngs) (values (reverse next-rngs)
|
||||
lifts-rngs
|
||||
superlifts-rngs
|
||||
partials-rngs
|
||||
stronger-ribs)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
|
||||
(opt/i opt/info (car rngs))])
|
||||
(loop (cdr vars)
|
||||
(cdr rngs)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-rngs)
|
||||
(append lifts-rngs lift)
|
||||
(append superlifts-rngs superlift)
|
||||
(append partials-rngs partial)
|
||||
(append this-stronger-ribs stronger-ribs)))]))])
|
||||
(values
|
||||
(with-syntax ((pos (opt/info-pos opt/info))
|
||||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
((rng-arg ...) rng-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars))
|
||||
((next-rng ...) next-rngs))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len src-info pos orig-str)
|
||||
(λ (dom-arg ...)
|
||||
(let-values ([(rng-arg ...) (val next-dom ...)])
|
||||
(values next-rng ...))))))
|
||||
(append lifts-doms lifts-rngs)
|
||||
(append superlifts-doms superlifts-rngs)
|
||||
(append partials-doms partials-rngs)
|
||||
#f
|
||||
#f
|
||||
(append stronger-ribs-dom stronger-ribs-rng))))
|
||||
|
||||
(define (opt/arrow-any-ctc doms)
|
||||
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
||||
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
|
||||
(let loop ([vars dom-vars]
|
||||
[doms doms]
|
||||
[next-doms null]
|
||||
[lifts-doms null]
|
||||
[superlifts-doms null]
|
||||
[partials-doms null]
|
||||
[stronger-ribs null])
|
||||
(cond
|
||||
[(null? doms) (values (reverse next-doms)
|
||||
lifts-doms
|
||||
superlifts-doms
|
||||
partials-doms
|
||||
stronger-ribs)]
|
||||
[else
|
||||
(let-values ([(next lift superlift partial flat _ this-stronger-ribs)
|
||||
(opt/i (opt/info-swap-blame opt/info) (car doms))])
|
||||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifts-doms lift)
|
||||
(append superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)))]))])
|
||||
(values
|
||||
(with-syntax ((pos (opt/info-pos opt/info))
|
||||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars)))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len src-info pos orig-str)
|
||||
(λ (dom-arg ...)
|
||||
(val next-dom ...)))))
|
||||
lifts-doms
|
||||
superlifts-doms
|
||||
partials-doms
|
||||
#f
|
||||
#f
|
||||
stronger-ribs-dom)))
|
||||
|
||||
(syntax-case* stx (-> values any) module-or-top-identifier=?
|
||||
[(-> dom ... (values rng ...))
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(syntax->list (syntax (rng ...))))]
|
||||
[(-> dom ... any)
|
||||
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
|
||||
[(-> dom ... rng)
|
||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
||||
(list #'rng))])))
|
||||
438
collects/scheme/private/contract-object.ss
Normal file
438
collects/scheme/private/contract-object.ss
Normal file
|
|
@ -0,0 +1,438 @@
|
|||
(module contract-object mzscheme
|
||||
(require (lib "etc.ss")
|
||||
"contract-arrow.ss"
|
||||
"contract-guts.ss"
|
||||
"class-internal.ss"
|
||||
"contract-arr-checks.ss")
|
||||
|
||||
(require-for-syntax "contract-helpers.ss"
|
||||
"contract-arr-obj-helpers.ss"
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide mixin-contract
|
||||
make-mixin-contract
|
||||
is-a?/c
|
||||
subclass?/c
|
||||
implementation?/c
|
||||
object-contract)
|
||||
|
||||
(define-syntax-set (object-contract)
|
||||
|
||||
(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 select/h))
|
||||
|
||||
;; WARNING: select/h is copied from contract-arrow.ss. I'm not sure how
|
||||
;; I can avoid this duplication -robby
|
||||
(define (select/h stx err-name ctxt-stx)
|
||||
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
|
||||
[(-> . args) ->/h]
|
||||
[(->* . args) ->*/h]
|
||||
[(->d . args) ->d/h]
|
||||
[(->d* . args) ->d*/h]
|
||||
[(->r . args) ->r/h]
|
||||
[(->pp . args) ->pp/h]
|
||||
[(->pp-rest . args) ->pp-rest/h]
|
||||
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
|
||||
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
|
||||
|
||||
|
||||
(define (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)
|
||||
|
||||
;; 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)))
|
||||
|
|
@ -4814,7 +4814,7 @@ so that propagation occurs.
|
|||
'provide/contract12
|
||||
'(begin
|
||||
(eval '(module pc12-m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define-struct (exn2 exn) ())
|
||||
(provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
|
||||
(eval '(require 'pc12-m))))
|
||||
|
|
@ -4823,7 +4823,7 @@ so that propagation occurs.
|
|||
'provide/contract13
|
||||
'(begin
|
||||
(eval '(module pc13-common-msg-structs mzscheme
|
||||
(require (lib "contract.ss" "mzlib"))
|
||||
(require scheme/contract)
|
||||
(define-struct register (name type) (make-inspector))
|
||||
(provide/contract (struct register ([name any/c] [type any/c])))))
|
||||
|
||||
|
|
@ -4838,7 +4838,7 @@ so that propagation occurs.
|
|||
'provide/contract14
|
||||
'(begin
|
||||
(eval '(module pc14-test1 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
|
||||
(define-struct type (flags))
|
||||
(define-struct (type:ptr type) (type))
|
||||
|
|
@ -4861,7 +4861,7 @@ so that propagation occurs.
|
|||
(contract-error-test
|
||||
#'(begin
|
||||
(eval '(module pos mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(provide/contract [i any/c]))))
|
||||
exn:fail:syntax?)
|
||||
|
||||
|
|
@ -4871,7 +4871,7 @@ so that propagation occurs.
|
|||
'provide/contract15
|
||||
'(begin
|
||||
(eval '(module pos mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require 'pos)))
|
||||
|
|
@ -4882,7 +4882,7 @@ so that propagation occurs.
|
|||
'provide/contract16
|
||||
'(begin
|
||||
(eval '(module neg mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require 'neg)))
|
||||
|
|
@ -4895,7 +4895,7 @@ so that propagation occurs.
|
|||
'provide/contract17
|
||||
'(begin
|
||||
(eval '(module pos mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define-struct s (a))
|
||||
(provide/contract [struct s ((a integer?))])))
|
||||
(eval '(module neg mzscheme
|
||||
|
|
@ -4908,7 +4908,7 @@ so that propagation occurs.
|
|||
'provide/contract18
|
||||
'(begin
|
||||
(eval '(module pc18-pos mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define-struct s ())
|
||||
(provide/contract [struct s ()])))
|
||||
(eval '(require 'pc18-pos))
|
||||
|
|
@ -4918,19 +4918,19 @@ so that propagation occurs.
|
|||
'provide/contract19
|
||||
'(begin
|
||||
(eval '(module pc19-a mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define-struct a (x))
|
||||
(provide/contract [struct a ([x number?])])))
|
||||
|
||||
(eval '(module pc19-b mzscheme
|
||||
(require 'pc19-a
|
||||
(lib "contract.ss"))
|
||||
scheme/contract)
|
||||
(define-struct (b a) (y))
|
||||
(provide/contract [struct (b a) ([x number?] [y number?])])))
|
||||
|
||||
(eval '(module pc19-c mzscheme
|
||||
(require 'pc19-b
|
||||
(lib "contract.ss"))
|
||||
scheme/contract)
|
||||
|
||||
(define-struct (c b) (z))
|
||||
(provide/contract [struct (c b) ([x number?] [y number?] [z number?])])))
|
||||
|
|
@ -4948,7 +4948,7 @@ so that propagation occurs.
|
|||
(test/spec-passed
|
||||
'provide/contract20
|
||||
'(eval '(module tmp mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(require scheme/contract
|
||||
(lib "unit.ss"))
|
||||
|
||||
(define-struct s (a b))
|
||||
|
|
@ -4961,7 +4961,7 @@ so that propagation occurs.
|
|||
'provide/contract21
|
||||
'(begin
|
||||
(eval '(module provide/contract21a mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(provide/contract [f integer?])
|
||||
(define f 1)))
|
||||
(eval '(module provide/contract21b mzscheme
|
||||
|
|
@ -4974,7 +4974,7 @@ so that propagation occurs.
|
|||
'provide/contract22
|
||||
'(begin
|
||||
(eval '(module provide/contract22a mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(provide/contract [make-bound-identifier-mapping integer?])
|
||||
(define make-bound-identifier-mapping 1)))
|
||||
(eval '(module provide/contract22b mzscheme
|
||||
|
|
@ -4990,7 +4990,7 @@ so that propagation occurs.
|
|||
'provide/contract23
|
||||
'(begin
|
||||
(eval '(module provide/contract23a mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(provide/contract [f integer?])
|
||||
(define f 3)))
|
||||
|
||||
|
|
@ -5005,7 +5005,7 @@ so that propagation occurs.
|
|||
'provide/contract24
|
||||
'(begin
|
||||
(eval '(module provide/contract24 mzscheme
|
||||
(require (prefix c: (lib "contract.ss")))
|
||||
(require (prefix c: scheme/contract))
|
||||
(c:case-> (c:-> integer? integer?)
|
||||
(c:-> integer? integer? integer?))))))
|
||||
|
||||
|
|
@ -5015,7 +5015,7 @@ so that propagation occurs.
|
|||
'provide/contract25
|
||||
'(begin
|
||||
(eval '(module provide/contract25a mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(provide/contract [seventeen integer?])
|
||||
(define seventeen 17)))
|
||||
(eval '(module provide/contract25b mzscheme
|
||||
|
|
@ -5039,7 +5039,7 @@ so that propagation occurs.
|
|||
(contract-error-test
|
||||
#'(begin
|
||||
(eval '(module pce1-bug mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define the-defined-variable1 'five)
|
||||
(provide/contract [the-defined-variable1 number?])))
|
||||
(eval '(require 'pce1-bug)))
|
||||
|
|
@ -5050,7 +5050,7 @@ so that propagation occurs.
|
|||
(contract-error-test
|
||||
#'(begin
|
||||
(eval '(module pce2-bug mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define the-defined-variable2 values)
|
||||
(provide/contract [the-defined-variable2 (-> number? any)])))
|
||||
(eval '(require 'pce2-bug))
|
||||
|
|
@ -5062,7 +5062,7 @@ so that propagation occurs.
|
|||
(contract-error-test
|
||||
#'(begin
|
||||
(eval '(module pce3-bug mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define the-defined-variable3 (λ (x) #f))
|
||||
(provide/contract [the-defined-variable3 (-> any/c number?)])))
|
||||
(eval '(require 'pce3-bug))
|
||||
|
|
@ -5074,7 +5074,7 @@ so that propagation occurs.
|
|||
(contract-error-test
|
||||
#'(begin
|
||||
(eval '(module pce4-bug mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
(define the-defined-variable4 (λ (x) #f))
|
||||
(provide/contract [the-defined-variable4 (-> any/c number?)])))
|
||||
(eval '(require 'pce4-bug))
|
||||
|
|
@ -5086,7 +5086,7 @@ so that propagation occurs.
|
|||
(contract-error-test
|
||||
#'(begin
|
||||
(eval '(module pce5-bug mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
|
||||
(define-struct bad (a b))
|
||||
|
||||
|
|
@ -5100,7 +5100,7 @@ so that propagation occurs.
|
|||
(contract-error-test
|
||||
#'(begin
|
||||
(eval '(module pce6-bug mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(require scheme/contract)
|
||||
|
||||
(define-struct bad-parent (a))
|
||||
(define-struct (bad bad-parent) (b))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user