home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part10 / braid.l
Encoding:
Text File  |  1987-08-02  |  33.4 KB  |  832 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); 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. ;;; The meta-braid and defstruct.
  27. ;;;
  28. ;;; NOTE: This file must be loaded before it can be compiled.
  29.  
  30. #| *** TO DO ***
  31.  
  32. |#
  33. (in-package 'pcl)
  34.  
  35.   ;;   
  36. ;;;;;; Medium-level support for the class CLASS.
  37.   ;;   
  38. ;;; The low-level macros are defined by the file portable-low (or a special
  39. ;;; version) of that file if there is one for this implementation.  This is
  40. ;;; the lowest-level completely portable code which operates on instances
  41. ;;; with meta-class class.
  42.  
  43. (defmacro get-static-slot--class (iwmc-class slot-index)
  44.   `(%static-slot-storage-get-slot--class
  45.      (iwmc-class-static-slots ,iwmc-class)
  46.      ,slot-index))
  47.  
  48. (defmacro get-dynamic-slot--class (iwmc-class slot-name default)
  49.   `(%dynamic-slot-storage-get-slot--class
  50.      (iwmc-class-dynamic-slots ,iwmc-class)
  51.      ,slot-name
  52.      ,default))
  53.  
  54. (defmacro remove-dynamic-slot--class (iwmc-class slot-name)
  55.   `(%dynamic-slot-storage-remove-slot--class
  56.      (iwmc-class-dynamic-slots ,iwmc-class)
  57.      ,slot-name))
  58.  
  59.  
  60.   ;;
  61. ;;;;;; defmeth  -- defining methods
  62.   ;;
  63. ;;; We need to be able to define something like methods before we really have
  64. ;;; real method functionality available.
  65. ;;;
  66. ;;; defmeth expands by calling expand-defmeth, this means that we can define
  67. ;;; an early version of defmeth just by defining an early version of expand-
  68. ;;; defmeth.
  69. ;;;
  70. (defmacro defmethod (&rest args)
  71.  ;(declare (zl:arglist name qualifier* arglist &body body))
  72.   (let ((name (pop args))
  73.     (qualifiers ())
  74.     (arglist ())
  75.     (body nil))
  76.     (multiple-value-setq (qualifiers args) (defmethod-qualifiers args))
  77.     (setq arglist (pop args)
  78.       body args)
  79.     `(defmeth (,name . ,qualifiers) ,arglist . ,body)))
  80.  
  81. (defmacro defmethod-setf (&rest args)
  82.   (let ((name (pop args))
  83.     (qualifiers ())
  84.     (arglist ())
  85.     (new-value-arglist ())
  86.     (body nil))
  87.     (multiple-value-setq (qualifiers args) (defmethod-qualifiers args))
  88.     (setq arglist (pop args)
  89.       new-value-arglist (pop args)
  90.       body args)
  91.     `(defmeth (,name (:setf ,new-value-arglist) ,.qualifiers) ,arglist
  92.        ,@body)))
  93.  
  94. (defun defmethod-qualifiers (args)
  95.   (declare (values qualifiers arglist-and-body))
  96.   (let ((qualifiers ()))
  97.     (loop (if (and (car args) (listp (car args)))
  98.           (return (values (nreverse qualifiers) args))
  99.           (push (pop args) qualifiers)))))
  100.  
  101. (defun defmethod-argument-specializers (arglist)
  102.   (let ((arg (car arglist)))
  103.     (cond ((null arglist) nil)
  104.       ((memq arg '(&optional &rest &key &aux)) nil) ;Don't allow any
  105.                                                         ;argument specializers
  106.                                                     ;after one of these.
  107.       ((memq arg lambda-list-keywords)            ;Or one of these!!
  108.        (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
  109.                   Assuming that no argument specializers appear after it."
  110.          arg)
  111.        nil)
  112.       (t
  113.        (let ((tail (defmethod-argument-specializers (cdr arglist)))
  114.          (specializer (and (listp arg) (cadr arg))))
  115.          (or (and tail (cons (or specializer 't) tail))
  116.          (and specializer (cons specializer ()))))))))
  117.  
  118.  
  119. (defmacro defmeth (name&options arglist &body body)
  120.   (expand-defmeth name&options arglist body))
  121.  
  122. (eval-when (compile load eval)
  123.   ;; Make sure we call bootstrap-expand-defmeth during bootstrapping.
  124.   ;;  - Can't say (setf (symbol-fu ..) #'bootstrap-expand-defmeth because
  125.   ;;    bootstrap-expand-defmeth isn't defined yet and that isn't legal
  126.   ;;    in Common Lisp.
  127.   ;;  - Can't say (setf (symbol-fu ..) 'bootstrap-expand-defmeth because
  128.   ;;    not all Common Lisps like having symbols in the function cell.
  129.   (setf (symbol-function 'expand-defmeth)
  130.     #'(lambda (name&options arglist body)
  131.         (bootstrap-expand-defmeth name&options arglist body)))
  132.   )
  133.  
  134.   ;;   
  135. ;;;;;; Early methods
  136.   ;;   
  137.  
  138. (defvar *real-methods-exist-p*)
  139. (eval-when (compile load eval)
  140.   (setq *real-methods-exist-p* nil))
  141.  
  142. (eval-when (load)  
  143.   (setq *error-when-defining-method-on-existing-function* 'bootstrapping))
  144.  
  145. (defvar *protected-early-selectors* '(print-instance))
  146.  
  147. (defparameter *early-defmeths* ())
  148.  
  149. (defmacro simple-type-specs (arglist)
  150.   `(let ((type-specs
  151.        (iterate ((arg in ,arglist))
  152.             (until (memq arg '(&optional &rest &key &aux)))
  153.             (collect (if (listp arg) (cadr arg) 't)))))
  154.      (setq type-specs (nreverse type-specs))
  155.      (iterate ((type-spec in type-specs))
  156.           (until (neq type-spec 't))
  157.           (pop type-specs))
  158.      (nreverse type-specs)))
  159.  
  160. (defmacro simple-without-type-specs (arglist)
  161.   `(iterate ((loc on ,arglist))
  162.         (cond ((memq (car loc) '(&optional &rest &key &aux))
  163.            (join loc) (until t))
  164.           (t
  165.            (collect (if (listp (car loc))
  166.                 (caar loc)
  167.                 (car loc)))))))
  168. (defmacro simple-args (arglist)
  169.   `(iterate ((arg in ,arglist))
  170.         (until (eq arg '&aux))
  171.         (unless (memq arg '(&optional &rest &key))
  172.           (collect (if (listp arg) (car arg) arg)))))
  173.  
  174. (defun bootstrap-expand-defmeth (name&options arglist body)
  175.   ;; Some SIMPLE local macros for getting the type-specifiers out of the
  176.   ;; argument list.  Unfortunately, it is important that these simple
  177.   ;; macros and the methods which come along later and do this job better
  178.   ;; be compatible.  This will become less of an issue once methods don't
  179.   ;; have names anymore.
  180. ; (macrolet ()             
  181.     (multiple-value-bind (documentation declares body)
  182.         (extract-declarations body)
  183.       (or (listp name&options) (setq name&options (list name&options)))
  184.       (keyword-parse ((setf () setfp))
  185.                      (cdr name&options)
  186.         (let* ((name (car name&options))
  187.                (discriminator-name (if setfp
  188.                        (make-setf-discriminator-name name)
  189.                        name))
  190.                (method-name (if setfp
  191.                                 (make-setf-method-name
  192.                   name
  193.                   (simple-type-specs setf)
  194.                   (simple-type-specs arglist))
  195.                                 (make-method-name
  196.                   name (simple-type-specs arglist))))
  197.                (method-arglist (simple-without-type-specs
  198.                                  (if setfp
  199.                                      (cons (car arglist)
  200.                        (append setf (cdr arglist)))
  201.                                      arglist))))
  202.           `(progn
  203.              ;; Record this early defmeth so that fixup-early-defmeths will
  204.              ;; know to fix it up later.
  205.              (eval-when (compile load eval)
  206.                (record-early-defmeth
  207.          ',discriminator-name ',name&options ',arglist ',body))
  208.          (record-definition ',discriminator-name 'method)
  209.              (defun ,method-name ,method-arglist
  210.                ,@(and documentation (list documentation))
  211.                ,@declares
  212. ;              #+Symbolics(declare (sys:function-parent ,name defmeth))
  213.                . ,body)         
  214.          ,(unless (memq discriminator-name *protected-early-selectors*)
  215.         `(eval-when (load eval)
  216.            (setf (symbol-function ',discriminator-name)
  217.              (symbol-function ',method-name))))
  218.              ,@(and setfp
  219.             (not (memq discriminator-name *protected-early-selectors*))
  220.                     (let ((args (simple-without-type-specs arglist))
  221.                           (setf-args (simple-without-type-specs setf)))
  222.                       `((defsetf ,name ,args ,setf-args
  223.                           (list ',discriminator-name
  224.                                 ,(car args)
  225.                                 ,@(simple-args setf)
  226.                                 ,@(simple-args (cdr args))))))))))))
  227. ;)
  228.  
  229. (defun record-early-defmeth (discriminator-name name&options arglist body)
  230.   (pushnew (list* 'defmeth discriminator-name name&options arglist body)
  231.        *early-defmeths*
  232.        :test #'equal))
  233.  
  234. (defun record-early-discriminator (discriminator-name)
  235.   (pushnew (list 'clear discriminator-name) *early-defmeths* :test #'equal))
  236.  
  237. (defun record-early-method-fixup (form)
  238.   (pushnew (list 'eval form) *early-defmeths* :test #'equal))
  239.  
  240. (defmacro fix-early-defmeths ()
  241.   (let ((resets ())
  242.     (evals ()))
  243.     (dolist (entry *early-defmeths*)
  244.       (ecase (car entry)
  245.     (defmeth (push (cons 'defmeth (cddr entry)) evals)
  246.          (push (cadr entry) resets))
  247.     (clear   (push (cadr entry) resets))
  248.     (eval    (push (cadr entry) evals))))    
  249.     `(progn
  250.        ;; The first thing to do is go through and get rid of all the old
  251.        ;; discriminators.  This only needs to happen when we are being
  252.        ;; loaded into the same VMem we were compiled in.  The WHEN is
  253.        ;; making that optimization.
  254.        (defun fix-early-defmeths-1 ()     
  255.      (when (discriminator-named ',(car resets))       
  256.        (dolist (x ',resets) (setf (discriminator-named x) nil))))
  257.        (fix-early-defmeths-1)
  258.        ,@evals)))
  259.  
  260. #| This is useful for debugging.
  261. (defmacro unfix-early-defmeths ()
  262.   `(progn
  263.      (do-symbols (x)
  264.        (remprop x 'discriminator)
  265.        (remprop x 'setf-discriminator))
  266.      . ,(mapcar '(lambda (x) (cons 'defmeth x)) (reverse *early-defmeths*))))
  267.  
  268. (unfix-early-defmeths)
  269. |#
  270.  
  271. (defun make-setf-discriminator-name (name)
  272.   (intern (string-append name " :SETF-discriminator")
  273.       (symbol-package name)))
  274.  
  275. (defun make-method-name (selector type-specifiers)
  276.   (intern (apply #'string-append
  277.                       (list* "Method "
  278.                              selector
  279.                              " "
  280.                              (make-method-name-internal type-specifiers)))
  281.       (symbol-package selector)))
  282.  
  283. (defun make-setf-method-name (selector setf-type-specifiers type-specifiers)
  284.   (intern (apply #'string-append
  285.                       (list* "Method "
  286.                              selector
  287.                              " ("
  288.                              (apply #'string-append
  289.                                     ":SETF "
  290.                                     (make-method-name-internal setf-type-specifiers))
  291.                              ") "
  292.                              (make-method-name-internal type-specifiers)))
  293.       (symbol-package selector)))
  294.  
  295. (defun make-method-name-internal (type-specifiers)
  296.   (if type-specifiers
  297.       (iterate ((type-spec on type-specifiers))
  298.         (collect (string (car type-spec)))
  299.         (when (cdr type-spec) (collect " ")))
  300.       '("Default")))
  301.   
  302.  
  303.  
  304.   ;;
  305. ;;;;;; SLOTDS and DS-OPTIONS
  306.   ;;
  307. ;;;
  308. ;;; A slot-description is the thing which appears in a defstruct.  A SLOTD is
  309. ;;; an internal description of a slot.
  310. ;;;
  311. ;;; The SLOTD structure corresponds to the kind of slot the structure-class
  312. ;;; meta-class creates (the kind of slot that appears in Steele Edition 1).
  313. ;;; Other metaclasses which need to have more elaborate slot options and
  314. ;;; slotds, they :include that class in their slotds.
  315. ;;;
  316. ;;; slotds are :type list for 2 important reasons:
  317. ;;;   - so that looking up a slotd in a list of lists will compile
  318. ;;;     into a call to assq
  319. ;;;   - PCL assumes only the existence of the simplest of defstructs
  320. ;;;     this allows PCL to be used to implement a real defstruct.
  321. ;;;     
  322. (defstruct (essential-slotd (:type list)
  323.                 (:constructor make-slotd--essential-class))
  324.   name)
  325.  
  326. ;;;
  327. ;;; Slotd-position is used to find the position of a slot with a particular
  328. ;;; name in a list of slotds.  Specifically it is used in the case of a
  329. ;;; get-slot cache miss to find this slot index.  That means it is used in
  330. ;;; about 2% of the total slot accesses so it should be fast.
  331. ;;; 
  332. (defmacro slotd-position (slotd-name slotds)
  333.   `(let ((slotd-name ,slotd-name))
  334.      (do ((pos 0 (+ pos 1))
  335.       (slotds ,slotds (cdr slotds)))
  336.      ((null slotds) nil)
  337.        (declare (type integer pos) (type list slotds))
  338.        (and (eq slotd-name (slotd-name (car slotds)))
  339.         (return pos)))))
  340.  
  341. (defmacro slotd-member (slotd-name slotds)                  ;I wonder how
  342.   `(member ,slotd-name ,slotds :test #'eq :key #'slotd-name)) ;many compilers
  343.                                       ;are really
  344.                                       ;smart enough.
  345. (defmacro slotd-assoc (slotd-name slotds)    
  346.   `(assq ,slotd-name ,slotds))
  347.  
  348. ;;;
  349. ;;; Once defstruct-options are defaulted and parsed, they are stored in a
  350. ;;; ds-options (defstruct-options) structure.  This modularity makes it
  351. ;;; easier to build the meta-braid which has to do some slot and option
  352. ;;; parsing long before the real new defstruct exists.  More importantly,
  353. ;;; this allows new meta-classes to inherit the option parsing code 
  354. ;;; from other metaclasses.
  355. ;;;
  356. (defstruct (ds-options (:constructor make-ds-options--class))
  357.   name
  358.   constructors             ;The constructor argument, a list whose car is the
  359.                ;name of the constructor and whose cadr if present
  360.                            ;is the argument-list for the constructor.
  361.   copier                   ;(defaulted) value of the :copier option.
  362.   predicate                ;ditto for :predicate
  363.   print-function           ;ditto for :print-function
  364.   generate-accessors       ;ditto for :generate-accessors
  365.   conc-name                ;ditto for :conc-name 
  366.   includes                 ;The included structures (car of :include)
  367.   slot-includes            ;The included slot modifications (cdr of :include)
  368.   initial-offset           ;(defaulted) value of the :initial-offset option.
  369.   )
  370.  
  371.   
  372.  
  373.   ;;
  374. ;;;;;; The beginnings of the meta-class CLASS (parsing the defstruct)
  375.   ;;   
  376.  
  377. (defmeth make-ds-options ((class basic-class) name)
  378.   (ignore class)
  379.   (make-ds-options--class :name name))
  380.  
  381. (defmeth parse-defstruct-options ((class basic-class) name options)
  382.   (parse-defstruct-options-internal
  383.     class name options
  384.     (default-ds-options class name (make-ds-options class name))))
  385.  
  386. (defmeth default-ds-options ((class basic-class) name ds-options)
  387.   (ignore class)
  388.   (setf
  389.     (ds-options-constructors ds-options)       `((,(symbol-append "MAKE-"
  390.                                   name)))
  391.     (ds-options-copier ds-options)             (symbol-append "COPY-" name)
  392.     (ds-options-predicate ds-options)          (symbol-append name "-P")
  393.     (ds-options-print-function ds-options)     nil
  394.     (ds-options-generate-accessors ds-options) 'method
  395.     (ds-options-conc-name ds-options)          (symbol-append name "-")
  396.     (ds-options-includes ds-options)           ()
  397.     (ds-options-slot-includes ds-options)      ()
  398.     (ds-options-initial-offset ds-options)     0)
  399.   ds-options)
  400.  
  401. (defmeth parse-defstruct-options-internal ((class basic-class)
  402.                         name options ds-options)
  403.   (ignore class name)
  404.   (keyword-parse ((conc-name (ds-options-conc-name ds-options))
  405.                   (constructor () constructor-p :allowed :multiple
  406.                         :return-cdr t)
  407.                   (copier (ds-options-copier ds-options))
  408.                   (predicate (ds-options-predicate ds-options))
  409.                   (include () include-p :return-cdr t)
  410.                   (print-function () print-function-p)
  411.                   (initial-offset (ds-options-initial-offset ds-options))
  412.                   (generate-accessors (ds-options-generate-accessors
  413.                     ds-options)))
  414.                  options
  415.     (setf (ds-options-conc-name ds-options) conc-name)
  416.     (when constructor-p
  417.       (setf (ds-options-constructors ds-options) constructor))
  418.     (setf (ds-options-copier ds-options) copier)
  419.     (setf (ds-options-predicate ds-options) predicate)
  420.     (when include-p
  421.       (destructuring-bind (includes . slot-includes) include
  422.     (setf (ds-options-includes ds-options) (if (listp includes)
  423.                            includes
  424.                            (list includes))
  425.           (ds-options-slot-includes ds-options) slot-includes)))
  426.     (when print-function-p
  427.       (setf (ds-options-print-function ds-options)
  428.         (cond ((null print-function) nil)
  429.           ((symbolp print-function) print-function)
  430.           ((and (listp print-function)
  431.             (eq (car print-function) 'lambda)
  432.             (listp (cadr print-function)))
  433.            print-function)
  434.           (t
  435.            (error "The :PRINT-FUNCTION option, ~S~%~
  436.                            is not either nil or a function suitable for the~
  437.                            function special form."
  438.                print-function)))))
  439.     (setf (ds-options-initial-offset ds-options) initial-offset)
  440.     (setf (ds-options-generate-accessors ds-options) generate-accessors)
  441.     ds-options))
  442.  
  443. ;;;
  444. ;;;
  445.  
  446. (defvar *slotd-unsupplied* (list nil))
  447.  
  448. (defstruct (class-slotd (:include essential-slotd)
  449.             (:type list)
  450.             (:conc-name slotd-)
  451.             (:constructor make-slotd--class)
  452.             (:copier copy-slotd))
  453.   keyword
  454.   (default *slotd-unsupplied*)
  455.   (type *slotd-unsupplied*)
  456.   (read-only *slotd-unsupplied*)
  457.   (accessor *slotd-unsupplied*)
  458.   (allocation *slotd-unsupplied*)
  459.   get-function   ;NIL if no :get(put)-function argument was supplied.
  460.   put-function   ;Otherwise, a function of two (three)arguments, the
  461.                  ;object, the name of the slot (and the new-value).
  462.   )
  463.  
  464. (defmeth make-slotd ((class basic-class) &rest keywords-and-options)
  465.   (ignore class)
  466.   (apply #'make-slotd--class keywords-and-options))
  467.  
  468. (defmeth parse-slot-descriptions ((class basic-class) ds-options slot-descriptions)
  469.   (iterate ((slot-description in slot-descriptions))
  470.     (collect (parse-slot-description class ds-options slot-description))))
  471.  
  472. (defmeth parse-slot-description ((class basic-class) ds-options slot-description)
  473.   (parse-slot-description-internal
  474.     class ds-options slot-description (make-slotd class)))
  475.  
  476. (defmeth parse-slot-description-internal ((class basic-class) ds-options slot-description slotd)
  477.   (ignore class)
  478.   (let ((conc-name (ds-options-conc-name ds-options))
  479.         (generate-accessors (ds-options-generate-accessors ds-options)))
  480.     #+Lucid (declare (special conc-name generate-accessors))
  481.     (destructuring-bind (name default . args)
  482.                         slot-description
  483.       (keyword-bind ((type nil)
  484.                      (read-only nil)
  485.                      (generate-accessor generate-accessors)
  486.                      (allocation :instance)
  487.                      (get-function nil)
  488.                      (put-function nil)
  489.  
  490.              (accessor nil accessor-p)
  491.              (initform nil)        ;ignore
  492.              )
  493.                     args
  494.         #+Lucid(declare (special type read-only generate-accessor allocation
  495.                                  get-function put-function))
  496.         (check-member allocation '(:class :instance :dynamic)
  497.                       :test #'eq
  498.                       :pretty-name "the :allocation option")
  499.         (setf (slotd-name slotd)         name
  500.               (slotd-keyword slotd)      (make-keyword name)
  501.               (slotd-default slotd)      default
  502.               (slotd-type slotd)         type
  503.               (slotd-read-only slotd)    read-only
  504.               (slotd-accessor slotd)     (if accessor-p
  505.                          accessor
  506.                          (and generate-accessor
  507.                           (if conc-name
  508.                              (symbol-append conc-name
  509.                                     name)
  510.                              name)))
  511.               (slotd-allocation slotd)   allocation
  512.               (slotd-get-function slotd) (and get-function
  513.                                               (if (and (consp get-function)
  514.                                                        (eq (car get-function) 'function))
  515.                                                   get-function
  516.                                                   (list 'function get-function)))
  517.               (slotd-put-function slotd) (and put-function
  518.                                               (if (and (consp put-function)
  519.                                                        (eq (car put-function) 'function))
  520.                                                   put-function
  521.                                                   (list 'function put-function))))
  522.         slotd))))
  523.  
  524. ;;;
  525. ;;; Take two lists of slotds and return t if they describe an set of slots of
  526. ;;; the same shape.  Otherwise return nil.  Sets of slots are have the same
  527. ;;; same shape if they have they both have the same :allocation :instance
  528. ;;; slots and if those slots appear in the same order.
  529. ;;; 
  530. (defun same-shape-slots-p (old-slotds new-slotds)
  531.   (do ()
  532.       ((and (null old-slotds) (null new-slotds)) t)
  533.     (let* ((old (pop old-slotds))
  534.        (new (pop new-slotds))
  535.        (old-allocation (and old (slotd-allocation old)))
  536.        (new-allocation (and new (slotd-allocation new))))
  537.       ;; For the old and new slotd check all the possible reasons
  538.       ;; why they might not match.
  539.       ;;   - One or the other is null means that a slot either
  540.       ;;     disappeared or got added.
  541.       ;;   - The names are different means that a slot moved
  542.       ;;     disappared or go added.
  543.       ;;   - If the allocations are different, and one of them
  544.       ;;     is :instance then a slot either became or ceased
  545.       ;;     to be :allocation :instance.
  546.       (when (or (null old)
  547.         (null new)
  548.         (neq (slotd-name old) (slotd-name new))
  549.         (and (neq old-allocation new-allocation)
  550.              (or (eq old-allocation :instance)
  551.              (eq new-allocation :instance))))
  552.     (return nil)))))
  553.  
  554. (defmeth slots-with-allocation ((class basic-class) slotds allocation)
  555.   (ignore class)
  556.   (iterate ((slotd in slotds))
  557.     (when (eq (slotd-allocation slotd) allocation)
  558.       (collect slotd))))
  559.  
  560. (defmeth slots-with-allocation-not ((class basic-class) slotds allocation)
  561.   (ignore class)
  562.   (iterate ((slotd in slotds))
  563.     (unless (eq (slotd-allocation slotd) allocation)
  564.       (collect slotd))))
  565.  
  566.   ;;   
  567. ;;;;;; GET-SLOT and PUT-SLOT
  568.   ;;
  569. ;;; Its still too early to fully define get-slot and put-slot since they need
  570. ;;; the meta-braid to work.
  571. ;;;
  572. ;;; But its nice if as part of defining the meta-braid we can define and compile
  573. ;;; code which does get-slots and setfs of get-slots and in order to do this we
  574. ;;; need to have get-slot around.  Actually we could do with just the defsetf of
  575. ;;; get-slot but might as well put all 3 here.
  576. ;;;
  577. ;;; The code bootstrap meta-braid defines with get-slot in it is all done with
  578. ;;; defmeth, so these get-slots will all get recompiled once the optimizers
  579. ;;; exist don't worry.
  580. (defun get-slot (object slot-name)
  581.   (get-slot-using-class (class-of object) object slot-name))
  582.  
  583. (defun put-slot (object slot-name new-value)
  584.   (put-slot-using-class (class-of object) object slot-name new-value))
  585.  
  586. (defun setf-of-get-slot (new-value object slot-name)
  587.   (put-slot-using-class (class-of object) object slot-name new-value))
  588.  
  589. (defsetf get-slot (object slot-name &rest extra-args) (new-value)
  590.   `(setf-of-get-slot ,new-value ,object ,slot-name . ,extra-args))
  591.  
  592. (defun get-slot-always (object slot-name &optional default)
  593.   (get-slot-using-class (class-of object) object slot-name t default))
  594.  
  595. (defun put-slot-always (object slot-name new-value)
  596.   (put-slot-using-class (class-of object) object slot-name new-value t))
  597.  
  598. (defsetf get-slot-always (object slot-name &optional default) (new-value)
  599.   `(put-slot-always ,object ,slot-name ,new-value))
  600.  
  601. (defun remove-dynamic-slot (object slot-name)
  602.   (remove-dynamic-slot-using-class (class-of object) object slot-name))
  603.  
  604.  
  605.  
  606.  
  607.   ;;   
  608. ;;;;;; Actually bootstrapping the meta-braid
  609.   ;;
  610. ;;;
  611. ;;; *meta-braid* is the list from which the initial meta-classes are created.
  612. ;;; The elements look sort of like defstructs.  The car of each element is
  613. ;;; the name of the class;  the cadr is the defstruct options;  the caddr is
  614. ;;; the slot-descriptions.
  615. ;;;
  616. (defvar *meta-braid*
  617.         '((t
  618.             ((:include ()))
  619.             ())
  620.           (object
  621.             ((:include (t)))
  622.             ())
  623.           (essential-class
  624.             ((:include (object))
  625.              (:conc-name class-))
  626.             ((name nil)                    ;A symbol, the name of the class.
  627.              (class-precedence-list ())    ;The class's class-precedence-list
  628.                        ;see compute-class-precedence-list
  629.              (local-supers ())           ;This class's direct superclasses.
  630.          (local-slots ())
  631.              (direct-subclasses ())       ;All the classes which have this
  632.                        ;class on their local-supers.
  633.          (direct-methods ())
  634.          ))
  635.           (basic-class
  636.             ((:include (essential-class))
  637.          (:conc-name class-))
  638.             ((no-of-instance-slots 0)      ;The # of slots with :allocation :instance
  639.                                            ;in an instance of this class.
  640.              (instance-slots ())           ;The slotds of those slots.
  641.              (non-instance-slots ())       ;The declared slots with :allocation other
  642.                                            ;than :instance.  instance-slots + non-
  643.                                            ;instance-slots = all-slots.
  644.              (wrapper nil)                 ;The class-wrapper which instances of
  645.                                            ;this class point to.
  646.          (direct-discriminators ())
  647.          (discriminators-which-combine-methods ())
  648.              (prototype nil :get-function (lambda (c slot-name)
  649.                                             (ignore slot-name)
  650.                                             (or (get-slot c 'prototype)
  651.                                                 (setf (get-slot c 'prototype)
  652.                                                       (make c)))))      
  653.              (ds-options ())))
  654.       (class
  655.         ((:include (basic-class)))
  656.         ())))
  657.  
  658. ;;;
  659. ;;; *bootstrap-slots* is a list of the slotds corresponding to the slots of class
  660. ;;; class with :allocation :instance.  It is used by bootstrap-get-slot during the
  661. ;;; bootstrapping of the meta-braid.
  662. ;;;
  663. (defvar *bootstrap-slots*)
  664.  
  665. (defmacro bootstrap-get-slot (iwmc-class slot-name)
  666.   `(get-static-slot--class ,iwmc-class
  667.         (%convert-slotd-position-to-slot-index 
  668.           (slotd-position ,slot-name *bootstrap-slots*))))
  669.  
  670. (defun bootstrap-initialize (iwmc-class name includes local-slots
  671.                                         prototype wrapper ds-options)
  672.   (let ((cpl ())
  673.         (all-slots ())
  674.         (instance-slots ()))
  675.     (setf (bootstrap-get-slot iwmc-class 'name) name)
  676.     (setf (bootstrap-get-slot iwmc-class 'local-supers)
  677.           (iterate ((i in includes)) (collect (class-named i))))
  678.     (setf (bootstrap-get-slot iwmc-class 'class-precedence-list)
  679.           (setq cpl (bootstrap-compute-class-precedence-list iwmc-class)))
  680.     (setq all-slots (append (iterate ((super in (reverse (cdr cpl))))
  681.                               (join (bootstrap-get-slot super 'local-slots)))
  682.                             local-slots))
  683.     (setf (bootstrap-get-slot iwmc-class 'instance-slots)
  684.           (setq instance-slots (slots-with-allocation () all-slots :instance)))
  685.     (setf (bootstrap-get-slot iwmc-class 'non-instance-slots)
  686.           (slots-with-allocation-not () all-slots :instance))
  687.     (setf (bootstrap-get-slot iwmc-class 'no-of-instance-slots)
  688.           (length instance-slots))
  689.     (setf (bootstrap-get-slot iwmc-class 'local-slots) local-slots)
  690.     (setf (bootstrap-get-slot iwmc-class 'direct-discriminators) ())
  691.     (setf (bootstrap-get-slot iwmc-class 'direct-methods) ())
  692.     (setf (bootstrap-get-slot iwmc-class 'prototype) prototype)
  693.     (setf (bootstrap-get-slot iwmc-class 'wrapper) wrapper)
  694.     (setf (bootstrap-get-slot iwmc-class 'ds-options) ds-options)))
  695.  
  696. (defun bootstrap-compute-class-precedence-list (class)
  697.   ;; Used by define-meta-braid to compute the class-precedence-list of a class.
  698.   (let ((local-supers (bootstrap-get-slot class 'local-supers)))
  699.     (cons class
  700.           (and local-supers
  701.                (iterate ((ls in local-supers))
  702.                  (join (bootstrap-compute-class-precedence-list ls)))))))
  703.  
  704. ;;; bootstrap-meta-braid sets *bootstrap-slots* and builds the meta-braid.
  705. ;;; Note that while it is somewhat general-purpose and driven off of *meta-braid*,
  706. ;;; it has several important built-in assumptions about the meta-braid.
  707. ;;; Namely:
  708. ;;;  - The class of every class in the meta-braid is class.
  709. ;;;  - The class class inherits its slots from every other class in the
  710. ;;;    meta-braid.  Put another way, bootstrap-meta-braid figures out the
  711. ;;;    slots of class by appending the slots of all the other classes
  712. ;;;    in the meta-braid.
  713. ;;;   
  714. (defmacro bootstrap-meta-braid ()
  715.   ;; Parse *meta-braid* and setup *bootstrap-slots* so that we can call
  716.   ;; bootstrap-get-slot to fill in the slotds of the classes we create.
  717.   (let* ((meta-braid
  718.            (iterate ((classd in *meta-braid*))
  719.              (let* ((name (car classd))
  720.                     (ds-options (parse-defstruct-options ()
  721.                              name
  722.                              (cadr classd)))
  723.                     (slotds (parse-slot-descriptions ()
  724.                              ds-options
  725.                              (caddr classd))))
  726.                (collect (list name ds-options slotds)))))
  727.          (all-slots-of-class-class
  728.            (iterate ((classd in meta-braid))
  729.              (join (caddr classd)))))
  730.     (setq *bootstrap-slots* (slots-with-allocation ()
  731.                                                    all-slots-of-class-class
  732.                                                    :instance))
  733.     `(progn      
  734.        (setq *bootstrap-slots* ',*bootstrap-slots*)
  735.        ;; First make the class class.  It is the class of all the classes in
  736.        ;; the metabraid so we need it and a wrapper of it so that we can set
  737.        ;; the wrapped class field of the other metaclasses as we make them.
  738.        (let* ((class-class
  739.         (%allocate-class-class ,(length *bootstrap-slots*)))
  740.               (wrapper-of-class-class (make-class-wrapper class-class)))
  741.          ,@(iterate ((classd in meta-braid))
  742.              (collect
  743.                (destructuring-bind (met-name met-ds-options met-slotds)
  744.                    classd
  745.                  (let ((met-includes (ds-options-includes met-ds-options)))
  746.                    `(let* ((name ',met-name)
  747.                            (includes ',met-includes)
  748.                            (ds-options ',met-ds-options)
  749.                            (slotds ',met-slotds)
  750.                            (class ,(if (eq met-name 'class)
  751.                                        'class-class
  752.                                        `(%allocate-instance--class
  753.                                           ,(length *bootstrap-slots*)
  754.                       (class-named 'class))))
  755.                            (class-wrapper ,(if (eq met-name 'class)
  756.                                                'wrapper-of-class-class
  757.                                                '(make-class-wrapper class))))
  758.                       (setf (iwmc-class-class-wrapper class)
  759.                 wrapper-of-class-class)
  760.                       (setf (class-named name) class)
  761.                       (bootstrap-initialize class
  762.                                             name
  763.                                             includes
  764.                                             slotds
  765.                                             (if (eq class class-class)
  766.                         class
  767.                         ())
  768.                                             class-wrapper
  769.                                             ds-options))))))
  770.          (let ((class-cpl (bootstrap-get-slot class-class
  771.                           'class-precedence-list)))
  772.            (iterate ((sub in class-cpl)
  773.                      (sup in (cdr class-cpl)))
  774.              (push sub (bootstrap-get-slot sup 'direct-subclasses)))))
  775.        ;; CLASS-INSTANCE-SLOTS has to be defined specially!
  776.        ;; It cannot be defined in terms of get-slot since it is the method
  777.        ;; that the get-slot mechanism (actually get-slot-using-class) appeals
  778.        ;; to to find out what slots are in an instance of a particular class.
  779.        ;;
  780.        ;; The fact that class-instance-slots is defined specially this way
  781.        ;; means that any change to the class class which changes the location
  782.        ;; of the instance-slots slot must redefine and recompile
  783.        ;; class-instance-slots.
  784.        (defun class-instance-slots (class)
  785.          (get-static-slot--class class
  786.            ,(%convert-slotd-position-to-slot-index
  787.               (slotd-position 'instance-slots *bootstrap-slots*))))
  788.        (defun class-non-instance-slots (class)
  789.          (get-static-slot--class class
  790.            ,(%convert-slotd-position-to-slot-index
  791.               (slotd-position 'non-instance-slots *bootstrap-slots*))))
  792.        ;; Now define the other accessors and :setf methods for those
  793.        ;; accessors.
  794.        ,@(iterate ((classd in meta-braid))
  795.            (destructuring-bind (name () slotds) classd
  796.              (join
  797.                (iterate ((slotd in slotds))
  798.                  (let* ((slot-name (slotd-name slotd))
  799.                         (accessor-name (slotd-accessor slotd)))
  800.                    (unless (memq slot-name '(instance-slots
  801.                          non-instance-slots))
  802.                      (collect
  803.                        `(defmeth ,accessor-name ((,name ,name))
  804.                           (funcall ,(or (slotd-get-function slotd)
  805.                     ''get-slot)
  806.                                    ,name
  807.                                    ',(slotd-name slotd)))))
  808.                    (collect
  809.                      `(defmeth (,accessor-name (:setf (.new_value.)))
  810.                 ((,name ,name))
  811.                         (funcall ,(or (slotd-put-function slotd) ''put-slot)
  812.                                  ,name
  813.                                  ',(slotd-name slotd)
  814.                                  .new_value.))))))))
  815.        t)))
  816.  
  817.  
  818. (eval-when (eval load)
  819.   (clrhash *class-name-hash-table*)
  820.   (bootstrap-meta-braid)
  821.   (recompile-class-of))
  822.  
  823. (defmeth class-slots ((class class))
  824.   (append (class-non-instance-slots class)
  825.       (class-instance-slots class)))
  826.  
  827. (defmeth (class-direct-methods (:setf (nv))) ((class class))
  828.   (setf (get-slot class 'direct-methods) nv)
  829.   (dolist (m nv) (pushnew (method-discriminator m)
  830.               (get-slot class 'direct-discriminators))))
  831.  
  832.