;; Copyright (C) 2002-2004, Yuji Minejima ;; ALL RIGHTS RESERVED. ;; ;; $Id: clos.lisp,v 1.28 2004/09/24 07:31:33 yuji Exp $ ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; * Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; * Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in ;; the documentation and/or other materials provided with the ;; distribution. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; Non conformance points to CLOS. ;; * (defmethod allocate-instance ((class structure-class) &rest initargs)) ;; is not implemented. ;; ;; Non conformance points to MOP. ;; * ;; (defparameter *mop-working-p* nil) (defparameter *symbol-function-is-funcallable-object-p* t) (defstruct %standard-object class (version nil) storage) (defun swap-%standard-object (a b) (rotatef (%standard-object-class a) (%standard-object-class b)) (rotatef (%standard-object-version a) (%standard-object-version b)) (rotatef (%standard-object-storage a) (%standard-object-storage b))) (defparameter *classes* (make-hash-table) "The hash table of all classes in CLOS system.") (defun find-class (symbol &optional errorp environment) ; clos "Return the class object named by SYMBOL in ENVIRONMENT." (declare (ignore environment)) (multiple-value-bind (class presentp) (gethash symbol *classes*) (if presentp class (when errorp (error "Class ~S does not exist." symbol))))) (defun (setf find-class) (new-class symbol &optional errorp environment) ; clos "Set the name of NEW-CLASS to SYMBOL in ENVIRONMENT." (declare (ignore environment)) (if new-class (setf (gethash symbol *classes*) new-class) (remhash symbol *classes*)) new-class) (defun plist-member (key plist) (loop for rest on plist by #'cddr if (eq key (car rest)) return rest)) (defun plist-keys (plist) (loop for key in plist by #'cddr collect key)) ;; AMOP 5.4.2 The defclass Macro http://www.lisp.org/mop/concepts.html#defclass ;; > The relationship between the arguments to the defclass macro and ;; > the arguments received by ensure-generic-function is defined. (defun qt? (object) "Return a quoted form of OBJECT or OBJECT itself if it's self-evaluating." (flet ((self-evaluating-object-p (object) (typecase object ((or number character array) t) (symbol (or (keywordp object) (member object '(t nil)))) (t nil)))) (if (self-evaluating-object-p object) object `(quote ,object)))) (defun check-direct-slot-spec-options (slot-spec) (let ((reserved-keys '(:name :initargs :initfunction :readers :writers)) (multiple-keys '(:initarg :reader :writer :accessor)) (keys '()) (name (car slot-spec))) (dolist (key (plist-keys (cdr slot-spec))) (cond ((member key reserved-keys) (error "Reserved option ~S is wrongly given in slot ~S ." key name)) ((and (member key keys) (not (member key multiple-keys))) (error "Option ~S is given more than once in slot ~S." key name)) (t (push key keys)))))) (defun direct-slot-initargs-form (slot-spec) ;; direct-slot-initargs is a canonicalized slot specification described in ;; http://www.lisp.org/mop/concepts.html#defclass . (flet ((specified-more-than-once-p (key) (< 1 (count key (plist-keys (cdr slot-spec))))) (quote-keys (plist) (loop for (key value) on plist by #'cddr nconc `(,(qt? key) ,value)))) (check-direct-slot-spec-options slot-spec) (loop for (key value) on (cdr slot-spec) by #'cddr if (eq key :initform) nconc `(:initform ',value :initfunction #'(lambda () ,value)) into plist else if (eq key :initarg) collect value into initargs else if (eq key :reader) collect value into readers else if (eq key :writer) collect value into writers else if (eq key :accessor) collect value into readers and collect `(setf ,value) into writers else if (specified-more-than-once-p key) if (getf plist key) do (setf (cdr (last (getf plist key))) `((quote ,value))) else nconc `(,key (list ',value)) into plist end else nconc `(,key ',value) into plist finally (return `(list :name ',(car slot-spec) :initargs ',initargs :readers ',readers :writers ',writers ,@(quote-keys `(,@plist :initform 'nil :initfunction 'nil :documentation 'nil))))))) (defun class-initargs-form (options) ;; See http://www.lisp.org/mop/concepts.html#defclass (labels ((check-options (alist) (let ((reserved-keys '(:name :direct-default-initargs)) (keys '())) (dolist (key (mapcar #'first alist)) (cond ((member key reserved-keys) (error "Reserved option ~S is wrongly given." key)) ((member key keys) (error "Option ~S is given more than once." key)) (t (push key keys)))))) (direct-default-initargs-form (initargs) (loop for (key form) on initargs by #'cddr collect `(list ',key ',form #'(lambda () ,form)) into result finally (return `(list ,@result)))) (value-form (key rest) (case key (:direct-default-initargs (direct-default-initargs-form rest)) (:direct-slots `(list ,@(mapcar #'direct-slot-initargs-form rest))) ((:metaclass :documentation) (destructuring-bind (value) rest (qt? value))) (t (qt? rest))))) (check-options options) (loop for (key . rest) in options when (eq key :default-initargs) do (setq key :direct-default-initargs) nconc `(,(qt? key) ,(value-form key rest)) into result finally (return `(list ,@result))))) (defun (name &rest initargs) (apply (if *mop-working-p* #'ensure-class #'ensure-system-class) name initargs)) (defmacro defclass (name direct-superclasses direct-slots &rest options) ; clos "Define a new class named NAME which is a subclass of DIRECT-SUPERCLASSES." (let* ((*message-prefix* (format nil "DEFCLASS ~S: " name))) `(let ((*message-prefix* ,*message-prefix*)) (apply #' ',name ,(class-initargs-form `((:direct-superclasses ,@direct-superclasses) (:direct-slots ,@direct-slots) ,@options)))))) (defun class-of (object) ; clos "Return the class of which OBJECT is a direct instance." ;; 4.3.7 Integrating Types and Classes ;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm (cond ((%standard-object-p object) (%standard-object-class object)) ((functionp object) (let ((gf (find-generic-function object))) (if gf (class-of gf) (find-class 'function)))) (t (let ((type (type-of object))) (or (and (symbolp type) (find-class type)) (typecase object ((and symbol (not null)) (find-class 'symbol)) (character (find-class 'character)) (hash-table (find-class 'hash-table)) (sequence (class-of-sequence object)) ((and array (not vector)) (find-class 'array)) (number (class-of-number object)) (stream (class-of-stream object)) (pathname (typecase object (logical-pathname (find-class 'logical-pathname)) (t (find-class 'pathname)))) (package (find-class 'package)) (random-state (find-class 'random-state)) (readtable (find-class 'readtable)) (restart (find-class 'restart)) (condition (class-of-condition object)) (t (find-class 't)))))))) (defun frozen-class-instance-p (object) (and (%standard-object-p object) (null (%standard-object-version object)))) (defconstant +unbound-state+ (gensym "UNBOUND-STATE-")) (defun slot-value (object slot-name) ; clos "Return the value of the slot named SLOT-NAME in OBJECT." (flet ((slot-is-missing () (slot-missing (class-of object) object slot-name 'slot-value)) (slot-is-unbound () (slot-unbound (class-of object) object slot-name))) (if (frozen-class-instance-p object) (let ((binding (assoc slot-name (%standard-object-storage object)))) (if binding (let ((value (second binding))) (if (not (eq value +unbound-state+)) value (values (slot-is-unbound)))) (values (slot-is-missing)))) (let* ((class (class-of object)) (slot (find-slot class slot-name))) (if slot (slot-value-using-class class object slot) (values (slot-is-missing))))))) (defun (setf slot-value) (new-value object slot-name) ; clos "Set the value of the slot named SLOT-NAME in OBJECT to NEW-VALUE." (flet ((slot-is-missing () (slot-missing (class-of object) object slot-name 'setf new-value))) (if (frozen-class-instance-p object) (let ((binding (assoc slot-name (%standard-object-storage object)))) (if binding (progn (assert (typep new-value (third binding))) (setf (second binding) new-value)) (slot-is-missing))) (let* ((class (class-of object)) (slot (find-slot class slot-name))) (assert (typep new-value (slot-definition-type slot))) (if slot (setf (slot-value-using-class class object slot) new-value) (slot-is-missing)))) new-value)) (defun slot-boundp (instance slot-name) ; clos "Return true if the slot named SLOT-NAME in INSTANCE is bound." (flet ((slot-is-missing () (slot-missing (class-of instance) instance slot-name 'slot-value))) (if (frozen-class-instance-p instance) (let ((binding (assoc slot-name (%standard-object-storage instance)))) (if binding (not (eq (second binding) +unbound-state+)) (values (slot-is-missing)))) (let* ((class (class-of instance)) (slot (find-slot class slot-name))) (if slot (slot-boundp-using-class class instance slot) (values (slot-is-missing))))))) (defun find-slot (class slot-name) (find slot-name (slot-value class 'slots) :key #'(lambda (slot) (slot-value slot 'name)))) (defun local-slot-p (slot) (eq (slot-value slot 'allocation) :instance)) ;; for debug (defmethod print-object ((object %standard-object) stream) (flet ((slot (object name) (second (assoc name (%standard-object-storage object))))) (let ((class (class-of object))) (cond ((and (%standard-object-p class) (assoc 'name (%standard-object-storage class))) (if (assoc 'name (%standard-object-storage object)) (format stream "#<~S:(~S)>" (slot class 'name) (slot object 'name)) (format stream "#<~S:>" (slot class 'name)))) ((assoc 'name (%standard-object-storage object)) (format stream "#<:(~S)>" (slot object 'name))) (t (format stream "#<(CLOS object)>")))))) ;; 7.1.3 Defaulting of Initialization Arguments ;; http://www.lispworks.com/reference/HyperSpec/Body/07_ac.htm ;; 7.1.4 Rules for Initialization Arguments ;; http://www.lispworks.com/reference/HyperSpec/Body/07_ad.htm (defun compute-standard-default-initargs (class) (flet ((default-initargs (class) (mapappend #'(lambda (class) (slot-value class 'direct-default-initargs)) (slot-value class 'precedence-list)))) (loop for initarg in (default-initargs class) with args = '() for name = (car initarg) unless (member name args) collect initarg and do (push name args)))) (defun defaulted-initargs (class initargs) (append initargs (loop for (key form func) in (slot-value class 'default-initargs) ;; each key is unique throughout the iteration. unless (plist-member key initargs) nconc `(,key ,(funcall func))))) (defun finalized-p (class) (flet ((defclassed-p (class) (and (%standard-object-p class) (%standard-object-storage class)))) (when (symbolp class) (setq class (find-class class))) (and (defclassed-p class) (slot-value class 'finalized-p)))) (defun canonicalize-instance (instance) (let* ((class (class-of instance)) (initargs (mapcan #'(lambda (binding) (list (%keyword (first binding)) (second binding))) (%standard-object-storage instance))) (defaulted-initargs (defaulted-initargs class initargs)) (dummy (make-%standard-object :class class :storage (allocate-standard-instance-storage class)))) (standard-shared-initialize dummy t defaulted-initargs) (swap-%standard-object instance dummy)) instance) (defun make-system-instance (class &rest initargs) (flet ((alist-storage (plist) (loop for (key value) on plist by #'cddr collect (list (intern (string key)) value 't)))) (let ((instance (make-%standard-object :class class :version nil :storage (alist-storage initargs)))) (when (finalized-p class) (canonicalize-instance instance)) instance))) (defun ensure-class-object (name &rest initargs) (let ((metaclass (let ((metaclass-name (getf initargs :metaclass))) (when metaclass-name (ensure-class-object metaclass-name)))) (class (find-class name))) (if class (when initargs (let* ((dummy (apply #'make-system-instance metaclass initargs))) (swap-%standard-object class dummy))) (setf (find-class name) (apply #'make-system-instance metaclass initargs))) (find-class name))) (defun allocate-standard-instance-storage (class) (let* ((slots (slot-value class 'slots)) (local-slots (sort (mapcan #'(lambda (slot) (when (local-slot-p slot) (list slot))) slots) #'< :key #'(lambda (slot) (slot-value slot 'location)))) (shared-slots (mapcan #'(lambda (slot) (when (not (local-slot-p slot)) (list slot))) slots))) (if (frozen-class-instance-p class) (let ((local-alist (loop for slot in local-slots for name = (slot-value slot 'name) for type = (slot-value slot 'type) collect `(,name ,+unbound-state+ ,type))) (shared-alist (loop for slot in shared-slots for name = (slot-value slot 'name) for binding = (slot-value slot 'shared-binding) collect (cons name binding)))) (nconc local-alist shared-alist)) (make-array (length local-slots) :initial-element +unbound-state+)))) (defun class-slot-names (class) (mapcar #'(lambda (slot) (slot-value slot 'name)) (slot-value class 'slots))) (defun standard-shared-initialize (instance slot-names initargs) (when (eq slot-names 't) (setq slot-names (class-slot-names (class-of instance)))) (mapc #'(lambda (slot) (let ((name (slot-value slot 'name))) (multiple-value-bind (key value tail) (get-properties initargs (slot-value slot 'initargs)) (declare (ignore key)) (if tail (setf (slot-value instance name) value) (when (and (member name slot-names) (not (slot-boundp instance name)) (slot-value slot 'initfunction)) (setf (slot-value instance name) (funcall (slot-value slot 'initfunction)))))))) (slot-value (class-of instance) 'slots))) ;; 4.3.5 Determining the Class Precedence List ;; http://www.lispworks.com/reference/HyperSpec/Body/04_ce.htm (defun topological-sort (classes pairs) (do (next (unordered classes (remove next unordered)) (pairs pairs (remove-if #'(lambda (pair) (eq (first pair) next)) pairs)) (result nil (cons next result))) ((null unordered) (nreverse result)) (setq next (let ((candidates (remove-if #'(lambda (class) (find class pairs :key #'second)) unordered))) (assert (not (null candidates))) (if (endp (cdr candidates)) (car candidates) (block picker (dolist (class result) (dolist (super (slot-value class 'direct-superclasses)) (when (find super candidates) (return-from picker super)))))))))) (defun compute-standard-class-precedence-list (class) (labels ((direct-supers (class) (slot-value class 'direct-superclasses)) (superclasses (class) (labels ((supers (class) (unless (eq class (find-class 't 'errorp)) (let ((directs (direct-supers class))) (append directs (mapappend #'supers directs)))))) (remove-duplicates (supers class)))) (local-precedence-order-pairs (class) (unless (eq class (find-class 't 'errorp)) (let ((directs (direct-supers class))) (mapcar #'list (cons class directs) directs)))) (pairs (classes) (delete-duplicates (mapcan #'local-precedence-order-pairs classes) :test #'equal))) (let ((classes (cons class (superclasses class)))) (topological-sort classes (pairs classes))))) (defun class-precedence-names (class) ; for debug (when (symbolp class) (setq class (find-class class 'errorp))) (mapcar #'(lambda (class) (slot-value class 'name)) (slot-value class 'precedence-list))) ;; 7.5.3 Inheritance of Slots and Slot Options ;; http://www.lispworks.com/reference/HyperSpec/Body/07_ec.htm (defun and-types (types) (labels ((type-eq (a b) (and (subtypep a b) (subtypep b a))) (proper-subtype-p (subtype type) (and (not (type-eq subtype type)) (subtypep subtype type)))) (let ((types (mapcan #'(lambda (type) (when (notany #'(lambda (t1) (proper-subtype-p t1 type)) types) (list type))) (remove-duplicates types :test #'type-eq)))) (if (endp (cdr types)) (car types) `(and ,@types))))) (defun effective-slot-initargs (class name direct-slots) (declare (ignorable class)) (assert (not (null direct-slots))) (let* ((most-specific-slot (first direct-slots)) (allocation (slot-value most-specific-slot 'allocation)) (type (and-types (mapcar #'(lambda (slot) (slot-value slot 'type)) direct-slots))) (shared-binding (slot-value most-specific-slot 'shared-binding))) `(:name ,name :allocation ,allocation ,@(or (loop for slot in direct-slots for initfunction = (slot-value slot 'initfunction) if initfunction return `(:initform ,(slot-value slot 'initform) :initfunction ,(slot-value slot 'initfunction))) '(:initform nil :initfunction nil)) :type ,type :initargs ,(remove-duplicates (mapappend #'(lambda (slot) (slot-value slot 'initargs)) direct-slots)) :documentation ,(loop for slot in direct-slots for documentation = (slot-value slot 'documentation) if documentation return it) :location nil :shared-binding ,(prog1 shared-binding (when shared-binding (setf (cdr shared-binding) (list type))))))) (defun effective-slot-specs (class) ;; effective-slot-spec::= (name ([[direct-slot-object*]])) (let* ((direct-slots (mapappend #'(lambda (class) (slot-value class 'direct-slots)) (slot-value class 'precedence-list))) (names (remove-duplicates (mapcar #'(lambda (slot) (slot-value slot 'name)) direct-slots)))) (mapcar #'(lambda (name) (list name (loop for slot in direct-slots if (eq name (slot-value slot 'name)) collect slot))) names))) (defun standard-direct-slot-definition (slot-spec) (setq slot-spec `(:shared-binding ,(when (eq :class (getf slot-spec :allocation)) (list +unbound-state+)) ,@slot-spec :allocation :instance :type t)) (let ((class (ensure-class-object 'standard-direct-slot-definition))) (apply #'make-system-instance class slot-spec))) (defun assign-slots-locations (slots) (loop for slot in slots with location = 0 if (local-slot-p slot) do (setf (slot-value slot 'location) location) (incf location)) slots) (defun compute-system-class-slots (class) (let* ((slot-class (ensure-class-object 'standard-effective-slot-definition)) (slots (mapcar #'(lambda (initargs) (apply #'make-system-instance slot-class initargs)) (mapcar #'(lambda (spec) (apply #'effective-slot-initargs class spec)) (effective-slot-specs class))))) (assign-slots-locations slots) slots)) (defconstant +funcallable-instance-function-slot-name+ (gensym "FUNCALLABLE-INSTANCE-FUNCTION-SLOT-NAME-")) (defconstant +funcallable-instance-function-slot-spec+ (let ((name +funcallable-instance-function-slot-name+)) (eval (direct-slot-initargs-form `(,name :initarg ,name))))) (defun canonicalize-system-class-initargs (name &rest initargs &key (metaclass 'standard-class) direct-slots direct-superclasses &allow-other-keys) (when (eq metaclass 'funcallable-standard-class) (push +funcallable-instance-function-slot-spec+ direct-slots)) (assert (not (null direct-superclasses))) (setq direct-superclasses (mapcar #'ensure-class-object direct-superclasses) direct-slots (mapcar #'standard-direct-slot-definition direct-slots)) `(:name ,name :version nil :slots nil :precedence-list nil :default-initargs nil :finalized-p nil :direct-subclasses nil :direct-superclasses ,direct-superclasses :direct-slots ,direct-slots :direct-default-initargs nil :metaclass ,metaclass ,@initargs)) (defun subclassp (subclass class) (when (symbolp subclass) (setq subclass (find-class subclass 'errorp))) (when (symbolp class) (setq class (find-class class 'errorp))) (member class (slot-value subclass 'precedence-list))) (defun instancep (object class) (subclassp (class-of object) class)) (defun canonicalize-system-instances (new-class) (let ((name (slot-value new-class 'name))) (cond ((subclassp new-class (ensure-class-object 'base-class)) (loop for class being the hash-values of *classes* do (when (eq (class-of class) new-class) (canonicalize-instance class)))) ((eq name 'standard-direct-slot-definition) (loop for class being the hash-values of *classes* do (when (finalized-p class) (dolist (slot (slot-value class 'direct-slots)) (canonicalize-instance slot))))) ((eq name 'standard-effective-slot-definition) (loop for class being the hash-values of *classes* do (when (finalized-p class) (dolist (slot (slot-value class 'slots)) (canonicalize-instance slot)))))))) (defun finalize-system-class-inheritance (class) (setf (slot-value class 'precedence-list) (compute-standard-class-precedence-list class)) (setf (slot-value class 'slots) (compute-system-class-slots class)) (setf (slot-value class 'default-initargs) (compute-standard-default-initargs class)) (setf (slot-value class 'finalized-p) t) (dolist (super (slot-value class 'direct-superclasses)) (pushnew class (slot-value super 'direct-subclasses))) (canonicalize-system-instances class)) (defun ensure-system-class (name &rest initargs) (format t "~&ensure-system-class: class name = ~S~%" name) (let* ((initargs (apply #'canonicalize-system-class-initargs name initargs)) (class (apply #'ensure-class-object name initargs))) (finalize-system-class-inheritance class) class)) ;;; Inheritance Structure of Metaobject Classes specified by MOP ;; http://www.lisp.org/mop/concepts.html#inherit-struct-figure ;; ;; t-+- standard-object ;; | +- a class defined by DEFCLASS ;; | +- *metaobject -+- *specializer ;; | | | +- *class -+- standard-class ;; | | | | +- funcallable-standard-class ;; | | | | +- forward-referenced-class ;; | | | | +- structure-class ;; | | | | +- built-in-class ;; | | | +- eql-specializer ;; | | +- *method - standard-method ;; | | | +- *standard-accessor-method ;; | | | + standard-reader-method ;; | | | + standard-writer-method ;; | | +- *method-combination ;; | | +- *slot-definition ;; | | | +- *effective-slot-definition ---------+ ;; | | | +- *direct-slot-definition --------+ | ;; | +------+ | +- *standard-slot-definition | | ;; | | | + standard-direct-slot-definition | ;; | | | + standard-effective-slot-definition ;; | | | ;; | | +----------+ ;; +- function | | ;; | | | | ;; | funcallable-standard-object | ;; | | | ;; | | +-------------------+ ;; | | | ;; | *generic-function ;; | | ;; | standard-generic-function ;; | ;; +- structure-object ;; | | ;; | +- a structure defined by DEFSTRUCT ;; ;; Each class marked with a ``*'' is an abstract class and is not ;; intended to be instantiated. The results are undefined if an attempt ;; is made to make an instance of one of these classes with make-instance. ;; Current build time DEFCLASS limitations. ;; * superclasses must be defclassed before their subclasses. ;; * shared slots are not supported (partially implemented). (defclass t (t) () (:documentation "A superclass of every class, including itself.") (:metaclass built-in-class)) (defclass standard-object (t) () (:documentation "A superclass of every class that is an instance of standard-class except itself.")) (defclass metaobject (standard-object) ()) ; mop abstract (defclass specializer (metaobject) ; mop abstract ((direct-methods :reader specializer-direct-methods :initarg :direct-methods :initform nil) (direct-generic-functions :reader specializer-direct-generic-functions :initarg :direct-generic-functions :initform nil))) (defclass class (specializer) ; clos abstract ((name :accessor class-name :initarg :name :initform nil))) (defclass base-class (class) ((version :accessor class-version :initarg :version :initform nil) (slots :reader class-slots :initarg :slots :initform nil) (direct-slots :reader class-direct-slots :initarg :direct-slots :initform nil) (precedence-list :reader class-precedence-list :initarg :precedence-list :initform nil) (direct-superclasses :accessor class-direct-superclasses :initarg :direct-superclasses :initform nil) (direct-subclasses :accessor class-direct-subclasses :initarg :direct-subclasses :initform nil) (default-initargs :reader class-default-initargs :initarg :default-initargs :initform nil) (direct-default-initargs :reader class-direct-default-initargs :initarg :direct-default-initargs :initform nil) (finalized-p :reader class-finalized-p :initarg :finalized-p :initform nil) (documentation :initform nil :initarg :documentation))) (defclass standard-base-class (base-class) ((version :initform 0) (old-classes :reader class-old-classes :initform (make-array 1 :adjustable t :fill-pointer 0)) (dependents :initform nil))) (defclass standard-class (standard-base-class) ()) ; clos (defclass funcallable-standard-class (standard-base-class) ; mop ((direct-superclasses :initform (list (find-class 'funcallable-standard-object))))) (defclass forward-referenced-class (class) ; mop ((direct-subclasses :accessor class-direct-subclasses :initform nil))) (defclass structure-class (base-class) ; clos () (:metaclass structure-class)) (defclass built-in-class (base-class) ()) ; clos (defclass old-class (class) ((version :reader class-version) (slots :reader class-slots))) (defvar *eql-specializers* (make-hash-table)) (defclass eql-specializer (specializer) ; mop ((object :initarg :object))) (defun eql-specializer-object (eql-specializer) ; mop (slot-value eql-specializer 'object)) (defun find-eql-specializer (object) (gethash object *eql-specializers*)) (defun intern-eql-specializer (object) ; mop (or (find-eql-specializer object) (setf (gethash object *eql-specializers*) (make-instance 'eql-specializer :object object)))) (defclass slot-definition (metaobject) ()) ; mop abstract (defclass standard-slot-definition (slot-definition) ; mop abstract ((name :reader slot-definition-name :initarg :name) (type :reader slot-definition-type :initarg :type :initform 't) (allocation :reader slot-definition-allocation :initarg :allocation :initform :instance) (initargs :reader slot-definition-initargs :initarg :initargs) (initform :reader slot-definition-initform :initarg :initform) (initfunction :reader slot-definition-initfunction :initarg :initfunction) (shared-binding :reader slot-definition-shared-binding :initarg :shared-binding) (documentation :initarg :documentation)) (:default-initargs :name (error "Slot name must be specified."))) (defclass direct-slot-definition (slot-definition) ; mop abstract ((readers :reader slot-definition-readers :initarg :readers) (writers :reader slot-definition-writers :initarg :writers))) (defclass effective-slot-definition (slot-definition) ; mop abstract ((location :reader slot-definition-location :initarg :location))) (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) ; mop ()) (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) ; mop ()) (defclass method (metaobject) ()) ; clos abstract (defclass standard-method (method) ; clos ((function :reader method-function :initarg :function) (qualifiers :reader method-qualifiers :initarg :qualifiers) (specializers :reader method-specializers :initarg :specializers) (specialized-lambda-list :reader method-specialized-lambda-list :initarg :specialized-lambda-list) (lambda-list :reader method-lambda-list :initarg :lambda-list) (generic-function :reader method-generic-function :initarg :generic-function) )) (defclass standard-accessor-method (standard-method) ()) ; mop abstract (defclass standard-reader-method (standard-accessor-method) ; mop ()) (defclass standard-writer-method (standard-accessor-method) ; mop ()) (defclass function (t) () (:metaclass built-in-class)) (defclass funcallable-standard-object (standard-object function) ; mop () (:metaclass funcallable-standard-class)) (defun funcallable-instance-function (funcallable-instance) (slot-value funcallable-instance +funcallable-instance-function-slot-name+)) (defun set-funcallable-instance-function (funcallable-instance function) ; mop (setf (slot-value funcallable-instance +funcallable-instance-function-slot-name+) function)) (defclass generic-function (metaobject funcallable-standard-object) () ;; clos abstract (:metaclass funcallable-standard-class)) (defclass standard-generic-function (generic-function) ; clos ((name :reader generic-function-name :initarg :name) (lambda-list :reader generic-function-lambda-list :initarg :lambda-list) (argument-precedence-order :reader generic-function-argument-precedence-order :initarg :argument-precedence-order) (declarations :reader generic-function-declarations :initarg :declarations) (method-class :reader generic-function-method-class :initarg :method-class) (method-combination :reader generic-function-method-combination :initarg :method-combination) (methods :reader generic-function-methods :initarg :methods) (number-of-required-args :reader number-of-required-args :initarg :number-of-required-args) (applicable-methods :reader generic-function-applicable-methods :initform (make-hash-table)) (effective-methods :reader generic-function-effective-methods :initform (make-hash-table :test #'equal)) (dependents :initform nil))) (defclass structure-object (t) () (:documentation "A superclass of every class that is an instance of structure-class except itself.") (:metaclass structure-class)) ;; Classes that correspond to pre-defined type specifiers ;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm#classtypecorrespondence (defclass symbol (t) () (:metaclass built-in-class)) (defclass character (t) () (:metaclass built-in-class)) (defclass hash-table (t) () (:metaclass built-in-class)) (defclass sequence (t) () (:metaclass built-in-class)) (defclass list (sequence) () (:metaclass built-in-class)) (defclass cons (list) () (:metaclass built-in-class)) (defclass null (symbol list) () (:metaclass built-in-class)) (defclass array (t) () (:metaclass built-in-class)) (defclass vector (array sequence) () (:metaclass built-in-class)) (defclass bit-vector (vector) () (:metaclass built-in-class)) (defclass string (vector) () (:metaclass built-in-class)) (defclass number (t) () (:metaclass built-in-class)) (defclass complex (number) () (:metaclass built-in-class)) (defclass real (number) () (:metaclass built-in-class)) (defclass float (real) () (:metaclass built-in-class)) (defclass rational (real) () (:metaclass built-in-class)) (defclass ratio (rational) () (:metaclass built-in-class)) (defclass integer (rational) () (:metaclass built-in-class)) (defclass stream (t) () (:metaclass built-in-class)) (defclass broadcast-stream (stream) () (:metaclass built-in-class)) (defclass concatenated-stream (stream) () (:metaclass built-in-class)) (defclass string-stream (stream) () (:metaclass built-in-class)) (defclass echo-stream (stream) () (:metaclass built-in-class)) (defclass synonym-stream (stream) () (:metaclass built-in-class)) (defclass file-stream (stream) () (:metaclass built-in-class)) (defclass two-way-stream (stream) () (:metaclass built-in-class)) (defclass pathname (t) () (:metaclass built-in-class)) (defclass logical-pathname (pathname) () (:metaclass built-in-class)) (defclass package (t) () (:metaclass built-in-class)) (defclass random-state (t) () (:metaclass built-in-class)) (defclass readtable (t) () (:metaclass built-in-class)) (defclass restart (t) () (:metaclass built-in-class)) (defclass method-combination (metaobject) ()) ; clos (defstruct method-combination-type (name) (lambda-list) (group-specifiers) (args-lambda-list) (generic-function-symbol) (documentation) (function) (short-form-options)) (defclass standard-method-combination (method-combination) ; clos ((type :reader method-combination-type :initarg :type) (arguments :reader method-combination-arguments :initarg :arguments))) (defparameter *method-combination-types* (make-hash-table)) (defun define-method-combination-type (name &rest initargs) (let ((combination-type (apply #'make-method-combination-type :allow-other-keys t :name name initargs))) (setf (gethash name *method-combination-types*) combination-type))) (defun method-group-p (selecter qualifiers) ;; selecter::= qualifier-pattern | predicate (etypecase selecter (list (or (equal selecter qualifiers) (let ((last (last selecter))) (when (eq '* (cdr last)) (let* ((prefix `(,@(butlast selecter) ,(car last))) (pos (mismatch prefix qualifiers))) (or (null pos) (= pos (length prefix)))))))) ((eql *) t) (symbol (funcall (symbol-function selecter) qualifiers)))) (defun check-variable-name (name) (flet ((valid-variable-name-p (name) (and (symbolp name) (not (constantp name))))) (assert (valid-variable-name-p name)))) (defun canonicalize-method-group-spec (spec) ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]]) ;; long-form-option::= :description description | :order order | ;; :required required-p ;; a canonicalized-spec is a simple plist. (let* ((rest spec) (name (prog2 (check-variable-name (car rest)) (car rest) (setq rest (cdr rest)))) (option-names '(:description :order :required)) (selecters (let ((end (or (position-if #'(lambda (it) (member it option-names)) rest) (length rest)))) (prog1 (subseq rest 0 end) (setq rest (subseq rest end))))) (description (getf rest :description "")) (order (getf rest :order :most-specific-first)) (required-p (getf rest :required))) `(:name ,name :predicate #'(lambda (qualifiers) (loop for item in ',selecters thereis (method-group-p item qualifiers))) :description ,description :order ,order :required ,required-p))) (defconstant +gf-args-variable+ (gensym "GF-ARGS-VARIABLE-") "A Variable name whose value is a list of all arguments to a generic function.") (defun extract-required-part (lambda-list) (flet ((skip (key lambda-list) (if (eq (first lambda-list) key) (cddr lambda-list) lambda-list))) (ldiff (skip '&environment (skip '&whole lambda-list)) (member-if #'(lambda (it) (member it lambda-list-keywords)) lambda-list)))) (defun extract-specified-part (key lambda-list) (case key ((&eval &whole) (list (second (member key lambda-list)))) (t (let ((here (cdr (member key lambda-list)))) (ldiff here (member-if #'(lambda (it) (member it lambda-list-keywords)) here)))))) (defun extract-optional-part (lambda-list) (extract-specified-part '&optional lambda-list)) (defun parse-define-method-combination-arguments-lambda-list (lambda-list) ;; Define-method-combination Arguments Lambda Lists ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm (let ((required (extract-required-part lambda-list)) (whole (extract-specified-part '&whole lambda-list)) (optional (extract-specified-part '&optional lambda-list)) (rest (extract-specified-part '&rest lambda-list)) (keys (extract-specified-part '&key lambda-list)) (aux (extract-specified-part '&aux lambda-list))) (values (first whole) required (mapcar #'(lambda (spec) (if (consp spec) `(,(first spec) ,(second spec) ,@(cddr spec)) `(,spec nil))) optional) (first rest) (mapcar #'(lambda (spec) (let ((key (if (consp spec) (car spec) spec)) (rest (when (consp spec) (rest spec)))) `(,(if (consp key) key `(,(%keyword key) ,key)) ,(car rest) ,@(cdr rest)))) keys) (mapcar #'(lambda (spec) (if (consp spec) `(,(first spec) ,(second spec)) `(,spec nil))) aux)))) (defmacro getk (plist key init-form) "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST." (let ((not-exist (gensym)) (value (gensym))) `(let ((,value (getf ,plist ,key ,not-exist))) (if (eq ,not-exist ,value) ,init-form ,value)))) (defmacro with-args-lambda-list (args-lambda-list generic-function-symbol &body forms) (let ((gf-lambda-list (gensym)) (nrequired (gensym)) (noptional (gensym)) (rest-args (gensym))) (multiple-value-bind (whole required optional rest keys aux) (parse-define-method-combination-arguments-lambda-list args-lambda-list) `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list)) (,nrequired (length (extract-required-part ,gf-lambda-list))) (,noptional (length (extract-optional-part ,gf-lambda-list))) (,rest-args (subseq ,+gf-args-variable+ (+ ,nrequired ,noptional))) ,@(when whole `((,whole ,+gf-args-variable+))) ,@(loop for var in required and i upfrom 0 collect `(,var (when (< ,i ,nrequired) (nth ,i ,+gf-args-variable+)))) ,@(loop for (var init-form) in optional and i upfrom 0 collect `(,var (if (< ,i ,noptional) (nth (+ ,nrequired ,i) ,+gf-args-variable+) ,init-form))) ,@(when rest `((,rest ,rest-args))) ,@(loop for ((key var) init-form) in keys and i upfrom 0 collect `(,var (getk ,rest-args ',key ,init-form))) ,@(loop for (var init-form) in aux and i upfrom 0 collect `(,var ,init-form))) ,@forms)))) (defun invalid-method-error (method format-control &rest args) (declare (ignorable method)) (apply #'error format-control args)) (defun method-combination-error (format-control &rest args) (apply #'error format-control args)) (defmacro with-method-groups (method-group-specs methods-form &body forms) (flet ((grouping-form (spec methods-var) (let ((predicate (getf spec :predicate)) (group (gensym)) (leftovers (gensym)) (method (gensym))) `(let ((,group '()) (,leftovers '())) (dolist (,method ,methods-var) (if (funcall ,predicate (slot-value ,method 'qualifiers)) (push ,method ,group) (push ,method ,leftovers))) (ecase ,(getf spec :order) (:most-specific-last ) (:most-specific-first (setq ,group (nreverse ,group)))) ,@(when (getf spec :required) `((when (null ,group) (error "Method group ~S must not be empty." ',(getf spec :name))))) (setq ,methods-var (nreverse ,leftovers)) ,group)))) (let ((rest (gensym)) (method (gensym))) `(let* ((,rest ,methods-form) ,@(mapcar #'(lambda (spec) `(,(getf spec :name) ,(grouping-form spec rest))) method-group-specs)) (dolist (,method ,rest) (invalid-method-error ,method "Method ~S with qualifiers ~S does not~ belong ~ to any method group." ,method (slot-value ,method 'qualifiers))) ,@forms)))) (defun method-combination-type-lambda (&key name lambda-list args-lambda-list generic-function-symbol method-group-specs declarations forms &allow-other-keys) (let ((methods (gensym))) `(lambda (,generic-function-symbol ,methods ,@lambda-list) ,@declarations (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name))) (with-method-groups ,method-group-specs ,methods ,@(if (null args-lambda-list) forms `((with-args-lambda-list ,args-lambda-list ,generic-function-symbol ,@forms)))))))) (defun long-form-method-combination-args (args) ;; define-method-combination name lambda-list (method-group-specifier*) args ;; args ::= [(:arguments . args-lambda-list)] ;; [(:generic-function generic-function-symbol)] ;; [[declaration* | documentation]] form* (let ((rest args)) (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest)))) (args-lambda-list () (when (nextp :arguments) (prog1 (cdr (car rest)) (setq rest (cdr rest))))) (generic-function-symbol () (if (nextp :generic-function) (prog1 (second (car rest)) (setq rest (cdr rest))) (gensym))) (declaration* () (let ((end (position-if-not #'declarationp rest))) (when end (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest)))))) (documentation? () (when (stringp (car rest)) (prog1 (car rest) (setq rest (cdr rest))))) (form* () rest)) (let ((declarations '())) `(:args-lambda-list ,(args-lambda-list) :generic-function-symbol ,(generic-function-symbol) :documentation ,(prog2 (setq declarations (declaration*)) (documentation?)) :declarations (,@declarations ,@(declaration*)) :forms ,(form*)))))) (defun define-long-form-method-combination (name lambda-list method-group-specs &rest args) (let* ((initargs `(:name ,name :lambda-list ,lambda-list :method-group-specs ,(mapcar #'canonicalize-method-group-spec method-group-specs) ,@(long-form-method-combination-args args))) (lambda-expression (apply #'method-combination-type-lambda initargs))) ;;(format t "~&~S~%" lambda-expression) (apply #'define-method-combination-type name `(,@initargs :function ,(compile nil lambda-expression) :short-form-options nil)))) (defun define-short-form-method-combination (name &key identity-with-one-argument (documentation "") (operator name)) (define-long-form-method-combination name '(&optional (order :most-specific-first)) `((around (:around)) (primary (,name) :order order :required t)) documentation `(let ((form (if (and ,identity-with-one-argument (null (rest primary))) `(call-method ,(first primary)) (cons ',operator (mapcar #'(lambda (method) `(call-method ,method)) primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))) (let ((combination-type (gethash name *method-combination-types*))) (setf (method-combination-type-short-form-options combination-type) `(:documentation ,documentation :operator ,operator :identity-with-one-argument ,identity-with-one-argument))) name) (defmacro define-method-combination (name &rest args) ; clos "Define new types of method combination." (format t "~&define-method-combination: ~S~%" name) `(let ((*message-prefix* ,(format nil "DEFINE-METHOD-COMBINATION ~S: " name))) (apply #',(if (listp (first args)) 'define-long-form-method-combination 'define-short-form-method-combination) ',name ',args))) ;; 7.6.6.4 Built-in Method Combination Types ;; http://www.lispworks.com/reference/HyperSpec/Body/07_ffd.htm (define-method-combination + :identity-with-one-argument t) (define-method-combination and :identity-with-one-argument t) (define-method-combination append :identity-with-one-argument t) (define-method-combination list :identity-with-one-argument t) (define-method-combination max :identity-with-one-argument t) (define-method-combination min :identity-with-one-argument t) (define-method-combination nconc :identity-with-one-argument t) (define-method-combination or :identity-with-one-argument t) (define-method-combination progn :identity-with-one-argument t) (define-method-combination standard () ((around (:around)) (before (:before)) (primary () :required t) (after (:after))) (flet ((call-methods (methods) (mapcar #'(lambda (method) `(call-method ,method)) methods))) (let ((form (if (or before after (rest primary)) `(multiple-value-prog1 (progn ,@(call-methods before) (call-method ,(first primary) ,(rest primary))) ,@(call-methods (reverse after))) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))) ;;;; ;#| ;; AMOP 5.4.5 The defgeneric Macro ;; http://www.lisp.org/mop/concepts.html#defgeneric ;; ;; AMOP 5.4.3 The defmethod Macro ;; http://www.lisp.org/mop/concepts.html#defmethod ;; AMOP 5.4.4 Processing Method Bodies ;; http://www.lisp.org/mop/concepts.html#processing-method-bodies (defvar *generic-functions* (make-hash-table)) (defun find-generic-function (symbol &optional errorp) (let ((symbol-function function)) (if (instancep function 'generic-function) function (multiple-value-bind (generic-function presentp) (gethash discriminating-function *generic-functions*) (if presentp generic-function (when errorp (error "Generic function ~S does not exist." symbol))))))) (defun install-generic-function (symbol gf) (let (discriminating-function (compute-discriminating-function gf)) (if *symbol-function-is-funcallable-object-p* (when symbol (setf (symbol-function symbol) gf)) (progn (remhash (funcallable-instance-function gf) *generic-functions*) (setf (gethash discriminating-function *generic-functions*) gf) (when symbol (setf (symbol-function symbol) discriminating-function)))) (set-funcallable-instance-function gf discriminating-function) gf)) (defun method-spec (method-description) ;; method-description::= (:method method-qualifier* specialized-lambda-list ;; [[declaration* | documentation]] form*) (let ((rest (progn (assert (eq :method (car method-description))) (cdr method-description)))) (flet ((qualifier* () (let* ((end (or (position-if #'consp rest) (error "No specialized lambda list found in ~S." method-description))) (method-qualifiers (subseq rest 0 end))) (assert (notany #'listp method-qualifiers)) (prog1 method-qualifiers (setq rest (nthcdr end rest))))) (lambda-list1 () (let ((specialized-lambda-list (car rest))) (validate-specialized-lambda-list specialized-lambda-list) (prog1 specialized-lambda-list (setq rest (cdr rest))))) (declaration* () (let ((end (position-if-not #'declarationp rest))) (when end (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest)))))) (documentation? () (when (stringp (car rest)) (prog1 (car rest) (setq rest (cdr rest))))) (form* () rest)) `(:qualifiers ,(qualifier*) :specialized-lambda-list ,(lambda-list1) ,@(let ((decls (declaration*))) `(:documentation ,(documentation?) :declarations ,(mapappend #'cdr `(,@decls ,@(declaration*))))) :forms ,(form*))))) (defun method-spec-to-ensure-generic-function-form (name spec env) (let* ((lambda-list (extract-lambda-list (getf spec :specialized-lambda-list))) (options (canonicalize-defgeneric-options lambda-list '()))) `(ensure-generic-function ,name :environment ,env ,@options))) (defun allow-other-keys (lambda-list) (if (and (member '&key lambda-list) (not (member '&allow-other-keys lambda-list))) (let* ((key-end (or (position &aux lambda-list) (length lambda-list))) (aux-part (subseq lambda-list key-end))) `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part)) lambda-list)) (defun make-system-method-lambda () ) (defun (generic-function method lambda-expression environment) (funcall (if *mop-working-p* #'make-method-lambda #'make-system-method-lambda) generic-function method lambda-expression environment)) (defun (class) (funcall (if *mop-working-p* #'class-prototype #'make-system-instance) class)) (defun method-initargs-form (gf-form environment &key initial-method-p null-lexical-environment-p specialized-lambda-list qualifiers documentation declarations forms) (let* ((lambda-list (extract-lambda-list specialized-lambda-list)) (specializer-names (extract-specializer-names specialized-lambda-list)) (gf (gensym)) (methods (gensym)) ;; used by make-method-lambda (lambda-expression (gensym)) (initargs (gensym))) `(let* ((,gf ,gf-form) (,method-class (slot-value ,gf 'method-class))) (multiple-value-bind (,lambda-expression ,initargs) ( ,gf ( ,method-class) '(lambda (,+gf-args-variable+ ,methods) (apply #'(lambda ,(allow-other-keys lambda-list) (declare ,@declarations) ,@forms) ,+gf-args-variable+)) ,environment) (append ,initargs (list :qualifiers ',qualifiers :specialized-lambda-list ',specialized-lambda-list :lambda-list ',lambda-list :specializers (mapcar #'find-class ,specializer-names) :documentation ',documentation :function (compile nil ,(if null-lexical-environment-p `(eval ,lambda-expression) 'lambda-expression)) :initial-method-p ,initial-method-p))))))) (defun check-defgeneric-declarations (declarations) ) (defun check-singleton-options (options valid-option-names) (flet ((redundant-option-error (option-name) (error 'simple-program-error :format-control "~AOption ~S is given more than once." :format-arguments (list *message-prefix* option-name))) (invalid-option-error (option-name) (error 'simple-program-error :format-control "~AInvalid option ~S is given." :format-arguments (list *message-prefix* option-name)))) (loop for (key . rest) in options with processed = '() when (member key processed) do (redundant-option-error key) when (not (member key valid-option-names)) do (invalid-option-error key) do (push key processed))) (defvar generic-function-initarg-names '(:argument-precedence-order :declare :documentation :environment :generic-function-class :lambda-list :method-class :method-combination)) (defun generic-function-initargs-form (options) (check-singleton-options options generic-function-initarg-names) (flet ((value-form (key rest) (case key ((:documentation :environment :generic-function-class :method-class :lambda-list) (destructuring-bind (value) rest (qt? value))) (t (qt? rest))))) (loop for (key . rest) in options when (eq key :declare) do (setq key :declarations) nconc `(,(qt? key) ,(value-form key rest)) into result finally (return `(list ,@result))))) (defun ensure-system-generic-function (name &rest initargs) ) (defun add-system-method (generic-function method) ) (defun (name &rest initargs) (apply (if *mop-working-p* #'ensure-generic-function #'ensure-system-generic-function) name initargs)) (defun (name &rest initargs) (apply (if *mop-working-p* #'make-instance #'make-system-instance) name initargs)) (defun (generic-function method) (funcall (if *mop-working-p* #'add-method #'add-system-method) generic-function method)) (defmacro defgeneric (name lambda-list &body args &environment env) ; clos "Define a generic function named NAME." (let* ((*message-prefix* (format nil "DEFGENERIC ~S: " name)) (method-descriptions (loop for spec in args if (eq (first spec) :method) collect spec)) (declarations (loop for spec in args if (eq (first spec) 'declare) append (rest spec))) (options `((:lambda-list ,lambda-list) (:environment ,env) ,@(when declarations `((:declare ,@declarations))) ,@(loop for spec in args unless (member (first spec) '(:method declare)) collect spec))) (gf (gensym)) (method-class (gensym)) (methods (gensym))) (check-defgeneric-declarations declarations) `(let* ((*message-prefix* ,*message-prefix*) (,gf (apply #' ',name ,(generic-function-initargs-form options))) (,method-class (generic-function-method-class ,gf)) (,methods (list ,@(mapcar #'(lambda (spec) `(apply #' ,method-class :initial-method-p t ,(apply #'method-initargs-form gf env spec))) (mapcar #'method-spec method-descriptions))))) (mapc #'(lambda (method) ( ,gf method)) ,methods) ,gf))))) (defmacro defmethod (name &rest args &environment env) ; clos "Define a method named NAME." (let ((spec (method-spec `(:method ,@args))) (gf (gensym)) (method (gensym))) `(let* ((,gf (or (find-generic-function name) ,(method-spec-to-ensure-generic-function-form name spec env))) (,method (apply #' (generic-function-method-class ,gf) (method-initargs-form ,gf ,env ,@spec)))) ( ,gf ,method) ,method))) (defgeneric ensure-class-using-class (class name &key direct-default-initargs direct-slots direct-superclasses metaclass &allow-other-keys)) ; mop (defmethod ensure-class-using-class ((class class) name &key (metaclass 'standard-class) direct-superclasses &allow-other-keys) (check-type class metaclass) (apply #'reinitialize-instance class initargs)) (defmethod ensure-class-using-class ((class forward-referenced-class) name &rest initargs &key (metaclass 'standard-class) direct-superclasses &allow-other-keys) (apply #'change-class class metaclass initargs)) (defmethod ensure-class-using-class ((class null) name &rest initargs &key (metaclass 'standard-class) direct-superclasses &allow-other-keys) (setf (find-class name) (apply #'make-instance metaclass initargs))) (defun ensure-class (name &rest args &key &allow-other-keys) ; mop (apply #'ensure-class-using-class (find-class name) name args)) (defgeneric compute-class-precedence-list (class)) ; mop (defmethod compute-class-precedence-list ((class class)) (compute-standard-class-precedence-list class)) (defgeneric compute-default-initargs (class)) ; mop (defmethod compute-default-initargs ((class standard-base-class)) (compute-standard-default-initargs class)) (defgeneric effective-slot-definition-class (class &rest initargs)) ; mop (defmethod effective-slot-definition-class ((class standard-base-class) &rest initargs) (find-class 'standard-effective-slot-definition)) (defgeneric compute-effective-slot-definition (class name direct-slot-definitions)) ; mop (defmethod compute-effective-slot-definition ((class standard-base-class) name direct-slot-definitions) (apply #'make-instance (apply #'effective-slot-definition-class class initargs) (effective-slot-initargs class name direct-slot-definitions))) (defgeneric compute-slots (class)) ; mop (defmethod compute-slots :around ((class standard-base-class)) (let ((slots (call-next-method))) (assign-slots-locations slots) slots)) (defmethod compute-slots ((class standard-base-class)) (loop for (name direct-slots) in (effective-slot-specs class) collect (compute-effective-slot-definition class name direct-slots))) (defgeneric finalize-inheritance (class)) ; mop (defmethod finalize-inheritance ((class standard-base-class)) ;; see "Class Finalization Protocol" ;; http://www.lisp.org/mop/concepts.html#class-finalization-protocol (setf (slot-value class 'precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'default-initargs) (compute-default-initargs class)) (setf (slot-value class 'slots) (compute-slots class)) (setf (slot-value class 'finalized-p) t) class) (defmethod finalize-inheritance ((class forward-referenced-class)) (error "Cannot finalize inheritance for forward-referenced-class object.")) ;; ! write an after method which computes a hash-table of slot-names and ;; slot-definition objects which will be used in find-slot. (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys) (:documentation ;; clos "Create and return a new instance of CLASS, without initializing it.")) (defmethod allocate-instance ((class standard-base-class) &rest initargs) (make-%standard-object :class class :version (slot-value class 'version) :storage (allocate-standard-instance-storage class))) (defmethod allocate-instance ((class structure-class) &rest initargs) (error "allocate-instance specialized for structure-class is not implemented.")) (defmethod allocate-instance ((class built-in-class) &rest initargs) (error "`allocate-instance' is not applicable to built-in-class.")) (defgeneric validate-superclass (class superclass)) ; mop (defmethod validate-superclass ((class class) (superclass class)) (let ((class-of-class (class-of class-of)) (class-of-superclass (class-of superclass)) (standard-class (find-class 'standard-class)) (funcallable-standard-class (find-class 'funcallable-standard-class))) ;; http://www.lisp.org/mop/dictionary.html#validate-superclass (or (eq superclass (find-class 't)) ;; (i) If the superclass argument is the class named t, (eq class-of-superclass class-of-class) ;; (ii) if the class of the class argument is the same as ;; the class of the superclass argument or (and (eq class-of-class standard-class) (eq class-of-superclass funcallable-standard-class)) (and (eq class-of-class funcallable-standard-class) (eq class-of-superclass standard-class)) ;; (iii) if the classes one of the arguments is standard-class and ;; the class of the other is funcallable-standard-class. ))) (defun canonicalize-direct-superclasses (class direct-superclasses) (flet ((superclass (designator) (etypecase designator (symbol (or (find-class designator) (ensure-class designator :metaclass 'forward-referenced-class))) (class designator)))) (mapcar #'(lambda (designator) (let ((superclass (superclass designator))) (unless (validate-superclass class superclass) (error "~S cannot be a superclass of ~S" superclass class)) superclass)) direct-superclasses))) (defgeneric shared-initialize (instance slot-names &rest initargs &key &allow-other-keys) (:documentation ;; clos "Fill the slots of INSTANCE using INITARGS and :initform forms.")) (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) (standard-shared-initialize instance slot-names initargs)) (defgeneric check-initargs (instance gf-args-pairs initargs)) (defmethod check-initargs ((instance standard-object) gf-args-pairs initargs) (unless (getf initargs :allow-other-keys) (let* ((class (class-of instance)) (valid-keys (remove-duplicates (nconc (mapappend #'function-keywords (mapappend #'(lambda (gf-args-pair) (apply #'applicable-methods gs-args-pair)) gf-args-pairs)) (mapappend #'slot-definition-initargs (class-slots class)) '(:allow-other-keys)))) (keys (remove-duplicates (plist-keys initargs))) (invalid-keys (set-difference keys valid-keys))) (when invalid-keys (error "Invalid initialization argument keyword~P: ~S" (length invalid-keys) invalid-keys))))) (defmethod check-initargs ((instance standard-slot-definition) gf-args-pairs initargs) (let ((initform-supplied-p (plist-member :initform initargs)) (initfunction-supplied-p (plist-member :initfunction initargs))) (assert (or (and initform-supplied-p initfunction-supplied-p) (and (not initform-supplied-p) (not initfunction-supplied-p)))) (when (and (not initform-supplied-p) (not initfunction-supplied-p)) (setq initargs `(:initform nil :initfunction nil ,@initargs))) (call-next-method instance gf-args-pairs initargs))) ;; ... more check-initargs methods (defmethod shared-initialize ((instance standard-base-class) slot-names &rest initargs &key (direct-slots "never used" direct-slots-p)) (flet ((direct-slot (class spec) (apply #'make-instance (apply #'direct-slot-definition-class class spec) spec))) (when direct-slots-p (setq initargs `(:direct-slots ,(mapcar #'(lambda (spec) (direct-slot instance spec)) direct-slots) ,@initargs))) (apply #'call-next-method instance slot-names initargs) ;; define readers & writers here using reader-method-class & writer-method-class ! )) (defmethod shared-initialize ((instance standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'standard-class)) ;; http://www.lispworks.com/reference/HyperSpec/Body/m_defcla.htm ;; If the superclass list is empty, then the superclass defaults ;; depending on the metaclass, with standard-object being the default ;; for standard-class. (when direct-superclasses-p (setq initargs `(:direct-superclasses ,(canonicalize-direct-superclasses instance (or direct-superclasses (list 'standard-object))) ,@initargs))) (apply #'call-next-method instance slot-names initargs)) (defmethod shared-initialize ((instance funcallable-standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'funcallable-standard-class)) ;; http://www.lisp.org/mop/dictionary.html#class-mo-init ;; if the class is an instance of funcallable-standard-class ;; or one of its subclasses the default value is list of the class ;; funcallable-standard-object. (when direct-superclasses-p (setq initargs `(:direct-superclasses ,(canonicalize-direct-superclasses instance (or direct-superclasses (list 'funcallable-standard-object))) ,@initargs))) (apply #'call-next-method instance slot-names initargs) (let ((name (getf initargs :name (generic-function-name instance)))) (install-generic-function name instance)) instance) (defgeneric add-direct-subclass (superclass subclass)) ; mop (defmethod add-direct-subclass ((superclass class) (subclass class)) (pushnew subclass (class-direct-subclasses superclass))) (defgeneric remove-direct-subclass (superclass subclass)) ; mop (defmethod remove-direct-subclass ((superclass class) (subclass class)) (setf (class-direct-subclasses superclass) (remove subclass (class-direct-subclasses superclass)))) (defgeneric reinitialize-instance (instance &rest initargs &key &allow-other-keys) (:documentation ;; clos "Change the values of local slots of INSTANCE according to INITARGS.")) (defmethod reinitialize-instance ((instance standard-object) &rest initargs) ;; http://www.lispworks.com/reference/HyperSpec/Body/f_reinit.htm ;; The system-supplied primary method for reinitialize-instance checks ;; the validity of initargs and signals an error if an initarg is supplied ;; that is not declared as valid. The method then calls the generic function ;; shared-initialize with the following arguments: the instance, nil ;; (which means no slots should be initialized according to their initforms), ;; and the initargs it received. (check-initargs instance `((,#'reinitialize-instance (,instance ,@initargs)) (,#'shared-initialize (,instance nil ,@initargs))) initargs) (apply #'shared-initialize instance nil initargs)) (defmethod reinitialize-instance :after ((instance standard-generic-function) &rest initargs) (map-dependents instance #'(lambda (dependent) (apply #'update-dependent instance dependent initargs)))) (defgeneric make-instances-obsolete (class) ; clos (:documentation "Initiate the process of updating the instances of CLASS.")) (defmethod make-instances-obsolete ((class standard-base-class)) (vector-push-extend (make-instance 'old-class :current-class class) (class-old-classes class)) (setf (slot-value class 'finalized-p) nil) (incf (slot-value class 'version)) (mapc #'(lambda (gf) (clear-gf-cache gf)) (specializer-direct-generic-functions class)) (mapc #'(lambda (child) (when (class-finalized-p child) (make-instances-obsolete child))) (class-direct-subclasses class)) class) (defmethod make-instances-obsolete ((class symbol)) (apply #'make-instances-obsolete (find-class class))) (defmethod reinitialize-instance ((instance standard-base-class) &rest initargs) (let ((finalizedp (class-finalized-p instance)) (previous (class-direct-superclasses instance))) (when finalizedp (make-instances-obsolete instance)) (call-next-method) (let ((current (class-direct-superclasses instance))) (mapc #'(lambda (super) (remove-direct-subclass super instance)) (set-difference previous current)) (mapc #'(lambda (super) (add-direct-subclass super instance)) (set-difference current previous))) (when finalizedp (finalize-inheritance instance) (map-dependents instance #'(lambda (dependent) (apply #'update-dependent instance dependent initargs)))) instance)) (defgeneric update-instance-for-different-class (previous current &rest initargs &key &allow-other-keys) (:documentation ;; clos "Called only by change-class. Programmers may write methods for it.")) (defmethod update-instance-for-different-class ((previous standard-object) (current standard-object) &rest initargs) ;; http://www.lispworks.com/reference/HyperSpec/Body/f_update.htm ;; The system-supplied primary method on update-instance-for-different-class ;; checks the validity of initargs and signals an error if an initarg is ;; supplied that is not declared as valid. This method then initializes slots ;; with values according to the initargs, and initializes the newly added ;; slots with values according to their :initform forms. It does this by ;; calling the generic function shared-initialize with the following ;; arguments: the instance (current), a list of names of the newly added ;; slots, and the initargs it received. Newly added slots are those local ;; slots for which no slot of the same name exists in the previous class. (let ((added-local-slots (set-difference (mapcan #'(lambda (slot) (when (local-slot-p slot) (list (slot-definition-name slot)))) (class-slots (class-of current))) (class-slot-names (class-of previous))))) (check-initargs current `((,#'update-instance-for-different-class (,previous ,current ,@initargs)) (,#'shared-initialize (,current ,added-local-slots ,@initargs))) initargs) (apply #'shared-initialize current added-local-slots initargs))) (defmethod update-instance-for-different-class :after ((previous forward-referenced-class) (current standard-base-class) &rest initargs) (mapc #'(lambda (super) (add-direct-subclass super current)) (class-direct-superclasses current))) (defgeneric change-class (instance new-class &key &allow-other-keys) (:documentation ;; clos "Change the class of INSTANCE to NEW-CLASS destructively.")) (defmethod change-class ((instance t) (new-class symbol) &rest initargs) (apply #'change-class instance (find-class new-class) initargs)) (defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs) (let ((previous (allocate-instance new-class))) (swap-%standard-object instance previous) (loop with prev-slot-names = (class-slot-names (class-of previous)) slot in (mapcan #'(lambda (slot) (when (and (local-slot-p slot) (member (slot-definition-name slot) prev-slot-names)) (list slot))) (class-slots new-class)) name = (slot-definition-name slot) if (slot-boundp previous name) do (slot-makunbound instance name) else do (setf (slot-value instance name) (slot-value previous name))) (apply #'update-instance-for-different-class previous instance initargs))) (defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) (:documentation ;; clos "Called by the mechanism activated by make-instances-obsolete.")) (defmethod update-instance-for-redefined-class ((instance standard-object) added-slots discarded-slots property-list &rest initargs) ;; http://www.lispworks.com/reference/HyperSpec/Body/f_upda_1.htm ;; The system-supplied primary method on ;; update-instance-for-redefined-class checks the validity of initargs ;; and signals an error if an initarg is supplied that is not declared as ;; valid. This method then initializes slots with values according to the ;; initargs, and initializes the newly added-slots with values according ;; to their :initform forms. It does this by calling the generic function ;; shared-initialize with the following arguments: the instance, a list ;; of names of the newly added-slots to instance, and the initargs it ;; received. Newly added-slots are those local slots for which no slot of ;; the same name exists in the old version of the class. (let* ((class (class-of instance)) (added-local-slots (mapcan #'(lambda (name) (if (local-slot-p (find-slot class name)) (list name) nil)) added-slots))) (check-initargs instance `((,#'update-instance-for-redefined-class (,instance ,added-slots ,discarded-slots ,property-list ,@initargs)) (,#'shared-initialize (,instance ,added-local-slots ,@initargs))) initargs) (apply #'shared-initialize instance added-local-slots initargs))) (defun obsolete-instance-p (instance) (/= (%standard-object-version instance) (class-version (class-of instance)))) (defun update-obsolete-instance (instance) (let* ((class (class-of instance)) (old-class (aref (class-old-classes class) (%standard-object-version instance))) (old-instance (allocate-instance class))) (swap-%standard-object instance old-instance) (setf (%standard-object-class old-instance) old-class) (let* ((old (class-slot-names old-class)) (new (class-slot-names class)) (common (intersection old new)) (discarded (set-difference old new)) (added (set-difference new old))) (mapc #'(lambda (name) ;; slots of the same name ;; old current slot value/unbound state ;; local shared discarded ;; shared shared retained ;; local local retained ;; shared local retained (if (and (local-slot-p (find-slot old-class name)) (not (local-slot-p (find-slot class name)))) (push name discarded) (if (slot-boundp old-instance name) (setf (slot-value instance name) (slot-value old-instance name)) (slot-makunbound instance name)))) common) (let ((plist (loop for name in discarded when (slot-boundp old-instance name) nconc `(,name ,(slot-value old-instance name))))) (update-instance-for-redefined-class instance added discarded plist))))) (defun update-instance-if-obsolete (instance) (when (obsolete-instance-p object) (update-obsolete-instance object))) (defgeneric initialize-instance (instance &key &allow-other-keys)) ; clos (defmethod initialize-instance ((instance standard-object) &rest initargs) (apply #'shared-initialize instance t initargs)) (defmethod initialize-instance :after ((instance class) &rest initargs) (mapc #'(lambda (super) (add-direct-subclass super instance)) (class-direct-superclasses instance))) (defgeneric make-instance (class &rest initargs &key &allow-other-keys) (:documentation "Create and return a new instance of CLASS.")) ; clos (defmethod make-instance ((class symbol) &rest initargs) (apply #'make-instance (find-class class) initargs)) (defmethod make-instance ((class funcallable-standard-class) &rest initargs) (push +funcallable-instance-function-slot-spec+ (getf initargs :direct-slots)) (apply #'call-next-method class ,@initargs)) (defmethod make-instance ((class standard-base-class) &rest initargs) (let ((instance (apply #'allocate-instance class initargs)) (defaulted-initargs (defaulted-initargs class initargs))) (check-initargs instance `((,#'allocate-instance (,class ,@defaulted-initargs)) (,#'initialize-instance (,instance ,@defaulted-initargs)) (,#'shared-initialize (,instance t ,@defaulted-initargs))) defaulted-initargs) (apply #'initialize-instance instance defaulted-initargs))) (defmethod make-instance ((class old-class) &rest initargs &key (current-class (required-argument))) (let ((instance (apply #'allocate-instance class initargs))) (check-initargs initargs `(,#'make-instance (,class ,@initargs) initargs)) (setf (slot-value instance 'name) (slot-value current-class 'name)) (setf (slot-value instance 'version) (slot-value current-class 'version)) (setf (slot-value instance 'slots) (copy-seq (slot-value current-class 'slots))) instance)) (defgeneric class-name (class) ; clos (:documentation "Return the name of CLASS.")) (defgeneric (setf class-name) (name class) ; clos (:documentation "Set the name of CLASS to NAME.")) (defgeneric class-direct-slots (class)) ; mop (defgeneric class-direct-default-initargs (class)) ; mop (defgeneric class-direct-superclasses (class)) ; mop (defgeneric class-direct-subclasses (class)) ; mop (defgeneric class-precedence-list (class)) ; mop (defgeneric class-default-initargs (class)) ; mop (defgeneric class-default-initfuncs (class)) (defgeneric class-slots (class)) ; mop (defgeneric class-finalized-p (class)) ; mop (defgeneric class-prototype (class)) ; mop (defmethod class-precedence-list :before ((class standard-base-class)) (unless (class-finalized-p class) (finalize-inheritance class))) (defmethod class-slots :before ((class standard-base-class)) (unless (class-finalized-p class) (finalize-inheritance class))) (defmethod class-default-initargs :before ((class standard-base-class)) (unless (class-finalized-p class) (finalize-inheritance class))) (defmethod class-default-initfuncs :before ((class standard-base-class)) (unless (class-finalized-p class) (finalize-inheritance class))) (defmethod documentation ((x standard-base-class) (doc-type (eql 't))) (slot-value x 'documentation)) (defmethod documentation ((x standard-base-class) (doc-type (eql 'type))) (slot-value x 'documentation)) (defgeneric direct-slot-definition-class (class &rest initargs)) ; mop (defmethod direct-slot-definition-class ((class standard-base-class) &rest initargs) (find-class 'standard-direct-slot-definition)) (defgeneric specializer-direct-methods (specializer)) ; mop (defgeneric specializer-direct-generic-functions (specializer)) ; mop (defgeneric add-direct-method (specializer method)) ; mop (defmethod add-direct-method ((specializer specializer) (method method)) (pushnew method (slot-value specializer 'direct-methods)) (pushnew (method-generic-function method) (slot-value specializer 'direct-generic-functions))) (defgeneric remove-direct-method (specializer method)) ; mop (defmethod remove-direct-method ((specializer specializer) (method method)) (setf (slot-value specializer 'direct-methods) (remove method (specializer-direct-methods specializer))) (let ((gf (method-generic-function method))) (unless (member gf (mapcar #'method-generic-function (specializer-direct-methods specializer))) (setf (slot-value specializer 'direct-generic-functions) (remove gf (specializer-direct-generic-functions)))))) (defgeneric reader-method-class (class direct-slot &rest initargs)) ; mop (defmethod reader-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs) (find-class 'standard-reader-method)) (defgeneric writer-method-class (class direct-slot &rest initargs)) ; mop (defmethod writer-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs) (find-class 'standard-writer-method)) (defgeneric add-dependent (metaobject dependent)) ; mop (defmethod add-dependent ((class standard-base-class) dependent) (pushnew dependent (slot-value class 'dependents))) (defmethod add-dependent ((generic-function standard-generic-function) dependent) (pushnew dependent (slot-value generic-function 'dependents))) (defgeneric remove-dependent (metaobject dependent)) ; mop (defmethod remove-dependent ((class standard-base-class) dependent) (setf (slot-value class 'dependents) (remove dependent (slot-value class 'dependents)))) (defmethod remove-dependent ((generic-function standard-generic-function) dependent) (setf (slot-value generic-function 'dependents) (remove dependent (slot-value generic-function 'dependents)))) (defgeneric map-dependents (metaobject function)) ; mop (defmethod map-dependents ((metaobject standard-base-class) function) (mapc function (slot-value metaobject 'dependents))) (defmethod map-dependents ((metaobject standard-generic-function) function) (mapc function (slot-value metaobject 'dependents))) (defgeneric update-dependent (metaobject dependent &rest initargs)) ; mop (defgeneric make-load-form (object &optional environment) (:documentation ;; clos "Return forms to enable load to construct an object equivalent to OBJECT.")) (defmethod make-load-form ((object standard-object) &optional environment) ) (defmethod make-load-form ((object structure-object) &optional environment) ) (defmethod make-load-form ((object condition) &optional environment) ) (defmethod make-load-form ((object class) &optional environment) ) (defun make-load-form-saving-slots (object &key slot-names environment) ; clos "Return forms that will construct an object equivalent to OBJECT." ) (defmacro with-accessors (slot-entries instance &body body) ; clos "Make slots accessible like variables through specified accessors." (let ((instance (gensym))) `(let ((,instance ,instance-form)) (symbol-macrolet (,@(mapcar #'(lambda (entry) `(,(first entry) (,(second entry) ,instance))) slot-entries)) ,@body)))) (defmacro with-slots (slot-entries instance-form &body body) ; clos "Create a lexical environment where slots are accessible like variables." (let ((instance (gensym))) `(let ((,instance ,instance-form)) (symbol-macrolet (,@(mapcar #'(lambda (entry) (if (symbolp entry) `(,entry (slot-value ,instance ',entry)) `(,(first entry) (slot-value ,instance ',(second entry))))) slot-entries)) ,@body)))) (defun standard-instance-access (instance location) ; mop (let ((storage (%standard-object-storage instance))) (if (frozen-class-instance-p instance) (second (nth location storage)) (aref storage location)))) (defun funcallable-standard-instance-access (instance location) (standard-instance-access instance location)) (defun refer-slot-using-class (class object slot) (update-instance-if-obsolete object) (if (local-slot-p slot) (let (location (slot-definition-location slot)) (aref (%standard-object-storage object) location)) (car (slot-definition-shared-binding slot)))) (defgeneric slot-value-using-class (class object slot)) ; mop (defmethod slot-value-using-class ((class standard-base-class) object (slot standard-effective-slot-definition)) (let* ((value (refer-slot-using-class class object slot))) (if (eq value +unbound-state+) (values (slot-unbound class object (slot-definition-name slot))) value))) (defmethod slot-value-using-class ((class built-in-class) object slot) (error "slot-value-using-class cannot be used for a built-in-class object.")) (defgeneric (setf slot-value-using-class) (new-value class object slot)) ; mop (defmethod (setf slot-value-using-class) (new-value (class standard-base-class) object (slot standard-effective-slot-definition)) (update-instance-if-obsolete object) (if (local-slot-p slot) (let ((location (slot-definition-location slot))) (setf (aref (%standard-object-storage object) location) new-value)) (setf (car (slot-definition-shared-binding slot)) new-value))) (defmethod (setf slot-value-using-class) (new-value (class built-in-class) object slot) (error "(setf slot-value-using-class) cannot be used for ~ a built-in-class object.")) (defgeneric slot-exists-p-using-class (class object slot-name)) ; mop? (defmethod slot-exists-p-using-class ((class standard-base-class) object slot-name) (find-slot class slot-name)) (defun slot-exists-p (object slot-name) ; clos "Return true if OBJECT has a slot named SLOT-NAME." (slot-exists-p-using-class (class-of object) object slot-name)) (defgeneric slot-boundp-using-class (class object slot)) ; mop (defmethod slot-boundp-using-class ((class standard-base-class) object (slot standard-effective-slot-definition)) (not (eq (refer-slot-using-class class object slot) +unbound-state+))) (defmethod slot-boundp-using-class ((class built-in-class) object slot) (error "slot-boundp-using-class cannot be used for a built-in-class object.")) (defun directly-accessible-slot-p (slot) ;; http://www.lisp.org/mop/concepts.html#instance-structure-protocol ;; > In particular, portable programs can control the implementation ;; > of, and obtain direct access to, slots with allocation :instance and ;; > type t. These are called directly accessible slots. (and (eq (slot-definition-allocation slot) :instance) (eq (slot-definition-type slot) 't))) (defgeneric slot-makunbound-using-class (class object slot)) ; mop (defmethod slot-makunbound-using-class ((class standard-base-class) object (slot standard-effective-slot-definition)) (setf (slot-value-using-class class object slot) +unbound-state+)) (defmethod slot-makunbound-using-class ((class built-in-class) object slot) (error "slot-makunbound-using-class cannot be used for a built-in-class object.")) (defun slot-makunbound (instance slot-name) ; clos "Restore a slot of the name SLOT-NAME in INSTANCE to the unbound state." (let* ((class (class-of instance)) (slot (find-slot class slot-name))) (if slot (slot-makunbound-using-class class instance slot) (slot-missing class instance slot-name 'slot-makunbound)) instance)) (defgeneric slot-missing (class object slot-name operation &optional new-value) (:documentation ;; clos "Invoked when a slot not defined in CLASS is accessed by SLOT-NAME.")) (defmethod slot-missing ((class t) object slot-name operation &optional new-value) (error "The slot ~S is missing in the class ~S." slot-name (etypecase class (symbol class) (class (class-name class))))) (defgeneric slot-unbound (class instance slot-name) (:documentation ;; clos "Called when an unbound slot named SLOT-NAME is read in INSTANCE of CLASS.")) (defmethod slot-unbound ((class t) instance slot-name) (error 'unbound-slot :instance instance :name slot-name)) (defgeneric ensure-generic-function-using-class (generic-function function-name &key argument-precedence-order declarations documentation generic-function-class lambda-list method-class method-combination name &allow-other-keys)) ; mop (defmethod ensure-generic-function-using-class ((generic-function generic-function) function-name &rest initargs &key generic-function-class &allow-other-keys) (apply #'reinitialize-instance generic-function initargs)) (defmethod ensure-generic-function-using-class ((generic-function null) function-name &rest initargs &key generic-function-class &allow-other-keys) (apply #'make-instance generic-function-class initargs)) (defun ensure-generic-function (function-name &rest initargs &key argument-precedence-order declare documentation environment generic-function-class lambda-list method-class method-combination) "Define a globally named generic function with no methods." ; clos (let ((fdefinition (fdefinition function-name))) (when (and fdefinition (not (instancep fdefinition 'generic-function))) (error "~S already names an ordinary function or a macro." function-name)) (loop initially (setq initargs (copy-list initargs)) while (remf initargs :declare)) (apply #'ensure-generic-function-using-class fdefinition `(:declarations ,declare ,@initargs)))) (defun (setf generic-function-name) (new-name generic-function) ) (defun clear-gf-cache (gf) (clrhash (generic-function-applicable-methods gf)) (clrhash (generic-function-effective-methods gf))) (defgeneric method-qualifiers (method) ; clos (:documentation "Return a list of the qualifiers of METHOD.")) (defun check-specialized-lambda-list (specialized-lambda-list) (let ((required-part (extract-required-part specialized-lambda-list))) (assert (plusp (length required-part))) (dolist (var-spec required-part) (etypecase var-spec (symbol (check-variable-name var-speck)) (cons (let ((variable-name (first var-spec)) (parameter-specializer-name (second var-spec))) (check-variable-name variable-name) (assert (or (symbolp parameter-specializer-name) (eq (car parameter-specializer-name) 'eql))))))))) (defun extract-lambda-list (specialized-lambda-list) ; mop (check-specialized-lambda-list specialized-lambda-list) (loop for rest on specialized-lambda-list for item = (car rest) if (member item '(&optional &rest &key &aux)) append rest and do (loop-finish) else collect (if (consp item) (car item) item))) (defun extract-specializer-names (specialized-lambda-list) ; mop (check-specialized-lambda-list specialized-lambda-list) (loop for item in specialized-lambda-list if (member item '(&optional &rest &key &aux)) do (loop-finish) else collect (if (consp item) (second item) 't))) (defun extract-keyword-names (specialized-lambda-list) (check-specialized-lambda-list specialized-lambda-list) (let ((allow-other-keys-p nil)) (values (loop for item in (rest (member '&key specialized-lambda-list)) if (eq item '&allow-other-keys) do (setq allow-other-keys-p t) (loop-finish) else if (eq item '&aux) do (loop-finish) else collect (if (consp item) (if (consp (car item)) (caar item) (%keyword (car item))) (%keyword item))) allow-other-keys-p))) (defgeneric function-keywords (method) ; clos (:documentation "Return the keyword parameter specifiers for METHOD.")) (defmethod function-keywords ((method standard-method)) (extract-keyword-names (method-specialized-lambda-list method))) (defgeneric no-applicable-method (generic-function &rest function-arguments) (:documentation ;; clos "Called when GENERIC-FUNCTION is invoked and no method is applicable.")) (defmethod no-applicable-method ((generic-function t) &rest function-arguments) ) (defgeneric no-next-method (generic-function method &rest args) ; clos (:documentation "Called by call-next-method when there is no next method.")) (defmethod no-next-method ((generic-function standard-generic-function) (method standard-method) &rest args) ) (defgeneric find-method-combination ; mop (generic-function method-combination-type-name method-combination-arguments)) (defmethod find-method-combination ((gf standard-generic-function) method-combination-type combination-options) (multiple-value-bind (type presentp) (gethash method-combination-type *method-combination-types*) (if presentp (make-instance 'standard-method-combination :type type :arguments method-combination-arguments) (error "Method combination ~S does not exist." method-combination-type)))) (defun make-method-form-p (object) (and (consp object) (eq 'make-method (first object)))) (defun make-method-description (gf form) `(:method 'make-method ,(generic-function-lambda-list gf) (with-call-method ,gf ,form))) ;; Local Macro CALL-METHOD, MAKE-METHOD (defmacro with-call-method (gf &body body) `(macrolet ((call-method (method next-methods &environment env) (flet ((method-form (form) (apply #' (generic-function-method-class ,gf) (method-initargs-form ',gf env :null-lexical-environment-p t (method-spec (make-method-description ,gf form)))))) (when (make-method-form-p method) (setq method (method-form (second method)))) (setq next-methods (mapcar #'(lambda (method) (if (make-method-form-p method) (method-form (second method)) `(quote ,method))) next-methods))) `(funcall (method-function ,method) ,+gf-args-variable+ (list ,@next-methods)))) ,@body)) (defgeneric compute-effective-method (generic-function method-combination methods)) ; mop (defmethod compute-effective-method ((generic-function standard-generic-function) method-combination methods) (let* ((type (method-combination-type method-combination)) (type-function (method-combination-type-function type)) (arguments (method-combination-arguments method-combination)) (effective-method (apply type-function generic-function methods arguments))) (values `(with-call-method ,generic-function ,effective-method) `(:arguments ,(method-combination-type-args-lambda-list type) :generic-function ,(method-combination-type-generic-function-symbol type))))) ;; Local Function NEXT-METHOD-P ;; Local Function CALL-NEXT-METHOD (defgeneric make-method-lambda (generic-function method lambda-expression environment)) ; mop (defmethod make-method-lambda ((generic-function standard-generic-function) (method standard-method) lambda-expression environment) (let* ((lambda-list (second lambda-expression)) (gf-args (first lambda-list)) (next-methods (second lambda-list)) (name (generic-function-name generic-function)) (args (gensym))) (multiple-value-bind (decls forms) (declarations-and-forms (cddr lambda-expression)) `(lambda ,lambda-list ,@decls (block ,(if (symbolp name) name (second name)) (labels ((next-method-p () ,next-methods) (call-next-method (&rest ,args) (unless ,args (setq ,args ,gf-args)) (if (next-method-p) (funcall (method-function (car ,next-methods)) ,args (cdr ,next-methods)) (apply #'no-next-method ,generic-function ,method ,(first lambda-list))))) ,@forms)))))) (defgeneric specializer-satisfied-p (specifier arg)) (defmethod specializer-satisfied-p ((specializer class) arg) (member (class-of arg) (class-precedence-list specializer))) (defmethod specializer-satisfied-p ((specializer eql-specializer) arg) (eql arg (eql-specializer-object specializer))) (defun applicable-method-p (method args) (every #'specializer-satisfied-p (method-specializers method) args)) (defun eql-specializer-p (specializer) (eq (class-of specializer) (find-class 'eql-specializer))) (defun more-specific-specializer-p (a b arg) (cond ((eql-specializer-p a) (not (eql-specializer-p b))) ((eql-specializer-p b) nil) (t (let ((list (class-precedence-list (class-of arg)))) (< (position a list) (position b list)))))) (defun sort-methods (gf methods) (let ((indeces (loop for arg in (generic-function-argument-precedence-order gf) collect (position arg (generic-function-lambda-list gf))))) (flet ((more-specific-method-p (a b) (loop for i in indeces if (more-specific-specializer-p (elt (method-specializers a) i) (elt (method-specializers b) i) (elt args i)) return t))) (sort methods #'more-specific-method-p)))) (defgeneric compute-applicable-methods (generic-function function-arguments) ;clos (:documentation "Return the set of applicable methods of GENERIC-FUNCTION. ")) (defmethod compute-applicable-methods ((gf standard-generic-function) args) (let ((methods (mapcan #'(lambda (method) (when (applicable-method-p method args) (list method))) (generic-function-methods gf)))) (sort-methods gf methods))) (defgeneric compute-applicable-methods-using-classes (generic-function classes)) ; mop (defmethod compute-applicable-methods-using-classes ((generic-function standard-generic-function) classes) (flet ((filter (method) (let ((eql-specializer-p nil)) (when (every #'(lambda (a b) (if (and (eql-specializer-p a) (eq (class-of (eql-specializer-object a)) b)) (setq eql-specializer-p t) (subclassp b a))) (method-specializers method) classes) (if eql-specializer-p (return-from compute-applicable-methods-using-classes (values nil nil)) (list method)))))) (values (sort-methods gf (mapcan #'filter (generic-function-methods gf))) t))) (defun applicable-methods (gf args) (let ((classes (mapcar #'class-of (subseq args 0 (number-of-required-args gf))))) (multiple-value-bind (methods presentp) (gethash classes (generic-function-applicable-methods gf)) (if presentp methods (multiple-value-bind (methods memorablep) (compute-applicable-methods-using-classes gf classes) (if memorablep (setf (gethash classes (generic-function-applicable-methods gf)) methods) (compute-applicable-methods gf args))))))) (defgeneric compute-discriminating-function (generic-function)) ; mop (defmethod compute-discriminating-function ((gf standard-generic-function)) (let* ((combination (slot-value gf 'method-combination)) (methods (gensym))) (compile nil `(lambda (&rest ,+gf-args-variable+) ;; check args here. (let ((,methods (applicable-methods ,gf ,+gf-args-variable+))) (if (null ,methods) (apply #'no-applicable-method ,gf ,+gf-args-variable+) (multiple-value-bind (effective-method-function presentp) (gethash methods (generic-function-effective-methods gf)) (if presentp (funcall effective-method-function ,+gf-args-variable+) (progn (setq effective-method-function (compile nil (eval '(lambda (,+gf-args-variable+) ,(compute-effective-method gf combination methods))))) (setf (gethash methods (generic-function-effective-methods gf)) effective-method-function) (funcall effective-method-function ,+gf-args-variable+)))))))))) (defgeneric find-method (generic-function qualifiers specializers &optional errorp) (:documentation ;; clos "Return the method object that agrees on QUALIFIERS and SPECIALIZERS.")) (defmethod find-method ((gf standard-generic-function) qualifiers specializers &optional errorp) (when (/= (length specializers) (number-of-required-args gf)) (error "The lambda list of ~S is ~S, and it doesn't match specializers ~S." gf (generic-function-lambda-list gf) specializers)) (flet ((agreep (a b) (if (eql-specializer-p a) (and (eql-specializer-p b) (eql (eql-specializer-object a) (eql-specializer-object b))) (eq a b)))) (let ((method (find-if #'(lambda (method) (and (agreep (method-specializers method) specializers) (equal (method-qualifiers method) qualifiers))) (generic-function-methods generic-function)))) (or method (when errorp (error "No method for ~S with qualifiers ~S and specializers ~S." gf qualifiers specializers)))))) (defun check-lambda-list-congruence (gf method) ) (defgeneric add-method (generic-function method) ; clos (:documentation "Add METHOD to GENERIC-FUNCTION.")) (defmethod add-method ((generic-function standard-generic-function) (method method)) (when (method-generic-function method) (error "Method ~S is already associated with generic function ~S" method (method-generic-function method))) (check-lambda-list-congruence generic-function method) (let ((old-method (find-method generic-function (method-qualifiers method) (method-specializers method)))) (when old-method (remove-method generic-function old-method))) (push method (slot-value generic-function 'methods)) (mapc #'(lambda (specializer) (add-direct-method specializer method)) (method-specializers method)) (clear-gf-cache gf) (map-dependents generic-function #'(lambda (dependent) (update-dependent generic-function dependent 'add-method method))) method) (defgeneric remove-method (generic-function method) ; clos (:documentation "Remove METHOD from GENERIC-FUNCTION by modifying it")) (defmethod remove-method ((generic-function standard-generic-function) method) (let ((gf-methods (generic-function-methods generic-function))) (when (member method gf-methods) (setf (slot-value generic-function 'methods) (remove method gf-methods)) (mapc #'(lambda (specializer) (remove-direct-method specializer method)) (method-specializers method)))) (clear-gf-cache gf) (map-dependents generic-function #'(lambda (dependent) (update-dependent generic-function dependent 'remove-method method))) method) (defun class-of-sequence (sequence) (typecase sequence (list (typecase sequence (null (find-class 'null)) (cons (find-class 'cons)) (t (find-class 'list)))) (vector (typecase sequence (bit-vector (find-class 'bit-vector)) (string (find-class 'string)) (t (find-class 'vector)))) (t (find-class 'sequence)))) (defun class-of-number (number) (typecase number (integer (find-class 'integer)) (ratio (find-class 'ratio)) (rational (find-class 'rational)) (float (find-class 'float)) (real (find-class 'real)) (complex (find-class 'complex)) (t (find-class 'number)))) (defun class-of-stream (stream) (typecase stream (broadcast-stream (find-class 'broadcast-stream)) (concatenated-stream (find-class 'concatenated-stream)) (string-stream (find-class 'string-stream)) (echo-stream (find-class 'echo-stream)) (synonym-stream (find-class 'synonym-stream)) (file-stream (find-class 'file-stream)) (two-way-stream (find-class 'two-way-stream)) (t (find-class 'stream)))) (defun class-of-condition (condition) (typecase condition (simple-error (find-class 'simple-error)) (simple-type-error (find-class 'simple-type-error)) (simple-warning (find-class 'simple-warning)) (simple-condition (find-class 'simple-condition)) (floating-point-inexact (find-class 'floating-point-inexact)) (floating-point-invalid-operation (find-class 'floating-point-invalid-operation)) (floating-point-overflow (find-class 'floating-point-overflow)) (floating-point-underflow (find-class 'floating-point-underflow)) (division-by-zero (find-class 'division-by-zero)) (arithmetic-error (find-class 'arithmetic-error)) (reader-error (find-class 'reader-error)) (parse-error (find-class 'parse-error)) (end-of-file (find-class 'end-of-file)) (stream-error (find-class 'stream-error)) (unbound-slot (find-class 'unbound-slot)) (unbound-variable (find-class 'unbound-variable)) (undefined-function (find-class 'undefined-function)) (cell-error (find-class 'cell-error)) (type-error (find-class 'type-error)) (package-error (find-class 'package-error)) (control-error (find-class 'control-error)) (print-not-readable (find-class 'print-not-readable)) (program-error (find-class 'program-error)) (file-error (find-class 'file-error)) (error (find-class 'error)) (storage-condition (find-class 'storage-condition)) (serious-condition (find-class 'serious-condition)) (style-warning (find-class 'style-warning)) (warning (find-class 'warning)) (t (find-class 'condition)))) (progn (setq *mop-working-p* t)) (defconstant +condition-report-slot-name+ (gensym "CONDITION-REPORT-SLOT-NAME-")) (deftype lambda-expression () '(satisfies lambda-expression-p)) (defun lambda-expression-p (object) (and (consp object) (eq (first object) 'lambda) (listp (second object)))) (defun condition-initargs-form (options) (check-singleton-options options '(:default-initargs :documentation :report :direct-superclasses :direct-slots)) (let ((report-option (assoc :report options))) (when report-option (destructuring-bind (report-name) (cdr report-option) (assert (typep report-name (or string symbol lambda-expression))) (let ((slot-spec `(,+condition-report-slot-name+ :allocation :class :initform ',report-name))) (push slot-spec (cdr (assoc :direct-slots options))))) (setq options (remove :report options :key #'car)))) (class-initargs-form options)) (defmacro define-condition (name parent-types slot-specs &rest options) (let ((*message-prefix* (format nil "DEFINE-CONDITION ~S: " name)) (options `((:direct-superclasses ,@(or parent-types '(condition))) (:direct-slots ,@slot-specs) ,@options))) `(let ((*message-prefix* ,*message-prefix*)) (apply #'ensure-class ',name ,(condition-initargs-form options))))) ;; 9.1.1 Condition Types ;; http://www.lispworks.com/reference/HyperSpec/Body/09_aa.htm ;; > The metaclass of the class condition is not specified. (define-condition condition (t) () (:report (lambda (condition stream) (format stream "Condition ~S is signaled." (class-of condition))))) (defun make-condition (type &rest slot-initializations) ) |#