#|

define-class:

definition -> (define-class (class-name class-formal*)

(base-name base-actual*)

clause*)

clause -> (implements interface*)

| (ivars ivar*)

| (init init-expr*)

| (methods method*)

| (constructor id)

| (predicate id)

| (prefix string)

ivar -> (modifier* ivar-name ivar-expression)

modifier -> mutability | visibility

mutability -> mutable | immutable

visibility -> public | private

method -> (method-name formals method-body+)

formals -> (var*) | var | (var+ . var)

notes:

- at most one of each kind of clause may be present

- at most one of each kind of modifier may be present

- multiple methods of the same name but different formals can be present

products:

- class-name is bound to class information in the expand-time environment

- make-class-name (or specified constructor name) is bound to creation procedure

- class-name? (or specified predicate name) is bound to predicate procedure

- new (not inherited) method names are bound to method-dispatch procedures

- for each public ivar, <prefix>-ivar is bound to an accessor procedure,

where <prefix> is the specified prefix or "class-name-"

- for each public, mutable ivar, <prefix>-ivar-set! is bound to a mutator

procedure, where <prefix> is the specified prefix or "class-name-"

define-interface:

definition -> (define-interface interface-name method*)

| (define-interface interface-name base-name method*)

method -> (method-name formals)

products:

- interface-name is bound to interface information in the expand-time environment

- new (not inherited) method names are bound to method-dispatch procedures

|#

#| Todo:

- try using record-constructor, record-accessor, and record-mutator!

instead of $record, $object-ref, and $object-set!

- add a nongenerative clause ala define-record-type

- squawk if any methods or interfaces

- default to generative

- need more tests:

- init-expr checks

- profile to see if all paths are covered by test suite

- consider: don't degenerate to record definition facility

- flush implicit nongenerative option

- flush visibility keywords

- flush getter/setter

=> less complex but less useful

- consider: alternative version

- <class-name> and method definitions are only products

- (make-class-name arg ...) replaced by (make <class-name> arg ...)

- (class-name? arg) replaced by (isa? <class-name> arg)

- accessors and mutators replaced by

(open-instance <class-name> (ivar ...) expr expr ...)

- upside: prettier, less namespace clutter

- downside: can't use module system directly to control visibility of

makers, predicates, accessors, and mutators separately

- downside: maker, predicate, accessors, mutators aren't

first-class procedures

- consider: inherited ivars

- (inherited-ivar ivar ...)

- inheritable / noninheritable ivar modifiers

- (frogware) Error messages for incorrect syntax should be better. (You often

get a generic "invalid syntax" message and have to hunt to figure

out what caused it.)

- consider exposing query-interface somehow

- (interface I x) => version of x to which I's methods are applicable

- (interface->instance (interface I x)) => x

- interfaces and inheritence

- either require parent for define-interface or hide <root-interface>

- consider allowing multiple inheritence (including zero parents) for interfaces

|#

#|

reaching into Chez Scheme's internals for:

#!base-rtd

$make-record-type

$record-type-field-offsets

$record-type-interfaces

$record

$object-ref

$object-set!

|#

#!chezscheme

