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
This commit is contained in:
Robby Findler
parent
f12a39d97b
commit
9a0498b44d
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
;; All of the implementation is actually in private/class-internal.ss,
|
||||
;; which provides extra (private) functionality to contract.ss.
|
||||
(require "private/class-internal.ss")
|
||||
(require (lib "private/class-internal.ss" "scheme"))
|
||||
|
||||
(provide (rename class-traced class)
|
||||
(rename class*-traced class*)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,11 @@
|
|||
(module class mzscheme
|
||||
|
||||
(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")
|
||||
|
||||
(provide-public-names))
|
||||
|
||||
(module class scheme/base
|
||||
(require mzlib/class)
|
||||
(provide (all-from-out mzlib/class)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,176 @@
|
|||
|
||||
(module contract scheme/base
|
||||
(require mzlib/contract)
|
||||
(provide (all-from-out mzlib/contract)))
|
||||
(module contract mzscheme
|
||||
|
||||
(require "private/contract.ss"
|
||||
"private/contract-arrow.ss"
|
||||
"private/contract-guts.ss"
|
||||
"private/contract-ds.ss"
|
||||
"private/contract-opt-guts.ss"
|
||||
"private/contract-opt.ss"
|
||||
"private/contract-basic-opters.ss")
|
||||
|
||||
(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.
|
||||
;; (last used pre v4)
|
||||
|
||||
#;
|
||||
(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)
|
||||
|
||||
)
|
||||
|
|
@ -5,7 +5,7 @@
|
|||
(lib "etc.ss")
|
||||
(lib "stxparam.ss")
|
||||
"class-events.ss"
|
||||
"serialize-structs.ss"
|
||||
"serialize-structs.ss"
|
||||
(for-syntax (lib "kerncase.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax")
|
||||
|
|
@ -17,6 +17,52 @@
|
|||
|
||||
(define insp (current-inspector)) ; for all opaque structures
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; spec for external interface
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(provide provide-public-names)
|
||||
(define-syntax (provide-public-names stx)
|
||||
#'(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-out 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))
|
||||
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; keyword setup
|
||||
;;--------------------------------------------------------------------
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
(module serialize scheme/base
|
||||
(require syntax/modcollapse
|
||||
"serialize-structs.ss")
|
||||
"serialize-structs.ss")
|
||||
|
||||
;; This module implements the core serializer. The syntactic
|
||||
;; `define-serializable-struct' layer is implemented separately
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
|
||||
(module serialize scheme/base
|
||||
(require mzlib/private/serialize
|
||||
(require "private/serialize.ss"
|
||||
(for-syntax scheme/base
|
||||
scheme/struct-info))
|
||||
|
||||
(provide (all-from-out mzlib/private/serialize)
|
||||
(provide (all-from-out "private/serialize.ss")
|
||||
define-serializable-struct
|
||||
define-serializable-struct/versions)
|
||||
|
||||
|
|
|
|||
729
collects/scheme/trait.ss
Normal file
729
collects/scheme/trait.ss
Normal file
|
|
@ -0,0 +1,729 @@
|
|||
(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 "private/classidmap.ss"
|
||||
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)
|
||||
|
||||
;; ----------------------------------------;
|
||||
)
|
||||
|
|
@ -1153,6 +1153,77 @@ Evaluation of a @scheme[mixin] form checks that the
|
|||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section{Object and Class Contracts}
|
||||
|
||||
@defform/subs[
|
||||
#:literals (field opt-> opt->* case-> -> ->* ->d ->d* ->r ->pp ->pp-rest)
|
||||
|
||||
(object-contract member-spec ...)
|
||||
|
||||
([member-spec
|
||||
(method-id method-contract)
|
||||
(field field-id contract-expr)]
|
||||
|
||||
[method-contract
|
||||
(opt-> (required-contract-expr ...)
|
||||
(optional-contract-expr ...)
|
||||
any)
|
||||
(opt-> (required-contract-expr ...)
|
||||
(optional-contract-expr ...)
|
||||
result-contract-expr)
|
||||
(opt->* (required-contract-expr ...)
|
||||
(optional-contract-expr ...)
|
||||
(result-contract-expr ...))
|
||||
(case-> arrow-contract ...)
|
||||
arrow-contract]
|
||||
|
||||
[arrow-contract
|
||||
(-> expr ... res-expr)
|
||||
(-> expr ... (values res-expr ...))
|
||||
(->* (expr ...) (res-expr ...))
|
||||
(->* (expr ...) rest-expr (res-expr ...))
|
||||
(->d expr ... res-proc-expr)
|
||||
(->d* (expr ...) res-proc-expr)
|
||||
(->d* (expr ...) rest-expr res-gen-expr)
|
||||
(->r ((id expr) ...) expr)
|
||||
(->r ((id expr) ...) id expr expr)
|
||||
(->pp ((id expr) ...) pre-expr
|
||||
res-expr res-id post-expr)
|
||||
(->pp ((id expr) ...) pre-expr any)
|
||||
(->pp ((id expr) ...) pre-expr
|
||||
(values (id expr) ...) post-expr)
|
||||
(->pp-rest ((id expr) ...) id expr pre-expr
|
||||
res-expr res-id post-expr)
|
||||
(->pp-rest ((id expr) ...) id expr pre-expr any)
|
||||
(->pp-rest ((id expr) ...) id expr pre-expr
|
||||
(values (id expr) ...) post-expr)])]{
|
||||
|
||||
Produces a contract for an object.
|
||||
|
||||
Each of the contracts for a method has the same semantics as the
|
||||
corresponding function contract, but the syntax of the method contract
|
||||
must be written directly in the body of the object-contract---much
|
||||
like the way that methods in class definitions use the same syntax as
|
||||
regular function definitions, but cannot be arbitrary procedures. The
|
||||
only exception is that the @scheme[->r], @scheme[->pp], and
|
||||
@scheme[->pp-rest] contracts implicitly bind @scheme[this] to the
|
||||
object itself.}
|
||||
|
||||
|
||||
@defthing[mixin-contract contract?]{
|
||||
|
||||
A @tech{function contract} that recognizes mixins. It guarantees that
|
||||
the input to the function is a class and the result of the function is
|
||||
a subclass of the input.}
|
||||
|
||||
@defproc[(make-mixin-contract [type (or/c class? interface?)] ...) contract?]{
|
||||
|
||||
Produces a @tech{function contract} that guarantees the input to the
|
||||
function is a class that implements/subclasses each @scheme[type], and
|
||||
that the result of the function is a subclass of the input.}
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section[#:tag "objectserialize"]{Object Serialization}
|
||||
|
||||
@defform[
|
||||
|
|
|
|||
|
|
@ -619,77 +619,6 @@ lazy contract.}
|
|||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section{Object and Class Contracts}
|
||||
|
||||
@defform/subs[
|
||||
#:literals (field opt-> opt->* case-> -> ->* ->d ->d* ->r ->pp ->pp-rest)
|
||||
|
||||
(object-contract member-spec ...)
|
||||
|
||||
([member-spec
|
||||
(method-id method-contract)
|
||||
(field field-id contract-expr)]
|
||||
|
||||
[method-contract
|
||||
(opt-> (required-contract-expr ...)
|
||||
(optional-contract-expr ...)
|
||||
any)
|
||||
(opt-> (required-contract-expr ...)
|
||||
(optional-contract-expr ...)
|
||||
result-contract-expr)
|
||||
(opt->* (required-contract-expr ...)
|
||||
(optional-contract-expr ...)
|
||||
(result-contract-expr ...))
|
||||
(case-> arrow-contract ...)
|
||||
arrow-contract]
|
||||
|
||||
[arrow-contract
|
||||
(-> expr ... res-expr)
|
||||
(-> expr ... (values res-expr ...))
|
||||
(->* (expr ...) (res-expr ...))
|
||||
(->* (expr ...) rest-expr (res-expr ...))
|
||||
(->d expr ... res-proc-expr)
|
||||
(->d* (expr ...) res-proc-expr)
|
||||
(->d* (expr ...) rest-expr res-gen-expr)
|
||||
(->r ((id expr) ...) expr)
|
||||
(->r ((id expr) ...) id expr expr)
|
||||
(->pp ((id expr) ...) pre-expr
|
||||
res-expr res-id post-expr)
|
||||
(->pp ((id expr) ...) pre-expr any)
|
||||
(->pp ((id expr) ...) pre-expr
|
||||
(values (id expr) ...) post-expr)
|
||||
(->pp-rest ((id expr) ...) id expr pre-expr
|
||||
res-expr res-id post-expr)
|
||||
(->pp-rest ((id expr) ...) id expr pre-expr any)
|
||||
(->pp-rest ((id expr) ...) id expr pre-expr
|
||||
(values (id expr) ...) post-expr)])]{
|
||||
|
||||
Produces a contract for an object (see @secref["mzlib:class"]).
|
||||
|
||||
Each of the contracts for a method has the same semantics as the
|
||||
corresponding function contract, but the syntax of the method contract
|
||||
must be written directly in the body of the object-contract---much
|
||||
like the way that methods in class definitions use the same syntax as
|
||||
regular function definitions, but cannot be arbitrary procedures. The
|
||||
only exception is that the @scheme[->r], @scheme[->pp], and
|
||||
@scheme[->pp-rest] contracts implicitly bind @scheme[this] to the
|
||||
object itself.}
|
||||
|
||||
|
||||
@defthing[mixin-contract contract?]{
|
||||
|
||||
A @tech{function contract} that recognizes mixins. It guarantees that
|
||||
the input to the function is a class and the result of the function is
|
||||
a subclass of the input.}
|
||||
|
||||
@defproc[(make-mixin-contract [type (or/c class? interface?)] ...) contract?]{
|
||||
|
||||
Produces a @tech{function contract} that guarantees the input to the
|
||||
function is a class that implements/subclasses each @scheme[type], and
|
||||
that the result of the function is a subclass of the input.}
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section{Attaching Contracts to Values}
|
||||
|
||||
@defform/subs[
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -111,6 +111,11 @@ in several significant ways:
|
|||
- Windows console binary names are converted like Unix binary names:
|
||||
downcased with " " replaced by "-".
|
||||
|
||||
- The contract library (in scheme/contract) no longer
|
||||
exports object or mixin contracts. Instead they are
|
||||
exported from scheme/class. (The libraries in mzlib
|
||||
remain the same as before.)
|
||||
|
||||
======================================================================
|
||||
Immutable and Mutable Pairs
|
||||
======================================================================
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user