home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part03 / co-meta.l next >
Encoding:
Text File  |  1987-07-30  |  11.7 KB  |  419 lines
  1.  
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         co-meta.l
  5. ; RCS:          $Revision: 1.1 $
  6. ; SCCS:         %A% %G% %U%
  7. ; Description:  Metaclass for CommonObjects
  8. ; Author:       James Kempf
  9. ; Created:      March 10, 1987
  10. ; Modified:     March 10, 1987  13:30:58 (Roy D'Souza)
  11. ; Language:     Lisp
  12. ; Package:      COMMON-OBJECTS
  13. ; Status:       Distribution
  14. ;
  15. ; (c) Copyright 1987, HP Labs, all rights reserved.
  16. ;
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;
  19. ; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
  20. ;
  21. ; Use and copying of this software and preparation of derivative works based
  22. ; upon this software are permitted.  Any distribution of this software or
  23. ; derivative works must comply with all applicable United States export
  24. ; control laws.
  25. ; 
  26. ; This software is made available AS IS, and Hewlett-Packard Corporation makes
  27. ; no warranty about the software, its performance or its conformity to any
  28. ; specification.
  29. ;
  30. ; Suggestions, comments and requests for improvement may be mailed to
  31. ; aiws@hplabs.HP.COM
  32.  
  33. ;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
  34. ;;;
  35. ;;; *************************************************************************
  36. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  37. ;;;
  38. ;;; Use and copying of this software and preparation of derivative works
  39. ;;; based upon this software are permitted.  Any distribution of this
  40. ;;; software or derivative works must comply with all applicable United
  41. ;;; States export control laws.
  42. ;;; 
  43. ;;; This software is made available AS IS, and Xerox Corporation makes no
  44. ;;; warranty about the software, its performance or its conformity to any
  45. ;;; specification.
  46. ;;; 
  47. ;;; Any person obtaining a copy of this software is requested to send their
  48. ;;; name and post office or electronic mail address to:
  49. ;;;   CommonLoops Coordinator
  50. ;;;   Xerox Artifical Intelligence Systems
  51. ;;;   2400 Hanover St.
  52. ;;;   Palo Alto, CA 94303
  53. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  54. ;;;
  55. ;;; Suggestions, comments and requests for improvements are also welcome.
  56. ;;; *************************************************************************
  57.  
  58. (in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
  59.  
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61. ; 
  62. ;    CommonObjects Class Ndefstruct
  63. ;
  64. ;  Instances are represented as trees of their parent instances just like
  65. ;  in the original CommonObjects implementation except that we do not make
  66. ;  make the single inheritance optimization of in-lining the first parent.
  67. ;  The first slot of every instance is the class object.
  68. ;  The second slot of every instance is named .SELF. and is a pointer to
  69. ;  the acutal object. Then come slots for each of the parent class instances,
  70. ;  then the slots for this class.
  71. ;
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73.  
  74. (ndefstruct (common-objects-class
  75.           (:class class)
  76.           (:include (essential-class))    
  77.           (:conc-name class-)
  78.             )
  79.  
  80.   (instance-size 1)             ;The total number of slots every instance
  81.                 ;of this class must have.  This includes
  82.                 ;one slot for the pointer to outer self and
  83.                 ;one slot for each of the parent instances.
  84.  
  85.   (local-super-slot-names ())   ;A list of the names of the slots used to
  86.                 ;store the parent instances.  This list
  87.                 ;exactly parallels the local-supers as
  88.                 ;stored in class-local-supers.
  89.  
  90.   (slots ())            ;The slots required by CommonLoops.
  91.  
  92.   (user-visible-slots ())    ;Instance variable names.
  93.  
  94.   (children ())            ;Children of this guy. Not currently used.
  95.  
  96.   (init-keywords                ;Initialization keywords
  97.     () 
  98.   )        
  99.   (init-keywords-check T)       ;Whether to check the initialization 
  100.                 ;keywords
  101. ) ;end ndefstruct for common-objects-class
  102.  
  103. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  104. ;  Establishment of the CommonObjects MetaClass
  105. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  106. (eval-when (load)
  107.  (define-meta-class common-objects-class 
  108.    (lambda (x) (%instance-ref x $CLASS-OBJECT-INDEX))
  109. ))
  110.  
  111. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  112. ;  CommonObjects MetaClass Protocol  
  113. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  114.  
  115. ;;add-class-Add a CommonObjects class. Part of the metaclass protocol.
  116.  
  117. (defmeth add-class ((class common-objects-class)
  118.             new-local-supers
  119.             new-local-slots
  120.             extra
  121.                    )
  122.  
  123.   (let 
  124.     ( 
  125.       (local-super-slot-names
  126.       (mapcar #'(lambda (nls) (local-super-slot-name (class-name nls)))
  127.           new-local-supers
  128.           )
  129.        )
  130.      )
  131.  
  132.     (setf (class-local-super-slot-names class) local-super-slot-names)
  133.  
  134.     (setf (class-user-visible-slots class) new-local-slots)
  135.  
  136.     (setq new-local-slots 
  137.           (mapcar #'(lambda (x) (make-slotd class :name x))
  138.                     (append local-super-slot-names
  139.                         new-local-slots)
  140.           )
  141.     )
  142.  
  143.     (setf (class-instance-size class) (length new-local-slots))
  144.  
  145.     (run-super)
  146.  
  147.   ) ;let
  148.  
  149. ) ;end add-class
  150.  
  151. ;;class-slots-Return the slot names for the parents
  152.  
  153. (defmeth class-slots ((class common-objects-class))
  154.  
  155.   (class-local-slots class)
  156.  
  157. ) ;end class-slots
  158.  
  159. ;;has-slot-p-Return T if class has user visible slot symbol
  160.  
  161. (defmeth has-slot-p ((class common-objects-class) symbol)
  162.  
  163.   (let
  164.     (
  165.       (bool NIL)
  166.     )
  167.  
  168.     (dolist (slotd (class-user-visible-slots class))
  169.       (when  (equal symbol (slot-name-from-slotd slotd))
  170.     (setf bool T)
  171.         (return)
  172.       )
  173.     )
  174.     bool
  175.  
  176.   ) ;end let
  177.  
  178. ) ;end has-slot-p
  179.  
  180. ;;init-keywords-Return the initialization keywords
  181.  
  182. (defmeth init-keywords ((class common-objects-class))
  183.  
  184.   (class-init-keywords class)
  185.  
  186. ) ;init-keywords
  187.  
  188. ;;class-local-super-names-Return the names of the local supers for
  189. ;;  this class.
  190.  
  191. (defmeth class-local-super-names ((class common-objects-class))
  192.  
  193.   (mapcar #'(lambda (x) (class-name x)) (class-local-supers class))
  194.  
  195. ) ;end class-local-super-names
  196.  
  197. ;;compute-class-precedence-list-Calculate class precedence.
  198. ;;  CommonObjects classes don't inherit in the CommonLoops sense.  
  199. ;;  Tell CommonLoops that they only inherit from themselves, 
  200. ;;  the class COMMON-OBJECTS-CLASS itself which they need for 
  201. ;;  GET-SLOT-USING-CLASS and PUT-SLOT-USING-CLASS and default printing
  202. ;;  to work right.
  203.  
  204. (defmeth compute-class-precedence-list ((class common-objects-class))
  205.  
  206.   (list class (class-named 'common-objects-class) (class-named 'object))
  207.  
  208. ) ;end compute-class-precedence-list
  209.  
  210. ;;method-alist-Return the a-list of names v.s. method objects. Only
  211. ;;  methods which are CommonObjects methods are returned. This
  212. ;;  is to accomodate system generated methods, like TYPE-OF, which
  213. ;;  should not be identified as methods on CommonObjects instances.
  214. ;;  This routine is primarily used in parsing.
  215.  
  216. (defmeth method-alist ((class common-objects-class))
  217.   (declare (special *universal-methods*))
  218.  
  219.   (let
  220.     (
  221.       (alist NIL)
  222.     )
  223.  
  224.     ;;First get the direct methods
  225.  
  226.     (dolist (methobj (class-direct-methods class))
  227.  
  228.         (if (eq (class-name (class-of methobj)) 'common-objects-method)
  229.  
  230.           (push 
  231.         (list (unkeyword-standin (method-name methobj)) methobj)
  232.         alist
  233.       )
  234.         ) ;if
  235.     )
  236.  
  237.     ;;Now check if any of the universal methods need to be added
  238.  
  239.     (dolist (univmeth *universal-methods*)
  240.  
  241.       (if (not (assoc univmeth alist))
  242.         (push
  243.           (list 
  244.         univmeth 
  245.         (find-method 
  246.           (discriminator-named (keyword-standin univmeth))
  247.               '(common-objects-class)
  248.           NIL
  249.           T
  250.             )
  251.           )
  252.           alist
  253.         )
  254.  
  255.       ) ;if
  256.  
  257.     ) ;dolist            
  258.  
  259.     alist
  260.  
  261.   ) ;end let
  262.  
  263. ) ;end method-alist
  264.  
  265. ;;check-init-keywords-Check if the initialization keywords are
  266. ;;  correct
  267.  
  268. (defmeth check-init-keywords ((class common-objects-class) keylist)
  269.  
  270.   (let
  271.     (
  272.       (legalkeys (class-init-keywords class))
  273.     )
  274.     
  275.     (do
  276.       (
  277.         (key (car keylist) (cddr key) )
  278.       )
  279.       ( (null key) )
  280.  
  281.       (if (not (and (keywordp (car key)) (>= (length key) 2)))
  282.         (error "MAKE-INSTANCE: For type ~S, keylist must have alternating keys and values. List:~S~%"
  283.          (class-name class) (car keylist)
  284.         )
  285.       )
  286.  
  287.       (when (not (member (car key) legalkeys))
  288.         (error "MAKE-INSTANCE: For type ~S, ~S is not a legal initialization keyword.~%"
  289.          (class-name class) (car key)
  290.         )
  291.       )
  292.     ) ;dolist
  293.  
  294.   ) ;let
  295.  
  296. ) ;end check-init-keywords
  297.  
  298. ;;optimize-get-slot-Optimize a get slot by returning
  299. ;;  the right code. CommonObjects instances are statically
  300. ;;  allocated, so "hard" indicies can be used for them.
  301. ;;  Stolen from the protocol for BASIC-CLASS.
  302.  
  303. ;(defmeth optimize-get-slot ((method common-objects-method)
  304. ;                     (class common-objects-class)
  305. ;                     form)
  306. ;  (declare (ignore method)) ; rds 3/9
  307. (defmeth optimize-get-slot ((class common-objects-class) form)
  308.     `(%instance-ref ,(second form) ,(slot-index class (second (third form))))
  309.  
  310.  
  311.  
  312. ) ;end optimize-get-slot
  313.  
  314. ;;pcl::optimize-setf-of-get-slot-Optimize a setf of a slot
  315. ;;  by returning the right code. Again, "hard" indicies
  316. ;;  can be used since in-line allocation is the rule.
  317. ;;  Stolen from the protocol for BASIC-CLASS.
  318.  
  319. ;(defmeth pcl::optimize-setf-of-get-slot ((method common-objects-method)
  320. ;                         (class common-objects-class)
  321. ;                         form)
  322. ;  (declare (ignore method))
  323. (defmeth pcl::optimize-setf-of-get-slot ((class common-objects-class)
  324.                                          form)
  325.     `(setf 
  326.       (%instance-ref , (nth 1 form) ,(slot-index class (second (nth 2 form))))
  327.            ,(nth 3 form)
  328.      )
  329.  
  330. ) ;end optimize-setf-of-get-slot
  331.  
  332. ;;slot-index-Calculate the slot index for the indicated slot
  333.  
  334. (defmeth slot-index ((class common-objects-class) slotname)
  335.  
  336.   ;;Treat .SELF. as a special case
  337.  
  338.   (if (eq slotname '.self.)
  339.     $SELF-INDEX
  340.  
  341.     (calculate-slot-index 
  342.       slotname
  343.       (class-local-super-slot-names class) 
  344.       (class-user-visible-slots class)
  345.     )
  346.  
  347.   ) ;if
  348.  
  349. ) ;end slot-index
  350.  
  351. ;;get-slot-using-class-Generic version for all CommonObjects classes.
  352. ;;  Normally, this will be optimized out by the optimization method
  353. ;;  but just in case.
  354.  
  355. (defmeth get-slot-using-class ((class common-objects-class) object slot-name)
  356.  
  357.   (%instance-ref object (slot-index class slot-name))
  358.  
  359. ) ;get-slot-using-class 
  360.  
  361. ;;put-slot-using-class-Generic version for all CommonObjects classes.
  362. ;;  A bug in the default code-walker makes this necessary, although
  363. ;;  ultimately a custom walking function for CommonObjects methods
  364. ;;  might make the optimization work. Note that the code walker
  365. ;;  bug is fixed in the specialized walker method WALK-METHOD-BODY-INTERNAL
  366. ;;  for CommonObjects methods.
  367.  
  368. (defmeth pcl::put-slot-using-class 
  369.   ((class common-objects-class) object slot-name new-value)
  370.  
  371.   (setf 
  372.     (%instance-ref object (slot-index class slot-name) )
  373.     new-value
  374.   )
  375.   
  376. ) ;put-slot-using-class
  377.  
  378.  
  379. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  380. ;  CommonObjects MetaClass Utility Functions
  381. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  382.  
  383. ;;defined-classes-List the defined CommonObjects classes
  384.  
  385. (defun defined-classes ()
  386.  
  387.   (let 
  388.     (
  389.       (defined-types NIL)
  390.       (class (class-named 'common-objects-class))
  391.     )
  392.  
  393.     (maphash 
  394.     #'(lambda (key val) 
  395.         (when (and val (eq (class-of val) class))
  396.           (setf defined-types (cons key defined-types))
  397.             )
  398.       )
  399.           pcl::*class-name-hash-table*
  400.     )
  401.     defined-types
  402.   )
  403. ) ;end defined-classes
  404.  
  405. ;;slot-name-from-slotd-Return the name of the slot, given the SLOTD.
  406.  
  407. (defun slot-name-from-slotd (slotd)
  408.   slotd
  409.  
  410. ) ;slot-name-from-slotd
  411.  
  412. ;;method-name-Return the method name, given the method object
  413.  
  414. (defun method-name (methobj)
  415.  
  416.   (discriminator-name (method-discriminator methobj))
  417. )
  418.  
  419.