(library (oop helpers)

(export

$make-class $class?

$class-formals $class-formal-bindings $class-ivar-bindings $class-minfos

$class-vtable-rtd $class-ctrtd

$class-vtable-expr $class-interfaces $class-init-proc

$make-interface $interface?

$interface-rtd $interface-minfos

$instance $make-instance $instance?

root-vtable-rtd

make-minfo minfo-mname minfo-hidden-mname minfo-arity minfo-formals minfo-flat-formals

construct-name parse-formals build-generic make-ivar-defn free-id-member

)

(import (chezscheme))

(define-record-type ($class $make-class $class?)

(nongenerative)

(fields

(immutable formals) ; (formal ...)

(immutable formal-bindings) ; (((base-formal base-arg) ...) ...)

(immutable ivar-bindings) ; (((ivar init) ...) ...)

(immutable minfos) ; ((mname hidden-mname arity) ...)

; same mname may appear more than once

(immutable vtable-rtd)

(immutable ctrtd)

(immutable vtable-expr)

(immutable interfaces)

(immutable init-proc)))

(define-record-type ($interface $make-interface $interface?)

(nongenerative)

(fields

(immutable rtd)

(immutable minfos)))

(define-record-type ($instance $make-instance $instance?)

(nongenerative))

;; minfos cannot be records since we insert minfos into the output of

;; define-class and define-interface and the identifiers contained within

;; these minfos must be marked/unmarked as appropriate by the expander,

;; which delves into vectors but not records

(define make-minfo

(lambda (mname hidden-name arity formals flat-formals)

(vector mname hidden-name arity formals flat-formals)))

(define minfo-mname (lambda (x) (vector-ref x 0)))

(define minfo-hidden-mname (lambda (x) (vector-ref x 1)))

(define minfo-arity (lambda (x) (vector-ref x 2)))

(define minfo-formals (lambda (x) (vector-ref x 3)))

(define minfo-flat-formals (lambda (x) (vector-ref x 4)))

(define root-vtable-rtd

(#%$make-record-type #!base-rtd #!base-rtd

"root-vtable-rtd"

'((immutable ptr interfaces))

#f

#f))

(define construct-name

(lambda (template-identifier . args)

(datum->syntax template-identifier

(string->symbol

(apply string-append

(map (lambda (x)

(if (string? x)

x

(symbol->string (syntax->datum x))))

args))))))

(define parse-formals

(lambda (fmls)

(let f ([ids fmls] [n 0])

(syntax-case ids ()

[(car . cdr)

(if (identifier? #'car)

(f #'cdr (fx+ n 1))

(syntax-error fmls "invalid method formals"))]

[() (values n fmls)]

[else

(if (identifier? #'ids)

(values

(fx- -1 n)

(let f ([ids fmls])

(syntax-case ids ()

[(x . d) (cons #'x (f #'d))]

[x #'(x)])))

(syntax-error #'fmls "invalid method formals"))]))))

(define build-generic

(lambda (minfos offsets)

(define cull-method

(lambda (mname minfos offsets)

(if (null? minfos)

(values '() '() '() '())

(let ([offset (car offsets)] [minfo (car minfos)])

(let-values ([(gminfos goffsets new-minfos new-offsets)

(cull-method mname (cdr minfos) (cdr offsets))])

(if (bound-identifier=? (minfo-mname minfo) mname)

(values

(cons minfo gminfos)

(cons offset goffsets)

new-minfos

new-offsets)

(values

gminfos

goffsets

(cons (car minfos) new-minfos)

(cons (car offsets) new-offsets))))))))

(if (null? minfos)

'()

(let ([generic-name (minfo-mname (car minfos))])

(let-values ([(gminfos goffsets minfos offsets)

(cull-method generic-name minfos offsets)])

(cons `(,generic-name

,@(map (lambda (minfo offset)

`(,(minfo-formals minfo) ,(minfo-flat-formals minfo) ,offset))

gminfos

goffsets))

(build-generic minfos offsets)))))))

(define (make-ivar-defn ivar mutable? ivar-offset)

(with-syntax ([ivar ivar] [ivar-offset ivar-offset])

(if mutable?

#'(define-syntax ivar

(identifier-syntax

[id (#3%$object-ref 'scheme-object ego ivar-offset)]

[(set! var val) (#3%$object-set! 'scheme-object ego ivar-offset val)]))

#'(define-syntax ivar

(make-variable-transformer

(lambda (x)

(syntax-case x (set!)

[id (identifier? #'id) #'(#3%$object-ref 'scheme-object ego ivar-offset)]

[(set! var val) (syntax-error x "invalid assignment of immutable ivar")])))))))

(define free-id-member

(lambda (id ls2)

(and (not (null? ls2))

(if (free-identifier=? (car ls2) id)

ls2

(free-id-member id (cdr ls2))))))

(record-writer (type-descriptor $instance)

(lambda (x p wr)

(fprintf p "#<instance of ~a>"

(let ([rtd (record-rtd x)])

(if (eq? rtd (type-descriptor $instance))

"<root>"

(record-type-name rtd))))))

; these aren't evaluated if placed in (oop), since (oop) has no

; run-time (variable) exports

(pretty-format 'define-class

'(_ (fill 0 x ...) 13 (fill 0 x ...) #f clause ...))

(pretty-format 'methods

'(_ #f (bracket x (fill 0 x ...) #f e ...) ...))

(pretty-format 'ivars

'(_ (bracket fill #f x ...) 6 (bracket fill #f x ...) ...))

(pretty-format 'define-interface

'(alt (_ var var #f (bracket x x) ...)

(_ var #f (bracket x x) ...)))

)

(library (oop)

(export <root> <root-interface> define-interface

define-class ivars public private methods self implements init

constructor predicate prefix)

(import (chezscheme) (oop helpers))

(define-syntax <root>

(make-compile-time-value

($make-class '() '() '() '() ; formals formal-bindings ivar-bindings minfos

root-vtable-rtd

(type-descriptor $instance) ; ctrtd

#'(type-descriptor $instance) ; vtable-expr

'() ; interfaces

#'values))) ; init-expr ...

(define-syntax <root-interface>

(make-compile-time-value

($make-interface (make-record-type "base interface rtd" '()) '())))

(define-syntax define-interface

(lambda (x)

(define build-minfo

(lambda (mname formals)

(let-values ([(arity flat-formals) (parse-formals formals)])

; discard source information

(make-minfo mname "ignored" arity formals flat-formals))))

(syntax-case x ()

[(_ iname [method-name method-formals] ...)

(and (identifier? #'iname) (andmap identifier? #'(method-name ...)))

#'(define-interface iname <root-interface> [method-name method-formals] ...)]

[(_ iname base-iname [method-name method-formals] ...)

(and (identifier? #'iname) (identifier? #'base-iname) (andmap identifier? #'(method-name ...)))

(lambda (r)

(let ([bi (r #'base-iname)])

(unless ($interface? bi)

(syntax-error #'base-iname

"define-interface: unrecognized base interface"))

(let ([base-mnames (with-syntax ([(#(base-mname base-hidden-name base-arity base-formals base-flat-formals) ...) ($interface-minfos bi)])

#'(base-mname ...))])

(let f ([ls #'(method-name ...)])

(unless (null? ls)

(when (free-id-member (car ls) base-mnames)

(syntax-error (car ls) "conflict with inherited interface method"))

(f (cdr ls)))))

(with-syntax ([(base-minfo ...) ($interface-minfos bi)]

[(minfo ...) (map build-minfo #'(method-name ...) #'(method-formals ...))])

(with-syntax ([iface-rtd

(make-record-type ($interface-rtd bi)

(symbol->string (syntax->datum #'iname))

(syntax->datum (map minfo-mname #'(minfo ...))))])

(with-syntax ([((generic-name (generic-formals generic-flat-formals generic-offset) ...) ...)

(build-generic

#'(minfo ...)

(let ([ls (#%$record-type-field-offsets #'iface-rtd)])

(list-tail ls (- (length ls) (length #'(minfo ...))))))]

[opt3 (= (optimize-level) 3)])

#`(begin

(define-syntax iname (make-compile-time-value ($make-interface 'iface-rtd #'(base-minfo ... minfo ...))))

(define (qi who ego)

(define get-interfaces (#3%record-accessor '#,root-vtable-rtd 0))

(or (and (or opt3 (#3%record? ego))

(let ([rtd (#3%record-rtd ego)])

(and (or opt3 (#3%record? rtd '#,root-vtable-rtd))

(#3%ormap (lambda (i) (and (#3%record? i 'iface-rtd) i))

(get-interfaces rtd)))))

(errorf who "not applicable to ~s" ego)))

(define generic-name

(let ([who 'generic-name]) ; can't ref generic-name pattern vble inside ... below

(case-lambda

[(ego . generic-formals)

((#3%$object-ref 'scheme-object (qi who ego) generic-offset)

ego . generic-flat-formals)]

...)))

...))))))])))

(define-syntax define-class

(lambda (x)

(define build-minfo

(lambda (mname formals hidden)

(let-values ([(arity flat-formals) (parse-formals formals)])

(make-minfo mname hidden arity formals flat-formals))))

(define build-method

(lambda (minfo class-name body base-minfos)

(define cull-super

(lambda (mname minfos)

(if (null? minfos)

'()

(let ([minfo (car minfos)])

(if (free-identifier=? (minfo-mname minfo) mname)

(cons minfo (cull-super mname (cdr minfos)))

(cull-super mname (cdr minfos)))))))

(with-syntax ([(formal ...) (minfo-flat-formals minfo)]

[body body]

[super-definition

(with-syntax ([super (datum->syntax class-name 'super)])

(if (not (null? base-minfos))

(with-syntax ([(#(mname hidden-name arity formals flat-formals) ...)

(cull-super (minfo-mname minfo) base-minfos)])

#'(define super (case-lambda [formals (hidden-name ego . flat-formals)] ...)))

(with-syntax ([mname (minfo-mname minfo)] [class-name class-name])

#'(define-syntax super

(lambda (x)

(syntax-error x

(format "no inherited ~s method for ~s in" 'mname 'class-name)))))))])

#'(lambda (i formal ...)

(fluid-let-syntax ([ego (identifier-syntax i)])

super-definition

body)))))

(define unwrap-minfos

(lambda (minfos)

; need list/vector structure, with arity unwrapped

(with-syntax ([(#(mname hidden-name arity formals flat-formals) ...) minfos])

(with-syntax ([(arity ...) (syntax->datum #'(arity ...))])

#'(#(mname hidden-name arity formals flat-formals) ...)))))

(define build-interface-vtable

(lambda (minfos)

(lambda (iface)

(with-syntax

([irtd ($interface-rtd iface)]

[(hidden ...)

(map (lambda (iminfo)

(let ([mname (minfo-mname iminfo)] [arity (minfo-arity iminfo)])

(let f ([minfos minfos])

(cond

[(null? minfos) (syntax-error (minfo-mname iminfo) "no suitable implementation for interface method")]

[(minfo-match? (car minfos) mname arity) (minfo-hidden-mname (car minfos))]

[else (f (cdr minfos))]))))

(unwrap-minfos ($interface-minfos iface)))])

#'(#3%$record 'irtd hidden ...)))))

(define minfo-match?

(lambda (minfo mname arity)

(and (= arity (minfo-arity minfo))

(free-identifier=? mname (minfo-mname minfo)))))

(define process-methods

(lambda (class-name interfaces all-base-minfos minfos bodies)

(let f ([minfos minfos])

(unless (null? minfos)

(let ([mname (minfo-mname (car minfos))] [arity (minfo-arity (car minfos))])

(let f ([ls (cdr minfos)])

(unless (null? ls)

(if (minfo-match? (car ls) mname arity)

(syntax-error (minfo-mname (car ls)) "duplicate arity for method")

(f (cdr ls))))))

(f (cdr minfos))))

(let ([base-mnames (map minfo-mname all-base-minfos)])

(let f ([base-minfos all-base-minfos] [minfos minfos] [bodies bodies] [mlambdas '()] [all-minfos '()])

(if (null? base-minfos)

(let f ([minfos minfos] [bodies bodies] [mlambdas mlambdas] [all-minfos all-minfos] [generics '()])

(if (null? minfos)

(begin

; We should never create a new generic method that matches the name of

; an interface method. (If the generic method made it this far then we

; know it didn't match the arity of the interface method. If it did it

; would have been filtered out.)

(for-each

(lambda (generic)

(let ([mname (minfo-mname generic)])

(for-each

(lambda (i)

(for-each

(lambda (m)

(let ([interface-mname (minfo-mname m)])

(when (free-identifier=? mname interface-mname)

(syntax-error mname "arity not supported by interface method"))))

(unwrap-minfos ($interface-minfos i))))

interfaces)))

generics)

(list (reverse all-minfos)

(reverse mlambdas)

(reverse generics)

; We need to build a list of minfos that will actually be included in the class vtable--

; ie, minfos that appear in this class and/or any super-class (but not in any interface).

; That list will match up with the vtable offsets.

(let f ([possibly-included-minfos all-minfos] [included-minfos '()])

(if (null? possibly-included-minfos)

included-minfos

(let ([minfo (car possibly-included-minfos)])

(let ([mname (minfo-mname minfo)] [arity (minfo-arity minfo)])

(f (cdr possibly-included-minfos)

(if (ormap

(lambda (i)

(ormap (lambda (m) (minfo-match? m mname arity))

(unwrap-minfos ($interface-minfos i))))

interfaces)

included-minfos

(cons minfo included-minfos)))))))))

(let ([minfo (car minfos)])

(let ([mname (minfo-mname minfo)] [arity (minfo-arity minfo)])

(when (ormap (lambda (base-mname) (free-identifier=? mname base-mname)) base-mnames)

(syntax-error mname "arity not supported by base class method"))

(f (cdr minfos)

(cdr bodies)

(cons

(list (minfo-hidden-mname minfo)

(build-method minfo class-name (car bodies) '()))

mlambdas)

(cons minfo all-minfos)

(if (ormap

(lambda (i)

(ormap (lambda (m) (minfo-match? m mname arity))

(unwrap-minfos ($interface-minfos i))))

interfaces)

generics

(cons minfo generics)))))))

(let ([base-minfo (car base-minfos)])

(let ([base-mname (minfo-mname base-minfo)] [base-arity (syntax->datum (minfo-arity base-minfo))])

(let find-method ([xminfos minfos] [xbodies bodies])

(cond

[(null? xminfos)

(f (cdr base-minfos) minfos bodies mlambdas

(cons base-minfo all-minfos))]

[(and (= base-arity (minfo-arity (car xminfos)))

(free-identifier=? base-mname (minfo-mname (car xminfos))))

(f (cdr base-minfos)

(remq (car xminfos) minfos)

(remq (car xbodies) bodies)

(cons (list (minfo-hidden-mname (car xminfos))

(build-method (car xminfos) class-name (car xbodies) all-base-minfos))

mlambdas)

(cons (car xminfos) all-minfos))]

[else (find-method (cdr xminfos) (cdr xbodies))])))))))))

(define free-id-union

(lambda (ls1 ls2)

(if (null? ls1)

ls2

(if (free-id-member (car ls1) ls2)

(free-id-union (cdr ls1) ls2)

(cons (car ls1) (free-id-union (cdr ls1) ls2))))))

(module (parse-clauses)

(define-syntax define-option-parser

(lambda (x)

(syntax-case x (else)

[(_ name [desc (kwd ...) ([var default] ...) pattern guard expr] ...)

(with-syntax ([(seen? ...) (generate-temporaries #'(desc ...))])

#'(begin

(define (option-parser x*)

(let f ([x* x*] [seen? #f] ... [var default] ... ...)

(if (null? x*)

(values var ... ...)

(syntax-case (car x*) (kwd ... ...)

[pattern

guard

(begin

(when seen?

(syntax-error (car x*)

(format "extra ~a" desc)))

(let ([seen? #t])

(let-values ([(var ...) expr])

(f (cdr x*) seen? ... var ... ...))))]

...))))

(define-syntax name

(lambda (x)

(syntax-case x ()

[(k x* b1 b2 (... ...))

(with-implicit (k var ... ...)

#'(let-values ([(var ... ...) (option-parser x*)])

b1 b2 (... ...)))])))))])))

(define (valid-type? x) (eq? x 'scheme-object))

(define-option-parser parse-modifiers

["ivar mutability modifier" () ([mutable? #t])

x

(or (literal-identifier=? #'x #'mutable) (literal-identifier=? #'x #'immutable))

(literal-identifier=? #'x #'mutable)]

["ivar public/private modifier" () ([public? #f])

x

(or (literal-identifier=? #'x #'public) (literal-identifier=? #'x #'private))

(literal-identifier=? #'x #'public)]

["ivar type" () ([type 'scheme-object])

x

(valid-type? (datum x))

(datum x)]

["" () () x #t (syntax-error #'x "invalid ivar modifier")])

(define-option-parser parse-clauses

["implements clause" (implements) ([iface* '()])

(implements iface ...)

(andmap identifier? (syntax->list #'(iface ...)))

(syntax->list #'(iface ...))]

["ivars clause" (ivars) ([public?* '()] [mutable?* '()] [ivar* '()] [ivar-init* '()])

(ivars (modifier ... ivar ivar-init) ...)

(andmap identifier? (syntax->list #'(ivar ...)))

(let-values ([(public?* mutable?*)

(let f ([modifier** (syntax->list #'((modifier ...) ...))])

(if (null? modifier**)

(values '() '())

(let-values ([(public?* mutable?*) (f (cdr modifier**))])

(parse-modifiers (syntax->list (car modifier**))

(values (cons public? public?*)

(cons mutable? mutable?*))))))])

(values public?* mutable?* (syntax->list #'(ivar ...)) (syntax->list #'(ivar-init ...))))]

["init clause" (init) ([init-expr* '()])

(init init-expr ...)

#t

(syntax->list #'(init-expr ...))]

["methods clause" (methods) ([method-name* '()] [method-formals* '()] [method-body* '()])

(methods method ...)

#t

(let f ([method* (syntax->list #'(method ...))])

(if (null? method*)

(values '() '() '())

(let-values ([(method) (car method*)]

[(method-name* method-formals* method-body*) (f (cdr method*))])

(syntax-case method ()

[(method-name method-formals method-b1 method-b2 ...)

(values

(cons #'method-name method-name*)

(cons #'method-formals method-formals*)

(cons #'(let () method-b1 method-b2 ...) method-body*))]

[method (syntax-error #'method "invalid method syntax")]))))]

["constructor clause" (constructor) ([constructor-id #f])

(constructor id)

(identifier? #'id)

#'id]

["predicate clause" (predicate) ([predicate-id #f])

(predicate id)

(identifier? #'id)

#'id]

["prefix clause" (prefix) ([prefix-string #f])

(prefix str)

(string? (datum str))

(datum str)]

["" () () x #t (syntax-error #'x "invalid define-class clause")]))

(syntax-case x ()

[(_ (class-name class-formal ...) (base-name base-arg ...) clause ...)

(parse-clauses (syntax->list #'(clause ...))

(lambda (r)

(let ([bc (r #'base-name)])

(unless ($class? bc)

(syntax-error #'base-name

"define-class: unrecognized base class"))

(let f ([ls ivar*])

(define bound-id-member?

(lambda (x ls)

(and (not (null? ls))

(or (bound-identifier=? (car ls) x)

(bound-id-member? x (cdr ls))))))

(unless (null? ls)

(if (bound-id-member? (car ls) (cdr ls))

(syntax-error (car ls) "duplicate instance variable")

(f (cdr ls)))))

(with-syntax ([(iface-name ...) (free-id-union

iface*

(syntax->list ($class-interfaces bc)))])

(with-syntax ([(interface ...)

(map (lambda (x)

(let ([iface (r x)])

(unless ($interface? iface) (syntax-error x "unrecognized interface"))

iface))

#'(iface-name ...))])

(with-syntax ([(((base-ivar base-ivar-init) ...) ...) ($class-ivar-bindings bc)]

[base-init-proc ($class-init-proc bc)]

[(base-formal-binding ...)

(with-syntax ([(base-formal ...) ($class-formals bc)]

[(base-base-formal-binding ...) ($class-formal-bindings bc)])

(unless (= (length #'(base-arg ...)) (length #'(base-formal ...)))

(syntax-error #'base-name

"incorrect number of arguments to base class"))

#'(((base-formal base-arg) ...) base-base-formal-binding ...))]

[((all-minfo ...) ((new-hidden-mname mlambda) ...) (generic ...) (included-minfo ...))

(process-methods #'class-name #'(interface ...)

(unwrap-minfos ($class-minfos bc))

(map build-minfo

method-name*

method-formals*

(generate-temporaries method-name*))

method-body*)]

[self (datum->syntax #'class-name 'self)])

(let ([name (let ([name (datum class-name)])

(if (gensym? name)

name

(symbol->string name)))]

[nongenerative? (and (null? #'(all-minfo ...))

(null? #'(interface ...)))]

[flds (map list

(map (lambda (x) (if x 'mutable 'immutable)) mutable?*)

(map (lambda (x) 'ptr) ivar*)

(syntax->datum ivar*))])

(when (gensym? name)

(unless nongenerative?

(syntax-error #'class-name

"cannot specify gensym class-name with methods or interfaces")))

(with-syntax ([ctrtd (#%$make-record-type

#!base-rtd

($class-ctrtd bc)

name

flds

#f

#f)]

[vtable-rtd (#%$make-record-type

#!base-rtd

($class-vtable-rtd bc)

"compile-time-vtable-rtd"

(syntax->datum (map minfo-mname #'(generic ...)))

#f

#f)])

(with-syntax ([(ivar ...) ivar*]

[(ivar-init ...) ivar-init*]

[(ivar-defn ...)

(map make-ivar-defn

ivar*

mutable?*

(let ([offsets (#%$record-type-field-offsets #'ctrtd)])

(list-tail offsets (- (length offsets) (length ivar*)))))])

(with-syntax ([init-proc

(with-syntax ([(init-expr ...) init-expr*])

#'(lambda (ego)

(base-init-proc ego)

(let ()

ivar-defn

...

(define-syntax self (identifier-syntax ego))

init-expr ...

ego)))]

[vtable-expr

(if nongenerative?

#''ctrtd

(with-syntax ([(vtable-init ...) (map minfo-hidden-mname #'(included-minfo ...))]

[parent-rtd ($class-vtable-expr bc)]

[name (datum->syntax #'class-name name)]

[flds (datum->syntax #'class-name flds)]

[(iface-elt ...)

(map (build-interface-vtable #'(all-minfo ...)) #'(interface ...))])

#'(#%$make-record-type

'vtable-rtd

parent-rtd

name

'flds

#f

#f

(list iface-elt ...)

vtable-init ...)))]

[((generic-name (generic-formals generic-flat-formals generic-offset) ...) ...)

(build-generic

#'(generic ...)

(let ([offsets (#%$record-type-field-offsets #'vtable-rtd)] [minfos #'(included-minfo ...)])

(let f ([offsets (list-tail offsets (- (length offsets) (length minfos)))]

[minfos minfos]

[generics #'(generic ...)])

(if (null? generics)

'()

(if (eq? (car generics) (car minfos))

(cons (car offsets) (f (cdr offsets) (cdr minfos) (cdr generics)))

(f (cdr offsets) (cdr minfos) generics))))))]

[opt3 (= (optimize-level) 3)])

(with-syntax ([maker-name (or constructor-id (construct-name #'class-name "make-" #'class-name))]

[maker-body

(let f ([ls #'(base-formal-binding ...)])

(syntax-case ls ()

[(((lhs rhs) ...))

#'(let ((lhs rhs) ...)

(init-proc (let* ([base-ivar base-ivar-init] ... ... [ivar ivar-init] ...)

(#3%$record vtable base-ivar ... ... ivar ...))))]

[(((lhs rhs) ...) m ...)

(with-syntax ([body (f #'(m ...))])

#'(let ((lhs rhs) ...) body))]))]

[pred-name (or predicate-id (construct-name #'class-name #'class-name "?"))]

[((accessor-name . accessor) ...)

(let ([offset* (let ([offset* (#%$record-type-field-offsets #'ctrtd)])

(list-tail offset* (- (length offset*) (length ivar*))))]

[prefix-string (or prefix-string (format "~a-" (datum class-name)))])

(let f ([ivar* ivar*] [offset* offset*] [public?* public?*])

(if (null? ivar*)

'()

(with-syntax ([rest (f (cdr ivar*) (cdr offset*) (cdr public?*))])

(if (car public?*)

(with-syntax ([accessor-name (construct-name (car ivar*) prefix-string (car ivar*))]

[offset (car offset*)])

#'((accessor-name .

(lambda (x)

(unless (or opt3 (record? x vtable))

(errorf 'accessor-name "not applicable to ~s" x))

(#3%$object-ref 'scheme-object x offset)))

. rest))

#'rest)))))]

[((mutator-name . mutator) ...)

(let ([offset* (let ([offset* (#%$record-type-field-offsets #'ctrtd)])

(list-tail offset* (- (length offset*) (length ivar*))))]

[prefix-string (or prefix-string (format "~a-" (datum class-name)))])

(let f ([ivar* ivar*] [offset* offset*] [public?* public?*] [mutable?* mutable?*])

(if (null? ivar*)

'()

(with-syntax ([rest (f (cdr ivar*) (cdr offset*) (cdr public?*) (cdr mutable?*))])

(if (and (car public?*) (car mutable?*))

(with-syntax ([mutator-name (construct-name (car ivar*) prefix-string (car ivar*) "-set!")]

[offset (car offset*)])

#'((mutator-name .

(lambda (x v)

(unless (or opt3 (record? x vtable))

(errorf 'mutator-name "not applicable to ~s" x))

(#3%$object-set! 'scheme-object x offset v)))

. rest))

#'rest)))))])

#'(begin

; we use a module here (1) to attach necessary

; indirect exports to class-name in case class-name

; is exported from a top-level module and

; (2) so that we can define vtable after

; new-hidden-mname ... yet still have the introduced

; identifier vtable resolve to the correct binding

; in the method bodies. we don't wrap the entire

; define-class output in a module form since we want

; the pred-name, maker-name, and the generic names

; to be ordinary top-level variables at top level.

(module ((class-name vtable new-hidden-mname ...) vtable new-hidden-mname ...)

(module (new-hidden-mname ...)

; local ego for fluid-let-syntax to whack

(define-syntax ego values)

ivar-defn

...

(define-syntax self (identifier-syntax ego))

(define new-hidden-mname mlambda) ...)

; counting on letrec* semantics below so that

; new-hidden-mname ... are defined before referenced

; in vtable-expr

(define vtable vtable-expr)

(define-syntax class-name

(make-compile-time-value

($make-class

#'(class-formal ...)

#'(base-formal-binding ...)

#'(([base-ivar base-ivar-init] ...) ... ([ivar ivar-init] ...))

#'(all-minfo ...)

'vtable-rtd

'ctrtd

#'vtable

#'(iface-name ...)

#'init-proc))))

(define (pred-name x) (#3%record? x vtable))

(define (maker-name class-formal ...) maker-body)

(define accessor-name accessor) ...

(define mutator-name mutator) ...

(define generic-name

(let ([who 'generic-name]) ; can't ref generic-name pattern vble inside ... below

(case-lambda

[(ego . generic-formals)

(unless (or opt3 (#3%record? ego vtable))

(errorf who "not applicable to ~s" ego))

((#3%$object-ref 'scheme-object (#3%record-rtd ego) generic-offset)

ego . generic-flat-formals)]

...)))

...))))))))))))])))

(define-syntax aux

(syntax-rules ()

[(_ kwd)

(define-syntax kwd

(lambda (x)

(syntax-error x "misplaced aux keyword")))]))

(aux ivars)

(aux public)

(aux private)

(aux methods)

(aux self)

(aux implements)

(aux init)

; constructor, predicate, and prefix are defined by (chezscheme)

#;(aux constructor)

#;(aux predicate)

#;(aux prefix)

)