This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/mats/oop.ss

863 lines
46 KiB
Scheme
Raw Normal View History

2022-07-29 15:12:07 +02:00
;;; Copyright (c) 2002 Oscar Waddell and R. Kent Dybvig
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;; Last modified: October 2010
;;; Acknowledgements
;;; - Michael Lenaghan of frogware, Inc., contributed to the define-class
;;; interface handling code.
;;; Possible names:
;;; Chez Scheme OOP System (Chez SOOP)
#|
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 inheritance
- either require parent for define-interface or hide <root-interface>
- consider allowing multiple inheritance (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) ...)))
)
;;; supplies define-class, define-interface, <root>, and <root-interface>
;;; and aux keywords
(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)
)