;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox Artifical Intelligence Systems
;;; 2400 Hanover St.
;;; Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
#|
Want to make add-named-class is a functional interface to defclass. In
general, what we need to do is to stop using the expansion of the defclass
form to define extra things (like constructors) using top-level defining
forms. Instead, there is going to need to be a programmatic interface to
those things.
This means that things like make-constructor-definitions are going to be
replaced with something like do-constructor-definitions. Of course, we
may end up with some stuff in the expansion of defclass to do some pre
compiling of things like constructors (unless we introduce compile-class
analogous to compile-flavor-methods). But this would just be compiling
up templates which the do-constructor-definitions facility would then use
to do the constructor definition. This can be done by expand-defclass as
an optimization.
As a hack, we may leave some things in the expansion of the defclass until
we build enough machinery to interface properly to everyones Common Lisp.
This means that all the parsing stuff is going to happen in add-named-class.
BUT, we probably want to do some error checking in defclass (or expand-class)
so that we can have that compile-time error-checking appeal.
defclass epilogue is history, just get rid of it. from the method on class,
this happens:
* record-definition goes to defclass proper
- deftype goes to add-named-class but becomes do-deftype and we introduce a
new generic function make-type-predicate.
- make-constructor-definitions gets replaced with do-constructor-definitions
and goes into add-class
- the slot defsetfs go into slots-changed where they belong, going to have
to implement set-setf or something to provide a faster interface to
defining setf methods than saying (eval '(defsetf ..))
(defmethod defclass-epilogue ((proto class) name parsed-options parsed-slots)
`(progn
(eval-when (compile load eval)
(record-definition ',name 'class)
(deftype ,name () '(satisfies ,(type-predicate-name name)))
,(make-constructor-definitions proto name parsed-options)
,@(mapcar #'(lambda (slot) (defclass-slot-epilouge proto slot name))
parsed-slots))))
from load-defclass, do-type-predicate-definition goes to add-named-class
The call to do-type-predicate-definitions got moved to add-named-class
Also, it got renamed and had its contract changed slightly. Its now called
make-type-predicate.
do-accessor-definitions goes to add-class. Actually, it gets all spread
out into slots-changed since we need to be able to undefine accessors that
no longer exist and there is no use redefining ones that already exist.
issues:
o When do slot descriptions get parsed?
ans: Having these parsed at compile time would require dumping slot
descriptions in the file. Because slot descriptions are user
defined objects which may even have pointers to other classes,
this would require letting the user control how they are dumped.
This is not palatable.
There are many other problems with having them parsed at compile
time as well, having to do with making sure the right things get
reparsed in the load-time-environment.
NOTE: This seems to be the same conclusion Moon reached. A
comment taken from the new Flavors code reads:
;; Note that we cannot save the result of PARSE-DEFFLAVOR in the BIN file,
;; but must redo the parse at load time, for too many reasons to list here
o How does the environment (compile versus eval) get communicated?
ans: In order for portable code to make use of this we would have to
standardize so much mechanism that it would not be palatable to
the Common Lisp community nor would it be a good idea. This is
because we do not yet really understand all the different ways
to deal with compile time environments (e.g. very few people do
in-package right!).
So, we assume that this communication of compile-time versus
run-time environments will be done in a implementation specific
way. It is easy for defclass to pass the the proper environment
information to add-named-class in a special variable. The same
is true for defmethod and add-method and all the others.
To Do:
stop parsing defclass options. setf of class-options can take care
of that. Keep error checking them of course.
implement do-deftype ;and then get rid of this
implement do-defsetf ;goddam epilogue stuff.
do-constructor-definitions ; this may be hard??
|#
;;;;
;;;
;;;
(defmacro DEFCLASS (name includes slots &rest options)
(declare (indentation 2 4 3 1))
(let ((metaclass 'class))
;; Now go see if there is a :metaclass option. We need that before we
;; can do anything else. If there is a :metaclass option, we remove it
;; from the options -- it isn't needed anymore since the class-protype
;; communicates the same information.
(dolist (option options)
(if (not (listp option))
(error "~S is not a legal defclass option.")
(when (eq (car option) ':metaclass)
(unless (legal-class-name-p (cadr option))
(error "The value of the :metaclass option (~S) is not a~%~
legal class name."
(cadr option)))
(unless (class-named (cadr option) t)
(error "The value of the :metaclass option (~S) does not name~%~
a currently defined class. The metaclass must be~%~
defined at the time the defclass form is compiled or~%~
evaluated."
(cadr option)))
(setq metaclass (cadr option)
options (remove option options)))))
(let ((prototype-class (class-prototype (class-named metaclass))))
(make-top-level-form
`(defclass ,name)
(expand-defclass prototype-class name includes slots options)))))
;;;
;;;
;;;
(defmethod EXPAND-DEFCLASS ((proto class) name includes slots options)
`(eval-when (compile load eval)
(load-defclass ',(class-name (class-of proto))
',name
',includes
',slots
',options)))
(defun load-defclass (metaclass-name class-name superclasses slots options)
(record-definition 'class class-name)
(let ((proto (class-prototype (class-named metaclass-name))))
(setq superclasses (copy-list superclasses) ;I know that add-named-class
slots (copy-tree slots) ;and company are NOT allowed
options (copy-tree options)) ;to mutate these. But since
;CL is allowed to share lists
;in compiled files, why ask
;for hard to find bugs?
(add-named-class proto class-name superclasses slots options)))
;;;
;;; ADD-NAMED-CLASS is the programmatic interface to defining named classes.
;;; Think of it as a programmatic interface to defclass. The arguments are
;;; very slightly different, in particular the metaclass is communicated in
;;; a different way, but other than that it works just like defclass. After
;;; all, defclass basically expands into a simple call to add-named-class.
;;;
;;;
;;; ADD-NAMED-CLASS proto-class name superclasses slots options
;;;
;;; proto-class is a prototype instance of the metaclass of
;;; the new class
;;;
;;; name the name for the new class
;;;
;;; superclasses a list of the superclasses of the new class.
;;; These can be symbols (class names) or actual
;;; class objects.
;;;
;;; slots descriptions of the slots for this class. This
;;; list has the same syntax and interpretation as
;;; the third argument to defclass.
;;;
;;; options the options for this class. This list has the
;;; same syntax as the &rest options argument to
;;; defclass, except that the :metaclass option is
;;; not allowed. The metaclass option would have
;;; no meaning since it is communicated in the
;;; proto-class argument.
;;;
;;;
;;; add-named-class creates or updates the definition of a named class. If
;;; there is already a class with the given name, class-for-redefinition is
;;; called to get the class object to use for the new definition.
;;;
;;; Once it has a class object this calls add-class to cause the class lattice
;;; to be updated to take the new definition into account. Then stores this
;;; class in the class name table.
;;;
(defmethod ADD-NAMED-CLASS ((proto class) name superclasses slots options)
(unless (legal-class-name-p name)
(error "~S is not a legal class name (a non-keyword, non-nil symbol.)"
name))
(let* ((existing (class-named name t))
(class (if existing
(class-for-redefinition
existing proto name superclasses slots options)
(make-instance (class-of proto))))
(slotds ()))
;;
;; Error check the options and then parse the slots. We error check
;; the options first because there is no use doing a bunch of work
;; parsing the slots if we are just going to signal an error about the
;; options.
;;
(dolist (option options)
(unless (legal-class-option-p class (car option))
(error "~S is not a legal class-option." (car option))))
(setq slotds (mapcar #'(lambda (x) (parse-class-slot class x)) slots))
;;
;; Set the class name before calling update-class. This allows
;; methods on update-class (or other code they call) to get at
;; the class's name if they want.
;;
(setf (class-name class) name)
(update-class class :direct-superclasses superclasses
:direct-slots slotds
:options options)
(setf (class-named name) class)
(inform-type-system-about-class class name) ;NOT part of standard protocol
;see comment at the defmethod
;for this.
class))
;;;
;;; This is the programmatic (only) interface to updating the definition of
;;; an anonymous class.
;;;
(defmethod UPDATE-CLASS ((class class)
&rest key-arguments
&key (direct-superclasses () new-supers-p)
(direct-slots () new-slots-p)
(options () new-options-p)
&allow-other-keys)
(flet ((translate-&key-arg (name new-name new-value)
(let ((entry (memq name key-arguments)))
(if entry
(setf (car entry) new-name
(cadr entry) new-value)
(error "Can't find ~S in key-arguments?" name)))))
(let ((old-direct-superclasses (class-local-supers class))
(forward-referenced-supers ()))
(when new-supers-p
;; The supers appear to have changed (new ones were specified).
;; Go through and convert names to actual class objects. If
;; there is a name for a class that doesn't exist yet cons up
;; a forward-referenced class for that name.
(setq direct-superclasses (or (copy-list direct-superclasses) ;***
(list (class-named 'object)))) ;***
(let ((tail direct-superclasses)
(super nil))
(loop (when (null tail) (return))
(setq super (car tail))
(cond ((classp super))
((not (legal-class-name-p super))
(error "~S is not a class or a legal class name."
super))
(t
(setf (car tail)
(or (class-named super t)
(let ((fwd
(make-instance
'forward-referenced-class
:name super)))
(setf (class-named super) fwd)
(push fwd forward-referenced-supers)
fwd)))))
(pop tail)))
(setf
(class-forward-referenced-supers class) forward-referenced-supers
(class-local-supers class) direct-superclasses)
(setf (class-local-supers class) direct-superclasses)
(dolist (nds direct-superclasses)
(unless (memq nds old-direct-superclasses)
(check-super-metaclass-compatibility class nds)
(push class (class-direct-subclasses nds))))
(dolist (ods old-direct-superclasses)
(unless (memq ods direct-superclasses)
(setf (class-direct-subclasses ods)
(delq class (class-direct-subclasses ods)))))
(translate-&key-arg
:direct-superclasses :its-direct-superclasses direct-superclasses))
(when new-options-p
;; The options appear to have changed (new ones were specified).
;; Use legal-class-option-p to be sure all the new options are
;; legal.
(setf (class-options class) options)
(translate-&key-arg :options :its-options options))
(when new-slots-p
;; The slots appear to have changed (new ones were specified).
;; Use legal-slot-option-p to be sure all the slot options are
;; legal. Note that we don't check anything else about the
;; slot-descriptions, parse-class slot will have to signal an
;; error about that.
(setf (class-local-slots class) direct-slots)
(translate-&key-arg :direct-slots :its-direct-slots direct-slots))
(apply #'propagate-class-update class 't 't class key-arguments)
)))
;;;
;;;
;;;
(defvar *slotd-unsupplied* (list nil))
(defmethod PARSE-CLASS-SLOT ((class class) slot)
(let ((name nil)
(initform *slotd-unsupplied*)
(accessors ())
(readers ())
(allocation ':instance)
(type *slotd-unsupplied*)
(slotd (make-slotd class)))
(cond ((symbolp slot) (setq name slot))
((null (cdr slot)) (setq name (car slot)))
((null (cddr slot)) (setq name (car slot)
initform (cadr slot)))
(t
(setq name (car slot))
(let ((options (cdr slot))
(option nil)
(value nil))
(loop (when (null options) (return t))
(setq option (pop options)
value (pop options))
(unless (legal-slot-option-p class option)
(error "In the slot description ~S,~%~
the option ~S is not legal."
slot option))
(case option
(:initform (setq initform value))
(:accessor (push value accessors))
(:reader (push value readers))
(:allocation (setq allocation value))
(:type (setq type value)))))))
(setf (slotd-name slotd) name
(slotd-keyword slotd) (make-keyword name)
(slotd-initform slotd) initform
(slotd-accessors slotd) accessors
(slotd-readers slotd) readers
(slotd-allocation slotd) allocation
(slotd-type slotd) type)
slotd))
(defmethod MAKE-SLOTD ((class class) &rest keywords-and-options)
(declare (ignore class))
(apply #'make-instance 'standard-slotd keywords-and-options))
(defun merge-accessor/reader-prefixes (slotds class-options)
(dolist (class-option class-options)
(when (listp class-option)
(case (car class-option)
(:accessor-prefix
(dolist (slotd slotds)
(pushnew (if (cadr class-option)
(intern (string-append (cadr class-option)
(slotd-name slotd)))
(slotd-name slotd))
(slotd-accessors slotd))))
(:reader-prefix
(dolist (slotd slotds)
(pushnew (if (cadr class-option)
(intern (string-append (cadr class-option)
(slotd-name slotd)))
(slotd-name slotd))
(slotd-readers slotd))))))))
(defun check-accessor/reader-compatibility (slotds)
;; Now go off and check to be sure that this class doesn't have
;; incompatible accessors and readers, and that it doesn't define
;; the "same method" with different behavior.
(let ((entries ())
(losers ()))
(labels ((entry (gfun)
(alist-entry entries gfun (lambda (x) (list x nil nil))))
(check (gfun slot type)
(let ((entry (entry gfun)))
(ecase type
(:accessor
(when (and (cadr entry)
(not (memq slot (cadr entry))))
(pushnew entry losers))
(push slot (cadr entry)))
(:reader
(when (and (caddr entry)
(not (memq slot (caddr entry))))
(pushnew entry losers))
(push slot (caddr entry)))))))
(dolist (slotd slotds)
(let ((slot-name (slotd-name slotd)))
(dolist (accessor (slotd-accessors slotd))
(check accessor slot-name ':accessor))
(dolist (reader (slotd-readers slotd))
(check reader slot-name ':reader))))
(when losers
(complain-about-accessor/reader-incompatibility losers))))
slotds)
(defun complain-about-accessor/reader-incompatibility (losers)
(setq losers (apply #'append losers))
(error
"This class defines incompatible accessor or reader methods.~
~{~%For the generic-function ~S:~%~
accessors for the slot(s): ~:S, and readers for the slots(s): ~:S.~}"
losers))
;;;
;;; The legal-class-option-p and legal-slot-option-p generic functions
;;; use OR method combination. The method for a particular metaclass
;;; should method should return T if and only if it recognizes the option
;;; as one which it will accept responsibility for.
;;;
;;; Note that during bootstrapping, there is no OR combination so there
;;; can't really be more than one of these methods.
;;;
(defmethod LEGAL-CLASS-OPTION-P ((class class) option)
(declare (ignore class))
(memq option
'(:constructor :reader-prefix :accessor-prefix :documentation)))
(defmethod LEGAL-SLOT-OPTION-P ((class class) option)
(declare (ignore class))
(memq option '(:initform :type :accessor :reader :allocation)))
;;;
;;; MAKE-CONSTRUCTOR gets one or two arguments. The first argument is the
;;; class. For BOA constructors the second argument is the lambda list for
;;; constructor. It should RETURN the constructor, a (compiled) function
;;; object. The caller will take care of installing the constructor in the
;;; function cell of whatever symbol(s) it belongs in.
;;;
;;; Think of make-constructor as being APPLYd to the class and the CDDR of a
;;; :constructor class option. So if its a BOA constructor, it will get 2
;;; arguments, the class and the lambda list. Otherwise it will only get
;;; the class.
;;;
(defmethod MAKE-CONSTRUCTOR ((class class) &optional (lambda-list () llp))
(compile nil
(if llp
`(lambda ,lambda-list
(make-instance ,(class-constant-form class)
,@(iterate ((slot-name in lambda-list))
(unless (memq slot-name
'(&optional &rest &aux))
(collect `',(make-keyword slot-name))
(collect slot-name)))))
`(lambda (&rest initargs)
(apply #'make-instance
,(class-constant-form class)
initargs)))))
#-(or KCL GCLisp)
(defun class-constant-form (class)
(list 'quote class))
#+(or KCL GCLisp)
(let ((counter 0))
(defun class-constant-form (class)
(let ((symbol (intern (format nil "class constant form ~A" (incf counter))
(find-package 'pcl))))
(set symbol class)
`(locally (declare (special ,symbol)) ,symbol))))
;;;
;;; NOTE: For bootstrapping considerations, these can't use make-instance
;;; to make the method object. They have to use make-a-method which
;;; is a specially bootstrapped mechanism for making standard methods.
;;;
(defmethod ADD-READER-METHOD ((class class) slotd generic-function)
(let* ((name (class-name class))
(method (make-a-method 'standard-reader-method
()
(list (or name 'object))
(list class)
(make-reader-method-function class slotd)
"automatically generated reader method"
(slotd-name slotd))))
(add-method generic-function method)))
(defmethod ADD-WRITER-METHOD ((class class) slotd generic-function)
(let* ((name (class-name class))
(method (make-a-method 'standard-writer-method
()
(list (or name 'object) 'new-value)
(list class 'T)
(make-writer-method-function class slotd)
"automatically generated writer method"
(slotd-name slotd))))
(add-method generic-function method)))
(defmethod REMOVE-READER-METHOD ((class class) slotd generic-function)
(declare (ignore slotd))
(let ((method (get-method generic-function () (list class) nil)))
(when method (remove-method generic-function method))))
(defmethod REMOVE-WRITER-METHOD ((class class) slotd generic-function)
(declare (ignore slotd))
(let ((method (get-method generic-function () (list class 'T) nil)))
(when method (remove-method generic-function method))))
;;;
;;; make-reader-method-function and make-write-method function are NOT part of
;;; the standard protocol. They are however useful, PCL makes uses makes use
;;; of them internally and documents them for PCL users.
;;;
;;; NOTE: bootstrap-accessor-definitions calls the templated function
;;; constructors directly.
;;;
;;; *** This needs work to make type testing by the writer functions which
;;; *** do type testing faster. The idea would be to have one constructor
;;; *** for each possible type test. In order to do this it would be nice
;;; *** to have help from inform-type-system-about-class and friends.
;;;
(defmethod make-reader-method-function ((class class) slotd)
(declare (ignore class))
(funcall (get-templated-function-constructor 'reader-function--std-class)
(slotd-name slotd)))
(defmethod make-writer-method-function ((class class) slotd)
(declare (ignore class))
(let ((type (slotd-type slotd)))
(funcall (get-templated-function-constructor 'writer-function--std-class
(neq type 't))
(slotd-name slotd)
type)))
(define-function-template reader-function--std-class () '(slot-name)
`(function
(lambda (instance--std-class)
(slot-value--class instance--std-class slot-name))))
(define-function-template writer-function--std-class (do-type-test-p)
'(slot-name type)
(if do-type-test-p
`(function
(lambda (instance--std-class new-value)
(if (typep new-value type)
(put-slot--class instance--std-class slot-name new-value)
(error "~S is not of type ~S." new-value type))))
`(function
(lambda (instance--std-class new-value)
(put-slot--class instance--std-class slot-name new-value)))))
(eval-when (load)
(pre-make-templated-function-constructor reader-function--std-class)
(pre-make-templated-function-constructor writer-function--std-class nil)
(pre-make-templated-function-constructor writer-function--std-class t))
;;;; inform-type-system-about-class
;;;; make-type-predicate
;;;
;;; These are NOT part of the standard protocol. They are internal mechanism
;;; which PCL uses to *try* and tell the type system about class definitions.
;;; In a more fully integrated implementation of CLOS, the type system would
;;; know about class objects and class names in a more fundamental way and
;;; the mechanism used to inform the type system about new classes would be
;;; different.
;;;
;;; This is a generic function because built-in-classes need to be able to
;;; turn this off.
;;;
(defmethod inform-type-system-about-class ((class class) name)
(let ((predicate-name (make-type-predicate-name name)))
(setf (symbol-function predicate-name) (make-type-predicate class))
(do-deftype name () `'(satisfies ,predicate-name))))
(defmethod make-type-predicate ((class class))
(funcall (get-templated-function-constructor 'type-predicate--std-class)
class))
(define-function-template type-predicate--std-class () '(class)
'(function (lambda (x)
(and (iwmc-class-p x)
(memq class
(class-precedence-list
(class-of--class x)))))))
(eval-when (load)
(pre-make-templated-function-constructor type-predicate--std-class))