;;;-*-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)
#|
general renaming, get some kind of convention here,
change to using slot value
note class --> standard-class (std-class)
get-slot --> slot-value
let fsc-class be built on the abstraction of std-class, thats OK.
It doesn't matter that a lot of the --std-class things take optional
args just for fsc-class, those are all internal macros nobody is going
to see them
fsc has to pass in wrapper and static slots accessors
flush all dynamic stuff, dont-call-slot-missing-p default etc etc.
maybe pass fn-to-call-when-slot-missing in as an argument or something.
get rid of first arg to class-wrapper-slot-value-offset
work out args to optimize-slot-value and friends.
|#
;;;
;;; Slotd-position is used to find the position of a slot with a particular
;;; name in a list of slotds. Specifically it is used in the case of a
;;; slot-value cache miss to find this slot index. That means it is used in
;;; about 2% of the total slot accesses so it should be fast.
;;;
(defmacro slotd-position (slotd-name slotds)
`(let ((slotd-name ,slotd-name))
(do ((pos 0 (+ pos 1))
(slotds ,slotds (cdr slotds)))
((null slotds) nil)
(declare (type integer pos) (type list slotds))
(and (eq slotd-name (slotd-name (car slotds)))
(return pos)))))
(defmacro find-slotd (slotd-name slotds)
(once-only (slotd-name)
(let ((slotd-var (gensym)))
`(dolist (,slotd-var ,slotds)
(when (eq (slotd-name ,slotd-var) ,slotd-name)
(return ,slotd-var))))))
;(defmacro slotd-member (slotd-name slotds)
; `(member ,slotd-name ,slotds :test #'eq :key #'slotd-name))
;
;(defmacro slotd-assoc (slotd-name slotds)
; (once-only (slotd-name)
; (let ((var (gensym)))
; `(dolist (,slotd-var ,slotds)
; (when (eq (slotd-name ,slotd-var) ,slotd-name)
; (return ,slotd-var))))))
(defmethod copy-slotd ((slotd standard-slotd))
(make-instance 'standard-slotd
:name (slotd-name slotd)
:keyword (slotd-keyword slotd)
:initform (slotd-initform slotd)
:accessors (slotd-accessors slotd)
:readers (slotd-readers slotd)
:allocation (slotd-allocation slotd)
:type (slotd-type slotd)))
;;
;;;;;; Medium-level support for the class CLASS.
;;
;;; The low-level macros are defined by the file portable-low (or a special
;;; version) of that file if there is one for this implementation. This is
;;; the lowest-level completely portable code which operates on instances
;;; with meta-class class.
(defmacro get-static-slot--class (iwmc-class slot-index)
`(%static-slot-storage-slot-value--class
(iwmc-class-static-slots ,iwmc-class)
,slot-index))
(defmacro get-dynamic-slot--class (iwmc-class slot-name default)
`(%dynamic-slot-storage-slot-value--class
(iwmc-class-dynamic-slots ,iwmc-class)
,slot-name
,default))
(defmacro remove-dynamic-slot--class (iwmc-class slot-name)
`(%dynamic-slot-storage-remove-slot--class
(iwmc-class-dynamic-slots ,iwmc-class)
,slot-name))
;;
;;;;;; Slot access for the class class.
;; slot-value-using-class and friends
;;; At last the meta-braid is up. The method class-instance-slots exists and there
;;; is peace in the land. Now we can finish slot-value, put-slot and friends.
;(defmacro get-slot-using-class--class (&rest args)
; `(slot-value-using-class--std-class ,@args))
;
;(defmacro put-slot-using-class--class (&rest args)
; `(set-slot-value-using-class--std-clas ,@args))
;;;; SLOT-VALUE and PUT-SLOT
;;;
;;;
(defun slot-value (object slot-name)
(slot-value-using-class (class-of object) object slot-name))
(defun put-slot (object slot-name new-value)
(put-slot-using-class (class-of object) object slot-name new-value))
(defun set-slot-value (object slot-name new-value)
(put-slot-using-class (class-of object) object slot-name new-value))
(defun slot-value-always (object slot-name &optional default)
(slot-value-using-class (class-of object) object slot-name t default))
(defun put-slot-always (object slot-name new-value)
(put-slot-using-class (class-of object) object slot-name new-value t))
(defun remove-dynamic-slot (object slot-name)
(remove-dynamic-slot-using-class (class-of object) object slot-name))
(defmacro slot-value-using-class--class (class object slot-name
dont-call-slot-missing-p default)
(once-only (slot-name)
`(let* ((.wrapper.
(iwmc-class-class-wrapper ,object))
(.slot-value-offset.
(class-wrapper-slot-value-offset .wrapper. ,slot-name)))
(if (eq (class-wrapper-cached-key .wrapper. .slot-value-offset.)
,slot-name)
(get-static-slot--class
,object (class-wrapper-cached-val .wrapper. .slot-value-offset.))
(slot-value-using-class--class-internal
,class ,object ,slot-name ,dont-call-slot-missing-p ,default)))))
(defmacro put-slot-using-class--class (class object slot-name new-value
dont-call-slot-missing-p)
(once-only (slot-name)
`(let* ((.wrapper. (iwmc-class-class-wrapper ,object))
(.slot-value-offset. (class-wrapper-slot-value-offset .wrapper. ,slot-name)))
(if (eq (class-wrapper-cached-key .wrapper. .slot-value-offset.) ,slot-name)
(setf (get-static-slot--class
,object (class-wrapper-cached-val .wrapper. .slot-value-offset.))
,new-value)
(put-slot-using-class--class-internal
,class ,object ,slot-name ,new-value ,dont-call-slot-missing-p)))))
(defmacro slot-value--class (object slot-name)
(once-only (object)
`(slot-value-using-class--class
(class-of--class ,object) ,object ,slot-name () ())))
(defmacro put-slot--class (object slot-name new-value)
(once-only (object)
`(put-slot-using-class--class
(class-of--class ,object) ,object ,slot-name ,new-value ())))
(defmethod slot-value-using-class ((class basic-class) object slot-name
&optional dont-call-slot-missing-p default)
(slot-value-using-class--class
class object slot-name dont-call-slot-missing-p default))
(defmethod put-slot-using-class ((class basic-class) object slot-name new-value
&optional dont-call-slot-missing-p)
(put-slot-using-class--class
class object slot-name new-value dont-call-slot-missing-p))
(defmethod remove-dynamic-slot-using-class ((class basic-class)
object slot-name)
(declare (ignore class))
(remove-dynamic-slot--class object slot-name))
;;;
;;; with-slot-internal--class is macro which makes code which accesses the
;;; slots of instances with meta-class class more readable. The macro itself
;;; is kind of dense though. In the following call:
;;; (WITH-SLOT-INTERNAL--CLASS (CLASS OBJECT SLOT-NAME T)
;;; (:INSTANCE (INDEX) . instance-case-code)
;;; (:DYNAMIC (LOC NEWP) . dynamic-case-code)
;;; (:CLASS (SLOTD) . class-case-code)
;;; (NIL () . nil-case-code))
;;; If the slot is found and has allocation:
;;; :instance instance-case-code is evaluated with INDEX bound to the
;;; index of the slot.
;;; :dynamic dynamic-case-code is evaluated with LOC bound to the cons
;;; whose car holds the value of this dynamic slot, and NEWP
;;; bound to t if the slot was just created and nil otherwise.
;;; :class class-case-code is evaluated with slotd bound to the slotd
;;; of the slot.
;;; If the slot is not found.
;;; If createp is t it is created and things proceed as in the allocation
;;; :dynamic case.
;;; Otherwise, and if the allocation is nil the nil-case code is evaluated.
;;;
(defmacro with-slot-internal--class ((class object slot-name createp)
&body cases)
(let ((temp1 (gensym))
(temp2 (gensym))
(createp-var (gensym))
(instance-case (cdr (assq :instance cases)))
(dynamic-case (cdr (assq :dynamic cases)))
(class-case (cdr (assq :class cases)))
(nil-case (cdr (assq nil cases))))
`(prog (,temp1 ;The Horror! Its a PROG,
,temp2 ;but its in a macro so..
(,createp-var ,createp))
(cond
((setq ,temp1 (slotd-position ,slot-name
(class-instance-slots ,class)))
;; We have the slots position in the instance slots. Convert
;; that to the slots index and then cache the index and return
;; the result of evaluating the instance-case.
(setq ,temp1 (%convert-slotd-position-to-slot-index ,temp1))
(let ((wrapper (validate-class-wrapper ,object)))
(class-wrapper-cache-cache-entry
wrapper
(class-wrapper-slot-value-offset wrapper ,slot-name)
,slot-name
,temp1))
(return (let ,(and (car instance-case)
`((,(caar instance-case) ,temp1)))
. ,(cdr instance-case))))
((setq ,temp1 (find-slotd ,slot-name
(class-non-instance-slots ,class)))
;; We have a slotd -- this is some sort of declared slot.
(ecase (slotd-allocation ,temp1)
(:class (return
(let ,(and (car class-case)
`((,(caar class-case) ,temp1)))
. ,(cdr class-case))))
((:none nil) (go nil-case))
(:dynamic (setq ,createp-var :dynamic
,temp2 (slotd-initform ,temp1))))))
;; When we get here, either:
;; - we didn't find a slot-description for this slot, so try to
;; find it in the dynamic slots creating it if createp-var is
;; non-null.
;; - we found a :dynamic slot-description, createp-var got set
;; to :dynamic and we dropped through to here where we try
;; to find the slot. If we find it we return the loc. If
;; not we create it and initialize it to its default value.
(multiple-value-setq (,temp1 ,createp-var)
(dynamic-slot-loc--class ,object ,slot-name ,createp-var))
(when ,temp1
(when (and ,createp-var ,temp2)
(setf (car ,temp1) (eval ,temp2)))
(let
(,@(and (caar dynamic-case) `((,(caar dynamic-case) ,temp1)))
,@(and (cadar dynamic-case) `((,(cadar dynamic-case)
,createp-var))))
(return . ,(cdr dynamic-case))))
nil-case
;; This slot is either explicitly declared :allocation nil (we
;; jumped here by (GO NIL-CASE) or there is no declaration for
;; this slot and we didn't find it in the dynamic-slots, we fell
;; through from the dynamic lookup above.
(let ,(and (car nil-case) `((,(caar nil-case) ,temp1)))
. ,(cdr nil-case)))))
(defmacro dynamic-slot-loc--class (object slot-name createp)
(once-only (object)
`(let ((plist (iwmc-class-dynamic-slots ,object)))
(or (iterate ((prop on plist by cddr))
(when (eq (car prop) ,slot-name) (return (cdr prop))))
(and ,createp
(values (cdr (setf (iwmc-class-dynamic-slots ,object)
(list* ,slot-name () plist)))
,createp))))))
(defun slot-value-using-class--class-internal (class object slot-name
dont-call-slot-missing-p
default)
(with-slot-internal--class (class object slot-name nil)
(:instance (index) (get-static-slot--class object index))
(:dynamic (loc newp) (if (eq newp t) (setf (car loc) default) (car loc)))
(:class (slotd) (slotd-initform slotd))
(nil () (unless dont-call-slot-missing-p
(slot-missing object slot-name)))))
(defun put-slot-using-class--class-internal (class object slot-name new-value
dont-call-slot-missing-p)
(with-slot-internal--class
(class object slot-name dont-call-slot-missing-p)
(:instance (index) (setf (get-static-slot--class object index)
new-value))
(:dynamic (loc) (setf (car loc) new-value))
(:class (slotd) (setf (slotd-initform slotd) new-value))
(nil () (unless dont-call-slot-missing-p
(slot-missing object slot-name)))))
(defun all-slots (object)
(all-slots-using-class (class-of object) object))
(defmethod all-slots-using-class ((class basic-class) object)
(append (iterate ((slotd in (class-instance-slots class)))
(collect (slotd-name slotd))
(collect (slot-value object (slotd-name slotd))))
(iwmc-class-dynamic-slots object)))
(defmethod remove-dynamic-slot-using-class ((class basic-class) object
slot-name)
(declare (ignore class))
(remove-dynamic-slot--class object slot-name))
(defun slot-allocation (object slot-name)
(slot-allocation-using-class (class-of object) object slot-name))
(defmethod slot-allocation-using-class ((class basic-class) object slot-name)
(with-slot-internal--class (class object slot-name nil)
(:instance () :instance)
(:dynamic () :dynamic)
(:class () :class)
(nil () nil)))
(defun slot-exists-p (object slot-name)
(let* ((flag "")
(val
(slot-value-using-class (class-of object) object slot-name t flag)))
(neq val flag)))
(defmethod slot-missing (object slot-name)
(error "The slot: ~S is missing from the object: ~S" slot-name object))
(defmethod slots-with-allocation ((class basic-class) slotds allocation)
(declare (ignore class))
(iterate ((slotd in slotds))
(when (eq (slotd-allocation slotd) allocation)
(collect slotd))))
(defmethod slots-with-allocation-not ((class basic-class) slotds allocation)
(declare (ignore class))
(iterate ((slotd in slotds))
(unless (eq (slotd-allocation slotd) allocation)
(collect slotd))))
;;;
;;; Take two lists of slotds and return t if they describe an set of slots of
;;; the same shape. Otherwise return nil. Sets of slots are have the same
;;; same shape if they have they both have the same :allocation :instance
;;; slots and if those slots appear in the same order.
;;;
(defun same-shape-slots-p (old-slotds new-slotds)
(do ()
((and (null old-slotds) (null new-slotds)) t)
(let* ((old (pop old-slotds))
(new (pop new-slotds))
(old-allocation (and old (slotd-allocation old)))
(new-allocation (and new (slotd-allocation new))))
;; For the old and new slotd check all the possible reasons
;; why they might not match.
;; - One or the other is null means that a slot either
;; disappeared or got added.
;; - The names are different means that a slot moved
;; disappared or go added.
;; - If the allocations are different, and one of them
;; is :instance then a slot either became or ceased
;; to be :allocation :instance.
(when (or (null old)
(null new)
(neq (slotd-name old) (slotd-name new))
(and (neq old-allocation new-allocation)
(or (eq old-allocation :instance)
(eq new-allocation :instance))))
(return nil)))))
;;
;;;;;; Optimizing SLOT-VALUE
;;
(defmethod optimize-slot-value ((class basic-class)
form)
(declare (ignore class))
(cons 'slot-value--class (cdr form)))
(defmethod optimize-setf-of-slot-value ((class basic-class)
form)
(declare (ignore class))
(cons 'put-slot--class (cdr form)))
(defmacro typep--class (iwmc-class type)
`(not (null (memq (class-named ,type ())
(class-class-precedence-list
(class-wrapper-class
(iwmc-class-class-wrapper ,iwmc-class)))))))
(defmacro type-of--class (iwmc-class)
`(class-name
(class-wrapper-wrapped-class (iwmc-class-class-wrapper ,iwmc-class))))
(defun subclassp (class1 class2)
(or (classp class1) (setq class1 (class-named class1)))
(or (classp class2) (setq class2 (class-named class2)))
(memq class2 (class-class-precedence-list class1)))
(defun sub-class-p (x class)
(if (symbolp class) (setq class (class-named class)))
(not (null (memq class (class-precedence-list (class-of x))))))
(defmethod class-has-instances-p ((class basic-class))
(class-wrapper class))
(defmethod allocate-instance ((class basic-class))
(let ((class-wrapper (class-wrapper class)))
(if class-wrapper ;Are there any instances?
;; If there are instances, the class is OK, just go ahead and
;; make the instance.
(let ((instance (%allocate-instance--class
(class-no-of-instance-slots class))))
(setf (iwmc-class-class-wrapper instance) class-wrapper)
instance)
;; Do first allocate-instance-time error-checking, build the class
;; wrapper and call ourselves again to really build the instance.
(progn
;; no first time error checking yet.
(setf (class-wrapper class) (make-class-wrapper class))
(allocate-instance class)))))
(defun make-instance (class &rest init-plist)
(when (symbolp class) (setq class (class-named class)))
(let ((object (allocate-instance class)))
(initialize object init-plist)
object))
(defmethod initialize ((object object) init-plist)
(initialize-from-defaults object)
(initialize-from-init-plist object init-plist))
(defmethod initialize-from-defaults ((self object))
(iterate ((slotd in (class-instance-slots (class-of self))))
(let ((name (slotd-name slotd))
(value (eval (slotd-initform slotd))))
(setf (slot-value self name) value))))
(defmethod initialize-from-init-plist ((self object) init-plist)
(when init-plist
(let* ((class (class-of self))
(instance-slots (class-instance-slots class))
(non-instance-slots (class-non-instance-slots class)))
(flet ((get-slotd (keyword)
(flet ((find-internal (slotds)
(dolist (slotd slotds)
(when (eq (slotd-keyword slotd) keyword)
(return slotd)))))
(or (find-internal instance-slots)
(find-internal non-instance-slots)))))
(do* ((keyword-loc init-plist (cdr value-loc))
(value-loc (cdr keyword-loc) (cdr keyword-loc))
(slotd () ())
(allow-other-keys-p () allow-other-keys-p))
(())
(flet ((allow-other-keywords-p ()
(when (null allow-other-keys-p)
(setq allow-other-keys-p
(do ((loc keyword-loc (cddr loc)))
((null loc) 0)
(when (eq (car loc) ':allow-other-keys)
(return (if (cadr loc) 1 0))))))
(if (= allow-other-keys-p 1) t nil)))
(cond ((null keyword-loc) (return nil))
((eq (car keyword-loc) :allow-other-keys)
(setq allow-other-keys-p
(if (cadr keyword-loc) 1 0)))
((null value-loc)
(error "No value supplied for the init-keyword ~S."
(car keyword-loc)))
((null (setq slotd (get-slotd (car keyword-loc))))
(unless (allow-other-keywords-p)
(error "~S is not a valid keyword in the init-plist."
(car keyword-loc))))
(t
(setf (slot-value self (slotd-name slotd))
(car value-loc))))))))))
;(defmethod class-default-includes ((class basic-class))
; (declare (ignore class))
; (list (class-named 'object)))