;-*-Mode:LISP; Package: User; Base:10; Syntax:Common-lisp -*- ; ; ; ********************************************************************** ; Copyright (c) 1992, 1993 Xerox Corporation. ; All Rights Reserved. ; ; Use, reproduction, and preparation of derivative works are permitted. ; Any copy of this software or of any derivative work must include the ; above copyright notice of Xerox Corporation, this paragraph and the ; one after it. Any distribution of this software or derivative works ; must comply with all applicable United States export control laws. ; ; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS ; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY ; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS ; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING ; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED ; OF THE POSSIBILITY OF SUCH DAMAGES. ; ********************************************************************** ; ; EDIT HISTORY: ; ; 10/**/92 Gregor Originally Written ; 2.0 9/11/93 Gregor Converted to Common Lisp, and protocol revised ; to match that in the OOPSLA MOPs tutorial. ; ; (in-package :user) (shadow '(defclass defgeneric defmethod call-next-method print-object find-class class-of class-name class-direct-supers class-direct-slots class-cpl class-slots class-direct-subclasses class-direct-methods find-gf gf-name gf-arglist gf-methods method-specializer method-function method-gf)) (defvar *tiny-clos-version* "2.0 OOPSLA Tutorial Version") ; ; A very simple CLOS-like language, embedded in Common Lisp, with a simple ; MOP. The features of the default base language are: ; ; * Classes, with instance slots, but no slot options. ; * No such thing as unbound slots, the initial value of a slot is nil. ; * Multiple-inheritance. ; * Generic functions with classical methods and class specializers only. ; * Primary methods and call-next-method; no other method combination. ; * This is a more C++ compile-time language. So, classes and generic ; functions aren't first-class in the base language. In particular, ; this means that we don't have funcallable instances. Look carefully ; at how defgeneric and the like work. ; ; ; While the MOP is simple, it is essentially equal in power to both MOPs ; in AMOP. This implementation is not at all optimized, but the MOP is ; designed so that it can be optimized. In fact, this MOP allows better ; optimization of slot access extentions than those in AMOP. ; ; ; In addition to calling a generic, the entry points to the default base ; language are: ; ; (MAKE class . initargs) ; (INITIALIZE instance &rest initargs) ;Add methods to this, ; ;don't call it directly. ; ; (SLOT-REF object slot-name) ; (SLOT-SET object slot-name new-value) ; ; ; So, for example, one might do: ; ; (defclass () (x y)) ; (defmethod initialize ((p ) &key x y) ; (slot-set p 'x x) ; (slot-set p 'y y)) ; ; (set! p1 (make :x 1 :y 3)) ; ; ; ; The introspective part of the MOP looks like the following. Note that ; these are ordinary procedures, not generics. ; ; CLASS-OF ; FIND-CLASS ; ; CLASS-DIRECT-SUPERS ; CLASS-DIRECT-SLOTS ; CLASS-CPL ; CLASS-SLOTS ; CLASS-DIRECT-SUBCLASSES ; CLASS-DIRECT-METHODS ; ; FIND-GF ; GF-NAME ; GF-ARGLIST ; GF-METHODS ; ; METHOD-SPECIALIZER ; METHOD-FUNCTION ; METHOD-GF ; ; ; The intercessory protocol looks like (generics in uppercase): ; ; make ; INITIALIZE (really a base-level generic) ; ; class initialization ; COMPUTE-CPL ; COMPUTE-SLOTS ; COMPUTE-SLOT-REF-RESIDUAL ; COMPUTE-SLOT-SET-RESIDUAL ; ; *add-method (Notice this is not a generic!) ; *APPLY-GF ; *COMPUTE-METHODS ; *METHOD-MORE-SPECIFIC? ; *APPLY-METHODS ; ; ; OK, now let's get going. But, as usual, before we can do anything ; interesting, we have to muck around for a bit first. First, we need ; to define some simple support things. ; ; (defun compute-simple-cpl (c) (labels ((chase (supers) (append supers (chase-1 supers))) (chase-1 (supers) (apply #'append (mapcar #'chase (mapcar #'class-direct-supers supers))))) (remove-duplicates (cons c (chase (class-direct-supers c))) :from-end t))) (defun collect-if (predicate list) (let ((result '())) (dolist (i list) (when (funcall predicate i) (push i result))) (reverse result))) (defun mapappend (fn &rest args) (if (some #'null args) () (append (apply fn (mapcar #'car args)) (apply #'mapappend fn (mapcar #'cdr args))))) ; ; Then, we need to build what, in a more real implementation, would be ; the interface to the memory subsystem: instances. In this MOP, this ; isn't visible to base- or MOP-level programmers. ; ; (defstruct (%instance (:constructor %%allocate-instance (class locations)) (:print-function (lambda (o s d) (print-object o s))) (:predicate %instance?)) class locations) (defun %allocate-instance (class nlocations) (%%allocate-instance class (make-array nlocations))) (defun %object-ref (x loc) (svref (%instance-locations x) loc)) (defun %object-set (x loc n) (setf (svref (%instance-locations x) loc) n)) (defun %set-instance-class-to-self (x) (setf (%instance-class x) x)) (defun class-of (x) (if (%instance? x) (%instance-class x) (error "Tiny CLOS doesn't know about classes of Built-Ins."))) ; ; CLOS programmers should take note that in this language names are always ; proper names. See the initialize methods for and and you'll ; see that they call set-find-class and set-find-gf, rather than this being ; something defclass and defgeneric do, as in CLOS. ; (let ((table (make-hash-table :test #'equal))) (defun find-class (name) (values (gethash name table))) (defun set-find-class (name class) (setf (gethash name table) class)) ) (let ((table (make-hash-table :test #'equal))) (defun find-gf (name) (values (gethash name table))) (defun set-find-gf (name gf) (setf (gethash name table) gf) ; ; This next bit of trickiness is only needed because this is a ; `cheap' implementation of Tiny CLOS. A real implementation ; would scan all the source code, and turn all calls to GFs into ; calls to *apply-gf at the actual call sites. Or, perhaps it ; would do something like this in a more centralized fashion. ; But, we don't have access to all the source code, so we can't ; quite do that. ; ; This hack is mostly good enough. ; (setf (symbol-function name) #'(lambda (&rest args) #+Genera (setq args (copy-list args)) (trampoline-to-*apply-gf gf args)))) ) ; ; Turn this on when debugging the bootstrap. It is redefined at the end ; of this file by a GF. ; (defun print-object (o s) (let* ((class (%instance-class o)) (class-name (%object-ref class 0)) (possible-object-name (%object-ref o 0))) (format s "#<~S ~S>" class-name possible-object-name))) ; ; These are the convenient syntax we expose to the base-level user. ; ; Since they are macros, the code is terrible to write. Try not to ; focus on it. ; ; Also note that even though we aren't required to, we make a stab ; at supporting class, gf and method redefinition. ; ; (defmacro make (class-name &rest initargs) `(*make (find-class ',class-name) ,@initargs)) (defmacro defclass (name supers slots &rest options) #+Genera(declare (zwei:indentation 2 3 3 1)) (let ((class-name (getf options :class '))) (remf options :class) `(load-defclass ',name ',supers ',slots ',class-name (list ,@options)))) (defun load-defclass (name supers slots class-name extra-initargs) (let ((old (find-class name)) (initargs (list* :name name :direct-supers (mapcar #'find-class supers) :direct-slots slots extra-initargs))) (if old (apply #'initialize old :allow-other-keys 't initargs) (apply #'*make (find-class class-name) initargs)) name)) (defmacro defgeneric (name arglist &rest options) (let ((class-name (getf options :class '))) (remf options :class) `(load-defgeneric ',name ',arglist ',class-name (list ,@options)))) (defun load-defgeneric (name arglist class-name extra-initargs) (let ((old (find-gf name)) (initargs (list* :name name :arglist arglist extra-initargs))) (if old (apply #'initialize old :allow-other-keys 't initargs) (apply #'*make (find-class class-name) initargs)) name)) (defmacro defmethod (gf-name specialized-arglist &body body) (labels ((scan (tail args specializers) (if (null tail) (values args specializers) (if (not (consp (car tail))) (values (append args tail) specializers) (scan (cdr tail) (append args (list (caar tail))) (append specializers (list (cadar tail)))))))) (multiple-value-bind (args specializers) (scan specialized-arglist '() '()) `(load-defmethod ',gf-name ',(car specializers) #'(lambda (-cnm- &rest -args-) (flet ((call-next-method () (funcall -cnm-))) (apply #'(lambda ,args ,@body) -args-))))))) (defun load-defmethod (gf-name class-name function) (*add-method (find-gf gf-name) (make ':specializer (find-class class-name) ':function function)) (list gf-name class-name)) ; ; Now we can get down to business. First, we initialize the braid. ; ; For Bootstrapping, we define an early version of *MAKE. It will be ; changed to the real version later on. String search for ``set! make''. ; ; (defun *make (class &key name direct-supers direct-slots arglist specializer function &allow-other-keys) (cond ((eq class (find-class ')) (let* ((new (%allocate-instance class (length the-slots-of-a-class)))) (set-find-class name new) (slot-set new 'name name) (slot-set new 'direct-supers direct-supers) (slot-set new 'direct-slots direct-slots) (update-direct-supers direct-supers new) (let* ((cpl (compute-simple-cpl new)) (slot-names (apply #'append (mapcar #'class-direct-slots cpl))) ; ; Note that the next three variables are cheating. They aren't ; following the *allocate-location protocol. Don't read this ; code, read the real initialize method on instead. ; (slots (mapcar #'(lambda (sn) (list sn (position sn slot-names))) slot-names)) (nlocations (length slot-names)) (slot-access-residuals (mapcar #'(lambda (sn&loc) (let ((sn (car sn&loc)) (loc (cadr sn&loc))) (list sn #'(lambda (object) (%object-ref object loc)) #'(lambda (object n) (%object-set object loc n))))) slots))) (slot-set new 'cpl cpl) (slot-set new 'slots slots) (slot-set new 'nlocations nlocations) (slot-set new 'slot-access-residuals slot-access-residuals) new))) ((eq class (find-class ')) (let ((new (%allocate-instance class (length (class-slots class))))) (set-find-gf name new) (slot-set new 'name name) (slot-set new 'arglist arglist) (slot-set new 'methods '()) new)) ((eq class (find-class ')) (let ((new (%allocate-instance class (length (class-slots class))))) (slot-set new 'specializer specializer) (slot-set new 'function function) new)))) (defun update-direct-supers (direct-supers class) (dolist (ds direct-supers) (let* ((old (slot-ref ds 'direct-subclasses)) (new (cons class old))) (slot-set ds 'direct-subclasses new)))) ; ; Entrypoint into the slot access protocol. ; ; To make it easier to use this Tiny CLOS with the MOP Tutorial, we ; implement two slot access protocols. The `original' one and the ; revised or curried one. ; ; But note that for instances of we only implement the ; curried one -- that helps with metacircularity. There is no way ; that a user who isn't cheating should be able to detect this ; though. ; ; (defparameter *slot-access-protocol* :original) ;Either :original ;or :curried. (defun slot-ref (object slot-name) (let* ((class (class-of object)) (class-of-class (class-of class))) (cond ((or (eq class-of-class (find-class ')) (eq *slot-access-protocol* ':curried)) (funcall (cadr (lookup-slot-access-residuals class slot-name)) object)) ((eq *slot-access-protocol* ':original) (*slot-ref class object slot-name))))) (defun slot-set (object slot-name new-value) (let* ((class (class-of object)) (class-of-class (class-of class))) (cond ((or (eq class-of-class (find-class ')) (eq *slot-access-protocol* ':curried)) (funcall (caddr (lookup-slot-access-residuals class slot-name)) object new-value)) ((eq *slot-access-protocol* ':original) (*slot-set class object slot-name new-value))))) (defun lookup-slot-access-residuals (class slot-name) (let* ((residuals (if (eq class (find-class '));* This grounds out slot-access-residuals-for-class ;* the slot-ref tower. (slot-ref class 'slot-access-residuals))) (entry (assoc slot-name residuals))) (or entry (error "No slot named ~S." slot-name)))) ; ; Given that the early version of MAKE is allowed to call accessors on ; class metaobjects, the definitions for them come here, before the ; actual class definitions, which are coming up right afterwards. ; ; (defun class-name (class) (slot-ref class 'name)) (defun class-direct-slots (class) (slot-ref class 'direct-slots)) (defun class-direct-supers (class) (slot-ref class 'direct-supers)) (defun class-slots (class) (mapcar #'car (slot-ref class 'slots))) (defun class-slot-locations (class) (slot-ref class 'slots)) (defun class-cpl (class) (slot-ref class 'cpl)) (defun class-direct-subclasses (class) (slot-ref class 'direct-subclasses)) (defun class-direct-methods (class) (slot-ref class 'direct-methods)) (defun gf-name (gf) (slot-ref gf 'name)) (defun gf-arglist (gf) (slot-ref gf 'arglist)) (defun gf-methods (gf) (slot-ref gf 'methods)) (defun method-specializer (method) (slot-ref method 'specializer)) (defun method-function (method) (slot-ref method 'function)) (defun method-gf (method) (slot-ref method 'gf)) ; ; The next 7 clusters define the 6 initial classes. It takes 7 to 6 ; because the first and fourth both contribute to . ; (defparameter the-slots-of-a-class ; '(name ;symbol direct-supers ;(class ...) direct-slots ;(name ...) cpl ;(class ...) slots ;((name loc-or-whatever) ...) direct-subclasses ;(class ...) direct-methods ;(method ...) nlocations ;an integer slot-access-residuals)) ;((slot-name ref set) ...) ; (defparameter slot-access-residuals-for-class ;see lookup-slot-access-residuals (mapcar #'(lambda (s) (let ((loc (position s the-slots-of-a-class))) ;Cheating again! (list s #'(lambda (o) (%object-ref o loc)) #'(lambda (o n) (%object-set o loc n))))) the-slots-of-a-class)) (set-find-class ' (%allocate-instance nil (length the-slots-of-a-class))) (%set-instance-class-to-self (find-class ')) (defclass () ()) ; ; This cluster, together with the first cluster above that defines ; and sets its class, have the effect of: ; ; (defclass () ; (direct-supers ...)) ; (let (( (find-class ')) (direct-supers (mapcar #'find-class '()))) (update-direct-supers direct-supers ) (slot-set 'name ') (slot-set 'direct-supers direct-supers) (slot-set 'direct-slots the-slots-of-a-class) (slot-set 'cpl (mapcar #'find-class '( ))) (slot-set 'slots (mapcar #'(lambda (sn) (list sn (position sn the-slots-of-a-class))) the-slots-of-a-class)) (slot-set 'nlocations (length the-slots-of-a-class)) (slot-set 'slot-access-residuals '()) ) (defclass () (name arglist methods)) (defclass () (specializer function gf)) ; ; The initialization protocol ; (defgeneric initialize (object &rest initargs)) ; ; The class initialization protocol. ; (defgeneric *compute-cpl (class)) (defgeneric *compute-slots (class)) ; ; The instance structure protocol. ; (defgeneric *allocate (class)) (defgeneric *slot-ref (class object slot-name)) (defgeneric *slot-set (class object slot-name new-value)) (defgeneric *slot-ref-residual (class slot-name)) (defgeneric *slot-set-residual (class slot-name)) ; ; The generic invocation protocol. This part of the protocol ; isn't curried. That is left as an exercise for the reader! ; (defgeneric *apply-gf (gf args)) (defgeneric *compute-methods (gf args)) (defgeneric *method-more-specific? (gf method-1 method-2)) (defgeneric *apply-methods (gf methods args)) ; ; The next thing to do is bootstrap generic functions. ; (defparameter gf-invocation-protocol-gfs (mapcar #'find-gf '(*apply-gf *compute-methods *method-more-specific? *apply-methods))) (defun *add-method (gf new-method) ; ; A couple of crucial points here. First, note that this pushes ; new methods on the front of the list, and that the ground case ; for the gf invocation protocol counts on that. So, don't ; change this without working on trampoline-to-*apply-gf. ; ; Second, note that even though we aren't required to, we are ; supporting interactive program development by arranging for ; new method definitions to remove old definitions with the ; same specializer. (let ((old-method (find (method-specializer new-method) (slot-ref gf 'methods) :key #'method-specializer))) (when old-method (let ((old-specl (method-specializer old-method))) (slot-set old-specl 'direct-methods (remove old-method (slot-ref old-specl 'direct-methods))) (slot-set gf 'methods (remove old-method (slot-ref gf 'methods))) (slot-set old-method 'gf nil))) (let ((new-specl (method-specializer new-method))) (slot-set new-specl 'direct-methods (cons new-method (slot-ref new-specl 'direct-methods))) (slot-set gf 'methods (cons new-method (slot-ref gf 'methods))) (slot-set new-method 'gf gf)))) (defun trampoline-to-*apply-gf (gf args) (if (and (member gf gf-invocation-protocol-gfs) ;* G c (member (car args) gf-invocation-protocol-gfs)) ;* r a (apply (method-function ;* o s (car (last (gf-methods gf)))) ;* u e nil ;* n args) ;* d (*apply-gf gf args))) (defmethod *apply-gf ((gf ) args) (let ((methods (*compute-methods gf args))) (*apply-methods gf methods args))) (defmethod *compute-methods ((gf ) args) (flet ((applicable? (c arg) (member c (class-cpl (class-of arg))))) (let ((applicable (collect-if #'(lambda (method) (applicable? (method-specializer method) (car args))) (gf-methods gf)))) (sort applicable #'(lambda (m1 m2) (*method-more-specific? gf m1 m2 args)))))) (defmethod *method-more-specific? ((gf ) m1 m2 args) (let ((c1 (method-specializer m1)) (c2 (method-specializer m2)) (arg (car args))) (or (eq c1 c2) (member c2 (member c1 (class-cpl (class-of arg))))))) (defmethod *apply-methods ((gf ) methods args) (let* ((first (car methods)) (rest (cdr methods)) (cnm #'(lambda () (*apply-methods gf rest args)))) (apply (method-function first) cnm args))) (defmethod initialize ((object ) &rest initargs) object) (defmethod initialize ((class ) &key name direct-supers direct-slots) (call-next-method) (setq direct-supers (or direct-supers (list (find-class ')))) (when name (set-find-class name class)) (slot-set class 'name name) (slot-set class 'direct-supers direct-supers) (slot-set class 'direct-slots direct-slots) (update-direct-supers direct-supers class) (slot-set class 'cpl (*compute-cpl class)) (slot-set class 'slots (*compute-slots class)) (when (or (eq (class-of class) (find-class ')) (eq *slot-access-protocol* ':curried)) (slot-set class 'slot-access-residuals (mapcar #'(lambda (sn) (list sn (*slot-ref-residual class sn) (*slot-set-residual class sn))) (class-slots class)))) (unless (slot-ref class 'nlocations) (slot-set class 'nlocations 0))) (defmethod *slot-ref ((class ) object slot-name) (let ((location (find-and-check-location class slot-name '*slot-ref))) (%object-ref object location))) (defmethod *slot-set ((class ) object slot-name new-value) (let ((location (find-and-check-location class slot-name '*slot-ref))) (%object-set object location new-value))) (defmethod *slot-ref-residual ((class ) slot-name) (let ((location (find-and-check-location class slot-name '*slot-ref-residual))) #'(lambda (object) (%object-ref object location)))) (defmethod *slot-set-residual ((class ) slot-name) (let ((location (find-and-check-location class slot-name '*slot-ref-residual))) #'(lambda (object new) (%object-set object location new)))) (defun find-and-check-location (class slot-name for) (let* ((slot (assoc slot-name (class-slot-locations class))) (loc (cadr slot))) (unless (and (integerp loc) (< loc (slot-ref class 'nlocations))) (error "The location (~D) for the slot ~S doesn't look like~%~ a result of *ALLOCATE-LOCATION. Perhaps you are missing~%~ a method on ~S." loc slot-name for)) loc)) (defun *allocate-instance (class) (%allocate-instance class (slot-ref class 'nlocations))) (defun *allocate-location (class) ;This isn't a very robust (let* ((old (or (slot-ref class 'nlocations) 0)) ;implementation. It should (new (1+ old))) ;check to be sure it is within (slot-set class 'nlocations new) ;the dynamic scope of the call old)) (defmethod *compute-cpl ((class )) (compute-simple-cpl class)) (defmethod *compute-slots ((class )) (let ((names (remove-duplicates (apply #'append (mapcar #'class-direct-slots (class-cpl class)))))) (mapcar #'(lambda (sn) (list sn (*allocate-location class))) names))) ;to INITIALIZE the class. (defmethod initialize ((gf ) &key name arglist &allow-other-keys) (call-next-method) (when name (set-find-gf name gf)) (slot-set gf 'name name) (slot-set gf 'arglist arglist) (slot-set gf 'methods '())) (defmethod initialize ((method ) &key specializer function) (call-next-method) (slot-set method 'specializer specializer) (slot-set method 'function function)) ; ; Now everything works, both generic functions and classes, so we can ; turn on the real *MAKE. ; ; Notice that we have to be careful to make the method before the gf. ; That's because in the period of time between when we make the gf, ; and when it gets its method added, we can't call *make. During that ; time, it is a gf with no methods! ; ; (let ((method (make :specializer (find-class ') :function #'(lambda (-cnm- class &rest initargs) -cnm- (let ((new (*allocate-instance class))) (apply #'initialize new :allow-other-keys t initargs) new)))) (gf (make :name '*make :arglist '(class &rest initargs)))) (*add-method gf method)) ; ; Now turn on the printer. ; ; (let ((class-numbers (make-hash-table)) (object-numbers (make-hash-table))) (defun get-object-number (object) (or (gethash object object-numbers) (let* ((class (class-of object)) (class-number (gethash class class-numbers 0)) (number (1+ class-number))) (setf (gethash class class-numbers) number) (setf (gethash object object-numbers) number) number))) ) (defgeneric print-object (object stream)) (defmethod print-object ((object ) stream) (format stream "#<~S ~D>" (class-name (class-of object)) (get-object-number object))) (defmethod print-object ((class ) stream) (format stream "#" (class-name class))) (defmethod print-object ((gf ) stream) (format stream "#" (gf-name gf))) (defmethod print-object ((method ) stream) (format stream "#" (gf-name (method-gf method)) (class-name (method-specializer method)))) ; ; All done. ; ; 'tiny-clos-up-and-running