home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part04 / class-slots.l next >
Encoding:
Text File  |  1987-07-30  |  14.0 KB  |  336 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26.  
  27. (in-package 'pcl)
  28.  
  29.   ;;   
  30. ;;;;;; Slot access for the class class.
  31.   ;;   get-slot-using-class and friends
  32. ;;; At last the meta-braid is up.  The method class-instance-slots exists and there
  33. ;;; is peace in the land.  Now we can finish get-slot, put-slot and friends.
  34.  
  35. (defmacro get-slot-using-class--class (class object slot-name
  36.                                        dont-call-slot-missing-p default)
  37.   (once-only (slot-name)
  38.     `(let* ((.wrapper.
  39.           (iwmc-class-class-wrapper ,object))
  40.             (.get-slot-offset.
  41.           (class-wrapper-get-slot-offset .wrapper. ,slot-name)))
  42.        (if (eq (class-wrapper-cached-key .wrapper. .get-slot-offset.)
  43.            ,slot-name)
  44.            (get-static-slot--class
  45.              ,object (class-wrapper-cached-val .wrapper. .get-slot-offset.))
  46.            (get-slot-using-class--class-internal
  47.              ,class ,object ,slot-name ,dont-call-slot-missing-p ,default)))))
  48.  
  49.  
  50. (defmacro put-slot-using-class--class (class object slot-name new-value
  51.                                        dont-call-slot-missing-p)
  52.   (once-only (slot-name)
  53.     `(let* ((.wrapper. (iwmc-class-class-wrapper ,object))
  54.             (.get-slot-offset. (class-wrapper-get-slot-offset .wrapper. ,slot-name)))
  55.        (if (eq (class-wrapper-cached-key .wrapper. .get-slot-offset.) ,slot-name)
  56.            (setf (get-static-slot--class
  57.                    ,object (class-wrapper-cached-val .wrapper. .get-slot-offset.))
  58.                  ,new-value)
  59.             (put-slot-using-class--class-internal
  60.               ,class ,object ,slot-name ,new-value ,dont-call-slot-missing-p)))))
  61.  
  62. (defmacro get-slot--class (object slot-name)
  63.   (once-only (object)
  64.     `(get-slot-using-class--class
  65.        (class-of--class ,object) ,object ,slot-name () ())))
  66.  
  67. (defmacro put-slot--class (object slot-name new-value)
  68.   (once-only (object)
  69.     `(put-slot-using-class--class
  70.        (class-of--class ,object) ,object ,slot-name ,new-value ())))
  71.  
  72. (defmeth get-slot-using-class ((class basic-class) object slot-name
  73.                    &optional dont-call-slot-missing-p default)
  74.   (get-slot-using-class--class
  75.     class object slot-name dont-call-slot-missing-p default))
  76.  
  77. (defmeth put-slot-using-class ((class basic-class) object slot-name new-value
  78.                    &optional dont-call-slot-missing-p)
  79.   (put-slot-using-class--class
  80.     class object slot-name new-value dont-call-slot-missing-p))
  81.  
  82. (defmeth remove-dynamic-slot-using-class ((class basic-class)
  83.                       object slot-name)
  84.   (ignore class)
  85.   (remove-dynamic-slot--class object slot-name))
  86.  
  87. ;;;
  88. ;;; with-slot-internal--class is macro which makes code which accesses the
  89. ;;; slots of instances with meta-class class more readable.  The macro itself
  90. ;;; is kind of dense though.  In the following call:
  91. ;;;   (WITH-SLOT-INTERNAL--CLASS (CLASS OBJECT SLOT-NAME T)
  92. ;;;     (:INSTANCE (INDEX) . instance-case-code)
  93. ;;;     (:DYNAMIC (LOC NEWP) . dynamic-case-code)
  94. ;;;     (:CLASS (SLOTD) . class-case-code)
  95. ;;;     (NIL () . nil-case-code))
  96. ;;; If the slot is found and has allocation:
  97. ;;;   :instance   instance-case-code is evaluated with INDEX bound to the
  98. ;;;               index of the slot.
  99. ;;;   :dynamic    dynamic-case-code is evaluated with LOC bound to the cons
  100. ;;;               whose car holds the value of this dynamic slot, and NEWP
  101. ;;;               bound to t if the slot was just created and nil otherwise.
  102. ;;;   :class      class-case-code is evaluated with slotd bound to the slotd
  103. ;;;               of the slot.
  104. ;;; If the slot is not found.
  105. ;;;   If createp is t it is created and things proceed as in the allocation
  106. ;;;   :dynamic case.
  107. ;;; Otherwise, and if the allocation is nil the nil-case code is evaluated.
  108. ;;;               
  109. (defmacro with-slot-internal--class ((class object slot-name createp)
  110.                      &body cases)
  111.   (let ((temp1 (gensym))
  112.         (temp2 (gensym))
  113.         (createp-var (gensym))
  114.         (instance-case (cdr (assq :instance cases)))
  115.         (dynamic-case (cdr (assq :dynamic cases)))
  116.         (class-case (cdr (assq :class cases)))
  117.         (nil-case (cdr (assq nil cases))))
  118.     `(prog (,temp1                              ;The Horror! Its a PROG,
  119.             ,temp2                              ;but its in a macro so..
  120.             (,createp-var ,createp))
  121.          (cond
  122.            ((setq ,temp1 (slotd-position ,slot-name
  123.                      (class-instance-slots ,class)))
  124.             ;; We have the slots position in the instance slots.  Convert
  125.         ;; that to the slots index and then cache the index and return
  126.         ;; the result of evaluating the instance-case.
  127.             (setq ,temp1 (%convert-slotd-position-to-slot-index ,temp1))
  128.             (let ((wrapper (validate-class-wrapper ,object)))
  129.               (class-wrapper-cache-cache-entry
  130.                 wrapper
  131.                 (class-wrapper-get-slot-offset wrapper ,slot-name)
  132.                 ,slot-name
  133.                 ,temp1))
  134.             (return (let ,(and (car instance-case)
  135.                    `((,(caar instance-case) ,temp1)))
  136.                       . ,(cdr instance-case))))
  137.            ((setq ,temp1 (slotd-assoc ,slot-name
  138.                       (class-non-instance-slots ,class)))
  139.             ;; We have a slotd -- this is some sort of declared slot.
  140.             (ecase (slotd-allocation ,temp1)
  141.               (:class      (return
  142.                              (let ,(and (car class-case)
  143.                                         `((,(caar class-case) ,temp1)))
  144.                                . ,(cdr class-case))))
  145.               ((:none nil) (go nil-case))
  146.               (:dynamic    (setq ,createp-var :dynamic
  147.                                  ,temp2       (slotd-default ,temp1))))))
  148.          ;; When we get here, either:
  149.          ;;  - we didn't find a slot-description for this slot, so try to
  150.          ;;    find it in the dynamic slots creating it if createp-var is
  151.          ;;    non-null.
  152.          ;;  - we found a :dynamic slot-description, createp-var got set
  153.          ;;    to :dynamic and we dropped through to here where we try
  154.          ;;    to find the slot.  If we find it we return the loc.  If
  155.          ;;    not we create it and initialize it to its default value.
  156.          (multiple-value-setq (,temp1 ,createp-var)
  157.            (dynamic-slot-loc--class ,object ,slot-name ,createp-var))
  158.          (when ,temp1
  159.            (when (and ,createp-var ,temp2)
  160.              (setf (car ,temp1) (eval ,temp2)))
  161.            (let
  162.              (,@(and (caar dynamic-case) `((,(caar dynamic-case) ,temp1)))
  163.               ,@(and (cadar dynamic-case) `((,(cadar dynamic-case)
  164.                          ,createp-var))))
  165.              (return . ,(cdr dynamic-case))))
  166.       nil-case
  167.          ;; This slot is either explicitly declared :allocation nil (we
  168.          ;; jumped here by (GO NIL-CASE) or there is no declaration for
  169.          ;; this slot and we didn't find it in the dynamic-slots, we fell
  170.          ;; through from the dynamic lookup above.
  171.          (let ,(and (car nil-case) `((,(caar nil-case) ,temp1)))
  172.            . ,(cdr nil-case)))))
  173.  
  174. (defun dynamic-slot-loc--class (object slot-name createp)
  175.   (let ((plist (iwmc-class-dynamic-slots object)))
  176.     (or (iterate ((prop on plist by cddr))
  177.           (when (eq (car prop) slot-name) (return (cdr prop))))
  178.         (and createp
  179.              (values (cdr (setf (iwmc-class-dynamic-slots object)
  180.                                 (list* slot-name () plist)))
  181.                      createp)))))
  182.  
  183. (defun get-slot-using-class--class-internal (class object slot-name
  184.                                                    dont-call-slot-missing-p
  185.                            default)
  186.   (with-slot-internal--class (class object slot-name nil)
  187.     (:instance (index) (get-static-slot--class object index))
  188.     (:dynamic (loc newp) (if (eq newp t) (setf (car loc) default) (car loc)))
  189.     (:class (slotd) (slotd-default slotd))
  190.     (nil () (unless dont-call-slot-missing-p
  191.           (slot-missing object slot-name)))))
  192.  
  193. (defun put-slot-using-class--class-internal (class object slot-name new-value
  194.                                                    dont-call-slot-missing-p)
  195.   (with-slot-internal--class
  196.       (class object slot-name dont-call-slot-missing-p)
  197.     (:instance (index) (setf (get-static-slot--class object index)
  198.                  new-value))
  199.     (:dynamic (loc) (setf (car loc) new-value))
  200.     (:class (slotd) (setf (slotd-default slotd) new-value))
  201.     (nil () (unless dont-call-slot-missing-p
  202.           (slot-missing object slot-name)))))
  203.  
  204. (defun all-slots (object)
  205.   (all-slots-using-class (class-of object) object))
  206.  
  207. (defmeth all-slots-using-class ((class basic-class) object)
  208.   (append (iterate ((slotd in (class-instance-slots class)))
  209.             (collect (slotd-name slotd))
  210.             (collect (get-slot--class object (slotd-name slotd))))
  211.           (iwmc-class-dynamic-slots object)))
  212.  
  213. (defmeth remove-dynamic-slot-using-class ((class basic-class) object
  214.                                   slot-name)
  215.   (ignore class)
  216.   (remove-dynamic-slot--class object slot-name))
  217.  
  218. (defun slot-allocation (object slot-name)
  219.   (slot-allocation-using-class (class-of object) object slot-name))
  220.  
  221. (defmeth slot-allocation-using-class ((class basic-class) object slot-name)
  222.   (with-slot-internal--class (class object slot-name nil)
  223.     (:instance () :instance)
  224.     (:dynamic () :dynamic)
  225.     (:class () :class)
  226.     (nil    () nil)))
  227.  
  228. (defun slot-exists-p (object slot-name)
  229.   (let* ((flag "")
  230.          (val
  231.        (get-slot-using-class (class-of object) object slot-name t flag)))
  232.     (neq val flag)))
  233.  
  234. (defmeth slot-missing (object slot-name)
  235.   (error "The slot: ~S is missing from the object: ~S" slot-name object))
  236.  
  237. (defmacro typep--class (iwmc-class type)
  238.   `(not (null (memq (class-named ,type ())
  239.                     (class-class-precedence-list 
  240.                       (class-wrapper-class
  241.                         (iwmc-class-class-wrapper ,iwmc-class)))))))
  242.  
  243. (defmacro type-of--class (iwmc-class)
  244.   `(class-name
  245.      (class-wrapper-wrapped-class (iwmc-class-class-wrapper ,iwmc-class))))
  246.  
  247. (defun subclassp (class1 class2)
  248.   (or (classp class1) (setq class1 (class-named class1)))
  249.   (or (classp class2) (setq class2 (class-named class2)))
  250.   (memq class2 (class-class-precedence-list class1)))
  251.  
  252. (defun sub-class-p (x class)
  253.   (if (symbolp class) (setq class (class-named class)))
  254.   (not (null (memq class (class-class-precedence-list (class-of x))))))
  255.  
  256.  
  257. (defmeth class-has-instances-p ((class basic-class))
  258.   (class-wrapper class))
  259.  
  260. (defmeth make-instance ((class basic-class))
  261.   (let ((class-wrapper (class-wrapper class)))
  262.     (if class-wrapper                           ;Are there any instances?
  263.         ;; If there are instances, the class is OK, just go ahead and
  264.         ;; make the instance.
  265.         (let ((instance (%allocate-instance--class
  266.                           (class-no-of-instance-slots class))))
  267.           (setf (iwmc-class-class-wrapper instance) class-wrapper)
  268.           instance)
  269.         ;; Do first make-instance-time error-checking, build the class
  270.         ;; wrapper and call ourselves again to really build the instance.
  271.         (progn
  272.           ;; no first time error checking yet.
  273.           (setf (class-wrapper class) (make-class-wrapper class))
  274.           (make-instance class)))))
  275.  
  276. (defun make (class &rest init-plist)
  277.   (when (symbolp class) (setq class (class-named class)))
  278.   (let ((object (make-instance class)))
  279.     (initialize object init-plist)
  280.     object))
  281.  
  282. (defmeth initialize ((object object) init-plist)
  283.   (initialize-from-defaults object)
  284.   (initialize-from-init-plist object init-plist))
  285.  
  286. (defmeth initialize-from-defaults ((self object))
  287.   (iterate ((slotd in (class-instance-slots (class-of self))))
  288.     (setf (get-slot self (slotd-name slotd)) (eval (slotd-default slotd)))))
  289.  
  290. (defmeth initialize-from-init-plist ((self object) init-plist)
  291.   (when init-plist
  292.     (let* ((class (class-of self))
  293.        (instance-slots (class-instance-slots class))
  294.        (non-instance-slots (class-non-instance-slots class)))
  295.       (flet ((find-slotd (keyword)
  296.            (flet ((find-internal (slotds)
  297.             (dolist (slotd slotds)
  298.               (when (eq (slotd-keyword slotd) keyword)
  299.                 (return slotd)))))
  300.          (or (find-internal instance-slots)
  301.              (find-internal non-instance-slots)))))
  302.     (do* ((keyword-loc init-plist (cdr value-loc))
  303.           (value-loc (cdr keyword-loc) (cdr keyword-loc))
  304.           (slotd () ())
  305.           (allow-other-keys-p () allow-other-keys-p))
  306.          (())
  307.       (flet ((allow-other-keywords-p ()
  308.            (when (null allow-other-keys-p)
  309.              (setq allow-other-keys-p
  310.                (do ((loc keyword-loc (cddr loc)))
  311.                    ((null loc) 0)
  312.                  (when (eq (car loc) ':allow-other-keys)
  313.                    (if (cadr loc) 1 0)))))
  314.            (if (= allow-other-keys-p 1) t nil)))
  315.         (cond ((null keyword-loc) (return nil))
  316.           ((eq (car keyword-loc) :allow-other-keys)
  317.            (setq allow-other-keys-p
  318.              (if (cadr keyword-loc) 1 0)))
  319.           ((null value-loc)
  320.            (error "No value supplied for the init-keyword ~S."
  321.               (car keyword-loc)))
  322.           ((null (setq slotd (find-slotd (car keyword-loc))))
  323.            (unless (allow-other-keywords-p)
  324.              (error "~S is not a valid keyword in the init-plist."
  325.                 (car keyword-loc))))
  326.           (t
  327.            (setf (get-slot self (slotd-name slotd))
  328.              (car value-loc))))))))))
  329.  
  330.  
  331.  
  332. (defmeth class-default-includes ((class basic-class))
  333.   (ignore class)
  334.   (list 'object))
  335.  
  336.