918 lines
30 KiB

;;;; s t k l o s . s t k -- A variation of the Gregor Kickzales Tiny CLOS
;;;; for STk
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;; Author: Erick Gallesio []
;;;; Creation date: 20-Feb-1994 21:09
;;;; Last file update: 27-Sep-1999 12:05 (eg)
(when (provided? "stklos")
(error "STklos already initialized."))
(%init-stklos) ; Initialize STklos
(with-module STk (import STklos)) ; Import the STklos module
(select-module STklos) ; Rest of file belongs to the STklos module
(export ; Define the exported symbols of this file
find-class is-a?
ensure-metaclass ensure-metaclass-with-supers
define-class make-class ensure-class
define-generic make-generic-function ensure-generic-function
define-method ensure-method method add-method
object-eqv? object-equal?
write-object display-object Tk-write-object
slot-unbound slot-missing
slot-definition-name slot-definition-options slot-definition-allocation
slot-definition-getter slot-definition-setter slot-definition-accessor
slot-definition-init-form slot-definition-init-keyword
slot-init-function class-slot-definition
allocate-instance initialize make-instance make
no-next-method no-applicable-method no-method next-method-exists?
shallow-clone deep-clone
apply-generic apply-method apply-methods compute-applicable-methods
method-more-specific? sort-applicable-methods
class-subclasses class-methods
slot-value (setter slot-value)
; U t i l i t i e s
(define (mapappend func . args)
(if (memv '() args)
(append (apply func (map car args))
(apply mapappend func (map cdr args)))))
(define (find-duplicate l) ; find a duplicate in a list; #f otherwise
((null? l) #f)
((memv (car l) (cdr l)) (car l))
(else (find-duplicate (cdr l)))))
(define (set-symbol! symbol value env)
(let ((module (%get-module env)))
(eval `(define ,symbol ,value) (module-environment module))))
(define (lookup-symbol symbol env)
(let ((module (%get-module env)))
(eval symbol (module-environment module))))
(define make-closure eval)
(define (specializers l)
((null? l) '())
((pair? l) (cons (if (pair? (car l)) (cadar l) '<top>)
(specializers (cdr l))))
(else '<top>)))
(define (formals l)
(if (pair? l)
(cons (if (pair? (car l)) (caar l) (car l)) (formals (cdr l)))
; [FIXME] This is too complicate
(define (%find-class name env . default)
(if (symbol? name)
;; Search symbol in the globals of given env. (it must denote a class)
(or (and (symbol-bound? name env)
(let ((cls (lookup-symbol name env)))
(and (is-a? cls <class>) cls)))
(if (null? default)
(error "find-class: class ~S not found" name)
(car default)))
(if (is-a? name <class>)
(error "find-class: bad-class ~S" name))))
;; Find-class
(define-macro (find-class name . default)
(let ((%find-class (with-module STklos %find-class)))
`(apply ,%find-class ,name ,(the-environment) ',default)))
;; is-a?
(define (is-a? obj class)
(and (memv class (class-precedence-list (class-of obj))) #t))
; M e t a c l a s s e s s t u f f
(define ensure-metaclass-with-supers
(let ((table-of-metas '()))
(lambda (meta-supers)
(let ((entry (assoc meta-supers table-of-metas)))
(if entry
;; Found a previously created metaclass
(cdr entry)
;; Create a new meta-class which inherit from "meta-supers"
(let ((new (make <class> :dsupers meta-supers
:slots '()
:name (gensym "metaclass"))))
(set! table-of-metas (cons (cons meta-supers new) table-of-metas))
(define (ensure-metaclass supers env)
(if (null? supers)
(%find-class '<class> env)
(let* ((all-metas (map (lambda (x)
(if (is-a? x <class>)
(class-of (%find-class x env))))
(all-cpls (apply append
(map (lambda (m) (cdr (class-precedence-list m)))
(needed-metas '()))
;; Find the most specific metaclasses. The new metaclass will be
;; a subclass of these.
(lambda (meta)
(when (and (not (member meta all-cpls)) (not (member meta needed-metas)))
(set! needed-metas (append needed-metas (list meta)))))
;; Now return a subclass of the metaclasses we found.
(if (null? (cdr needed-metas))
(car needed-metas) ; If there's only one, just use it.
(ensure-metaclass-with-supers needed-metas)))))
; D e f i n e - c l a s s
;==== Define-class
(define-macro (define-class name supers slots . options)
(make-class ,name ,supers ,slots ,@options)
;==== Make-class
(define-macro (make-class name supers slots . options)
',name ; name
',supers ; supers
',slots ; slots
,(or (get-keyword :metaclass options #f) ; metaclass
`(ensure-metaclass ',supers (the-environment)))
(the-environment) ; environment
;==== Ensure-class
(define (ensure-class name supers slots metaclass env . options)
(let ((supers (if (null? supers)
(list (%find-class '<object> env))
(map (lambda (x) (%find-class x env)) supers))))
;; Verify that all direct slots are different and that we don't inherit
;; several time from the same class
(let ((tmp1 (find-duplicate supers))
(tmp2 (find-duplicate (map slot-definition-name slots))))
(when tmp1
(error "define-class: super class ~S is duplicate in class ~S" tmp1 name))
(when tmp2
(error "define-class: slot ~S is duplicate in class ~S" tmp2 name)))
;; Everything seems correct, build the class
(let ((old (%find-class name env #f))
(cls (apply make metaclass :dsupers supers :slots slots
:name name :environment env options)))
(when old (class-redefinition old cls))
(set-symbol! name cls env)
; D e f i n e - g e n e r i c
; ==== Define-generic
(define-macro (define-generic gf)
(make-generic-function ,gf)
;==== Make-generic-function
(define-macro (make-generic-function gf)
`(ensure-generic-function ',gf (the-environment)))
;==== Ensure-generic-function
(define (ensure-generic-function name env)
(let* ((name (extended-name->scheme-name name))
(old-value (and (symbol-bound? name env)
;FIXME: (not (autoload? name module))
(lookup-symbol name env))))
(set-symbol! name
(make <generic>
:name name
:default (and (procedure? old-value) old-value))
; D e f i n e - m e t h o d
(define-macro (define-method name args . body)
(ensure-method ',name
',(formals args)
',(specializers args)
(define (ensure-method name formals specializers body env . kind-of-method)
(let* ((name (and name (extended-name->scheme-name name)))
(old-value (and name
(symbol-bound? name env)
;FIXME: (not (autoload? name module))
(lookup-symbol name env))))
;; See if a generic function must be defined for this method.
(when (and name (not (is-a? old-value <generic>)))
(ensure-generic-function name env))
;; Define the method and, eventually, add it to its generic
(let ((method (make (if (null? kind-of-method) <method> (car kind-of-method))
:specializers (map* (lambda (x)
(if (symbol? x)
(%find-class x env)
:procedure (make-closure
`(lambda (next-method ,@formals) ,@body)
(when name (add-method (lookup-symbol name env) method))
; Return the newly created method as result
;==== Method
(define-macro (method args . body)
(ensure-method #f
',(formals args)
',(specializers args)
;==== Add-method
(define (add-method-in-classes m)
;; Add method in all the classes which appears in its specializers list
(for-each* (lambda (x)
(let ((dm (class-direct-methods x)))
(unless (memv m dm)
(slot-set! x 'direct-methods (cons m dm)))))
(method-specializers m)))
(define (remove-method-in-classes m)
;; Remove method in all the classes which appears in its specializers list
(for-each* (lambda (x)
(slot-set! x 'direct-methods (remv m (class-direct-methods x))))
(method-specializers m)))
(define (compute-new-list-of-methods gf new)
(let ((new-spec (method-specializers new))
(methods (generic-function-methods gf)))
(let Loop ((l methods))
(if (null? l)
(cons new methods)
(if (equal? (method-specializers (car l)) new-spec)
;; This spec. list already exists. Remove old method from dependents
(remove-method-in-classes (car l))
(set-car! l new)
(Loop (cdr l)))))))
;; Add-method
(define (add-method gf m)
(slot-set! m 'generic-function gf)
(slot-set! gf 'methods (compute-new-list-of-methods gf m))
(add-method-in-classes m)
; Access to Meta objects
; A lot of them are in C
;;; Methods
(define-method method-body ((m <method>))
(let* ((spec (map class-name (slot-ref m 'specializers)))
(proc (procedure-body (slot-ref m 'procedure)))
(args (cdadr proc))
(body (cddr proc)))
(list* 'method (map list args spec) body)))
;;; Slots
(define (slot-definition-name s)
(if (pair? s) (car s) s))
(define (slot-definition-options s)
(and (pair? s) (cdr s)))
(define (slot-definition-allocation s)
(if (symbol? s)
(get-keyword :allocation (cdr s) :instance)))
(define (slot-definition-getter s)
(and (pair? s) (get-keyword :getter (cdr s) #f)))
(define (slot-definition-setter s)
(and (pair? s) (get-keyword :setter (cdr s) #f)))
(define (slot-definition-accessor s)
(and (pair? s) (get-keyword :accessor (cdr s) #f)))
(define (slot-definition-init-form s)
(if (pair? s)
(let* ((none (list '**none**))
(v1 (get-keyword :init-form (cdr s) none))
(v2 (get-keyword :initform (cdr s) none))) ; Backward compatibility
(if (eq? v1 none)
(if (eq? v2 none)
(define (slot-definition-init-keyword s)
(and (pair? s) (get-keyword :init-keyword (cdr s) #f)))
(define (slot-init-function c s)
(let ((s (slot-definition-name s)))
(cadr (assoc s (slot-ref c 'getters-n-setters)))))
(define (class-slot-definition class slot-name)
(assoc slot-name (class-slots class)))
; Standard methods
; used by the C runtime
;==== Methods to compare objects
(define-method object-eqv? (x y) #f)
(define-method object-equal? (x y) (eqv? x y))
;==== Methods to display/write an object
; Code for writing objects must test that the slots they use are
; bound. Otherwise a slot-unbound method will be called and will
; conduct to an infinite loop.
;; Write
(define-method write-object (o file)
(format file "#[instance ~A]" (address-of o)))
(define-method write-object ((o <object>) file)
(let ((class (class-of o)))
(if (slot-bound? class 'name)
(format file "#[~A ~A]" (class-name class) (address-of o))
(define-method write-object((class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name) (slot-bound? meta 'name))
(format file "#[~A ~A ~A]" (class-name meta) (class-name class)
(address-of class))
(define-method write-object((gf <generic>) file)
(let ((meta (class-of gf)))
(if (and (slot-bound? gf 'name) (slot-bound? meta 'name)
(slot-bound? gf 'methods))
(format file "#[~A ~A (~A)]" (class-name meta)
(generic-function-name gf)
(length (generic-function-methods gf)))
;; Display (do the same thing as write by default)
(define-method display-object (o file)
(write-object o file))
;; Tk-write-object is called when a STklos object is passed to a Tk-command.
;; By default, we do the same job as write; but if an object is a <Tk-widget>
;; we will pass it its Eid. The method for <Tk-widget> is defined elsewhere.
(define-method Tk-write-object (o file)
(write-object o file))
;==== Slot access
(define-method slot-unbound ((c <class>) (o <object>) s)
(error "Slot `~S' is unbound in object ~S" s o))
(define-method slot-missing ((c <class>) (o <object>) s)
(error "No slot with name `~S' in object ~S" s o))
(define-method slot-missing ((c <class>) (o <object>) s value)
(slot-missing c o s))
; ==== Methods for the possible error we can encounter when calling a gf
(define-method no-next-method ((gf <generic>) args)
(error "No next method when calling ~S\nwith ~S as argument" gf args))
(define-method no-applicable-method ((gf <generic>) args)
(error "No applicable method for ~S\nin call ~S"
gf (cons (generic-function-name gf) args)))
(define-method no-method ((gf <generic>) args)
(error "No method defined for ~S" gf))
(define-macro (next-method-exists?)
`((with-module STklos %next-method-exists?) next-method))
; Cloning functions (from rdeline@CS.CMU.EDU)
(define-method shallow-clone ((self <object>))
(let ((clone (%allocate-instance (class-of self)))
(slots (map slot-definition-name
(class-slots (class-of self)))))
(for-each (lambda (slot)
(if (slot-bound? self slot)
(slot-set! clone slot (slot-ref self slot))))
(define-method deep-clone ((self <object>))
(let ((clone (%allocate-instance (class-of self)))
(slots (map slot-definition-name
(class-slots (class-of self)))))
(for-each (lambda (slot)
(if (slot-bound? self slot)
(slot-set! clone slot
(let ((value (slot-ref self slot)))
(if (instance? value)
(deep-clone value)
; Class redefinition utilities
;==== Class-redefinition
(define-method class-redefinition ((old <Class>) (new <Class>))
;; Work on direct methods:
;; 1. Remove accessor methods from the old class
;; 2. Patch the occurences of old in the specializers by new
;; 3. Displace the methods from old to new
(remove-class-accessors old) ;; -1-
(let ((methods (class-direct-methods old)))
(for-each (lambda (m) (update-direct-method m old new)) ;; -2-
(slot-set! new 'direct-methods methods)) ;; -3-
;; Remove the old class from the direct-subclasses list of its super classes
(for-each (lambda (c) (slot-set! c 'direct-subclasses
(remv old (class-direct-subclasses c))))
(class-direct-supers old))
;; Redefine all the subclasses of old to take into account modification
(lambda (c) (update-direct-subclass c old new))
(class-direct-subclasses old))
;; Invalidate class so that subsequent instances slot accesses invoke
;; change-object-class
(slot-set! old 'redefined new))
;==== Remove-class-accessors
(define-method remove-class-accessors ((c <class>))
(lambda (m) (if (is-a? m <accessor-method>) (remove-method-in-classes m)))
(class-direct-methods c)))
;==== Update-direct-method
(define-method update-direct-method ((m <method>) (old <class>) (new <class>))
(let Loop ((l (method-specializers m)))
(when (pair? l) ; Note: the <top> in dotted list is never used.
(if (eqv? (car l) old) ; So we can work if we had only proper lists.
(set-car! l new))
(Loop (cdr l)))))
;==== Update-direct-subclass
(define-method update-direct-subclass ((c <class>) (old <Class>) (new <Class>))
(let ((new-supers (map (lambda (cls) (if (eqv? cls old) new cls))
(class-direct-supers c))))
;; Create a new class with same name as c. This will automagically call
;; class-redefinition on this subclass and redefine all its descent
(ensure-class (class-name c)
(class-direct-slots c)
(class-of c)
(slot-ref c 'environment))))
; Utilities for INITIALIZE methods
;;; compute-slot-accessors
(define (compute-slot-accessors class slots env)
(lambda (s)
(let ((name (slot-definition-name s))
(getter (slot-definition-getter s))
(setter (slot-definition-setter s))
(accessor (slot-definition-accessor s)))
(when getter
(ensure-method getter (list 'o) (list class)
`((slot-ref o ',name))
env <accessor-method>))
(when setter
(ensure-method setter (list 'o 'v) (list class <top>)
`((slot-set! o ',name v))
env <accessor-method>))
(when accessor
(ensure-method accessor (list 'o) (list class)
`((slot-ref o ',name))
env <accessor-method>)
(ensure-method `(setter ,accessor) (list 'o 'v) (list class <top>)
`((slot-set! o ',name v))
env <accessor-method>))))
;;; compute-getters-n-setters
(define (compute-getters-n-setters class slots env)
(define (compute-slot-init-function s)
(let ((init (slot-definition-init-form s)))
(and (not (unbound? init)) (make-closure `(lambda () ,init) env))))
(define (verify-accessors slot l)
(if (pair? l)
(let ((get (car l))
(set (cadr l)))
(unless (and (closure? get) (= (%procedure-arity get) 1))
(error "Bad getter closure for slot `~S' in ~S: ~S" slot class get))
(unless (and (closure? set) (= (%procedure-arity set) 2))
(error "Bad setter closure for slot `~S' in ~S: ~S" slot class set)))))
(map (lambda (s)
(let* ((s (if (pair? s) s (list s)))
(g-n-s (compute-get-n-set class s))
(name (slot-definition-name s)))
; For each slot we have '(name init-function getter setter)
; If slot, we have the simplest form '(name init-function . index)
(verify-accessors name g-n-s)
(list* name (compute-slot-init-function s) g-n-s)))
;;; compute-cpl
(define (compute-cpl class)
(define (filter-cpl class)
(let ((res '()))
(for-each (lambda (item)
(unless (or (eq? item <object>)
(eq? item <top>)
(member item res))
(set! res (cons item res))))
(let* ((supers (slot-ref class 'direct-supers))
(big-list (apply append (cons class supers) (map compute-cpl supers))))
(reverse (list* <top> <object> (filter-cpl big-list)))))
;;; Compute-get-n-set
(define-method compute-get-n-set ((class <class>) s)
(case (slot-definition-allocation s)
(:instance ;; Instance slot
;; get-n-set is just its offset
(let ((already-allocated (slot-ref class 'nfields)))
(slot-set! class 'nfields (+ already-allocated 1))
(:class ;; Class slot
;; Class-slots accessors are implemented as 2 closures around
;; a Scheme variable. As instance slots, class slots must be
;; unbound at init time. Since assignement to an unbound variable
;; is not possible with our set! (in this case set! thinks that
;; the variable has not been defined), our variable is in fact
;; a vector of length 1. This permits to circumvent this problem,
;; without introducing a "set-environment" primitive.
(let ((name (slot-definition-name s)))
(if (memq name (map slot-definition-name (class-direct-slots class)))
;; This slot is direct; create a new shared cell
(let ((shared-cell (make-vector 1)))
(list (lambda (o) (vector-ref shared-cell 0))
(lambda (o v) (vector-set! shared-cell 0 v))))
;; Slot is inherited. Find its definition in superclass
(let Loop ((l (cdr (class-precedence-list class))))
(let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
(if r
(cddr r)
(Loop (cdr l))))))))
(:each-subclass ;; slot shared by instances of direct subclass.
;; (Thomas Buerger, April 1998)
(let ((shared-cell (make-vector 1)))
(list (lambda (o) (vector-ref shared-cell 0))
(lambda (o v) (vector-set! shared-cell 0 v)))))
(:virtual;; No allocation
;; slot-ref and slot-set! function must be given by the user
(let ((get (get-keyword :slot-ref (slot-definition-options s) #f))
(set (get-keyword :slot-set! (slot-definition-options s) #f))
(env (class-environment class)))
(unless (and get set)
(error "You must supply a :slot-ref and a :slot-set! in ~A" s))
(list (make-closure get env)
(make-closure set env))))
(else (next-method))))
(define-method compute-get-n-set ((o <object>) s)
(error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
; I n i t i a l i z e
(define-method initialize ((object <object>) initargs)
(%initialize-object object initargs))
(define-method initialize ((class <class>) initargs)
(let ((dslots (get-keyword :slots initargs '()))
(supers (get-keyword :dsupers initargs '()))
(env (get-keyword :environment initargs (global-environment))))
(slot-set! class 'name (get-keyword :name initargs '???))
(slot-set! class 'direct-supers supers)
(slot-set! class 'direct-slots dslots)
(slot-set! class 'direct-subclasses '())
(slot-set! class 'direct-methods '())
(slot-set! class 'cpl (compute-cpl class))
(slot-set! class 'redefined #f)
(slot-set! class 'environment env)
(let ((slots (%compute-slots class)))
(slot-set! class 'slots slots)
(slot-set! class 'nfields 0)
(slot-set! class 'getters-n-setters (compute-getters-n-setters class
;; Update the "direct-subclasses" of each inherited classes
(for-each (lambda (x)
(slot-set! x 'direct-subclasses
(cons class (slot-ref x 'direct-subclasses))))
;; Build getters - setters - accessors
(compute-slot-accessors class dslots env)))
(define-method initialize ((generic <generic>) initargs)
(let ((previous-definition (get-keyword :default initargs #f)))
(slot-set! generic 'name (get-keyword :name initargs '???))
(slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
(list (make <method>
:specializers <top>
(lambda (nm . l)
(apply previous-definition
(define-method initialize ((method <method>) initargs)
(slot-set! method 'generic-function (get-keyword :generic-function initargs #f))
(slot-set! method 'specializers (get-keyword :specializers initargs '()))
(slot-set! method 'procedure (get-keyword :procedure initargs (lambda l '()))))
; C h a n g e - c l a s s
(define (change-object-class old-instance old-class new-class)
(let ((new-instance (allocate-instance new-class ())))
;; Initalize the slot of the new instance
(for-each (lambda (slot)
(if (slot-exists-using-class? old-class old-instance slot)
;; Slot was present in old instance; set it
(if (slot-bound-using-class? old-class old-instance slot)
(slot-ref-using-class old-class old-instance slot)))
;; slot was absent; initialize it with its default value
(let ((init (slot-init-function new-class slot)))
(if init
(apply init '()))))))
(map slot-definition-name (class-slots new-class)))
;; Exchange old an new instance in place to keep pointers valids
(%modify-instance old-instance new-instance)
(define-method change-class ((old-instance <object>) (new-class <class>))
(change-object-class old-instance (class-of old-instance) new-class))
; M a k e
; A new definition which overwrite the previous one which was built-in
(define-method allocate-instance ((class <class>) initargs)
(%allocate-instance class))
(define-method make-instance ((class <class>) . initargs)
(let ((instance (allocate-instance class initargs)))
(initialize instance initargs)
(define make make-instance)
; a p p l y - g e n e r i c
; Protocol for calling standard generic functions.
; This protocol is not used for real <generic> functions (in this case we use
; a completely C hard-coded protocol).
; Apply-generic is used by STklos for calls to subclasses of <generic>.
; The code below is similar to the first MOP described in AMOP. In particular,
; it doesn't used the currified approach to gf call. There are 2 reasons for
; that:
; - the protocol below is exposed to mimic completely the one written in C
; - the currified protocol would be imho inefficient in C.
(define-method apply-generic ((gf <generic>) args)
(if (null? (slot-ref gf 'methods))
(no-method gf args))
(let ((methods (compute-applicable-methods gf args)))
(if methods
(apply-methods gf (sort-applicable-methods gf methods args) args)
(no-applicable-method gf args))))
(define-method compute-applicable-methods ((gf <generic>) args)
(apply find-method gf args))
(define-method sort-applicable-methods ((gf <generic>) methods args)
(let ((targs (map class-of args)))
(sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
(define-method method-more-specific? ((m1 <method>) (m2 <method>) targs)
(%method-more-specific? m1 m2 targs))
(define-method apply-method ((gf <generic>) methods build-next args)
(apply (method-procedure (car methods))
(build-next (cdr methods) args)
(define-method apply-methods ((gf <generic>) (l <list>) args)
(letrec ((next (lambda (procs args)
(lambda new-args
(let ((a (if (null? new-args) args new-args)))
(if (null? procs)
(no-next-method gf a)
(apply-method gf procs next a)))))))
(apply-method gf l next args)))
; <Composite-metaclass> and <Active-metaclass>
(autoload "active-slot" <Active-metaclass>)
(autoload "composite-slot" <Composite-metaclass>)
(export <Composite-metaclass> <Active-metaclass>)
; T o o l s
(define (list2set l) ;; duplicate the standard list->set
(let Loop ((l l) (res '())) ;; function but using eq instead of eqv
(cond ;; which really sucks a lot, uselessly here
((null? l) res)
((memq (car l) res) (Loop (cdr l) res))
(else (Loop (cdr l) (cons (car l) res))))))
(define (class-subclasses c)
(letrec ((allsubs (lambda (c)
(cons c (mapappend allsubs (class-direct-subclasses c))))))
(list2set (cdr (allsubs c)))))
(define (class-methods c)
(list2set (mapappend class-direct-methods (cons c (class-subclasses c)))))
;; Clos like SLOT-VALUE
;; Note: SLOT-VALUE is a gf whereas SLOT-REF and SLOT-SET! are functions.
(define-method slot-value ((o <object>) s)
(slot-ref o s))
(define-method (setter slot-value) ((o <object>) s v)
(slot-set! o s v))
; Backward compatibility
(define class-cpl class-precedence-list) ; Don' use these
(define get-slot-allocation slot-definition-allocation) ; obolete defs
(define slot-definition-initform slot-definition-init-form) ; anymore
(export class-cpl get-slot-allocation slot-definition-initform)
(provide "stklos")