suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
14ab0175c3
racket/collects/scheme/private/class-internal.ss
Stevie Strickland 14ab0175c3 Okay, expanding field accesses and mutations to basically inline the 
unwrapping operation helps a bit, especially with inherited fields.
Unfortunately, as one might expect, TANSTAAFL applies here.  In order
to make sure that we keep the contracted objects around as much as
possible to make sure there are no holes, we end up making local and
inherited field access codes 2-3x more than they did before.  However,
this is still something on the order of 5x faster than external
access.  But blah.

CONTRACTS ARE NOT FREE.  Just ask your local lawyer.

svn: r18285
2010-02-23 03:15:43 +00:00

4611 lines
229 KiB
Scheme
Raw Blame History

#lang scheme/base
(require (for-syntax scheme/base)
mzlib/etc
scheme/contract/base
(only-in scheme/contract/private/arrow making-a-method)
scheme/list
scheme/stxparam
"class-events.ss"
"serialize-structs.ss"
(for-syntax scheme/stxparam
syntax/kerncase
syntax/stx
syntax/name
syntax/context
syntax/define
syntax/flatten-begin
syntax/private/boundmap
"classidmap.ss"))
(define insp (current-inspector)) ; for all opaque structures
;;--------------------------------------------------------------------
;; spec for external interface
;;--------------------------------------------------------------------
(provide provide-public-names
;; needed for Typed Scheme
(protect-out do-make-object find-method/who))
(define-syntax-rule (provide-public-names)
(provide class class* class/derived
define-serializable-class define-serializable-class*
class?
mixin
interface interface* interface?
object% object? externalizable<%> printable<%> equal<%>
object=?
new make-object instantiate
send send/apply send* class-field-accessor class-field-mutator with-method
get-field set-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
class/c ->m ->*m object/c
;; "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 this% super inner
super-make-object super-instantiate super-new
inspect))
;;--------------------------------------------------------------------
;; keyword setup
;;--------------------------------------------------------------------
(define-for-syntax (do-class-keyword stx)
(if (identifier? stx)
(raise-syntax-error
#f
"illegal (unparenthesized) use of a class keyword"
stx)
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
stx)))
(define-syntax provide-class-keyword
(syntax-rules ()
[(_ id ...)
(begin
(define-syntax (id stx) (do-class-keyword stx))
...
(provide id ...))]))
(provide-class-keyword private public override augride
pubment overment augment
public-final override-final augment-final
rename-super rename-inner inherit inherit-field
inherit/super inherit/inner
inspect
init-rest)
(define-for-syntax (do-define-like-internal stx)
(syntax-case stx ()
[(_ orig . __)
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
#'orig)]))
(define-for-syntax (do-define-like stx internal-id)
(syntax-case stx ()
[(_ elem ...)
(syntax-property
#`(#,internal-id #,stx
#,@(map (lambda (e)
(if (identifier? e)
e
(syntax-property
(syntax-case e ()
[((n1 n2) . expr)
(quasisyntax/loc e
(#,(syntax-property
#'(n1 n2)
'certify-mode 'transparent)
. expr))]
[_else e])
'certify-mode 'transparent)))
(syntax-e #'(elem ...))))
'certify-mode
'transparent)]
[(_ . elems)
#`(#,internal-id #,stx . elems)]
[_else
(raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)]))
(define-syntax provide-class-define-like-keyword
(syntax-rules ()
[(_ [internal-id id] ...)
(begin
(define-syntax (internal-id stx) (do-define-like-internal stx))
...
(define-syntax (id stx) (do-define-like stx #'internal-id))
...
(provide id ...))]))
(provide-class-define-like-keyword
[-field field]
[-init init]
[-init-field init-field])
(define-for-syntax not-in-a-class
(lambda (stx)
(if (eq? (syntax-local-context) 'expression)
(raise-syntax-error
#f
"use of a class keyword is not in a class"
stx)
(quasisyntax/loc stx (#%expression #,stx)))))
(define-syntax define/provide-context-keyword
(syntax-rules ()
[(_ (id param-id) ...)
(begin
(begin
(provide id)
(define-syntax-parameter param-id
(make-set!-transformer not-in-a-class))
(define-syntax id
(make-parameter-rename-transformer #'param-id)))
...)]))
(define/provide-context-keyword
[this this-param]
[this% this%-param]
[super super-param]
[inner inner-param]
[super-make-object super-make-object-param]
[super-instantiate super-instantiate-param]
[super-new super-new-param])
;;--------------------------------------------------------------------
;; local member name lookup
;;--------------------------------------------------------------------
(define-for-syntax (localize orig-id)
(do-localize orig-id #'validate-local-member))
(define (validate-local-member orig s)
(if (symbol? s)
s
(error 'local-member-name
"used before its definition: ~a"
orig)))
;;--------------------------------------------------------------------
;; object wrapper for contracts
;;--------------------------------------------------------------------
(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
(let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
(make-struct-type 'raw-wrapper-object
#f
1
0)])
(values wrapper-object?
(lambda (v) (ref v 0))
(lambda (o v) (set! o 0 v))
struct:wrapper-object)))
;; unwrap-object : (union wrapper-object object) -> object
;; wrapped objects can only be one level deep, so just do a quick check and unwrap.
(define (unwrap-object o)
(if (wrapper-object? o) (wrapper-object-wrapped o) o))
;;--------------------------------------------------------------------
;; class macros
;;--------------------------------------------------------------------
(define-syntaxes (class* _class class/derived
class*-traced class-traced class/derived-traced)
(let ()
;; Start with Helper functions
(define (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)
(let* ([stop-forms
(append
(kernel-form-identifier-list)
(list
(quote-syntax #%app) ; scheme/base app, as opposed to #%plain-app
(quote-syntax lambda) ; scheme/base lambda, as opposed to #%plain-lambda
(quote-syntax -init)
(quote-syntax init-rest)
(quote-syntax -field)
(quote-syntax -init-field)
(quote-syntax inherit-field)
(quote-syntax private)
(quote-syntax public)
(quote-syntax override)
(quote-syntax augride)
(quote-syntax public-final)
(quote-syntax override-final)
(quote-syntax augment-final)
(quote-syntax pubment)
(quote-syntax overment)
(quote-syntax augment)
(quote-syntax rename-super)
(quote-syntax inherit)
(quote-syntax inherit/super)
(quote-syntax inherit/inner)
(quote-syntax rename-inner)
(quote-syntax super)
(quote-syntax inner)
(quote-syntax this)
(quote-syntax this%)
(quote-syntax super-instantiate)
(quote-syntax super-make-object)
(quote-syntax super-new)
(quote-syntax inspect)))]
[expand-context (generate-class-expand-context)]
[expand
(lambda (defn-or-expr)
(local-expand
defn-or-expr
expand-context
stop-forms
def-ctx))])
(let loop ([l defn-and-exprs])
(if (null? l)
null
(let ([e (expand (car l))])
(syntax-case e (begin define-syntaxes define-values)
[(begin . _)
(loop (append
(flatten-begin e)
(cdr l)))]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(begin
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
(cons #'(define-syntaxes (id ...) rhs) (loop (cdr l)))))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(begin
(map bind-local-id (syntax->list #'(id ...)))
(cons e (loop (cdr l))))]
[(begin . _)
(raise-syntax-error
#f
"ill-formed begin expression"
e)]
[_else (cons e (loop (cdr l)))]))))))
;; returns two lists: expressions that start with an identifier in
;; `kws', and expressions that don't
(define (extract kws l out-cons)
(let loop ([l l])
(if (null? l)
(values null null)
(let-values ([(in out) (loop (cdr l))])
(cond
[(and (stx-pair? (car l))
(let ([id (stx-car (car l))])
(and (identifier? id)
(ormap (lambda (k) (free-identifier=? k id)) kws))))
(values (cons (car l) in) out)]
[else
(values in (out-cons (car l) out))])))))
(define (extract* kws l)
(let-values ([(in out) (extract kws l void)])
in))
(define (flatten alone l)
(apply append
(map (lambda (i)
(let ([l (let ([l (syntax->list i)])
(if (ormap (lambda (i)
(free-identifier=? (car l) i))
(syntax-e (quote-syntax (-init -init-field -field))))
(cddr l)
(cdr l)))])
(if alone
(map (lambda (i)
(if (identifier? i)
(alone i)
(cons (stx-car i)
(stx-car (stx-cdr i)))))
l)
l)))
l)))
;; Used with flatten:
(define (pair i) (cons i i))
(define (normalize-init/field i)
;; Put i in ((iid eid) optional-expr) form
(cond
[(identifier? i) (list (list i i))]
[else (let ([a (stx-car i)])
(if (identifier? a)
(cons (list a a) (stx-cdr i))
i))]))
(define (norm-init/field-iid norm) (stx-car (stx-car norm)))
(define (norm-init/field-eid norm) (stx-car (stx-cdr (stx-car norm))))
;; expands an expression enough that we can check whether it has
;; the right form for a method; must use local syntax definitions
(define (proc-shape name orig-stx xform?
the-obj the-finder
bad class-name expand-stop-names
def-ctx lookup-localize)
(define (expand expr locals)
(local-expand
expr
'expression
(append locals (list #'lambda #'λ) expand-stop-names)
def-ctx))
;; Checks whether the vars sequence is well-formed
(define (vars-ok? vars)
(or (identifier? vars)
(stx-null? vars)
(and (stx-pair? vars)
(identifier? (stx-car vars))
(vars-ok? (stx-cdr vars)))))
(define (kw-vars-ok? vars)
(or (identifier? vars)
(stx-null? vars)
(and (stx-pair? vars)
(let ([a (stx-car vars)]
[opt-arg-ok?
(lambda (a)
(or (identifier? a)
(and (stx-pair? a)
(identifier? (stx-car a))
(stx-pair? (stx-cdr a))
(stx-null? (stx-cdr (stx-cdr a))))))])
(or (and (opt-arg-ok? a)
(kw-vars-ok? (stx-cdr vars)))
(and (keyword? (syntax-e a))
(stx-pair? (stx-cdr vars))
(opt-arg-ok? (stx-car (stx-cdr vars)))
(kw-vars-ok? (stx-cdr (stx-cdr vars)))))))))
;; mk-name: constructs a method name
;; for error reporting, etc.
(define (mk-name name)
(datum->syntax
#f
(string->symbol (format "~a method~a~a"
(syntax-e name)
(if class-name
" in "
"")
(or class-name
"")))
#f))
;; -- tranform loop starts here --
(let loop ([stx orig-stx][can-expand? #t][name name][locals null])
(syntax-case stx (#%plain-lambda lambda λ case-lambda letrec-values let-values)
[(lam vars body1 body ...)
(or (and (free-identifier=? #'lam #'#%plain-lambda)
(vars-ok? (syntax vars)))
(and (or (free-identifier=? #'lam #'lambda)
(free-identifier=? #'lam #'λ))
(kw-vars-ok? (syntax vars))))
(if xform?
(with-syntax ([the-obj the-obj]
[the-finder the-finder]
[name (mk-name name)])
(with-syntax ([vars (if (or (free-identifier=? #'lam #'lambda)
(free-identifier=? #'lam #'λ))
(let loop ([vars #'vars])
(cond
[(identifier? vars) vars]
[(syntax? vars)
(datum->syntax vars
(loop (syntax-e vars))
vars
vars)]
[(pair? vars)
(syntax-case (car vars) ()
[(id expr)
(identifier? #'id)
;; optional argument; need to wrap arg expression
(cons
(with-syntax ([expr (syntax/loc #'expr
(let-syntax ([the-finder (quote-syntax the-obj)])
(#%expression expr)))])
(syntax/loc (car vars)
(id expr)))
(loop (cdr vars)))]
[_ (cons (car vars) (loop (cdr vars)))])]
[else vars]))
#'vars)])
(let ([l (syntax/loc stx
(lambda (the-obj . vars)
(let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)))])
(with-syntax ([l (recertify (add-method-property l) stx)])
(syntax/loc stx
(let ([name l]) name))))))
stx)]
[(#%plain-lambda . _)
(bad "ill-formed lambda expression for method" stx)]
[(lambda . _)
(bad "ill-formed lambda expression for method" stx)]
[(λ . _)
(bad "ill-formed lambda expression for method" stx)]
[(case-lambda [vars body1 body ...] ...)
(andmap vars-ok? (syntax->list (syntax (vars ...))))
(if xform?
(with-syntax ([the-obj the-obj]
[the-finder the-finder]
[name (mk-name name)])
(let ([cl (syntax/loc stx
(case-lambda [(the-obj . vars)
(let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)] ...))])
(with-syntax ([cl (recertify (add-method-property cl) stx)])
(syntax/loc stx
(let ([name cl]) name)))))
stx)]
[(case-lambda . _)
(bad "ill-formed case-lambda expression for method" stx)]
[(let- ([(id) expr] ...) let-body)
(and (or (free-identifier=? (syntax let-)
(quote-syntax let-values))
(free-identifier=? (syntax let-)
(quote-syntax letrec-values)))
(andmap identifier? (syntax->list (syntax (id ...)))))
(let* ([letrec? (free-identifier=? (syntax let-)
(quote-syntax letrec-values))]
[ids (syntax->list (syntax (id ...)))]
[new-ids (if xform?
(map
(lambda (id)
(datum->syntax
#f
(gensym (syntax-e id))))
ids)
ids)]
[body-locals (append ids locals)]
[exprs (map (lambda (expr id)
(loop expr #t id (if letrec?
body-locals
locals)))
(syntax->list (syntax (expr ...)))
ids)]
[body (let ([body (syntax let-body)])
(if (identifier? body)
(ormap (lambda (id new-id)
(and (bound-identifier=? body id)
new-id))
ids new-ids)
(loop body #t name body-locals)))])
(unless body
(bad "bad form for method definition" orig-stx))
(with-syntax ([(proc ...) exprs]
[(new-id ...) new-ids]
[mappings
(if xform?
(map
(lambda (old-id new-id)
(with-syntax ([old-id old-id]
[old-id-localized (lookup-localize (localize old-id))]
[new-id new-id]
[the-obj the-obj]
[the-finder the-finder])
(syntax (old-id (make-direct-method-map
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax old-id)
(quote-syntax old-id-localized)
(quote new-id))))))
ids new-ids)
null)]
[body body])
(recertify
(if xform?
(if letrec?
(syntax/loc stx (letrec-syntax mappings
(let- ([(new-id) proc] ...)
body)))
(syntax/loc stx (let- ([(new-id) proc] ...)
(letrec-syntax mappings
body))))
(syntax/loc stx (let- ([(new-id) proc] ...)
body)))
stx)))]
[_else
(if can-expand?
(loop (expand stx locals) #f name locals)
(bad "bad form for method definition" orig-stx))])))
(define (add-method-property l)
(syntax-property l 'method-arity-error #t))
(define method-insp (current-code-inspector))
(define (recertify new old)
(syntax-recertify new old method-insp #f))
;; --------------------------------------------------------------------------------
;; Start here:
(define (main stx trace-flag super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
(let-values ([(this-id) #'this-id]
[(the-obj) (datum->syntax (quote-syntax here) (gensym 'self))]
[(the-finder) (datum->syntax (quote-syntax here) (gensym 'find-self))])
(let* ([def-ctx (syntax-local-make-definition-context)]
[localized-map (make-bound-identifier-mapping)]
[any-localized? #f]
[localize/set-flag (lambda (id)
(let ([id2 (localize id)])
(unless (eq? id id2)
(set! any-localized? #t))
id2))]
[bind-local-id (lambda (id)
(let ([l (localize/set-flag id)])
(syntax-local-bind-syntaxes (list id) #f def-ctx)
(bound-identifier-mapping-put!
localized-map
id
l)))]
[lookup-localize (lambda (id)
(bound-identifier-mapping-get
localized-map
id
(lambda ()
;; If internal & external names are distinguished,
;; we need to fall back to localize:
(localize id))))])
;; ----- Expand definitions -----
(let ([defn-and-exprs (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)]
[bad (lambda (msg expr)
(raise-syntax-error #f msg stx expr))]
[class-name (if name-id
(syntax-e name-id)
(let ([s (syntax-local-infer-name stx)])
(if (syntax? s)
(syntax-e s)
s)))])
;; ------ Basic syntax checks -----
(for-each (lambda (stx)
(syntax-case stx (-init init-rest -field -init-field inherit-field
private public override augride
public-final override-final augment-final
pubment overment augment
rename-super inherit inherit/super inherit/inner rename-inner
inspect)
[(form orig idp ...)
(and (identifier? (syntax form))
(or (free-identifier=? (syntax form) (quote-syntax -init))
(free-identifier=? (syntax form) (quote-syntax -init-field))))
(let ([form (syntax-e (stx-car (syntax orig)))])
(for-each
(lambda (idp)
(syntax-case idp ()
[id (identifier? (syntax id)) 'ok]
[((iid eid)) (and (identifier? (syntax iid))
(identifier? (syntax eid))) 'ok]
[(id expr) (identifier? (syntax id)) 'ok]
[((iid eid) expr) (and (identifier? (syntax iid))
(identifier? (syntax eid))) 'ok]
[else
(bad
(format
"~a element is not an optionally renamed identifier or identifier-expression pair"
form)
idp)]))
(syntax->list (syntax (idp ...)))))]
[(inspect expr)
'ok]
[(inspect . rest)
(bad "ill-formed inspect clause" stx)]
[(-init orig . rest)
(bad "ill-formed init clause" #'orig)]
[(init-rest)
'ok]
[(init-rest rest)
(identifier? (syntax rest))
'ok]
[(init-rest . rest)
(bad "ill-formed init-rest clause" stx)]
[(-init-field orig . rest)
(bad "ill-formed init-field clause" #'orig)]
[(-field orig idp ...)
(for-each (lambda (idp)
(syntax-case idp ()
[(id expr) (identifier? (syntax id)) 'ok]
[((iid eid) expr) (and (identifier? (syntax iid))
(identifier? (syntax eid)))
'ok]
[else
(bad
"field element is not an optionally renamed identifier-expression pair"
idp)]))
(syntax->list (syntax (idp ...))))]
[(-field orig . rest)
(bad "ill-formed field clause" #'orig)]
[(private id ...)
(for-each
(lambda (id)
(unless (identifier? id)
(bad "private element is not an identifier" id)))
(syntax->list (syntax (id ...))))]
[(private . rest)
(bad "ill-formed private clause" stx)]
[(form idp ...)
(and (identifier? (syntax form))
(ormap (lambda (f) (free-identifier=? (syntax form) f))
(syntax-e (quote-syntax (public
override
augride
public-final
override-final
augment-final
pubment
overment
augment
inherit
inherit/super
inherit/inner
inherit-field)))))
(let ([form (syntax-e (syntax form))])
(for-each
(lambda (idp)
(syntax-case idp ()
[id (identifier? (syntax id)) 'ok]
[(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok]
[else
(bad
(format
"~a element is not an identifier or pair of identifiers"
form)
idp)]))
(syntax->list (syntax (idp ...)))))]
[(public . rest)
(bad "ill-formed public clause" stx)]
[(override . rest)
(bad "ill-formed override clause" stx)]
[(augride . rest)
(bad "ill-formed augride clause" stx)]
[(public-final . rest)
(bad "ill-formed public-final clause" stx)]
[(override-final . rest)
(bad "ill-formed override-final clause" stx)]
[(augment-final . rest)
(bad "ill-formed augment-final clause" stx)]
[(pubment . rest)
(bad "ill-formed pubment clause" stx)]
[(overment . rest)
(bad "ill-formed overment clause" stx)]
[(augment . rest)
(bad "ill-formed augment clause" stx)]
[(inherit . rest)
(bad "ill-formed inherit clause" stx)]
[(inherit/super . rest)
(bad "ill-formed inherit/super clause" stx)]
[(inherit/inner . rest)
(bad "ill-formed inherit/inner clause" stx)]
[(inherit-field . rest)
(bad "ill-formed inherit-field clause" stx)]
[(kw idp ...)
(and (identifier? #'kw)
(or (free-identifier=? #'rename-super #'kw)
(free-identifier=? #'rename-inner #'kw)))
(for-each
(lambda (idp)
(syntax-case idp ()
[(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok]
[else
(bad
(format "~a element is not a pair of identifiers" (syntax-e #'kw))
idp)]))
(syntax->list (syntax (idp ...))))]
[(rename-super . rest)
(bad "ill-formed rename-super clause" stx)]
[(rename-inner . rest)
(bad "ill-formed rename-inner clause" stx)]
[_ 'ok]))
defn-and-exprs)
;; ----- Sort body into different categories -----
(let*-values ([(decls exprs)
(extract (syntax-e (quote-syntax (inherit-field
private
public
override
augride
public-final
override-final
augment-final
pubment
overment
augment
rename-super
inherit
inherit/super
inherit/inner
rename-inner)))
defn-and-exprs
cons)]
[(inspect-decls exprs)
(extract (list (quote-syntax inspect))
exprs
cons)]
[(plain-inits)
;; Normalize after, but keep un-normal for error reporting
(flatten #f (extract* (syntax-e
(quote-syntax (-init init-rest)))
exprs))]
[(normal-plain-inits) (map normalize-init/field plain-inits)]
[(init-rest-decls _)
(extract (list (quote-syntax init-rest))
exprs
void)]
[(inits)
(flatten #f (extract* (syntax-e
(quote-syntax (-init -init-field)))
exprs))]
[(normal-inits)
(map normalize-init/field inits)]
[(plain-fields)
(flatten #f (extract* (list (quote-syntax -field)) exprs))]
[(normal-plain-fields)
(map normalize-init/field plain-fields)]
[(plain-init-fields)
(flatten #f (extract* (list (quote-syntax -init-field)) exprs))]
[(normal-plain-init-fields)
(map normalize-init/field plain-init-fields)]
[(inherit-fields)
(flatten pair (extract* (list (quote-syntax inherit-field)) decls))]
[(privates)
(flatten pair (extract* (list (quote-syntax private)) decls))]
[(publics)
(flatten pair (extract* (list (quote-syntax public)) decls))]
[(overrides)
(flatten pair (extract* (list (quote-syntax override)) decls))]
[(augrides)
(flatten pair (extract* (list (quote-syntax augride)) decls))]
[(public-finals)
(flatten pair (extract* (list (quote-syntax public-final)) decls))]
[(override-finals)
(flatten pair (extract* (list (quote-syntax override-final)) decls))]
[(pubments)
(flatten pair (extract* (list (quote-syntax pubment)) decls))]
[(overments)
(flatten pair (extract* (list (quote-syntax overment)) decls))]
[(augments)
(flatten pair (extract* (list (quote-syntax augment)) decls))]
[(augment-finals)
(flatten pair (extract* (list (quote-syntax augment-final)) decls))]
[(rename-supers)
(flatten pair (extract* (list (quote-syntax rename-super)) decls))]
[(inherits)
(flatten pair (extract* (list (quote-syntax inherit)) decls))]
[(inherit/supers)
(flatten pair (extract* (list (quote-syntax inherit/super)) decls))]
[(inherit/inners)
(flatten pair (extract* (list (quote-syntax inherit/inner)) decls))]
[(rename-inners)
(flatten pair (extract* (list (quote-syntax rename-inner)) decls))])
;; At most one inspect:
(unless (or (null? inspect-decls)
(null? (cdr inspect-decls)))
(bad "multiple inspect clauses" (cadr inspect-decls)))
;; At most one init-rest:
(unless (or (null? init-rest-decls)
(null? (cdr init-rest-decls)))
(bad "multiple init-rest clauses" (cadr init-rest-decls)))
;; Make sure init-rest is last
(unless (null? init-rest-decls)
(let loop ([l exprs] [saw-rest? #f])
(unless (null? l)
(cond
[(and (stx-pair? (car l))
(identifier? (stx-car (car l))))
(let ([form (stx-car (car l))])
(cond
[(free-identifier=? #'init-rest form)
(loop (cdr l) #t)]
[(not saw-rest?) (loop (cdr l) #f)]
[(free-identifier=? #'-init form)
(bad "init clause follows init-rest clause" (stx-car (stx-cdr (car l))))]
[(free-identifier=? #'-init-field form)
(bad "init-field clause follows init-rest clause" (stx-car (stx-cdr (car l))))]
[else (loop (cdr l) #t)]))]
[else (loop (cdr l) saw-rest?)]))))
;; --- Check initialization on inits: ---
(let loop ([inits inits] [normal-inits normal-inits])
(unless (null? normal-inits)
(if (stx-null? (stx-cdr (car normal-inits)))
(loop (cdr inits)(cdr normal-inits))
(let loop ([inits (cdr inits)] [normal-inits (cdr normal-inits)])
(unless (null? inits)
(if (stx-null? (stx-cdr (car normal-inits)))
(bad "initializer without default follows an initializer with default"
(car inits))
(loop (cdr inits) (cdr normal-inits))))))))
;; ----- Extract method definitions; check that they look like procs -----
;; Optionally transform them, can expand even if not transforming.
(let* ([field-names (map norm-init/field-iid
(append normal-plain-fields normal-plain-init-fields))]
[inherit-field-names (map car inherit-fields)]
[plain-init-names (map norm-init/field-iid normal-plain-inits)]
[inherit-names (map car inherits)]
[inherit/super-names (map car inherit/supers)]
[inherit/inner-names (map car inherit/inners)]
[rename-super-names (map car rename-supers)]
[rename-inner-names (map car rename-inners)]
[local-public-dynamic-names (map car (append publics overrides augrides
overments augments
override-finals augment-finals))]
[local-public-names (append (map car (append pubments public-finals))
local-public-dynamic-names)]
[local-method-names (append (map car privates) local-public-names)]
[expand-stop-names (append
local-method-names
field-names
inherit-field-names
plain-init-names
inherit-names
inherit/super-names
inherit/inner-names
rename-super-names
rename-inner-names
(kernel-form-identifier-list))])
;; Do the extraction:
(let-values ([(methods ; (listof (cons id stx))
private-methods ; (listof (cons id stx))
exprs ; (listof stx)
stx-defines) ; (listof (cons (listof id) stx))
(let loop ([exprs exprs][ms null][pms null][es null][sd null])
(if (null? exprs)
(values (reverse ms) (reverse pms) (reverse es) (reverse sd))
(syntax-case (car exprs) (define-values define-syntaxes)
[(define-values (id ...) expr)
(let ([ids (syntax->list (syntax (id ...)))])
;; Check form:
(for-each (lambda (id)
(unless (identifier? id)
(bad "not an identifier for definition" id)))
ids)
;; method defn? (id in the list of privates/publics/overrides/augrides?)
(if (ormap (lambda (id)
(ormap (lambda (i) (bound-identifier=? i id))
local-method-names))
ids)
;; Yes, it's a method:
(begin
(unless (null? (cdr ids))
(bad "each method variable needs its own definition"
(car exprs)))
(let ([expr (proc-shape #f (syntax expr) #f
the-obj the-finder
bad class-name expand-stop-names
def-ctx lookup-localize)]
[public? (ormap (lambda (i)
(bound-identifier=? i (car ids)))
local-public-names)])
(loop (cdr exprs)
(if public?
(cons (cons (car ids) expr) ms)
ms)
(if public?
pms
(cons (cons (car ids) expr) pms))
es
sd)))
;; Non-method defn:
(loop (cdr exprs) ms pms (cons (car exprs) es) sd)))]
[(define-values . _)
(bad "ill-formed definition" (car exprs))]
[(define-syntaxes (id ...) expr)
(let ([ids (syntax->list (syntax (id ...)))])
(for-each (lambda (id) (unless (identifier? id)
(bad "syntax name is not an identifier" id)))
ids)
(loop (cdr exprs) ms pms es (cons (cons ids (car exprs)) sd)))]
[(define-syntaxes . _)
(bad "ill-formed syntax definition" (car exprs))]
[_else
(loop (cdr exprs) ms pms (cons (car exprs) es) sd)])))])
;; ---- Extract all defined names, including field accessors and mutators ---
(let ([defined-syntax-names (apply append (map car stx-defines))]
[defined-method-names (append (map car methods)
(map car private-methods))]
[private-field-names (let loop ([l exprs])
(if (null? l)
null
(syntax-case (car l) (define-values)
[(define-values (id ...) expr)
(append (syntax->list (syntax (id ...)))
(loop (cdr l)))]
[_else (loop (cdr l))])))]
[init-mode (cond
[(null? init-rest-decls) 'normal]
[(stx-null? (stx-cdr (car init-rest-decls))) 'stop]
[else 'list])])
;; -- Look for duplicates --
(let ([dup (check-duplicate-identifier
(append defined-syntax-names
defined-method-names
private-field-names
field-names
inherit-field-names
plain-init-names
inherit-names
inherit/super-names
inherit/inner-names
rename-super-names
rename-inner-names))])
(when dup
(bad "duplicate declared identifier" dup)))
;; -- Could still have duplicates within private/public/override/augride --
(let ([dup (check-duplicate-identifier local-method-names)])
(when dup
(bad "duplicate declared identifier" dup)))
;; -- Check for duplicate external method names, init names, or field names
(let ([check-dup
(lambda (what l)
(let ([ht (make-hasheq)])
(for-each (lambda (id)
(when (hash-ref ht (syntax-e id) #f)
(bad (format "duplicate declared external ~a name" what) id))
(hash-set! ht (syntax-e id) #t))
l)))])
;; method names
(check-dup "method" (map cdr (append publics overrides augrides
pubments overments augments
public-finals override-finals augment-finals)))
;; inits
(check-dup "init" (map norm-init/field-eid (append normal-inits)))
;; fields
(check-dup "field" (map norm-init/field-eid (append normal-plain-fields normal-plain-init-fields))))
;; -- Check that private/public/override/augride are defined --
(let ([ht (make-hasheq)]
[stx-ht (make-hasheq)])
(for-each
(lambda (defined-name)
(let ([l (hash-ref ht (syntax-e defined-name) null)])
(hash-set! ht (syntax-e defined-name) (cons defined-name l))))
defined-method-names)
(for-each
(lambda (defined-name)
(let ([l (hash-ref stx-ht (syntax-e defined-name) null)])
(hash-set! stx-ht (syntax-e defined-name) (cons defined-name l))))
defined-syntax-names)
(for-each
(lambda (pubovr-name)
(let ([l (hash-ref ht (syntax-e pubovr-name) null)])
(unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
;; Either undefined or defined as syntax:
(let ([stx-l (hash-ref stx-ht (syntax-e pubovr-name) null)])
(if (ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l)
(bad
"method declared but defined as syntax"
pubovr-name)
(bad
"method declared but not defined"
pubovr-name))))))
local-method-names))
;; ---- Check that rename-inner doesn't have a non-final decl ---
(unless (null? rename-inners)
(let ([ht (make-hasheq)])
(for-each (lambda (pub)
(hash-set! ht (syntax-e (cdr pub)) #t))
(append publics public-finals overrides override-finals augrides))
(for-each (lambda (inn)
(when (hash-ref ht (syntax-e (cdr inn)) #f)
(bad
"inner method is locally declared as public, override, public-final, override-final, or augride"
(cdr inn))))
rename-inners)))
;; ---- Convert expressions ----
;; Non-method definitions to set!
;; Initializations args access/set!
(let ([exprs (map (lambda (e)
(syntax-case e (define-values -field init-rest)
[(define-values (id ...) expr)
(syntax/loc e (set!-values (id ...) expr))]
[(_init orig idp ...)
(and (identifier? (syntax _init))
(ormap (lambda (it)
(free-identifier=? it (syntax _init)))
(syntax-e (quote-syntax (-init
-init-field)))))
(let* ([norms (map normalize-init/field
(syntax->list (syntax (idp ...))))]
[iids (map norm-init/field-iid norms)]
[exids (map norm-init/field-eid norms)])
(with-syntax ([(id ...) iids]
[(idpos ...) (map localize/set-flag exids)]
[(defval ...)
(map (lambda (norm)
(if (stx-null? (stx-cdr norm))
(syntax #f)
(with-syntax ([defexp (stx-car (stx-cdr norm))])
(syntax (lambda () defexp)))))
norms)]
[class-name class-name])
(syntax/loc e
(begin
1 ; to ensure a non-empty body
(set! id (extract-arg 'class-name `idpos init-args defval))
...))))]
[(-field orig idp ...)
(with-syntax ([(((iid eid) expr) ...)
(map normalize-init/field (syntax->list #'(idp ...)))])
(syntax/loc e (begin
1 ; to ensure a non-empty body
(set! iid expr)
...)))]
[(init-rest id/rename)
(with-syntax ([n (+ (length plain-inits)
(length plain-init-fields)
-1)]
[id (if (identifier? #'id/rename)
#'id/rename
(stx-car #'id/rename))])
(syntax/loc e (set! id (extract-rest-args n init-args))))]
[(init-rest)
(syntax (void))]
[_else e]))
exprs)]
[mk-method-temp
(lambda (id-stx)
(datum->syntax (quote-syntax here)
(gensym (syntax-e id-stx))))]
[rename-super-extras (append overments overrides override-finals inherit/supers)]
[rename-inner-extras (append pubments overments augments inherit/inners)]
[all-rename-inners (append (map car rename-inners)
(generate-temporaries (map car pubments))
(generate-temporaries (map car overments))
(generate-temporaries (map car augments))
(generate-temporaries (map car inherit/inners)))]
[all-inherits (append inherits inherit/supers inherit/inners)]
[definify (lambda (l)
(map bind-local-id l)
l)])
;; ---- set up field and method mappings ----
(with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))]
[(rename-super-orig-localized ...) (map lookup-localize (map car rename-supers))]
[(rename-super-extra-orig ...) (map car rename-super-extras)]
[(rename-super-temp ...) (definify (generate-temporaries (map car rename-supers)))]
[(rename-super-extra-temp ...) (generate-temporaries (map car rename-super-extras))]
[(rename-inner-orig ...) (definify (map car rename-inners))]
[(rename-inner-orig-localized ...) (map lookup-localize (map car rename-inners))]
[(rename-inner-extra-orig ...) (map car rename-inner-extras)]
[(rename-inner-temp ...) (generate-temporaries (map car rename-inners))]
[(rename-inner-extra-temp ...) (generate-temporaries (map car rename-inner-extras))]
[(private-name ...) (map car privates)]
[(private-name-localized ...) (map lookup-localize (map car privates))]
[(private-temp ...) (map mk-method-temp (map car privates))]
[(pubment-name ...) (map car pubments)]
[(pubment-name-localized ...) (map lookup-localize (map car pubments))]
[(pubment-temp ...) (map
mk-method-temp
(map car pubments))]
[(public-final-name ...) (map car public-finals)]
[(public-final-name-localized ...) (map lookup-localize (map car public-finals))]
[(public-final-temp ...) (map
mk-method-temp
(map car public-finals))]
[(method-name ...) (append local-public-dynamic-names
(map car all-inherits))]
[(method-name-localized ...) (map lookup-localize
(append local-public-dynamic-names
(map car all-inherits)))]
[(method-accessor ...) (generate-temporaries
(map car
(append publics overrides augrides
overments augments
override-finals augment-finals
all-inherits)))]
[(inherit-field-accessor ...) (generate-temporaries
(map (lambda (id)
(format "get-~a"
(syntax-e id)))
inherit-field-names))]
[(inherit-field-mutator ...) (generate-temporaries
(map (lambda (id)
(format "set-~a!"
(syntax-e id)))
inherit-field-names))]
[(inherit-name ...) (definify (map car all-inherits))]
[(inherit-field-name ...) (definify inherit-field-names)]
[(inherit-field-name-localized ...) (map lookup-localize inherit-field-names)]
[(local-field ...) (definify
(append field-names
private-field-names))]
[(local-field-localized ...) (map lookup-localize
(append field-names
private-field-names))]
[(local-field-pos ...) (let loop ([pos 0][l (append field-names
private-field-names)])
(if (null? l)
null
(cons pos (loop (add1 pos) (cdr l)))))]
[(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))]
[(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))]
[(plain-init-name ...) (definify plain-init-names)]
[(plain-init-name-localized ...) (map lookup-localize plain-init-names)]
[(local-plain-init-name ...) (generate-temporaries plain-init-names)])
(let ([mappings
;; make-XXX-map is supplied by private/classidmap.ss
(with-syntax ([the-obj the-obj]
[the-finder the-finder]
[this-id this-id]
[trace-flag (if trace-flag (syntax #t) (syntax #f))])
(syntax
([(inherit-field-name ...
local-field ...
rename-super-orig ...
rename-inner-orig ...
method-name ...
private-name ...
public-final-name ...
pubment-name ...)
(values
(make-field-map trace-flag
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax unwrap-object)
(quote-syntax inherit-field-name)
(quote-syntax inherit-field-name-localized)
(quote-syntax inherit-field-accessor)
(quote-syntax inherit-field-mutator)
'())
...
(make-field-map trace-flag
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax unwrap-object)
(quote-syntax local-field)
(quote-syntax local-field-localized)
(quote-syntax local-field-accessor)
(quote-syntax local-field-mutator)
'())
...
(make-rename-super-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax rename-super-orig)
(quote-syntax rename-super-orig-localized)
(quote-syntax rename-super-temp))
...
(make-rename-inner-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax rename-inner-orig)
(quote-syntax rename-inner-orig-localized)
(quote-syntax rename-inner-temp))
...
(make-method-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax method-name)
(quote-syntax method-name-localized)
(quote-syntax method-accessor))
...
(make-direct-method-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax private-name)
(quote-syntax private-name-localized)
(quote private-temp))
...
(make-direct-method-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax public-final-name)
(quote-syntax public-final-name-localized)
(quote public-final-temp))
...
(make-direct-method-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax pubment-name)
(quote-syntax pubment-name-localized)
(quote pubment-temp))
...)])))]
[extra-init-mappings (syntax
([(plain-init-name ...)
(values
(make-init-error-map (quote-syntax plain-init-name-localized))
...)]))])
(let ([find-method
(lambda (methods)
(lambda (name)
(ormap
(lambda (m)
(and (bound-identifier=? (car m) name)
(with-syntax ([proc (proc-shape (car m) (cdr m) #t
the-obj the-finder
bad class-name expand-stop-names
def-ctx lookup-localize)]
[extra-init-mappings extra-init-mappings])
(syntax
(syntax-parameterize
([super-instantiate-param super-error-map]
[super-make-object-param super-error-map]
[super-new-param super-error-map])
(letrec-syntaxes+values extra-init-mappings ()
proc))))))
methods)))]
[lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))])
(internal-definition-context-seal def-ctx)
;; ---- build final result ----
(with-syntax ([public-names (map lookup-localize-cdr publics)]
[public-final-names (map lookup-localize-cdr public-finals)]
[override-names (map lookup-localize-cdr overrides)]
[override-final-names (map lookup-localize-cdr override-finals)]
[augride-names (map lookup-localize-cdr augrides)]
[pubment-names (map lookup-localize-cdr pubments)]
[overment-names (map lookup-localize-cdr overments)]
[augment-names (map lookup-localize-cdr augments)]
[augment-final-names (map lookup-localize-cdr augment-finals)]
[(rename-super-name ...) (map lookup-localize-cdr rename-supers)]
[(rename-super-extra-name ...) (map lookup-localize-cdr rename-super-extras)]
[(rename-inner-name ...) (map lookup-localize-cdr rename-inners)]
[(rename-inner-extra-name ...) (map lookup-localize-cdr rename-inner-extras)]
[inherit-names (map lookup-localize-cdr all-inherits)]
[num-fields (datum->syntax
(quote-syntax here)
(+ (length private-field-names)
(length plain-init-fields)
(length plain-fields)))]
[field-names (map (lambda (norm)
(lookup-localize (norm-init/field-eid norm)))
(append
normal-plain-fields
normal-plain-init-fields))]
[inherit-field-names (map lookup-localize (map cdr inherit-fields))]
[init-names (map (lambda (norm)
(lookup-localize
(norm-init/field-eid norm)))
normal-inits)]
[init-mode init-mode]
[(private-method ...) (map (find-method private-methods) (map car privates))]
[public-methods (map (find-method methods) (map car publics))]
[override-methods (map (find-method methods) (map car (append overments
override-finals
overrides)))]
[augride-methods (map (find-method methods) (map car (append augments
augment-finals
augrides)))]
[(pubment-method ...) (map (find-method methods) (map car pubments))]
[(public-final-method ...) (map (find-method methods) (map car public-finals))]
[mappings mappings]
[exprs exprs]
[the-obj the-obj]
[the-finder the-finder]
[name class-name]
[(stx-def ...) (map cdr stx-defines)]
[super-expression super-expr]
[(interface-expression ...) interface-exprs]
[inspector (if (pair? inspect-decls)
(stx-car (stx-cdr (car inspect-decls)))
#'(current-inspector))]
[deserialize-id-expr deserialize-id-expr])
(quasisyntax/loc stx
(let ([superclass super-expression]
[interfaces (list interface-expression ...)])
(compose-class
'name superclass interfaces inspector deserialize-id-expr #,any-localized?
;; Field count:
num-fields
;; Field names:
`field-names
`inherit-field-names
;; Method names:
`(rename-super-name ... rename-super-extra-name ...)
`(rename-inner-name ... rename-inner-extra-name ...)
`pubment-names
`public-final-names
`public-names
`overment-names
`override-final-names
`override-names
`augment-names
`augment-final-names
`augride-names
`inherit-names
;; Init arg names (in order)
`init-names
(quote init-mode)
;; Methods (when given needed super-methods, etc.):
#, ;; Attach srcloc (useful for profiling)
(quasisyntax/loc stx
(lambda (local-field-accessor ...
local-field-mutator ...
inherit-field-accessor ... ; inherit
inherit-field-mutator ...
rename-super-temp ... rename-super-extra-temp ...
rename-inner-temp ... rename-inner-extra-temp ...
method-accessor ...) ; for a local call that needs a dynamic lookup
(syntax-parameterize
([this-param (make-this-map (quote-syntax this-id)
(quote-syntax the-finder)
(quote the-obj))]
[this%-param (make-this%-map (quote-syntax (object-ref this))
(quote-syntax the-finder))])
(let-syntaxes
mappings
(syntax-parameterize
([super-param
(lambda (stx)
(syntax-case stx (rename-super-extra-orig ...)
[(_ rename-super-extra-orig . args)
(generate-super-call
stx
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax rename-super-extra-temp)
(syntax args))]
...
[(_ id . args)
(identifier? #'id)
(raise-syntax-error
#f
(string-append
"identifier for super call does not have an override, "
"override-final, overment, or inherit/super declaration")
stx
#'id)]
[_else
(raise-syntax-error
#f
"expected an identifier after the keyword"
stx)]))]
[inner-param
(lambda (stx)
(syntax-case stx (rename-inner-extra-orig ...)
[(_ default-expr rename-inner-extra-orig . args)
(generate-inner-call
stx
(quote-syntax the-finder)
(quote the-obj)
(syntax default-expr)
(quote-syntax rename-inner-extra-temp)
(syntax args))]
...
[(_ default-expr id . args)
(identifier? #'id)
(raise-syntax-error
#f
(string-append
"identifier for inner call does not have a pubment, augment, "
"overment, or inherit/inner declaration")
stx
#'id)]
[(_)
(raise-syntax-error
#f
"expected a default-value expression after the keyword"
stx
#'id)]
[_else
(raise-syntax-error
#f
"expected an identifier after the keyword and default-value expression"
stx)]))])
stx-def ...
(letrec ([private-temp private-method]
...
[pubment-temp pubment-method]
...
[public-final-temp public-final-method]
...)
(values
(list pubment-temp ... public-final-temp ... . public-methods)
(list . override-methods)
(list . augride-methods)
;; Initialization
#, ;; Attach srcloc (useful for profiling)
(quasisyntax/loc stx
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
(let-syntax ([the-finder (quote-syntax the-obj)])
(syntax-parameterize
([super-instantiate-param
(lambda (stx)
(syntax-case stx ()
[(_ (arg (... ...)) (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
si_leftovers)
(list arg (... ...))
(kw kwarg) (... ...))))]))]
[super-new-param
(lambda (stx)
(syntax-case stx ()
[(_ (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
si_leftovers)
null
(kw kwarg) (... ...))))]))]
[super-make-object-param
(lambda (stx)
(let ([code
(quote-syntax
(lambda args
(super-go the-obj si_c si_inited? si_leftovers args null)))])
(if (identifier? stx)
code
(datum->syntax
code
(cons code
(cdr (syntax-e stx)))))))])
(letrec-syntaxes+values
([(plain-init-name) (make-init-redirect
(quote-syntax set!)
(quote-syntax #%plain-app)
(quote-syntax local-plain-init-name)
(quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...)
(void) ; in case the body is empty
. exprs))))))))))))
;; Not primitive:
#f))))))))))))))))
(define (core-class* trace-flag)
(lambda (stx)
(syntax-case stx ()
[(_ super-expression (interface-expr ...)
defn-or-expr
...)
(main stx trace-flag
#'super-expression
#f #f
(syntax->list #'(interface-expr ...))
(syntax->list #'(defn-or-expr ...)))])))
(define (core-class trace-flag)
(lambda (stx)
(syntax-case stx ()
[(_ super-expression
defn-or-expr
...)
(main stx trace-flag
#'super-expression
#f #f
null
(syntax->list #'(defn-or-expr ...)))])))
(define (core-class/derived trace-flag)
(lambda (stx)
(syntax-case stx ()
[(_ orig-stx
[name-id super-expression (interface-expr ...) deserialize-id-expr]
defn-or-expr
...)
(main #'orig-stx trace-flag
#'super-expression
#'deserialize-id-expr
(and (syntax-e #'name-id) #'name-id)
(syntax->list #'(interface-expr ...))
(syntax->list #'(defn-or-expr ...)))])))
;; The class* and class entry points:
(values
;; class*
(core-class* #f)
;; class
(core-class #f)
;; class/derived
(core-class/derived #f)
;; class*-traced
(core-class* #t)
;; class-traced
(core-class #t)
;; class/derived-traced
(core-class/derived #t)
)))
(define-syntax (-define-serializable-class stx)
(syntax-case stx ()
[(_ orig-stx name super-expression (interface-expr ...)
defn-or-expr ...)
(let ([deserialize-name-info (datum->syntax
#'name
(string->symbol
(format "deserialize-info:~a" (syntax-e #'name)))
#'name)])
(unless (memq (syntax-local-context) '(top-level module))
(raise-syntax-error
#f
"allowed only at the top level or within a module top level"
#'orig-stx))
(with-syntax ([deserialize-name-info deserialize-name-info]
[(provision ...) (if (eq? (syntax-local-context) 'module)
#`((provide #,deserialize-name-info))
#'())])
#'(begin
(define-values (name deserialize-name-info)
(class/derived orig-stx [name
super-expression
(interface-expr ...)
#'deserialize-name-info]
defn-or-expr ...))
provision ...)))]))
(define-syntax (define-serializable-class* stx)
(syntax-case stx ()
[(_ name super-expression (interface-expr ...)
defn-or-expr ...)
(with-syntax ([orig-stx stx])
#'(-define-serializable-class orig-stx
name
super-expression
(interface-expr ...)
defn-or-expr ...))]))
(define-syntax (define-serializable-class stx)
(syntax-case stx ()
[(_ name super-expression
defn-or-expr ...)
(with-syntax ([orig-stx stx])
#'(-define-serializable-class orig-stx
name
super-expression
()
defn-or-expr ...))]))
(define-syntaxes (private* public* pubment* override* overment* augride* augment*
public-final* override-final* augment-final*)
(let ([mk
(lambda (who decl-form)
(lambda (stx)
(unless (class-top-level-context? (syntax-local-context))
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
stx))
(syntax-case stx ()
[(_ binding ...)
(let ([bindings (syntax->list (syntax (binding ...)))])
(let ([name-exprs
(map (lambda (binding)
(syntax-case binding ()
[(name expr)
(identifier? (syntax name))
(cons (syntax name) (syntax expr))]
[_else
(identifier? (syntax name))
(raise-syntax-error
#f
"expected an identifier and expression"
stx
binding)]))
bindings)])
(with-syntax ([(name ...) (map car name-exprs)]
[(expr ...) (map cdr name-exprs)]
[decl-form decl-form])
(syntax
(begin
(decl-form name ...)
(define name expr)
...)))))])))])
(values
(mk 'private* (syntax private))
(mk 'public* (syntax public))
(mk 'pubment* (syntax pubment))
(mk 'override* (syntax override))
(mk 'overment* (syntax overment))
(mk 'augride* (syntax augride))
(mk 'augment* (syntax augment))
(mk 'public-final* (syntax public-final))
(mk 'override-final* (syntax override-final))
(mk 'augment-final* (syntax augment)))))
(define-syntaxes (define/private define/public define/pubment
define/override define/overment
define/augride define/augment
define/public-final define/override-final define/augment-final)
(let ([mk
(lambda (decl-form)
(lambda (stx)
(unless (class-top-level-context? (syntax-local-context))
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
stx))
(let-values ([(id rhs) (normalize-definition stx #'lambda #f #t)])
(quasisyntax/loc stx
(begin
(#,decl-form #,id)
(define #,id #,rhs))))))])
(values
(mk #'private)
(mk #'public)
(mk #'pubment)
(mk #'override)
(mk #'overment)
(mk #'augride)
(mk #'augment)
(mk #'public-final)
(mk #'override-final)
(mk #'augment-final))))
(define-syntax (define-local-member-name stx)
(syntax-case stx ()
[(_ id ...)
(let ([ids (syntax->list (syntax (id ...)))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"expected an identifier"
stx
id)))
ids)
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate identifier"
stx
dup)))
(if (eq? (syntax-local-context) 'top-level)
;; Does nothing in particular at the top level:
(syntax/loc stx (define-syntaxes (id ...) (values 'id ...)))
;; Map names to private indicators, which are made private
;; simply by introduction:
(with-syntax ([(gen-id ...) (generate-temporaries ids)])
(with-syntax ([stx-defs
;; Need to attach srcloc to this definition:
(syntax/loc stx
(define-syntaxes (id ...)
(values (make-private-name (quote-syntax id) (quote-syntax gen-id))
...)))])
(syntax/loc stx
(begin
(define-values (gen-id ...)
(values (generate-local-member-name 'id) ...))
stx-defs))))))]))
(define-syntax (define-member-name stx)
(syntax-case stx ()
[(_ id expr)
(let ([name #'id])
(unless (identifier? name)
(raise-syntax-error
#f
"expected an identifier for definition"
stx
name))
(with-syntax ([stx-def
;; Need to attach srcloc to this definition:
(syntax/loc stx
(define-syntax id
(make-private-name (quote-syntax id)
((syntax-local-certifier) (quote-syntax member-name)))))])
#'(begin
(define member-name (check-member-key 'id expr))
stx-def)))]))
(define (generate-local-member-name id)
(string->uninterned-symbol
(symbol->string id)))
(define-values (struct:member-key make-member-key member-name-key? member-key-ref member-key-set!)
(make-struct-type 'member-name-key
#f
1 0 #f
(list
(cons prop:custom-write
(lambda (v p write?)
(fprintf p "#<member-key:~a>" (member-key-id v)))))))
(define member-key-id (make-struct-field-accessor member-key-ref 0))
(define (check-member-key id v)
(unless (member-name-key? v)
(error 'define-local-member-name "not a member key for ~a: ~e" id v))
(member-key-id v))
(define-syntax (member-name-key stx)
(syntax-case stx ()
[(_ id)
(identifier? #'id)
(with-syntax ([id (localize #'id)])
(syntax/loc stx (make-member-key `id)))]
[(_ x)
(raise-syntax-error
#f
"not an identifier"
stx
#'x)]))
(define (generate-member-key)
(make-member-key (generate-local-member-name (gensym 'member))))
(define (member-name-key=? a b)
(if (and (member-name-key? a)
(member-name-key? b))
(eq? (member-key-id a) (member-key-id b))
(eq? a b)))
(define (member-name-key-hash-code a)
(unless (member-name-key? a)
(raise-type-error
'member-name-key-hash-code
"member name key"
a))
(eq-hash-code (member-key-id a)))
;;--------------------------------------------------------------------
;; class implementation
;;--------------------------------------------------------------------
(define-struct class (name
pos supers ; pos is subclass depth, supers is vector
self-interface ; self interface
insp-mk ; dummy struct maker to control inspection access
method-width ; total number of methods
method-ht ; maps public names to vector positions
method-ids ; reverse-ordered list of public method names
methods ; vector of methods (for external dynamic dispatch)
super-methods ; vector of methods (for subclass super calls)
int-methods ; vector of vector of methods (for internal dynamic dispatch)
beta-methods ; vector of vector of methods
meth-flags ; vector: #f => primitive-implemented
; 'final => final
; 'augmentable => can augment
inner-projs ; vector of projections for the last inner slot
dynamic-idxs ; vector of indexs for access into int-methods
dynamic-projs ; vector of vector of projections for internal dynamic dispatch
field-width ; total number of fields
field-pub-width ; total number of public fields
field-ht ; maps public field names to vector positions
field-ids ; list of public field names
int-field-refs ; vector of accessors for internal field access
int-field-sets ; vector of mutators for internal field access
ext-field-refs ; vector of accessors for external field access
ext-field-sets ; vector of mutators for internal field access
[struct:object ; structure type for instances
#:mutable]
[object? ; predicate
#:mutable]
[make-object ; : (-> object), constructor that creates an uninitialized object
#:mutable]
[field-ref ; accessor
#:mutable]
[field-set! ; mutator
#:mutable]
init-args ; list of symbols in order; #f => only by position
init-mode ; 'normal, 'stop (don't accept by-pos for super), or 'list
[init ; initializer
#:mutable] ; : object
; (object class (box boolean) leftover-args new-by-pos-args new-named-args
; -> void) // always continue-make-super?
; class
; (box boolean)
; leftover-args
; named-args
; -> void
[orig-cls ; uncontracted version of this class (or same class)
#:mutable]
[serializer ; proc => serializer, #f => not serializable
#:mutable]
[fixup ; for deserialization
#:mutable]
no-super-init?); #t => no super-init needed
#:inspector insp)
;; compose-class: produces one result if `deserialize-id' is #f, two
;; results if `deserialize-id' is not #f
(define (compose-class name ; symbol
super ; class
interfaces ; list of interfaces
inspector ; inspector or #f
deserialize-id ; identifier or #f
any-localized? ; #t => need to double-check distinct external names
num-fields ; total fields (public & private)
public-field-names ; list of symbols (shorter than num-fields)
inherit-field-names ; list of symbols (not included in num-fields)
rename-super-names ; list of symbols
rename-inner-names
pubment-names
public-final-names
public-normal-names
overment-names
override-final-names
override-normal-names
augment-names
augment-final-names
augride-normal-names
inherit-names
init-args ; list of symbols in order, or #f
init-mode ; 'normal, 'stop, or 'list
make-methods ; takes field and method accessors
make-struct:prim) ; see "primitive classes", below
;; -- Check superclass --
(unless (class? super)
(obj-error 'class* "superclass expression ~e returned a non-class: ~a"
super
(for-class name)))
(when any-localized?
(check-still-unique name
init-args
"initialization argument names")
;; We intentionally leave inherited names out of the lists below,
;; on the threory that it's ok to decide to inherit from
;; yourself:
(check-still-unique name
(append public-field-names)
"field names")
(check-still-unique name
(append pubment-names public-final-names public-normal-names
overment-names override-final-names override-normal-names
augment-names augment-final-names augride-normal-names)
"method names"))
;; -- Create new class's name --
(let* ([name (or name
(let ([s (class-name super)])
(and s
(not (eq? super object%))
(if (symbol? s)
(format "derived-from-~a" s)
s))))]
;; Combine method lists
[public-names (append pubment-names public-final-names public-normal-names)]
[override-names (append overment-names override-final-names override-normal-names)]
[augride-names (append augment-names augment-final-names augride-normal-names)]
[final-names (append public-final-names override-final-names augment-final-names)]
[augonly-names (append pubment-names overment-names augment-names)]
;; Mis utilities
[no-new-methods? (null? public-names)]
[no-method-changes? (and (null? public-names)
(null? override-names)
(null? augride-names)
(null? final-names))]
[no-new-fields? (null? public-field-names)]
[xappend (lambda (a b) (if (null? b) a (append a b)))])
;; -- Check interfaces ---
(for-each
(lambda (intf)
(unless (interface? intf)
(obj-error 'class* "interface expression returned a non-interface: ~a~a"
intf
(for-class name))))
interfaces)
;; -- Check inspectors ---
(when inspector
(unless (inspector? inspector)
(obj-error 'class* "inspect class result is not an inspector or #f: ~a~a"
inspector
(for-class name))))
;; -- Match method and field names to indices --
(let ([method-ht (if no-new-methods?
(class-method-ht super)
(hash-copy (class-method-ht super)))]
[field-ht (if no-new-fields?
(class-field-ht super)
(hash-copy (class-field-ht super)))]
[super-method-ht (class-method-ht super)]
[super-method-ids (class-method-ids super)]
[super-field-ids (class-field-ids super)]
[super-field-ht (class-field-ht super)])
;; Put new ids in table, with pos (replace field pos with accessor info later)
(unless no-new-methods?
(let loop ([ids public-names][p (class-method-width super)])
(unless (null? ids)
(when (hash-ref method-ht (car ids) #f)
(obj-error 'class* "superclass ~e already contains method: ~a~a"
super
(car ids)
(for-class name)))
(hash-set! method-ht (car ids) p)
(loop (cdr ids) (add1 p)))))
(unless no-new-fields?
(let loop ([ids public-field-names][p (class-field-pub-width super)])
(unless (null? ids)
(when (hash-ref field-ht (car ids) #f)
(obj-error 'class* "superclass ~e already contains field: ~a~a"
super
(car ids)
(for-class name)))
(hash-set! field-ht (car ids) p)
(loop (cdr ids) (add1 p)))))
;; Check that superclass has expected fields
(for-each (lambda (id)
(unless (hash-ref field-ht id #f)
(obj-error 'class* "superclass ~e does not provide field: ~a~a"
super
id
(for-class name))))
inherit-field-names)
;; Check that superclass has expected methods, and get indices
(let ([get-indices
(lambda (method-ht what ids)
(map
(lambda (id)
(hash-ref
method-ht id
(lambda ()
(obj-error 'class*
"~a does not provide an expected method for ~a: ~a~a"
(if (eq? method-ht super-method-ht) "superclass" "class")
what
id
(for-class name)))))
ids))]
[method-width (+ (class-method-width super) (length public-names))]
[field-width (+ (class-field-width super) num-fields)]
[field-pub-width (+ (class-field-pub-width super) (length public-field-names))])
(let ([inherit-indices (get-indices super-method-ht "inherit" inherit-names)]
[replace-augonly-indices (get-indices super-method-ht "overment" overment-names)]
[replace-final-indices (get-indices super-method-ht "override-final" override-final-names)]
[replace-normal-indices (get-indices super-method-ht "override" override-normal-names)]
[refine-augonly-indices (get-indices super-method-ht "augment" augment-names)]
[refine-final-indices (get-indices super-method-ht "augment-final" augment-final-names)]
[refine-normal-indices (get-indices super-method-ht "augride" augride-normal-names)]
[rename-super-indices (get-indices super-method-ht "rename-super" rename-super-names)]
[rename-inner-indices (get-indices method-ht "rename-inner" rename-inner-names)]
[new-augonly-indices (get-indices method-ht "pubment" pubment-names)]
[new-final-indices (get-indices method-ht "public-final" public-final-names)]
[new-normal-indices (get-indices method-ht "public" public-normal-names)])
;; -- Check that all interfaces are satisfied --
(for-each
(lambda (intf)
(for-each
(lambda (var)
(unless (hash-ref method-ht var #f)
(obj-error 'class*
"interface-required method missing: ~a~a~a"
var
(for-class name)
(for-intf (interface-name intf)))))
(interface-public-ids intf)))
interfaces)
(let ([c (get-implement-requirement interfaces 'class* (for-class name))])
(when (and c (not (subclass? super c)))
(obj-error 'class*
"interface-required implementation not satisfied~a~a"
(for-class name)
(let ([r (class-name c)])
(if r
(format " required class: ~a" r)
"")))))
;; -- For serialization, check that the superclass is compatible --
(when deserialize-id
(unless (class-serializer super)
(obj-error 'class*
"superclass is not serialiazable, not transparent, and does not implement externalizable<%>: ~e~a"
super
(for-class name))))
;; ---- Make the class and its interface ----
(let* ([class-make (if name
(make-naming-constructor
struct:class
(string->symbol (format "class:~a" name)))
make-class)]
[interface-make (if name
(make-naming-constructor
struct:interface
(string->symbol (format "interface:~a" name)))
make-interface)]
[method-names (append (reverse public-names) super-method-ids)]
[field-names (append public-field-names super-field-ids)]
[super-interfaces (cons (class-self-interface super) interfaces)]
[i (interface-make name super-interfaces #f method-names #f null)]
[methods (if no-method-changes?
(class-methods super)
(make-vector method-width))]
[super-methods (if no-method-changes?
(class-super-methods super)
(make-vector method-width))]
[int-methods (if no-method-changes?
(class-int-methods super)
(make-vector method-width))]
[beta-methods (if no-method-changes?
(class-beta-methods super)
(make-vector method-width))]
[inner-projs (if no-method-changes?
(class-inner-projs super)
(make-vector method-width))]
[dynamic-idxs (if no-method-changes?
(class-dynamic-idxs super)
(make-vector method-width))]
[dynamic-projs (if no-method-changes?
(class-dynamic-projs super)
(make-vector method-width))]
[meth-flags (if no-method-changes?
(class-meth-flags super)
(make-vector method-width))]
[int-field-refs (if no-new-fields?
(class-int-field-refs super)
(make-vector field-pub-width))]
[int-field-sets (if no-new-fields?
(class-int-field-sets super)
(make-vector field-pub-width))]
[ext-field-refs (if no-new-fields?
(class-ext-field-refs super)
(make-vector field-pub-width))]
[ext-field-sets (if no-new-fields?
(class-ext-field-sets super)
(make-vector field-pub-width))]
[c (class-make name
(add1 (class-pos super))
(list->vector (append (vector->list (class-supers super)) (list #f)))
i
(let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
make-)
method-width method-ht method-names
methods super-methods int-methods beta-methods meth-flags
inner-projs dynamic-idxs dynamic-projs
field-width field-pub-width field-ht field-names
int-field-refs int-field-sets ext-field-refs ext-field-sets
'struct:object 'object? 'make-object 'field-ref 'field-set!
init-args
init-mode
'init
#f #f #f ; serializer is set later
(and make-struct:prim #t))]
[obj-name (if name
(string->symbol (format "object:~a" name))
'object)]
;; Used only for prim classes
[preparer (lambda (name)
;; Map symbol to number:
(hash-ref method-ht name))]
[dispatcher (lambda (obj n)
;; Extract method:
(vector-ref (class-methods (object-ref obj)) n))])
(setup-all-implemented! i)
(vector-set! (class-supers c) (add1 (class-pos super)) c)
(set-class-orig-cls! c c)
;; --- Make the new object struct ---
(let*-values ([(prim-object-make prim-object? struct:prim-object)
(if make-struct:prim
(make-struct:prim c prop:object preparer dispatcher (get-properties interfaces))
(values #f #f #f))]
[(struct:object object-make object? object-field-ref object-field-set!)
(if make-struct:prim
;; Use prim struct:
(values struct:prim-object prim-object-make prim-object? #f #f)
;; Normal struct creation:
(make-struct-type obj-name
(add-properties (class-struct:object super) interfaces)
0 ;; No init fields
;; Fields for new slots:
num-fields undefined
;; Map object property to class:
(append
(list (cons prop:object c))
(if deserialize-id
(list
(cons prop:serializable
;; Serialization:
(make-serialize-info
(lambda (obj)
((class-serializer c) obj))
deserialize-id
(and (not inspector)
(not (interface-extension? i externalizable<%>))
(eq? #t (class-serializer super)))
(or (current-load-relative-directory)
(current-directory)))))
null))
inspector))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)
(unless (zero? num-fields)
;; We need these only if there are fields, used for for public-field
;; access or for inspection:
(set-class-field-ref! c object-field-ref)
(set-class-field-set!! c object-field-set!))
(unless no-new-fields?
(vector-copy! int-field-refs 0 (class-int-field-refs super))
(vector-copy! int-field-sets 0 (class-int-field-sets super))
(vector-copy! ext-field-refs 0 (class-ext-field-refs super))
(vector-copy! ext-field-sets 0 (class-ext-field-sets super))
;; For public fields, set both the internal and external accessors/mutators.
(for ([n (in-range (class-field-pub-width super) field-pub-width)]
[i (in-naturals)]
[id (in-list public-field-names)])
(vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f))
(vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f))
(vector-set! ext-field-refs n (make-struct-field-accessor object-field-ref i id))
(vector-set! ext-field-sets n (make-struct-field-mutator object-field-set! i id))))
;; --- Build field accessors and mutators ---
;; Use public field names to name the accessors and mutators
(let-values ([(local-accessors local-mutators)
(values (for/list ([n (in-range num-fields)])
(make-struct-field-accessor object-field-ref n #f))
(for/list ([n (in-range num-fields)])
(make-struct-field-mutator object-field-set! n #f)))]
[(inh-accessors inh-mutators)
(values (map (lambda (id)
(vector-ref int-field-refs (hash-ref field-ht id)))
inherit-field-names)
(map (lambda (id)
(vector-ref int-field-sets (hash-ref field-ht id)))
inherit-field-names))])
;; -- Extract superclass methods and make rename-inners ---
(let ([rename-supers (map (lambda (index mname)
;; While the last part of the vector is indeed the right
;; method, if there have been super contracts placed since,
;; they won't be reflected there, only in the super-methods
;; vector of the superclass.
(let ([vec (vector-ref (class-beta-methods super) index)])
(when (and (positive? (vector-length vec))
(not (vector-ref vec (sub1 (vector-length vec)))))
(obj-error 'class*
(string-append
"superclass ~e method for override, overment, inherit/super, "
"or rename-super is not overrideable: ~a~a")
super
mname
(for-class name))))
(vector-ref (class-super-methods super) index))
rename-super-indices
rename-super-names)]
[rename-inners (let ([new-augonly (make-vector method-width #f)])
(define (get-depth index)
(+ (if (index . < . (class-method-width super))
(vector-length (vector-ref (class-beta-methods super)
index))
0)
(if (vector-ref new-augonly index) 0 -1)))
;; To compute `rename-inner' indices, we need to know which methods
;; are augonly in this new class.
(for-each (lambda (id)
(vector-set! new-augonly (hash-ref method-ht id) #t))
(append pubment-names overment-names))
(let ([check-aug
(lambda (maybe-here?)
(lambda (mname index)
(let ([aug-ok?
(or (if (index . < . (class-method-width super))
(eq? (vector-ref (class-meth-flags super) index) 'augmentable)
#f)
(and maybe-here?
(or (memq mname pubment-names)
(memq mname overment-names))))])
(unless aug-ok?
(obj-error 'class*
(string-append
"superclass ~e method for augride, augment, inherit/inner, "
"or rename-inner method is not augmentable: ~a~a")
super
mname
(for-class name))))))])
(for-each (check-aug #f)
augride-normal-names
(get-indices method-ht "augride" augride-normal-names))
(for-each (check-aug #f)
augment-final-names
refine-final-indices)
(for-each (check-aug #t)
rename-inner-names
rename-inner-indices))
;; Now that checking is done, add `augment':
(for-each (lambda (id)
(vector-set! new-augonly (hash-ref method-ht id) #t))
augment-names)
(map (lambda (mname index)
(let ([depth (get-depth index)])
(lambda (obj)
(vector-ref (vector-ref (class-beta-methods (object-ref obj))
index)
depth))))
rename-inner-names
rename-inner-indices))])
;; Have to update these before making the method-accessors, since this is a "static" piece
;; of information (instead of being dynamic => method call time).
(unless no-method-changes?
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs super))
(for-each (lambda (index)
(vector-set! dynamic-idxs index 0))
(append new-augonly-indices new-final-indices new-normal-indices)))
;; -- Create method accessors --
(let ([method-accessors (map (lambda (index)
(let ([dyn-idx (vector-ref dynamic-idxs index)])
(lambda (obj)
(vector-ref (vector-ref (class-int-methods (object-ref obj))
index)
dyn-idx))))
(append new-normal-indices replace-normal-indices refine-normal-indices
replace-augonly-indices refine-augonly-indices
replace-final-indices refine-final-indices
inherit-indices))])
;; -- Get new methods and initializers --
(let-values ([(new-methods override-methods augride-methods init)
(apply make-methods
(append local-accessors
local-mutators
inh-accessors
inh-mutators
rename-supers
rename-inners
method-accessors))])
;; -- Fill in method tables --
;; First copy old methods
(unless no-method-changes?
(vector-copy! methods 0 (class-methods super))
(vector-copy! super-methods 0 (class-super-methods super))
(vector-copy! int-methods 0 (class-int-methods super))
(vector-copy! beta-methods 0 (class-beta-methods super))
(vector-copy! meth-flags 0 (class-meth-flags super))
(vector-copy! inner-projs 0 (class-inner-projs super))
(vector-copy! dynamic-projs 0 (class-dynamic-projs super)))
;; Add new methods:
(for-each (lambda (index method)
(vector-set! methods index method)
(vector-set! super-methods index method)
(vector-set! int-methods index (vector method))
(vector-set! beta-methods index (vector))
(vector-set! inner-projs index values)
(vector-set! dynamic-idxs index 0)
(vector-set! dynamic-projs index (vector values)))
(append new-augonly-indices new-final-indices new-normal-indices)
new-methods)
;; Override old methods:
(for-each (lambda (index method id)
(when (eq? 'final (vector-ref meth-flags index))
(obj-error 'class*
"cannot override or augment final method: ~a~a"
id
(for-class name)))
(let ([v (vector-ref beta-methods index)])
(if (zero? (vector-length v))
;; Normal mode - set vtable entry
(begin (vector-set! methods index method)
(vector-set! super-methods index method)
(let* ([dyn-idx (vector-ref dynamic-idxs index)]
[new-vec (make-vector (add1 dyn-idx))]
[proj-vec (vector-ref dynamic-projs index)])
(let loop ([n dyn-idx] [m method])
(if (< n 0)
(void)
(let* ([p (vector-ref proj-vec n)]
[new-m (p m)])
(vector-set! new-vec n new-m)
(loop (sub1 n) new-m)))
(vector-set! int-methods index new-vec))))
;; Under final mode - set extended vtable entry
(let ([v (list->vector (vector->list v))])
(vector-set! super-methods index method)
(vector-set! v (sub1 (vector-length v))
;; Apply current inner contract projection
((vector-ref inner-projs index) method))
(vector-set! beta-methods index v))))
(when (not (vector-ref meth-flags index))
(vector-set! meth-flags index (not make-struct:prim))))
(append replace-augonly-indices replace-final-indices replace-normal-indices
refine-augonly-indices refine-final-indices refine-normal-indices)
(append override-methods augride-methods)
(append override-names augride-names))
;; Update 'augmentable flags:
(unless no-method-changes?
(for-each (lambda (id)
(vector-set! meth-flags (hash-ref method-ht id) 'augmentable))
(append overment-names pubment-names))
(for-each (lambda (id)
(vector-set! meth-flags (hash-ref method-ht id) #t))
augride-normal-names))
;; Expand `rename-inner' vector, adding a #f to indicate that
;; no rename-inner function is available, so far
(for-each (lambda (id)
(let ([index (hash-ref method-ht id)])
(let ([v (list->vector (append (vector->list (vector-ref beta-methods index))
(list #f)))])
;; Since this starts a new part of the chain, reset the projection.
(vector-set! inner-projs index values)
(vector-set! beta-methods index v))))
augonly-names)
;; Mark final methods:
(for-each (lambda (id)
(let ([index (hash-ref method-ht id)])
(vector-set! meth-flags index 'final)))
final-names)
;; --- Install serialize info into class --
(set-class-serializer!
c
(cond
[(interface-extension? i externalizable<%>)
(let ([index (car (get-indices method-ht "???" '(externalize)))])
(lambda (obj)
(vector ((vector-ref methods index) obj))))]
[(and (or deserialize-id
(not inspector))
(class-serializer super))
=> (lambda (ss)
(lambda (obj)
(vector (cons (ss obj)
(let loop ([i 0])
(if (= i num-fields)
null
(cons (object-field-ref obj i)
(loop (add1 i)))))))))]
[else #f]))
(set-class-fixup!
c
;; Used only for non-externalizable:
(lambda (o args)
(if (pair? args)
(begin
((class-fixup super) o (vector-ref (car args) 0))
(let loop ([i 0][args (cdr args)])
(unless (= i num-fields)
(object-field-set! o i (car args))
(loop (add1 i) (cdr args)))))
(begin
((class-fixup super) o args)
(let loop ([i 0])
(unless (= i num-fields)
(object-field-set! o i (object-field-ref args i))
(loop (add1 i))))))))
;; --- Install initializer into class ---
(set-class-init! c init)
;; -- result is the class, and maybe deserialize-info ---
(if deserialize-id
(values c (make-deserialize-info
(if (interface-extension? i externalizable<%>)
(lambda (args)
(let ([o (make-object c)])
(send o internalize args)
o))
(lambda (args)
(let ([o (object-make)])
((class-fixup c) o args)
o)))
(if (interface-extension? i externalizable<%>)
(lambda ()
(error 'deserialize "cannot deserialize instance with cycles~a"
(for-class name)))
(lambda ()
(let ([o (object-make)])
(values o
(lambda (o2)
((class-fixup c) o o2))))))))
c))))))))))))
(define (check-still-unique name syms what)
(let ([ht (make-hasheq)])
(for-each (lambda (s)
(when (hash-ref ht s
(lambda ()
(hash-set! ht s #t)
#f))
(obj-error 'class* "external ~a mapped to overlapping keys~a"
what
(for-class name))))
syms)))
(define (get-properties intfs)
(if (ormap (lambda (i)
(pair? (interface-properties i)))
intfs)
(let ([ht (make-hash)])
;; Hash on gensym to avoid providing the same property multiple
;; times when it originated from a single interface.
(for-each (lambda (i)
(for-each (lambda (p)
(hash-set! ht (vector-ref p 0) p))
(interface-properties i)))
intfs)
(hash-map ht (lambda (k v) (cons (vector-ref v 1)
(vector-ref v 2)))))
;; No properties to add:
null))
(define (add-properties struct-type intfs)
(let ([props (get-properties intfs)])
(if (null? props)
struct-type
;; Create a new structure type to house the properties, so
;; that they can't see any fields directly via guards:
(let-values ([(struct: make- ? -ref -set!)
(make-struct-type 'props struct-type 0 0 #f props #f)])
struct:))))
(define-values (prop:object object? object-ref) (make-struct-type-property 'object))
;;--------------------------------------------------------------------
;; class/c
;;--------------------------------------------------------------------
;; Shorthand contracts that treat the implicit object argument as if it were
;; contracted with any/c.
(define-syntax-rule (->m . stx)
(syntax-parameterize ([making-a-method #t]) (-> . stx)))
(define-syntax-rule (->*m . stx)
(syntax-parameterize ([making-a-method #t]) (->* . stx)))
(define (class/c-check-first-order ctc cls blame)
(let/ec return
(define (failed str . args)
(if blame
(apply raise-blame-error blame cls str args)
(return #f)))
(unless (class? cls)
(failed "not a class"))
(let ([method-ht (class-method-ht cls)]
[beta-methods (class-beta-methods cls)]
[meth-flags (class-meth-flags cls)])
(for ([m (class/c-methods ctc)])
(unless (hash-ref method-ht m #f)
(failed "no public method ~a" m)))
(for ([m (class/c-inherits ctc)])
(unless (hash-ref method-ht m #f)
(failed "no public method ~a" m)))
(for ([m (class/c-overrides ctc)])
(let ([index (hash-ref method-ht m #f)])
(unless index
(failed "no public method ~a" m))
(let ([vec (vector-ref beta-methods index)])
(unless (zero? (vector-length vec))
(failed "method ~a was previously augmentable" m)))
(let ([flag (vector-ref meth-flags index)])
(when (eq? flag 'final)
(failed "method ~a is final" m)))))
(for ([m (class/c-augments ctc)])
(let ([index (hash-ref method-ht m #f)])
(unless index
(failed "no public method ~a" m))
(let* ([vec (vector-ref beta-methods index)])
(when (zero? (vector-length vec))
(failed "method ~a has never been augmentable" m))
(when (vector-ref vec (sub1 (vector-length vec)))
(failed "method ~a is currently overrideable, not augmentable" m)))))
(for ([m (class/c-augrides ctc)])
(let ([index (hash-ref method-ht m #f)])
(unless index
(failed "no public method ~a" m))
(let ([vec (vector-ref beta-methods index)])
(when (zero? (vector-length vec))
(failed "method ~a has never been augmentable" m))
(unless (vector-ref vec (sub1 (vector-length vec)))
(failed "method ~a is currently augmentable, not overrideable" m)))))
(for ([s (class/c-supers ctc)])
(let ([index (hash-ref method-ht s #f)])
(unless index
(failed "no public method ~a" s))
(let ([flag (vector-ref meth-flags index)])
(when (eq? flag 'final)
(failed "method ~a is final" s))
(when (eq? flag 'augmentable)
(failed "method ~a is augmentable, not overrideable" s)))))
(for ([i (class/c-inners ctc)])
(let ([index (hash-ref method-ht i #f)])
(unless index
(failed "no public method ~a" i))
(let ([vec (vector-ref beta-methods index)])
(when (zero? (vector-length vec))
(failed "method ~a has never been augmentable" i)))
(let ([flag (vector-ref meth-flags index)])
(when (eq? flag 'final)
(failed "method ~a is final" i)))))
(let ([field-ht (class-field-ht cls)])
(for ([f (class/c-fields ctc)])
(unless (hash-ref field-ht f #f)
(failed "no public field ~a" f)))
(for ([f (class/c-inherit-fields ctc)])
(unless (hash-ref field-ht f #f)
(failed "no public field ~a" f)))))
#t))
(define (class/c-proj ctc)
(λ (blame)
(λ (cls)
(class/c-check-first-order ctc cls blame)
(let* ([name (class-name cls)]
[method-width (class-method-width cls)]
[method-ht (class-method-ht cls)]
[dynamic-features
(append (class/c-overrides ctc)
(class/c-augments ctc)
(class/c-augrides ctc)
(class/c-inherits ctc))]
[dynamic-contracts
(append (class/c-override-contracts ctc)
(class/c-augment-contracts ctc)
(class/c-augride-contracts ctc)
(class/c-inherit-contracts ctc))]
[methods (if (null? (class/c-methods ctc))
(class-methods cls)
(make-vector method-width))]
[super-methods (if (null? (class/c-supers ctc))
(class-super-methods cls)
(make-vector method-width))]
[int-methods (if (null? dynamic-features)
(class-int-methods cls)
(make-vector method-width))]
[inner-projs (if (null? (class/c-inners ctc))
(class-inner-projs cls)
(make-vector method-width))]
[dynamic-idxs (if (null? dynamic-features)
(class-dynamic-idxs cls)
(make-vector method-width))]
[dynamic-projs (if (null? dynamic-features)
(class-dynamic-projs cls)
(make-vector method-width))]
[field-pub-width (class-field-pub-width cls)]
[field-ht (class-field-ht cls)]
[int-field-refs (if (null? (class/c-inherit-fields ctc))
(class-int-field-refs cls)
(make-vector field-pub-width))]
[int-field-sets (if (null? (class/c-inherit-fields ctc))
(class-int-field-sets cls)
(make-vector field-pub-width))]
[ext-field-refs (if (null? (class/c-fields ctc))
(class-ext-field-refs cls)
(make-vector field-pub-width))]
[ext-field-sets (if (null? (class/c-fields ctc))
(class-ext-field-sets cls)
(make-vector field-pub-width))]
[class-make (if name
(make-naming-constructor
struct:class
(string->symbol (format "class:~a" name)))
make-class)]
[c (class-make name
(class-pos cls)
(list->vector (vector->list (class-supers cls)))
(class-self-interface cls)
void ;; No inspecting
method-width
method-ht
(class-method-ids cls)
methods
super-methods
int-methods
(class-beta-methods cls)
(class-meth-flags cls)
inner-projs
dynamic-idxs
dynamic-projs
(class-field-width cls)
field-pub-width
field-ht
(class-field-ids cls)
int-field-refs
int-field-sets
ext-field-refs
ext-field-sets
'struct:object 'object? 'make-object
'field-ref 'field-set!
(class-init-args cls)
(class-init-mode cls)
(class-init cls)
(class-orig-cls cls)
#f #f ; serializer is never set
#f)]
[obj-name (if name
(string->symbol (format "object:~a" name))
'object)])
(vector-set! (class-supers c) (class-pos c) c)
;; --- Make the new object struct ---
(let-values ([(struct:object object-make object? object-field-ref object-field-set!)
(make-struct-type obj-name
(class-struct:object cls)
0 ;; No init fields
0 ;; No new fields in this class replacement
undefined
;; Map object property to class:
(list (cons prop:object c)))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)
(set-class-field-ref! c object-field-ref)
(set-class-field-set!! c object-field-set!))
;; Handle public method contracts
(unless (null? (class/c-methods ctc))
;; First, fill in from old methods
(vector-copy! methods 0 (class-methods cls))
;; Now apply projections
(for ([m (in-list (class/c-methods ctc))]
[c (in-list (class/c-method-contracts ctc))])
(when c
(let ([i (hash-ref method-ht m)]
[p ((contract-projection c) blame)])
(vector-set! methods i (p (vector-ref methods i)))))))
;; Handle super contracts
(unless (null? (class/c-supers ctc))
;; First, fill in from old (possibly contracted) super methods
(vector-copy! super-methods 0 (class-super-methods cls))
;; Now apply projections.
(for ([m (in-list (class/c-supers ctc))]
[c (in-list (class/c-super-contracts ctc))])
(when c
(let ([i (hash-ref method-ht m)]
[p ((contract-projection c) blame)])
(vector-set! super-methods i (p (vector-ref super-methods i)))))))
;; Add inner projections
(unless (null? (class/c-inners ctc))
(vector-copy! inner-projs 0 (class-inner-projs cls))
(let ([b (blame-swap blame)])
(for ([m (in-list (class/c-inners ctc))]
[c (in-list (class/c-inner-contracts ctc))])
(when c
(let ([i (hash-ref method-ht m)]
[p ((contract-projection c) b)])
(vector-set! inner-projs i
(compose (vector-ref inner-projs i) p)))))))
;; Handle external field contracts
(unless (null? (class/c-fields ctc))
(vector-copy! ext-field-refs 0 (class-ext-field-refs cls))
(vector-copy! ext-field-sets 0 (class-ext-field-sets cls))
(let ([bset (blame-swap blame)])
(for ([f (in-list (class/c-fields ctc))]
[c (in-list (class/c-field-contracts ctc))])
(when c
(let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)]
[old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i
(λ (o) ((pre-p blame) (old-ref o))))
(vector-set! ext-field-sets i
(λ (o v) (old-set o ((pre-p bset) v)))))))))
;; Handle internal field contracts
(unless (null? (class/c-inherit-fields ctc))
(vector-copy! int-field-refs 0 (class-int-field-refs cls))
(vector-copy! int-field-sets 0 (class-int-field-sets cls))
(let ([bset (blame-swap blame)])
(for ([f (in-list (class/c-inherit-fields ctc))]
[c (in-list (class/c-inherit-field-contracts ctc))])
(when c
(let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)]
[old-ref (vector-ref int-field-refs i)]
[old-set (vector-ref int-field-sets i)])
(vector-set! int-field-refs i
(λ (o) ((pre-p blame) (old-ref o))))
(vector-set! int-field-sets i
(λ (o v) (old-set o ((pre-p bset) v)))))))))
;; Now the trickiest of them all, internal dynamic dispatch.
;; First we update any dynamic indexes, as applicable.
(let ([old-idxs (class-dynamic-idxs (class-orig-cls cls))])
(unless (null? dynamic-features)
;; Go ahead and do all the copies here.
(vector-copy! dynamic-projs 0 (class-dynamic-projs cls))
(vector-copy! int-methods 0 (class-int-methods cls))
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls))
(for ([m (in-list dynamic-features)]
[c (in-list dynamic-contracts)])
(when c
(let* ([i (hash-ref method-ht m)]
[old-idx (vector-ref old-idxs i)]
[new-idx (vector-ref dynamic-idxs i)])
;; We need to extend all the vectors, so let's do that here.
(when (= old-idx new-idx)
(let* ([new-idx (add1 old-idx)]
[new-proj-vec (make-vector (add1 new-idx))]
[old-proj-vec (vector-ref dynamic-projs i)]
[new-int-vec (make-vector (add1 new-idx))]
[old-int-vec (vector-ref int-methods i)])
(vector-set! dynamic-idxs i new-idx)
(vector-copy! new-proj-vec 0 old-proj-vec)
(vector-set! new-proj-vec new-idx values)
(vector-set! dynamic-projs i new-proj-vec)
(vector-copy! new-int-vec 0 old-int-vec)
;; Just copy over the last entry here. We'll
;; update it appropriately later.
(vector-set! new-int-vec new-idx
(vector-ref old-int-vec old-idx))
(vector-set! int-methods i new-int-vec)))))))
;; Now we handle updating override contracts... here we just
;; update the projections, and not the methods (which we must
;; do during class composition).
(unless (null? (class/c-overrides ctc))
(for ([m (in-list (class/c-overrides ctc))]
[c (in-list (class/c-override-contracts ctc))])
(when c
(let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) (blame-swap blame))]
[old-idx (vector-ref old-idxs i)]
[proj-vec (vector-ref dynamic-projs i)])
(vector-set! proj-vec old-idx
(compose (vector-ref proj-vec old-idx) p))))))
;; For augment and augride contracts, we both update the projection
;; and go ahead and apply the projection to the last slot (which will
;; only be used by later classes).
(unless (and (null? (class/c-augments ctc))
(null? (class/c-augrides ctc)))
(for ([m (in-list (append (class/c-augments ctc)
(class/c-augrides ctc)))]
[c (in-list (append (class/c-augment-contracts ctc)
(class/c-augride-contracts ctc)))])
(when c
(let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) blame)]
[old-idx (vector-ref old-idxs i)]
[new-idx (vector-ref dynamic-idxs i)]
[proj-vec (vector-ref dynamic-projs i)]
[int-vec (vector-ref int-methods i)])
(vector-set! proj-vec old-idx
(compose p (vector-ref proj-vec old-idx)))
(vector-set! int-vec new-idx
(p (vector-ref int-vec new-idx)))))))
;; Now (that things have been extended appropriately) we handle
;; inherits.
(unless (null? (class/c-inherits ctc))
(for ([m (in-list (class/c-inherits ctc))]
[c (in-list (class/c-inherit-contracts ctc))])
(when c
(let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) blame)]
[new-idx (vector-ref dynamic-idxs i)]
[int-vec (vector-ref int-methods i)])
(vector-set! int-vec new-idx
(p (vector-ref int-vec new-idx))))))))
c))))
(define-struct class/c
(methods method-contracts fields field-contracts
inherits inherit-contracts inherit-fields inherit-field-contracts
supers super-contracts inners inner-contracts
overrides override-contracts augments augment-contracts
augrides augride-contracts)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:projection class/c-proj
#:name
(λ (ctc)
(let* ([pair-ids-ctcs
(λ (is ctcs)
(for/list ([i (in-list is)]
[ctc (in-list ctcs)])
(if (not ctc)
i
(build-compound-type-name i ctc))))]
[handle-optional
(λ (name is ctcs)
(if (null? is)
null
(list (cons name (pair-ids-ctcs is ctcs)))))]
[handled-methods
(for/list ([i (in-list (class/c-methods ctc))]
[ctc (in-list (class/c-method-contracts ctc))])
(cond
[ctc (build-compound-type-name i ctc)]
[else i]))])
(apply build-compound-type-name
'class/c
(append
handled-methods
(handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
(handle-optional 'inherit (class/c-inherits ctc) (class/c-inherit-contracts ctc))
(handle-optional 'inherit-field (class/c-inherit-fields ctc) (class/c-inherit-field-contracts ctc))
(handle-optional 'super (class/c-supers ctc) (class/c-super-contracts ctc))
(handle-optional 'inner (class/c-inners ctc) (class/c-inner-contracts ctc))
(handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
(handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc))
(handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc))))))
#:first-order
(λ (ctc)
(λ (cls)
(class/c-check-first-order ctc cls #f)))))
(define-for-syntax (parse-class/c-specs forms object/c?)
(define parsed-forms (make-hasheq))
(define form-name (if object/c? 'object/c 'class/c))
(define (parse-name-ctc stx)
(syntax-case stx ()
[x
(identifier? #'x)
(values #'(quote x) #f)]
[(x ctc)
(identifier? #'x)
(values #'(quote x)
#`(coerce-contract '#,form-name (let ([x ctc]) x)))]
[_
(raise-syntax-error 'class/c "expected identifier or (id contract)" stx)]))
(define (parse-names-ctcs stx)
(for/fold ([names null]
[ctcs null])
([stx (in-list (syntax->list stx))])
(let-values ([(name ctc) (parse-name-ctc stx)])
(values (cons name names) (cons ctc ctcs)))))
(define (parse-spec stx)
(syntax-case stx (field inherit inherit-field init super inner override augment augride)
[(field f-spec ...)
(let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
(hash-set! parsed-forms 'fields
(append names (hash-ref parsed-forms 'fields null)))
(hash-set! parsed-forms 'field-contracts
(append ctcs (hash-ref parsed-forms 'field-contracts null))))]
[(inherit m-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "inherit contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(m-spec ...))])
(hash-set! parsed-forms 'inherits
(append names (hash-ref parsed-forms 'inherits null)))
(hash-set! parsed-forms 'inherit-contracts
(append ctcs (hash-ref parsed-forms 'inherit-contracts null)))))]
[(inherit-field f-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "inherit-field contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
(hash-set! parsed-forms 'inherit-fields
(append names (hash-ref parsed-forms 'inherit-fields null)))
(hash-set! parsed-forms 'inherit-field-contracts
(append ctcs (hash-ref parsed-forms 'inherit-field-contracts null)))))]
[(super s-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "super contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(s-spec ...))])
(hash-set! parsed-forms 'supers
(append names (hash-ref parsed-forms 'supers null)))
(hash-set! parsed-forms 'super-contracts
(append ctcs (hash-ref parsed-forms 'super-contracts null)))))]
[(inner i-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "inner contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(i-spec ...))])
(hash-set! parsed-forms 'inners
(append names (hash-ref parsed-forms 'inners null)))
(hash-set! parsed-forms 'inner-contracts
(append ctcs (hash-ref parsed-forms 'inner-contracts null)))))]
[(override o-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "override contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(o-spec ...))])
(hash-set! parsed-forms 'overrides
(append names (hash-ref parsed-forms 'overrides null)))
(hash-set! parsed-forms 'override-contracts
(append ctcs (hash-ref parsed-forms 'override-contracts null)))))]
[(augment a-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "augment contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(a-spec ...))])
(hash-set! parsed-forms 'augments
(append names (hash-ref parsed-forms 'augments null)))
(hash-set! parsed-forms 'augment-contracts
(append ctcs (hash-ref parsed-forms 'augment-contracts null)))))]
[(augride a-spec ...)
(begin
(when object/c?
(raise-syntax-error 'object/c "augride contract not allowed in object/c" stx))
(let-values ([(names ctcs) (parse-names-ctcs #'(a-spec ...))])
(hash-set! parsed-forms 'augrides
(append names (hash-ref parsed-forms 'augrides null)))
(hash-set! parsed-forms 'augride-contracts
(append ctcs (hash-ref parsed-forms 'augride-contracts null)))))]
[m-spec
(let-values ([(name ctc1) (parse-name-ctc #'m-spec)])
(hash-set! parsed-forms 'methods
(cons name (hash-ref parsed-forms 'methods null)))
(hash-set! parsed-forms 'method-contracts
(cons ctc1 (hash-ref parsed-forms 'method-contracts null))))]
[else
(raise-syntax-error form-name "expected class/c subform" stx)]))
(for ([form (in-list forms)])
(parse-spec form))
parsed-forms)
(define-syntax (class/c stx)
(syntax-case stx ()
[(_ form ...)
(let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)])
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
[inherit-field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-field-contracts null)))]
[supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))]
[super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))]
[inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))]
[inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))]
[overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))]
[override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))]
[augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))]
[augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))]
[augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))]
[augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))])
(syntax/loc stx
(make-class/c methods method-ctcs
fields field-ctcs
inherits inherit-ctcs
inherit-fields inherit-field-ctcs
supers super-ctcs
inners inner-ctcs
overrides override-ctcs
augments augment-ctcs
augrides augride-ctcs))))]))
(define (check-object-contract obj blame methods fields)
(let/ec return
(define (failed str . args)
(if blame
(apply raise-blame-error blame obj str args)
(return #f)))
(unless (object? obj)
(failed "not a object"))
(let ([cls (object-ref obj)])
(let ([method-ht (class-method-ht cls)])
(for ([m methods])
(unless (hash-ref method-ht m #f)
(failed "no public method ~a" m))))
(let ([field-ht (class-field-ht cls)])
(for ([m fields])
(unless (hash-ref field-ht m #f)
(failed "no public field ~a" m)))))))
(define (object/c-check-first-order ctc obj blame)
(check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc)))
(define (object/c-proj ctc)
(λ (blame)
(λ (obj)
(object/c-check-first-order ctc obj blame)
(make-wrapper-object obj blame
(object/c-methods ctc) (object/c-method-contracts ctc)
(object/c-fields ctc) (object/c-field-contracts ctc)))))
(define-struct object/c (methods method-contracts fields field-contracts)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:projection object/c-proj
#:name
(λ (ctc)
(let* ([pair-ids-ctcs
(λ (is ctcs)
(map (λ (i ctc)
(build-compound-type-name i ctc))
is ctcs))]
[handle-optional
(λ (name is ctcs)
(if (null? is)
null
(list (cons name (pair-ids-ctcs is ctcs)))))])
(apply build-compound-type-name
'object/c
(append
(pair-ids-ctcs (object/c-methods ctc) (object/c-method-contracts ctc))
(handle-optional 'field (object/c-fields ctc) (object/c-field-contracts ctc))))))
#:first-order
(λ (ctc)
(λ (obj)
(with-handlers ([exn:fail:contract? (λ (e) #f)])
(object/c-check-first-order ctc obj #f))))))
(define-syntax (object/c stx)
(syntax-case stx ()
[(_ form ...)
(let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #t)])
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))])
(syntax/loc stx
(make-object/c methods method-ctcs fields field-ctcs))))]))
;;--------------------------------------------------------------------
;; interfaces
;;--------------------------------------------------------------------
;; >> Simplistic implementation for now <<
(define-for-syntax do-interface
(lambda (stx m-stx)
(syntax-case m-stx ()
[((interface-expr ...) ([prop prop-val] ...) var ...)
(let ([vars (syntax->list (syntax (var ...)))]
[name (syntax-local-infer-name stx)])
(for-each
(lambda (v)
(unless (identifier? v)
(raise-syntax-error #f
"not an identifier"
stx
v)))
vars)
(let ([dup (check-duplicate-identifier vars)])
(when dup
(raise-syntax-error #f
"duplicate name"
stx
dup)))
(with-syntax ([name (datum->syntax #f name #f)]
[(var ...) (map localize vars)])
(syntax/loc
stx
(compose-interface
'name
(list interface-expr ...)
`(var ...)
(list prop ...)
(list prop-val ...)))))])))
(define-syntax (_interface stx)
(syntax-case stx ()
[(_ (interface-expr ...) var ...)
(do-interface stx #'((interface-expr ...) () var ...))]))
(define-syntax (interface* stx)
(syntax-case stx ()
[(_ (interface-expr ...) ([prop prop-val] ...) var ...)
(do-interface stx #'((interface-expr ...) ([prop prop-val] ...) var ...))]
[(_ (interface-expr ...) (prop+val ...) var ...)
(for-each (lambda (p+v)
(syntax-case p+v ()
[(p v) (void)]
[_ (raise-syntax-error #f
"expected `[<prop-expr> <val-expr>]'"
stx
p+v)]))
(syntax->list #'(prop+val ...)))]
[(_ (interface-expr ...) prop+vals . _)
(raise-syntax-error #f
"expected `([<prop-expr> <val-expr>] ...)'"
stx
#'prop+vals)]))
(define-struct interface
(name ; symbol
supers ; (listof interface)
[all-implemented ; hash-table: interface -> #t
#:mutable]
public-ids ; (listof symbol) (in any order?!?)
[class ; (union #f class) -- means that anything implementing
#:mutable] ; this interface must be derived from this class
properties) ; (listof (vector gensym prop val))
#:inspector insp)
(define (compose-interface name supers vars props vals)
(for-each
(lambda (intf)
(unless (interface? intf)
(obj-error 'interface
"superinterface expression returned a non-interface: ~e~a"
intf
(for-intf name))))
supers)
(for-each
(lambda (p)
(unless (struct-type-property? p)
(obj-error 'interface
"property expression returned a non-property: ~e~a"
p
(for-intf name))))
props)
(let ([ht (make-hasheq)])
(for-each
(lambda (var)
(hash-set! ht var #t))
vars)
;; Check that vars don't already exist in supers:
(for-each
(lambda (super)
(for-each
(lambda (var)
(when (hash-ref ht var #f)
(obj-error 'interface "variable already in superinterface: ~a~a~a"
var
(for-intf name)
(let ([r (interface-name super)])
(if r
(format " already in: ~a" r)
"")))))
(interface-public-ids super)))
supers)
;; Merge properties:
(let ([prop-ht (make-hash)])
;; Hash on gensym to avoid providing the same property multiple
;; times when it originated from a single interface.
(for-each (lambda (i)
(for-each (lambda (p)
(hash-set! prop-ht (vector-ref p 0) p))
(interface-properties i)))
supers)
(for-each (lambda (p v)
(let ([g (gensym)])
(hash-set! prop-ht g (vector g p v))))
props vals)
;; Check for [conflicting] implementation requirements
(let ([class (get-implement-requirement supers 'interface (for-intf name))]
[interface-make (if name
(make-naming-constructor
struct:interface
(string->symbol (format "interface:~a" name)))
make-interface)])
;; Add supervars to table:
(for-each
(lambda (super)
(for-each
(lambda (var) (hash-set! ht var #t))
(interface-public-ids super)))
supers)
;; Done
(let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class
(hash-map prop-ht (lambda (k v) v)))])
(setup-all-implemented! i)
i)))))
;; setup-all-implemented! : interface -> void
;; Creates the hash table for all implemented interfaces
(define (setup-all-implemented! i)
(let ([ht (make-hasheq)])
(hash-set! ht i #t)
(for-each (lambda (si)
(hash-for-each
(interface-all-implemented si)
(lambda (k v)
(hash-set! ht k #t))))
(interface-supers i))
(set-interface-all-implemented! i ht)))
(define (get-implement-requirement interfaces where for)
(let loop ([class #f]
[supers interfaces])
(if (null? supers)
class
(let ([c (interface-class (car supers))])
(loop
(cond
[(not c) class]
[(not class) c]
[(subclass? c class) class]
[(subclass? class c) c]
[else
(obj-error
where
"conflicting class implementation requirements in superinterfaces~a"
for)])
(cdr supers))))))
;;--------------------------------------------------------------------
;; object%
;;--------------------------------------------------------------------
(define (make-naming-constructor type name)
(let-values ([(struct: make- ? -accessor -mutator)
(make-struct-type name type 0 0 #f null insp)])
make-))
(define object<%> ((make-naming-constructor struct:interface 'interface:object%)
'object% null #f null #f null))
(setup-all-implemented! object<%>)
(define object% ((make-naming-constructor struct:class 'class:object%)
'object%
0 (vector #f)
object<%>
void ; never inspectable
0 (make-hasheq) null
(vector) (vector) (vector) (vector) (vector)
(vector) (vector) (vector)
0 0 (make-hasheq) null
(vector) (vector) (vector) (vector)
'struct:object object? 'make-object
'field-ref-not-needed 'field-set!-not-needed
null
'normal
(lambda (this super-init si_c si_inited? si_leftovers args)
(unless (null? args)
(unused-args-error this args))
(void))
#f
(lambda (obj) #(())) ; serialize
(lambda (obj args) (void)) ; deserialize-fixup
#t)) ; no super-init
(vector-set! (class-supers object%) 0 object%)
(set-class-orig-cls! object% object%)
(let*-values ([(struct:obj make-obj obj? -get -set!)
(make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)])
(set-class-struct:object! object% struct:obj)
(set-class-make-object! object% make-obj))
(set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes
(set-interface-class! object<%> object%)
;;--------------------------------------------------------------------
;; instantiation
;;--------------------------------------------------------------------
(define-syntaxes (new new-traced)
(let* ([core-new
(lambda (instantiate-stx stx)
(syntax-case stx ()
[(_ cls (id arg) ...)
(andmap identifier? (syntax->list (syntax (id ...))))
(quasisyntax/loc stx
((unsyntax instantiate-stx) cls () (id arg) ...))]
[(_ cls (id arg) ...)
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error 'new "expected identifier" stx id)))
(syntax->list (syntax (id ...))))]
[(_ cls pr ...)
(for-each
(lambda (pr)
(syntax-case pr ()
[(x y) (void)]
[else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
(syntax->list (syntax (pr ...))))]))])
(values
(lambda (stx) (core-new (syntax/loc stx instantiate) stx))
(lambda (stx) (core-new (syntax/loc stx instantiate-traced) stx)))))
(define make-object
(lambda (class . args)
(do-make-object class args null)))
(define make-object-traced
(lambda (class . args)
(do-make-object-traced class args null)))
(define-syntaxes (instantiate instantiate-traced)
(let* ([core-instantiate
(lambda (do-make-object-stx stx)
(syntax-case stx ()
[(form class (arg ...) . x)
(with-syntax ([orig-stx stx])
(quasisyntax/loc stx
(-instantiate (unsyntax do-make-object-stx)
orig-stx (class) (list arg ...) . x)))]))])
(values
(lambda (stx)
(core-instantiate (syntax/loc stx do-make-object) stx))
(lambda (stx)
(core-instantiate (syntax/loc stx do-make-object-traced) stx)))))
;; Helper; used by instantiate and super-instantiate
(define-syntax -instantiate
(lambda (stx)
(syntax-case stx ()
[(_ do-make-object orig-stx (maker-arg ...) args (kw arg) ...)
(andmap identifier? (syntax->list (syntax (kw ...))))
(with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))])
(syntax/loc stx
(do-make-object maker-arg ...
args
(list (cons `kw arg)
...))))]
[(_ super-make-object orig-stx (make-arg ...) args kwarg ...)
;; some kwarg must be bad:
(for-each (lambda (kwarg)
(syntax-case kwarg ()
[(kw arg)
(identifier? (syntax kw))
'ok]
[(kw arg)
(raise-syntax-error
#f
"by-name argument does not start with an identifier"
(syntax orig-stx)
kwarg)]
[_else
(raise-syntax-error
#f
"ill-formed by-name argument"
(syntax orig-stx)
kwarg)]))
(syntax->list (syntax (kwarg ...))))])))
(define (alist->sexp alist)
(map (lambda (pair) (list (car pair) (cdr pair))) alist))
(define-traced (do-make-object class by-pos-args named-args)
(unless (class? class)
(raise-type-error 'instantiate "class" class))
(let ([o ((class-make-object class))])
(trace-begin
;; Initialize it:
(trace (new-event class o (alist->sexp (get-field-alist o))))
(trace (initialize-call-event
o (string->symbol "(constructor)")
(cons (alist->sexp named-args) by-pos-args)))
(continue-make-object o class by-pos-args named-args #t)
(trace (finalize-call-event o))
o)))
(define (get-field-alist obj)
(map (lambda (id) (cons id (get-field/proc id obj)))
(field-names obj)))
(define (continue-make-object o c by-pos-args named-args explict-named-args?)
(let ([by-pos-only? (not (class-init-args c))])
;; When a superclass has #f for init-args (meaning "by-pos args with no names"),
;; some propagated named args may have #f keys; move them to by-position args.
(let-values ([(by-pos-args named-args)
(if by-pos-only?
(let ([l (filter (lambda (x) (not (car x))) named-args)])
(if (pair? l)
(values (append by-pos-args (map cdr l))
(filter car named-args))
(values by-pos-args named-args)))
(values by-pos-args named-args))])
;; Primitive class with by-pos arguments?
(when by-pos-only?
(unless (null? named-args)
(if explict-named-args?
(obj-error
'instantiate
"class has only by-position initializers, but given by-name arguments:~a~a"
(make-named-arg-string named-args)
(for-class (class-name c)))
;; If args were implicit from subclass, should report as unused:
(unused-args-error o named-args))))
;; Merge by-pos into named args:
(let* ([named-args (if (not by-pos-only?)
;; Normal merge
(do-merge by-pos-args (class-init-args c) c named-args by-pos-args c)
;; Non-merge for by-position initializers
by-pos-args)]
[leftovers (if (not by-pos-only?)
(get-leftovers named-args (class-init-args c))
null)])
;; In 'list mode, make sure no by-name arguments are left over
(when (eq? 'list (class-init-mode c))
(unless (or (null? leftovers)
(not (ormap car leftovers)))
(unused-args-error o (filter car leftovers))))
(unless (and (eq? c object%)
(null? named-args))
(let ([inited? (box (class-no-super-init? c))])
;; ----- Execute the class body -----
((class-init c)
o
continue-make-super
c inited? leftovers ; merely passed through to continue-make-super
named-args)
(unless (unbox inited?)
(obj-error 'instantiate "superclass initialization not invoked by initialization~a"
(for-class (class-name c))))))))))
(define (continue-make-super o c inited? leftovers by-pos-args new-named-args)
(when (unbox inited?)
(obj-error 'instantiate "superclass already initialized by class initialization~a"
(for-class (class-name c))))
(set-box! inited? #t)
(let ([named-args (if (eq? 'list (class-init-mode c))
;; all old args must have been used up
new-named-args
;; Normal mode: merge leftover keyword-based args with new ones
(append
new-named-args
leftovers))])
(continue-make-object o
(vector-ref (class-supers c) (sub1 (class-pos c)))
by-pos-args
named-args
(pair? new-named-args))))
(define (do-merge al nl ic named-args by-pos-args c)
(cond
[(null? al) named-args]
[(null? nl)
;; continue mapping with superclass init args, if allowed
(let ([super (and (eq? 'normal (class-init-mode ic))
(positive? (class-pos ic))
(vector-ref (class-supers ic) (sub1 (class-pos ic))))])
(cond
[super
(if (class-init-args super)
(do-merge al (class-init-args super) super named-args by-pos-args c)
;; Like 'list mode:
(append (map (lambda (x) (cons #f x)) al)
named-args))]
[(eq? 'list (class-init-mode ic))
;; All unconsumed named-args must have #f
;; "name"s, otherwise an error is raised in
;; the leftovers checking.
(if (null? al)
named-args
(append (map (lambda (x) (cons #f x)) al)
named-args))]
[else
(obj-error 'instantiate
"too many initialization arguments:~a~a"
(make-pos-arg-string by-pos-args)
(for-class (class-name c)))]))]
[else (cons (cons (car nl) (car al))
(do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))]))
(define (get-leftovers l names)
(cond
[(null? l) null]
[(memq (caar l) names)
(get-leftovers (cdr l) (remq (caar l) names))]
[else (cons (car l) (get-leftovers (cdr l) names))]))
(define (extract-arg class-name name arguments default)
(if (symbol? name)
;; Normal mode
(let ([a (assq name arguments)])
(cond
[a (cdr a)]
[default (default)]
[else (missing-argument-error class-name name)]))
;; By-position mode
(cond
[(< name (length arguments))
(cdr (list-ref arguments name))]
[default (default)]
[else (obj-error 'instantiate "too few initialization arguments")])))
(define (extract-rest-args skip arguments)
(if (< skip (length arguments))
(map cdr (list-tail arguments skip))
null))
(define (make-pos-arg-string args)
(let ([len (length args)])
(apply string-append
(map (lambda (a)
(format " ~e" a))
args))))
(define (make-named-arg-string args)
(let loop ([args args][count 0])
(cond
[(null? args) ""]
[(= count 3) " ..."]
[else (let ([rest (loop (cdr args) (add1 count))])
(format " (~a ~e)~a"
(caar args)
(cdar args)
rest))])))
(define (unused-args-error this args)
(let ([arg-string (make-named-arg-string args)])
(obj-error 'instantiate "unused initialization arguments:~a~a"
arg-string
(for-class/which "instantiated" (class-name (object-ref this))))))
(define (missing-argument-error class-name name)
(obj-error 'instantiate "no argument for required init variable: ~a~a"
name
(if class-name (format " in class: ~a" class-name) "")))
;;--------------------------------------------------------------------
;; methods and fields
;;--------------------------------------------------------------------
(define-syntaxes (send send/apply send-traced send/apply-traced)
(let ()
(define (do-method traced? stx form obj name args rest-arg?)
(with-syntax ([(sym method receiver)
(generate-temporaries (syntax (1 2 3)))])
(quasisyntax/loc stx
(let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
[(method receiver)
(find-method/who '(unsyntax form)
(unsyntax obj)
sym)])
(unsyntax
(make-method-call
traced?
stx
(syntax/loc stx receiver)
(syntax/loc stx unwrap-object)
(syntax/loc stx method)
(syntax/loc stx sym)
args
rest-arg?))))))
(define (core-send traced? apply?)
(lambda (stx)
(syntax-case stx ()
[(form obj name . args)
(identifier? (syntax name))
(if (stx-list? (syntax args))
;; (send obj name arg ...) or (send/apply obj name arg ...)
(do-method traced? stx #'form #'obj #'name #'args apply?)
(if apply?
;; (send/apply obj name arg ... . rest)
(raise-syntax-error
#f "bad syntax (illegal use of `.')" stx)
;; (send obj name arg ... . rest)
(do-method traced? stx #'form #'obj #'name
(flatten-args #'args) #t)))]
[(form obj name . args)
(raise-syntax-error
#f "method name is not an identifier" stx #'name)])))
(values
;; send
(core-send #f #f)
;; send/apply
(core-send #f #t)
;; send-traced
(core-send #t #f)
;; send/apply-traced
(core-send #t #t))))
(define-syntaxes (send* send*-traced)
(let* ([core-send*
(lambda (traced?)
(lambda (stx)
(syntax-case stx ()
[(form obj clause ...)
(quasisyntax/loc stx
(let* ([o obj])
(unsyntax-splicing
(map
(lambda (clause-stx)
(syntax-case clause-stx ()
[(meth . args)
(quasisyntax/loc stx
((unsyntax (if traced?
(syntax/loc stx send-traced)
(syntax/loc stx send)))
o meth . args))]
[_ (raise-syntax-error
#f "bad method call" stx clause-stx)]))
(syntax->list (syntax (clause ...)))))))])))])
(values (core-send* #f) (core-send* #t))))
;; find-method/who : symbol[top-level-form/proc-name]
;; any[object]
;; symbol[method-name]
;; -> (values method-proc object)
;; returns the method's procedure and the object. If the object is a contract
;; wrapped one and the original class was a primitive one, then the method
;; will automatically unwrap both the object and any wrapped arguments on entry.
(define (find-method/who who in-object name #:error? [error? #t])
(unless (object? in-object)
(if error?
(obj-error who "target is not an object: ~e for method: ~a"
in-object name)
(values #f values)))
(let* ([cls (object-ref in-object)]
[pos (hash-ref (class-method-ht cls) name #f)])
(cond
[pos (values (vector-ref (class-methods cls) pos) in-object)]
[error?
(obj-error who "no such method: ~a~a"
name
(for-class (class-name cls)))]
[else (values #f values)])))
(define-values (make-class-field-accessor make-class-field-mutator)
(let ([mk (λ (who which)
(λ (class name)
(unless (class? class)
(raise-type-error who "class" class))
(unless (symbol? name)
(raise-type-error who "symbol" name))
(let ([p (hash-ref (class-field-ht class) name
(lambda ()
(obj-error who "no such field: ~a~a"
name
(for-class (class-name class)))))])
(vector-ref (which class) p))))])
(values (mk 'class-field-accessor class-ext-field-refs)
(mk 'class-field-mutator class-ext-field-sets))))
(define-struct generic (name applicable))
;; Internally, make-generic comes from the struct def.
;; Externally, make-generic is the following procedure.
;; The extra `let' gives it the right name.
(define make-generic/proc
(let ([make-generic
(lambda (class name)
(unless (or (class? class) (interface? class))
(raise-type-error 'make-generic "class or interface" class))
(unless (symbol? name)
(raise-type-error 'make-generic "symbol" name))
(make-generic
name
(if (interface? class)
(let ([intf class])
(unless (method-in-interface? name intf)
(obj-error 'make-generic "no such method: ~a~a"
name
(for-intf (interface-name intf))))
(lambda (obj)
(unless (is-a? obj intf)
(raise-type-error
(string->symbol (format "generic:~a~a" name (for-intf (interface-name intf))))
(format "instance~a" (for-intf (interface-name intf)))
obj))
(let-values ([(mth ths) (find-method/who 'make-generic obj name)])
mth)))
(let* ([pos (hash-ref (class-method-ht class) name
(lambda ()
(obj-error 'make-generic "no such method: ~a~a"
name
(for-class (class-name class)))))]
[instance? (class-object? class)]
[dynamic-generic
(lambda (obj)
(unless (instance? obj)
(raise-type-error
(string->symbol (format "generic:~a~a" name (for-class (class-name class))))
(format "instance~a" (for-class (class-name class)))
obj))
(vector-ref (class-methods (object-ref obj)) pos))])
(if (eq? 'final (vector-ref (class-meth-flags class) pos))
(let ([method (vector-ref (class-methods class) pos)])
(lambda (obj)
(unless (instance? obj)
(dynamic-generic obj))
method))
dynamic-generic)))))])
make-generic))
(define-syntaxes (send-generic send-generic-traced)
(let ()
(define (core-send-generic traced?)
(lambda (stx)
(syntax-case stx ()
[(_ object generic . args)
(let* ([args-stx (syntax args)]
[proper? (stx-list? args-stx)]
[flat-stx (if proper? args-stx (flatten-args args-stx))])
(with-syntax ([(gen obj)
(generate-temporaries (syntax (generic object)))])
(quasisyntax/loc stx
(let* ([obj object]
[gen generic])
(unsyntax
(make-method-call
traced?
stx
(syntax obj)
(syntax/loc stx unwrap-object)
(syntax/loc stx ((generic-applicable gen) obj))
(syntax/loc stx (generic-name gen))
flat-stx
(not proper?)))))))])))
(values (core-send-generic #f) (core-send-generic #t))))
(define-syntaxes (class-field-accessor class-field-mutator generic/form)
(let ([mk
(lambda (make targets)
(lambda (stx)
(syntax-case stx ()
[(_ class-expr name)
(let ([name (syntax name)])
(unless (identifier? name)
(raise-syntax-error
#f
"expected an indentifier"
stx
name))
(with-syntax ([name (localize name)]
[make make])
(syntax/loc stx (make class-expr `name))))]
[(_ class-expr)
(raise-syntax-error
#f
(format "expected a field name after the ~a expression"
targets)
stx)])))])
(values
(mk (quote-syntax make-class-field-accessor) "class")
(mk (quote-syntax make-class-field-mutator) "class")
(mk (quote-syntax make-generic/proc) "class or interface"))))
(define-syntax (class-field-accessor-traced stx)
(syntax-case stx ()
[(form class name)
(syntax/loc stx
(let* ([accessor (class-field-accessor class name)])
(lambda (obj)
(begin0 (accessor obj)
(get-event obj 'name)))))]))
(define-syntax (class-field-mutator-traced stx)
(syntax-case stx ()
[(form class name)
(syntax/loc stx
(let* ([mutator (class-field-mutator class name)])
(lambda (obj value)
(begin0 (mutator obj value)
(set-event obj 'name value)))))]))
(define-syntaxes (set-field! set-field!-traced)
(let ()
(define (core-set-field! traced?)
(λ (stx)
(syntax-case stx ()
[(_ name obj val)
(identifier? #'name)
(with-syntax ([set (if traced?
#'set-field!/proc-traced
#'set-field!/proc)]
[localized (localize #'name)])
(syntax/loc stx (set `localized obj val)))]
[(_ name obj val)
(raise-syntax-error
'set-field! "expected a field name as first argument"
stx #'name)])))
(values (core-set-field! #f) (core-set-field! #t))))
(define-traced (set-field!/proc id obj val)
(unless (object? obj)
(raise-mismatch-error
'set-field!
"expected an object, got "
obj))
(trace-begin
(trace (set-event obj id val))
(let loop ([obj obj])
(let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)]
[index (hash-ref field-ht id #f)])
(cond
[index
((vector-ref (class-ext-field-sets cls) index) obj val)]
[else
(raise-mismatch-error
'get-field
(format "expected an object that has a field named ~s, got " id)
obj)])))))
(define-syntaxes (get-field get-field-traced)
(let ()
(define (core-get-field traced?)
(lambda (stx)
(syntax-case stx ()
[(_ name obj)
(identifier? (syntax name))
(with-syntax ([get (if traced?
(syntax get-field/proc-traced)
(syntax get-field/proc))]
[localized (localize (syntax name))])
(syntax (get `localized obj)))]
[(_ name obj)
(raise-syntax-error
'get-field "expected a field name as first argument"
stx (syntax name))])))
(values (core-get-field #f) (core-get-field #t))))
(define-traced (get-field/proc id obj)
(unless (object? obj)
(raise-mismatch-error
'get-field
"expected an object, got "
obj))
(trace-begin
(trace (get-event obj id))
(let loop ([obj obj])
(let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)]
[index (hash-ref field-ht id #f)])
(cond
[index
((vector-ref (class-ext-field-refs cls) index) obj)]
[else
(raise-mismatch-error
'get-field
(format "expected an object that has a field named ~s, got " id)
obj)])))))
(define-syntaxes (field-bound? field-bound?-traced)
(let ()
(define (core-field-bound? traced?)
(lambda (stx)
(syntax-case stx ()
[(_ name obj)
(identifier? (syntax name))
(with-syntax ([localized (localize (syntax name))]
[bound? (if traced?
(syntax field-bound?/proc-traced)
(syntax field-bound?/proc))])
(syntax (bound? `localized obj)))]
[(_ name obj)
(raise-syntax-error
'field-bound? "expected a field name as first argument"
stx (syntax name))])))
(values (core-field-bound? #f) (core-field-bound? #t))))
(define-traced (field-bound?/proc id obj)
(unless (object? obj)
(raise-mismatch-error
'field-bound?
"expected an object, got "
obj))
(trace-begin
(trace (inspect-event obj))
(let loop ([obj obj])
(let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)])
(and (hash-ref field-ht id #f)
#t))))) ;; ensure that only #t and #f leak out, not bindings in ht
(define-traced (field-names obj)
(unless (object? obj)
(raise-mismatch-error
'field-names
"expected an object, got "
obj))
(trace-begin
(trace (inspect-event obj))
(let loop ([obj obj])
(let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)]
[flds (filter interned? (hash-map field-ht (lambda (x y) x)))])
flds))))
(define-syntaxes (with-method with-method-traced)
(let ()
(define (core-with-method traced?)
(lambda (stx)
(syntax-case stx ()
[(_ ([id (obj-expr name)] ...) body0 body1 ...)
(let ([ids (syntax->list (syntax (id ...)))]
[names (syntax->list (syntax (name ...)))])
(for-each (lambda (id name)
(unless (identifier? id)
(raise-syntax-error #f
"not an identifier for binding"
stx
id))
(unless (identifier? name)
(raise-syntax-error #f
"not an identifier for method name"
stx
name)))
ids names)
(with-syntax ([(method ...) (generate-temporaries ids)]
[(method-obj ...) (generate-temporaries ids)]
[(name ...) (map localize names)]
[trace-flag (if traced? (syntax/loc stx #t) (syntax/loc stx #f))])
(syntax/loc stx (let-values ([(method method-obj)
(let ([obj obj-expr])
(find-method/who 'with-method obj `name))]
...)
(letrec-syntaxes+values ([(id) (make-with-method-map
trace-flag
(quote-syntax set!)
(quote-syntax id)
(quote-syntax method)
(quote-syntax method-obj)
(syntax unwrap-object))]
...)
()
body0 body1 ...)))))]
;; Error cases:
[(_ (clause ...) . body)
(begin
(for-each (lambda (clause)
(syntax-case clause ()
[(id (obj-expr name))
(and (identifier? (syntax id))
(identifier? (syntax name)))
'ok]
[_else
(raise-syntax-error
#f
"binding clause is not of the form (identifier (object-expr method-identifier))"
stx
clause)]))
(syntax->list (syntax (clause ...))))
;; If we get here, the body must be bad
(if (stx-null? (syntax body))
(raise-syntax-error
#f
"empty body"
stx)
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
stx)))]
[(_ x . rest)
(raise-syntax-error
#f
"not a binding sequence"
stx
(syntax x))])))
(values
;; with-method
(core-with-method #f)
;; with-method-traced
(core-with-method #t))))
;;--------------------------------------------------------------------
;; class, interface, and object properties
;;--------------------------------------------------------------------
(define-traced (is-a? v c)
(trace-begin
(trace (when (object? v)
(inspect-event v)))
(cond
[(class? c) ((class-object? (class-orig-cls c)) (unwrap-object v))]
[(interface? c)
(and (object? v)
(implementation? (object-ref (unwrap-object v)) c))]
[else (raise-type-error 'is-a? "class or interface" 1 v c)])))
(define (subclass? v c)
(unless (class? c)
(raise-type-error 'subclass? "class" 1 v c))
(and (class? v)
(let* ([c (class-orig-cls c)]
[v (class-orig-cls v)]
[p (class-pos c)])
(and (<= p (class-pos v))
(eq? c (vector-ref (class-supers v) p))))))
(define-traced (object-interface o)
(unless (object? o)
(raise-type-error 'object-interface "object" o))
(trace-begin
(trace (inspect-event o))
(class-self-interface (object-ref (unwrap-object o)))))
(define-traced (object-method-arity-includes? o name cnt)
(unless (object? o)
(raise-type-error 'object-method-arity-includes? "object" o))
(unless (symbol? name)
(raise-type-error 'object-method-arity-includes? "symbol" name))
(unless (and (integer? cnt)
(exact? cnt)
(not (negative? cnt)))
(raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
(trace-begin
(trace (inspect-event o))
(let loop ([o o])
(let* ([c (object-ref o)]
[pos (hash-ref (class-method-ht c) name #f)])
(cond
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
(add1 cnt))]
[else #f])))))
(define (implementation? v i)
(unless (interface? i)
(raise-type-error 'implementation? "interface" 1 v i))
(and (class? v)
(interface-extension? (class-self-interface v) i)))
(define (interface-extension? v i)
(unless (interface? i)
(raise-type-error 'interface-extension? "interface" 1 v i))
(and (interface? i)
(hash-ref (interface-all-implemented v) i #f)))
(define (method-in-interface? s i)
(unless (symbol? s)
(raise-type-error 'method-in-interface? "symbol" 0 s i))
(unless (interface? i)
(raise-type-error 'method-in-interface? "interface" 1 s i))
(and (memq s (interface-public-ids i)) #t))
(define (class->interface c)
(unless (class? c)
(raise-type-error 'class->interface "class" c))
(class-self-interface c))
(define (interned? sym)
(eq? sym (string->symbol (symbol->string sym))))
(define (interface->method-names i)
(unless (interface? i)
(raise-type-error 'interface->method-names "interface" i))
(filter interned? (interface-public-ids i)))
(define-traced (object-info o)
(unless (object? o)
(raise-type-error 'object-info "object" o))
(trace-begin
(trace (inspect-event o))
(let loop ([c (object-ref (unwrap-object o))]
[skipped? #f])
(if (struct? ((class-insp-mk c)))
;; current inspector can inspect this object
(values c skipped?)
(if (zero? (class-pos c))
(values #f #t)
(loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))
(define (to-sym s)
(if (string? s)
(string->symbol s)
s))
(define (class-info c)
(unless (class? c)
(raise-type-error 'class-info "class" c))
(if (struct? ((class-insp-mk c)))
(let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
(let loop ([next super][skipped? #f])
(if (or (not next)
(struct? ((class-insp-mk next))))
(values (to-sym (class-name c))
(- (class-field-width c) (class-field-width super))
(filter interned? (class-field-ids c))
(class-field-ref c)
(class-field-set! c)
next
skipped?)
(if (zero? (class-pos next))
(loop #f #t)
(loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
(raise-mismatch-error 'class-info "current inspector cannot inspect class: " c)))
(define-traced object->vector
(opt-lambda (in-o [opaque-v '...])
(unless (object? in-o)
(raise-type-error 'object->vector "object" in-o))
(trace-begin
(trace (inspect-event in-o))
(let ([o (unwrap-object in-o)])
(list->vector
(cons
(string->symbol (format "object:~a" (class-name (object-ref o))))
(reverse
(let-values ([(c skipped?) (object-info o)])
(let loop ([c c][skipped? skipped?])
(cond
[(not c) (if skipped? (list opaque-v) null)]
[else (let-values ([(name num-fields field-ids field-ref
field-set next next-skipped?)
(class-info c)])
(let ([rest (loop next next-skipped?)]
[here (let loop ([n num-fields])
(if (zero? n)
null
(cons (field-ref o (sub1 n))
(loop (sub1 n)))))])
(append (if skipped? (list opaque-v) null)
here
rest)))]))))))))))
(define (object=? o1 o2)
(unless (object? o1)
(raise-type-error 'object=? "object" o1))
(unless (object? o2)
(raise-type-error 'object=? "object" o2))
(eq? (unwrap-object o1)
(unwrap-object o2)))
;;--------------------------------------------------------------------
;; primitive classes
;;--------------------------------------------------------------------
(define (make-primitive-class
make-struct:prim ; see below
prim-init ; primitive initializer: takes obj and list of name-arg pairs
name ; symbol
super ; superclass
intfs ; interfaces
init-arg-names ; #f or list of syms and sym--value lists
override-names ; overridden method names
new-names ; new (public) method names
override-methods ; list of methods
new-methods) ; list of methods
; The `make-struct:prim' function takes prop:object, a
; class, a preparer, a dispatcher function, and a property assoc list, and produces:
; * a struct constructor (must have prop:object)
; * a struct predicate
; * a struct type for derived classes (mustn't have prop:object)
;
; The supplied preparer takes a symbol and returns a num.
;
; The supplied dispatcher takes an object and a num and returns a method.
;
; When a primitive class has a superclass, the struct:prim maker
; is responsible for ensuring that the returned struct items match
; the supertype predicate.
(compose-class name
(or super object%)
intfs
#f
#f
#f
0 null null ; no fields
null ; no rename-supers
null ; no rename-inners
null null new-names
null null override-names
null null null ; no augrides
null ; no inherits
; #f => init args by position only
; sym => required arg
; sym--value list => optional arg
(and init-arg-names
(map (lambda (s)
(if (symbol? s) s (car s)))
init-arg-names))
'stop
(lambda ignored
(values
new-methods
override-methods
null ; no augride-methods
(lambda (this super-go/ignored si_c/ignored si_inited?/ignored si_leftovers/ignored init-args)
(apply prim-init this
(if init-arg-names
(extract-primitive-args this name init-arg-names init-args)
init-args)))))
make-struct:prim))
(define (extract-primitive-args this class-name init-arg-names init-args)
(let loop ([names init-arg-names][args init-args])
(cond
[(null? names)
(unless (null? args)
(unused-args-error this args))
null]
[else (let* ([name (car names)]
[id (if (symbol? name)
name
(car name))])
(let ([arg (assq id args)])
(cond
[arg
(cons (cdr arg) (loop (cdr names) (remq arg args)))]
[(symbol? name)
(missing-argument-error class-name name)]
[else
(cons (cadr name) (loop (cdr names) args))])))])))
;;--------------------------------------------------------------------
;; wrapper for contracts
;;--------------------------------------------------------------------
(define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts)
(let* ([name (class-name cls)]
[method-width (class-method-width cls)]
[method-ht (class-method-ht cls)]
[meths (if (null? methods)
(class-methods cls)
(make-vector method-width))]
[field-pub-width (class-field-pub-width cls)]
[field-ht (class-field-ht cls)]
[int-field-refs (make-vector field-pub-width)]
[int-field-sets (make-vector field-pub-width)]
[ext-field-refs (make-vector field-pub-width)]
[ext-field-sets (make-vector field-pub-width)]
[class-make (if name
(make-naming-constructor
struct:class
(string->symbol (format "class:~a" name)))
make-class)]
[c (class-make name
(class-pos cls)
(list->vector (vector->list (class-supers cls)))
(class-self-interface cls)
void ;; No inspecting
method-width
method-ht
(class-method-ids cls)
meths
(class-super-methods cls)
(class-int-methods cls)
(class-beta-methods cls)
(class-meth-flags cls)
(class-inner-projs cls)
(class-dynamic-idxs cls)
(class-dynamic-projs cls)
(class-field-width cls)
field-pub-width
field-ht
(class-field-ids cls)
int-field-refs
int-field-sets
ext-field-refs
ext-field-sets
'struct:object 'object? 'make-object
'field-ref 'field-set!
(class-init-args cls)
(class-init-mode cls)
(class-init cls)
(class-orig-cls cls)
#f #f ; serializer is never set
#f)]
[obj-name (if name
(string->symbol (format "wrapper-object:~a" name))
'object)])
(vector-set! (class-supers c) (class-pos c) c)
;; --- Make the new object struct ---
(let-values ([(struct:object object-make object? object-field-ref object-field-set!)
(make-struct-type obj-name
struct:wrapper-object
0 ;; No init fields
0 ;; No new fields in this wrapped object
undefined
;; Map object property to class:
(list (cons prop:object c)))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)
(set-class-field-ref! c object-field-ref)
(set-class-field-set!! c object-field-set!))
;; Handle public method contracts
(unless (null? methods)
;; First, fill in from old methods
(vector-copy! meths 0 (class-methods cls))
;; Now apply projections
(for ([m (in-list methods)]
[c (in-list method-contracts)])
(when c
(let ([i (hash-ref method-ht m)]
[p ((contract-projection c) blame)])
(vector-set! meths i (p (vector-ref meths i)))))))
;; Fix up internal/external field accessors/mutators
;; Normally we'd redirect these, but since make-field-map now unwraps
;; on all accesses, we just copy over the old vectors.
(vector-copy! int-field-refs 0 (class-int-field-refs cls))
(vector-copy! int-field-sets 0 (class-int-field-sets cls))
(vector-copy! ext-field-refs 0 (class-ext-field-refs cls))
(vector-copy! ext-field-sets 0 (class-ext-field-sets cls))
;; Handle external field contracts
(unless (null? fields)
(let ([bset (blame-swap blame)])
(for ([f (in-list fields)]
[c (in-list field-contracts)])
(when c
(let* ([i (hash-ref field-ht f)]
[pre-p (contract-projection c)]
[old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i
(λ (o) ((pre-p blame) (old-ref o))))
(vector-set! ext-field-sets i
(λ (o v) (old-set o ((pre-p bset) v)))))))))
c))
;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?)
(define (make-wrapper-object obj blame methods method-contracts fields field-contracts)
(check-object-contract obj blame methods fields)
(let ([new-cls (make-wrapper-class obj (object-ref obj) blame methods method-contracts fields field-contracts)])
((class-make-object new-cls) obj)))
;;--------------------------------------------------------------------
;; misc utils
;;--------------------------------------------------------------------
(define undefined (letrec ([x x]) x))
(define-struct (exn:fail:object exn:fail) () #:inspector insp)
(define (obj-error where . msg)
(raise (make-exn:fail:object
(string-append (format "~a: " where) (apply format msg))
(current-continuation-marks))))
(define (for-class name)
(if name (format " for class: ~a" name) ""))
(define (for-class/which which name)
(if name (format " for ~a class: ~a" which name) ""))
(define (for-intf name)
(if name (format " for interface: ~a" name) ""))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; mixin
;;
(define (check-mixin-super mixin-name super% from-ids)
(let ([mixin-name (or mixin-name 'mixin)])
(unless (class? super%)
(error mixin-name "argument is not a class: ~e" super%))
(for-each (lambda (from-id)
(unless (implementation? super% from-id)
(error mixin-name "argument does not implement ~e: ~e" from-id super%)))
from-ids)))
(define (check-mixin-from-interfaces all-from)
(for-each (lambda (from-id)
(unless (interface? from-id)
(error 'mixin
"expected from-interface, got: ~e; others ~e"
from-id
all-from)))
all-from))
(define (check-mixin-to-interfaces all-to)
(for-each (lambda (to-id)
(unless (interface? to-id)
(error 'mixin
"expected to-interface, got: ~e; others ~e"
to-id
all-to)))
all-to))
(define (check-interface-includes xs from-ids)
(for-each
(lambda (x)
(unless (ormap (lambda (i) (method-in-interface? x i)) from-ids)
(error 'mixin
"method `~a' was referenced in definition, but is not in any of the from-interfaces: ~e"
x from-ids)))
xs))
(define-syntax (mixin stx)
(syntax-case stx ()
[(_ (from ...) (to ...) clauses ...)
(let ([extract-renamed-names
(λ (x)
(map (λ (x) (syntax-case x ()
[(internal-name external-name) (syntax external-name)]
[else x]))
(syntax->list x)))])
(define (get-super-names stx)
(syntax-case stx (inherit rename
override overment override-final
define/override define/overment define/override-final
augment augride augment-final
define/augment define/augride define/augment-final)
[(inherit names ...) (extract-renamed-names (syntax (names ...)))]
[(rename [x names] ...) (syntax->list (syntax (names ...)))]
[(override names ...) (extract-renamed-names (syntax (names ...)))]
[(overment names ...) (extract-renamed-names (syntax (names ...)))]
[(override-final names ...) (extract-renamed-names (syntax (names ...)))]
[(augment names ...) (extract-renamed-names (syntax (names ...)))]
[(augride names ...) (extract-renamed-names (syntax (names ...)))]
[(augment-final names ...) (extract-renamed-names (syntax (names ...)))]
[(define/augment (name . names) . rest) (extract-renamed-names (syntax (name)))]
[(define/augment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
[(define/augride (name . names) . rest) (extract-renamed-names (syntax (name)))]
[(define/augride name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
[(define/augment-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
[(define/augment-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
[(define/override (name . names) . rest) (extract-renamed-names (syntax (name)))]
[(define/override name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
[(define/overment (name . names) . rest) (extract-renamed-names (syntax (name)))]
[(define/overment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
[(define/override-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
[(define/override-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
[else null]))
(with-syntax ([(from-ids ...) (generate-temporaries (syntax (from ...)))]
[(to-ids ...) (generate-temporaries (syntax (to ...)))]
[(super-vars ...)
(apply
append
(map get-super-names
(syntax->list (syntax (clauses ...)))))]
[mixin-name (or (with-syntax ([tmp (syntax-local-name)])
(syntax (quote tmp)))
(syntax (quote mixin)))])
;; Build the class expression first, to give it a good src location:
(with-syntax ([class-expr
(with-syntax ([orig-stx stx])
(syntax/loc stx
(class/derived orig-stx [#f super% (to-ids ...) #f]
clauses ...)))])
;; Now build mixin proc, again to give it a good src location:
(with-syntax ([mixin-expr
(syntax/loc stx
(λ (super%)
(check-mixin-super mixin-name super% (list from-ids ...))
class-expr))])
;; Finally, build the complete mixin expression:
(syntax/loc stx
(let ([from-ids from] ...)
(let ([to-ids to] ...)
(check-mixin-from-interfaces (list from-ids ...))
(check-mixin-to-interfaces (list to-ids ...))
(check-interface-includes (list (quote super-vars) ...)
(list from-ids ...))
mixin-expr)))))))]))
(define externalizable<%>
(_interface () externalize internalize))
(define printable<%>
(interface* ()
([prop:custom-write (lambda (obj port write?)
(if write?
(send obj custom-write port)
(send obj custom-display port)))])
custom-write custom-display))
(define equal<%>
(interface* ()
([prop:equal+hash (list
(lambda (obj obj2 base-equal?)
(send obj equal-to? obj2 base-equal?))
(lambda (obj base-hash-code)
(send obj equal-hash-code-of base-hash-code))
(lambda (obj base-hash2-code)
(send obj equal-secondary-hash-code-of base-hash2-code)))])
equal-to? equal-hash-code-of equal-secondary-hash-code-of))
;; Providing traced versions:
(provide class-traced
class*-traced
class/derived-traced
(rename-out [define-serializable-class define-serializable-class-traced]
[define-serializable-class* define-serializable-class*-traced]
[mixin mixin-traced])
new-traced
make-object-traced
instantiate-traced
send-traced
send/apply-traced
send*-traced
class-field-accessor-traced
class-field-mutator-traced
with-method-traced
get-field-traced
set-field!-traced
field-bound?-traced
field-names-traced
(rename-out [generic/form generic-traced]
[make-generic/proc make-generic-traced])
send-generic-traced
is-a?-traced
object-interface-traced
object-info-traced
object->vector-traced
object-method-arity-includes?-traced
)
;; Providing normal functionality:
(provide (protect-out make-wrapper-object
check-object-contract
get-field/proc)
(rename-out [_class class]) class* class/derived
define-serializable-class define-serializable-class*
class?
mixin
(rename-out [_interface interface]) interface* interface?
object% object? object=? externalizable<%> printable<%> equal<%>
new make-object instantiate
get-field set-field! field-bound? field-names
send send/apply send* class-field-accessor class-field-mutator with-method
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
(rename-out [generic/form generic]) (rename-out [make-generic/proc make-generic]) send-generic 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
class/c ->m ->*m object/c)
Reference in New Issue View Git Blame Copy Permalink