home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / braid.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-08-12  |  34.4 KB  |  847 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Bootstrapping the meta-braid.
  28. ;;;
  29. ;;; The code in this file takes the early definitions that have been saved
  30. ;;; up and actually builds those class objects.  This work is largely driven
  31. ;;; off of those class definitions, but the fact that STANDARD-CLASS is the
  32. ;;; class of all metaclasses in the braid is built into this code pretty
  33. ;;; deeply.
  34. ;;;
  35. ;;; 
  36.  
  37. (in-package 'pcl)
  38.  
  39. (defun early-class-name (class)
  40.   (bootstrap-get-slot 'class class 'name))
  41.  
  42. (defun early-class-definition (class-name)
  43.   (or (find class-name *early-class-definitions* :key #'ecd-class-name)
  44.       (error "~S is not a class in *early-class-definitions*." class-name)))
  45.  
  46. (defun canonical-slot-name (canonical-slot)
  47.   (getf canonical-slot :name))
  48.  
  49. (defun early-collect-inheritance (class-name)
  50.   (declare (values slots cpl default-initargs direct-subclasses))
  51.   (let ((cpl (early-collect-cpl class-name)))
  52.     (values (early-collect-slots cpl)
  53.         cpl
  54.         (early-collect-default-initargs cpl)
  55.         (gathering1 (collecting)
  56.           (dolist (definition *early-class-definitions*)
  57.         (when (memq class-name (ecd-superclass-names definition))
  58.           (gather1 (ecd-class-name definition))))))))
  59.  
  60. (defun early-collect-cpl (class-name)
  61.   (labels ((walk (c)
  62.          (let* ((definition (early-class-definition c))
  63.             (supers (ecd-superclass-names definition)))
  64.            (cons c
  65.              (apply #'append (mapcar #'early-collect-cpl supers))))))
  66.     (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
  67.  
  68. (defun early-collect-slots (cpl)
  69.   (let* ((definitions (mapcar #'early-class-definition cpl))
  70.      (super-slots (mapcar #'ecd-canonical-slots definitions))
  71.      (slots (apply #'append (reverse super-slots))))
  72.     (dolist (s1 slots)
  73.       (let ((name1 (canonical-slot-name s1)))
  74.     (dolist (s2 (cdr (memq s1 slots)))
  75.       (when (eq name1 (canonical-slot-name s2))
  76.         (error "More than one early class defines a slot with the~%~
  77.                     name ~S.  This can't work because the bootstrap~%~
  78.                     object system doesn't know how to compute effective~%~
  79.                     slots."
  80.            name1)))))
  81.     slots))
  82.  
  83. (defun early-collect-default-initargs (cpl)
  84.   (let ((default-initargs ()))
  85.     (dolist (class-name cpl)
  86.       (let ((definition (early-class-definition class-name)))
  87.     (dolist (option (ecd-other-initargs definition))
  88.       (unless (eq (car option) :default-initargs)
  89.         (error "The defclass option ~S is not supported by the bootstrap~%~
  90.                     object system."
  91.            (car option)))
  92.       (setq default-initargs
  93.         (nconc default-initargs (reverse (cdr option)))))))
  94.     (reverse default-initargs)))
  95.  
  96.  
  97. ;;;
  98. ;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
  99. ;;; the values of slots during bootstrapping.  During bootstrapping, there
  100. ;;; are only two kinds of objects whose slots we need to access, CLASSes
  101. ;;; and SLOT-DEFINITIONs.  The first argument to these functions tells whether the
  102. ;;; object is a CLASS or a SLOT-DEFINITION.
  103. ;;;
  104. ;;; Note that the way this works it stores the slot in the same place in
  105. ;;; memory that the full object system will expect to find it later.  This
  106. ;;; is critical to the bootstrapping process, the whole changeover to the
  107. ;;; full object system is predicated on this.
  108. ;;;
  109. ;;; One important point is that the layout of standard classes and standard
  110. ;;; slots must be computed the same way in this file as it is by the full
  111. ;;; object system later.
  112. ;;; 
  113. (defun bootstrap-get-slot (type object slot-name)
  114.   (let ((index (bootstrap-slot-index type slot-name)))
  115.     (svref (std-instance-slots object) index)))
  116.  
  117. (defun bootstrap-set-slot (type object slot-name new-value)
  118.   (let ((index (bootstrap-slot-index type slot-name)))
  119.     (setf (svref (std-instance-slots object) index) new-value)))
  120.  
  121. (defvar *early-class-slots* nil)
  122.  
  123. (defun early-class-slots (class-name)
  124.   (cdr (or (assoc class-name *early-class-slots*)
  125.        (let ((a (cons class-name
  126.               (mapcar #'canonical-slot-name
  127.                   (early-collect-inheritance class-name)))))
  128.          (push a *early-class-slots*)
  129.          a))))
  130.  
  131. (defun early-class-original-static-slot-storage-copy (class-name)
  132.   (%allocate-origional-static-slot-storage-copy
  133.     (length (the list (early-class-slots class-name)))))
  134.  
  135. (defun bootstrap-slot-index (class-name slot-name)
  136.   (or (posq slot-name (the list (early-class-slots class-name)))
  137.       (error "~S not found" slot-name)))
  138.  
  139.  
  140. ;;;
  141. ;;; bootstrap-meta-braid
  142. ;;;
  143. ;;; This function builds the base metabraid from the early class definitions.
  144. ;;;   
  145. (defun bootstrap-meta-braid ()
  146.   (let* ((slot-class-original-slot-copy
  147.            (early-class-original-static-slot-storage-copy 'slot-class))
  148.      (standard-class-original-slot-copy
  149.            (early-class-original-static-slot-storage-copy 'standard-class))
  150.      (built-in-class-original-slot-copy
  151.            (early-class-original-static-slot-storage-copy 'built-in-class))
  152.      (structure-class-original-slot-copy
  153.            (early-class-original-static-slot-storage-copy 'structure-class))
  154.          (slot-class      (%allocate-instance--class standard-class-original-slot-copy))
  155.          (standard-class  (%allocate-instance--class standard-class-original-slot-copy))
  156.          (built-in-class  (%allocate-instance--class standard-class-original-slot-copy))
  157.          (structure-class (%allocate-instance--class standard-class-original-slot-copy))
  158.      (direct-slotd    (%allocate-instance--class standard-class-original-slot-copy))
  159.      (effective-slotd (%allocate-instance--class standard-class-original-slot-copy))
  160.      (class-eq        (%allocate-instance--class standard-class-original-slot-copy))
  161.      (slot-class-wrapper      (make-wrapper slot-class))
  162.      (standard-class-wrapper  (make-wrapper standard-class))
  163.      (built-in-class-wrapper  (make-wrapper built-in-class))
  164.      (structure-class-wrapper (make-wrapper structure-class))
  165.      (direct-slotd-wrapper    (make-wrapper direct-slotd))
  166.      (effective-slotd-wrapper (make-wrapper effective-slotd))
  167.      (class-eq-wrapper        (make-wrapper class-eq)))
  168.     ;;
  169.     ;; First, make a class metaobject for each of the early classes.  For
  170.     ;; each metaobject we also set its wrapper.  Except for the class T,
  171.     ;; the wrapper is always that of STANDARD-CLASS.
  172.     ;; 
  173.     (dolist (definition *early-class-definitions*)
  174.       (let* ((name (ecd-class-name definition))
  175.          (meta (ecd-metaclass definition))
  176.          (original-slot-copy
  177.                (ecase meta
  178.          (slot-class slot-class-original-slot-copy)
  179.          (standard-class standard-class-original-slot-copy)
  180.          (built-in-class built-in-class-original-slot-copy)
  181.          (structure-class structure-class-original-slot-copy)))
  182.              (class (case name
  183.               (slot-class                         slot-class)
  184.                       (standard-class                     standard-class)
  185.                       (standard-direct-slot-definition    direct-slotd)
  186.               (standard-effective-slot-definition effective-slotd)
  187.               (built-in-class                     built-in-class)
  188.               (structure-class                    structure-class)
  189.               (class-eq-specializer               class-eq)
  190.                       (otherwise (%allocate-instance--class original-slot-copy)))))
  191.     (when (eq meta 'standard-class)
  192.       (inform-type-system-about-class class name))
  193.     (setf (std-instance-wrapper class)
  194.           (ecase meta
  195.         (slot-class slot-class-wrapper)
  196.         (standard-class standard-class-wrapper)
  197.         (built-in-class built-in-class-wrapper)
  198.         (structure-class structure-class-wrapper)))
  199.         (setf (find-class name) class)))
  200.     ;;
  201.     ;;
  202.     ;;
  203.     (dolist (definition *early-class-definitions*)
  204.       (let ((name (ecd-class-name definition))
  205.         (meta (ecd-metaclass definition))
  206.         (source (ecd-source definition))
  207.         (direct-supers (ecd-superclass-names definition))
  208.         (direct-slots  (ecd-canonical-slots definition))
  209.         (other-initargs (ecd-other-initargs definition)))
  210.     (let ((direct-default-initargs
  211.         (getf other-initargs :default-initargs)))
  212.       (multiple-value-bind (slots cpl default-initargs direct-subclasses)
  213.           (early-collect-inheritance name)
  214.             (declare (type list slots cpl default-initargs direct-subclasses))
  215.         (let* ((class (find-class name))
  216.            (wrapper
  217.              (cond
  218.                ((eq class slot-class)      slot-class-wrapper)
  219.                ((eq class standard-class)  standard-class-wrapper)
  220.                ((eq class direct-slotd)    direct-slotd-wrapper)
  221.                ((eq class effective-slotd) effective-slotd-wrapper)
  222.                ((eq class built-in-class)  built-in-class-wrapper)
  223.                ((eq class structure-class) structure-class-wrapper)
  224.                ((eq class class-eq)        class-eq-wrapper)
  225.                (t (make-wrapper class))))
  226.            (proto nil)
  227.                    (slot-names
  228.             (mapcar #'canonical-slot-name slots))
  229.                    (static-slot-copy
  230.                     (%allocate-origional-static-slot-storage-copy (length slot-names))))
  231.               (declare (type list slot-names))
  232.           (cond ((eq name 't)
  233.              (setq *the-wrapper-of-t* wrapper
  234.                *the-class-t* class))
  235.             ((memq name '(slot-object
  236.                   standard-object
  237.                   structure-object
  238.                   built-in-class
  239.                   slot-class
  240.                   standard-class
  241.                   funcallable-standard-class
  242.                   structure-class
  243.                   standard-direct-slot-definition
  244.                   standard-effective-slot-definition))
  245.              (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
  246.                   *the-pcl-package*)
  247.               class)))
  248.           (dolist (slot slots)
  249.         (unless (eq (getf slot :allocation :instance) :instance)
  250.           (error "Slot allocation ~S not supported in bootstrap.")))
  251.           
  252.           (setf (wrapper-instance-slots-layout wrapper) slot-names)
  253.           (setf (wrapper-allocate-static-slot-storage-copy wrapper)
  254.                     static-slot-copy)
  255.           (setf (wrapper-class-slots wrapper)
  256.             ())
  257.           
  258.           (setq proto (%allocate-instance--class static-slot-copy))
  259.           (setf (std-instance-wrapper proto) wrapper)
  260.         
  261.           (setq direct-slots
  262.             (bootstrap-make-slot-definitions 
  263.               name class direct-slots direct-slotd-wrapper nil))
  264.           (setq slots
  265.             (bootstrap-make-slot-definitions 
  266.               name class slots effective-slotd-wrapper t))
  267.           
  268.           (case meta
  269.         (standard-class
  270.          (bootstrap-initialize-standard-class
  271.           class name class-eq-wrapper source
  272.           direct-supers direct-subclasses cpl wrapper
  273.           direct-slots slots direct-default-initargs
  274.           default-initargs proto))
  275.         (built-in-class ; *the-class-t*
  276.          (bootstrap-initialize-built-in-class
  277.           class name class-eq-wrapper source
  278.           direct-supers direct-subclasses cpl wrapper
  279.           proto nil))
  280.         (slot-class ; *the-class-slot-object*
  281.          (bootstrap-initialize-built-in-class
  282.           class name class-eq-wrapper source
  283.           direct-supers direct-subclasses cpl wrapper
  284.           proto nil)
  285.          (bootstrap-set-slot 'slot-class class 'direct-slots nil)
  286.          (bootstrap-set-slot 'slot-class class 'slots nil)
  287.          (bootstrap-set-slot 'slot-class class 'internal-slotds nil)
  288.          (bootstrap-set-slot 'slot-class class
  289.                                      'side-effect-internal-slotds nil))
  290.         (structure-class ; *the-class-structure-object*
  291.          (bootstrap-initialize-structure-class
  292.           class name class-eq-wrapper source
  293.           direct-supers direct-subclasses cpl wrapper)))
  294.           
  295.           (let ((class-name 'standard-direct-slot-definition))
  296.         (dolist (slotd direct-slots)
  297.           (bootstrap-accessor-definitions
  298.             name
  299.             (bootstrap-get-slot class-name slotd 'name)
  300.             (bootstrap-get-slot class-name slotd 'readers)
  301.             (bootstrap-get-slot class-name slotd 'writers)))))))))))
  302.  
  303. (defun bootstrap-accessor-definitions (class-name slot-name readers writers)
  304.   (flet ((do-reader-definition (reader)
  305.            (let ((optimized-method-function
  306.                    (make-std-reader-method-function slot-name))
  307.                  (generic-function
  308.                    (ensure-generic-function reader)))
  309.              (add-method
  310.                generic-function
  311.                (make-a-method
  312.                  'standard-reader-method
  313.                  ()
  314.                  (list class-name)
  315.                  (list class-name)
  316.                  (when (call-store-method-function-p generic-function nil nil)
  317.                    (make-documented-std-reader-method-function slot-name))
  318.                  optimized-method-function
  319.                  NIL
  320.                  "automatically generated reader method"
  321.                  slot-name
  322.                  `(:needs-next-methods-p NIL)))))
  323.          (do-writer-definition (writer)
  324.            (let ((optimized-method-function
  325.                    (make-std-writer-method-function slot-name))
  326.                  (generic-function
  327.                    (ensure-generic-function writer)))
  328.              (add-method
  329.                generic-function
  330.                (make-a-method
  331.                  'standard-writer-method
  332.                  ()
  333.                  (list 'new-value class-name)
  334.                  (list 't class-name)
  335.                  (when (call-store-method-function-p generic-function nil nil)
  336.                    (make-documented-std-writer-method-function slot-name))
  337.                  optimized-method-function
  338.                  NIL
  339.                  "automatically generated writer method"
  340.                  slot-name
  341.                  `(:needs-next-methods-p NIL))))))
  342.     (dolist (reader readers) (do-reader-definition reader))
  343.     (dolist (writer writers) (do-writer-definition writer))))
  344.  
  345.  
  346. ;;;
  347. ;;; Initialize a standard class metaobject.
  348. ;;;
  349. (defun bootstrap-initialize-standard-class
  350.        (class
  351.     name class-eq-wrapper definition-source direct-supers direct-subclasses cpl
  352.     wrapper direct-slots slots direct-default-initargs default-initargs proto)
  353.   (declare (type list direct-slots slots))
  354.   (flet ((classes (names) (mapcar #'find-class names))
  355.      (set-slot (slot-name value)
  356.        (bootstrap-set-slot 'standard-class class slot-name value)))
  357.     (let ((class-precedence-list (classes cpl)))
  358.     
  359.       (set-slot 'default-initargs default-initargs)
  360.       (set-slot 'direct-slots direct-slots)
  361.       (set-slot 'direct-default-initargs direct-default-initargs)
  362.       (set-slot 'direct-subclasses (classes direct-subclasses))
  363.       (set-slot 'direct-superclasses (classes direct-supers))
  364.       (set-slot 'finalized-p T)
  365.       (set-slot 'name name)
  366.       (set-slot 'class-precedence-list class-precedence-list)
  367.       (set-slot 'prototype proto)
  368.       (set-slot 'slots slots)
  369.  
  370.       (set-slot 'cached-in-generic-functions ())
  371.       (set-slot 'can-precede-list (classes (cdr cpl)))
  372.       (set-slot 'class-eq-specializer 
  373.             (let ((spec (%allocate-instance--class
  374.                               (early-class-original-static-slot-storage-copy
  375.                                 'class-eq-specializer))))
  376.           (setf (std-instance-wrapper spec) class-eq-wrapper)
  377.           (bootstrap-set-slot 'class-eq-specializer spec 'type 
  378.                       `(class-eq ,class))
  379.           (bootstrap-set-slot 'class-eq-specializer spec 'object
  380.                       class)
  381.           spec))
  382.       (set-slot 'direct-methods (cons nil nil))
  383.       (set-slot 'incompatible-superclass-list nil)
  384.       (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
  385.                     (make-class-predicate-name name)))
  386.       (setf (wrapper-class-precedence-list wrapper) class-precedence-list)
  387.       (set-slot 'wrapper wrapper)
  388.  
  389.       (set-slot 'plist nil)
  390.       (set-slot 'source definition-source)
  391.       (set-slot 'type `(class ,class))
  392.       (set-slot 'documentation NIL)
  393.  
  394.       (let ((internal-slotds ())
  395.             (side-effect-internal-slotds ()))
  396.         (dolist (slot slots)
  397.           (let ((internal-slotd
  398.                   (bootstrap-get-slot 'standard-effective-slot-definition
  399.                                       slot 'internal-slotd)))
  400.             (push internal-slotd internal-slotds)
  401.             (unless (bootstrap-get-slot 'standard-effective-slot-definition
  402.                                         slot
  403.                                         'initfunction-side-effect-free-p)
  404.               (push internal-slotd side-effect-internal-slotds))))
  405.         (set-slot 'internal-slotds (nreverse internal-slotds))
  406.         (set-slot 'side-effect-internal-slotds
  407.                   (nreverse side-effect-internal-slotds)))
  408.       (setf (wrapper-allocate-static-slot-storage-copy wrapper)
  409.             (%allocate-origional-static-slot-storage-copy (length slots)))
  410.     )))
  411.  
  412. ;;;
  413. ;;; Initialize a built-in-class metaobject.
  414. ;;;
  415. (defun bootstrap-initialize-built-in-class
  416.        (class name class-eq-wrapper source direct-supers direct-subclasses cpl 
  417.     wrapper proto predicate-name)
  418.   (flet ((classes (names) (mapcar #'find-class names))
  419.      (set-slot (slot-name value)
  420.        (bootstrap-set-slot 'built-in-class class slot-name value)))
  421.  
  422.     (set-slot 'default-initargs ())
  423.     (set-slot 'direct-default-initargs ())
  424.     (set-slot 'direct-slots ())
  425.     (set-slot 'direct-subclasses (classes direct-subclasses))
  426.     (set-slot 'direct-superclasses (classes direct-supers))
  427.     (set-slot 'name name)
  428.     (set-slot 'finalized-p T)
  429.     (let ((real-cpl (classes cpl)))
  430.       (set-slot 'class-precedence-list real-cpl)
  431.       (setf (wrapper-class-precedence-list wrapper) real-cpl))
  432.     (set-slot 'prototype
  433.               (or proto
  434.           (let* ((proto (%allocate-instance--class *empty-vector*)))
  435.                    (setf (std-instance-wrapper proto) wrapper)
  436.                    proto)))
  437.     (set-slot 'slots ())
  438.  
  439.     (set-slot 'source source)
  440.     (set-slot 'type (if (eq class (find-class 't))
  441.             t
  442.             `(class ,class)))
  443.     (set-slot 'class-eq-specializer 
  444.            (let ((spec (%allocate-instance--class
  445.                              (early-class-original-static-slot-storage-copy
  446.                                 'class-eq-specializer))))
  447.          (setf (std-instance-wrapper spec) class-eq-wrapper)
  448.          (bootstrap-set-slot 'class-eq-specializer spec 'type 
  449.                      `(class-eq ,class))
  450.          (bootstrap-set-slot 'class-eq-specializer spec 'object 
  451.                      class)
  452.          spec))
  453.  
  454.     (set-slot 'direct-methods (cons nil nil))
  455.     (set-slot 'can-precede-list (classes (cdr cpl)))
  456.     (set-slot 'incompatible-superclass-list nil)
  457.     (set-slot 'internal-slotds nil)
  458.     (set-slot 'wrapper wrapper)
  459.     (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
  460.                   predicate-name
  461.                   (make-class-predicate-name name)))
  462.     (set-slot 'plist nil)
  463.     (set-slot 'documentation (format nil "Built-in-class ~S" name))))
  464.  
  465. (defun bootstrap-initialize-structure-class
  466.     (class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper)
  467.   (unless (eq name 'structure-object) (error "You forgot to do something"))
  468.   (flet ((classes (names) (mapcar #'find-class names))
  469.      (set-slot (slot-name value)
  470.        (bootstrap-set-slot 'structure-class class slot-name value)))
  471.     (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
  472.  
  473.       (set-slot 'default-initargs nil)
  474.       (set-slot 'direct-default-initargs nil)
  475.       (set-slot 'direct-slots nil)
  476.       (set-slot 'direct-subclasses (classes direct-subclasses))
  477.       (set-slot 'direct-superclasses (classes direct-supers))
  478.       (set-slot 'finalized-p T)
  479.       (set-slot 'name name)
  480.       (let ((real-cpl (classes cpl)))
  481.         (set-slot 'class-precedence-list real-cpl)
  482.         (setf (wrapper-class-precedence-list wrapper) real-cpl))
  483.       (set-slot 'prototype (funcall (symbol-function constructor-sym)))
  484.       (set-slot 'slots nil)
  485.  
  486.       (set-slot 'source source)
  487.       (set-slot 'type `(class ,class))
  488.       (set-slot 'class-eq-specializer 
  489.         (let ((spec (%allocate-instance--class
  490.                               (early-class-original-static-slot-storage-copy
  491.                                  'class-eq-specializer))))
  492.           (setf (std-instance-wrapper spec) class-eq-wrapper)
  493.           (bootstrap-set-slot 'class-eq-specializer spec 'type 
  494.                       `(class-eq ,class))
  495.           (bootstrap-set-slot 'class-eq-specializer spec 'object
  496.                       class)
  497.           spec))
  498.       (set-slot 'direct-methods (cons nil nil))
  499.       (set-slot 'can-precede-list (classes (cdr cpl)))
  500.       (set-slot 'incompatible-superclass-list nil)
  501.       (set-slot 'wrapper wrapper)
  502.       (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
  503.                     (make-class-predicate-name name)))
  504.       (set-slot 'internal-slotds nil)
  505.       (set-slot 'side-effect-internal-slotds nil)
  506.       (set-slot 'defstruct-conc-name "|STRUCTURE-OBJECT class ")
  507.       (set-slot 'defstruct-constructor constructor-sym)
  508.       (set-slot 'from-defclass-p t)    
  509.       (set-slot 'plist nil)
  510.       (set-slot 'documentation NIL))))
  511.  
  512. (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
  513.   (let ((index -1))
  514.     (declare (type fixnum index))
  515.     (mapcar #'(lambda (slot)
  516.         (incf index)
  517.         (bootstrap-make-slot-definition
  518.           name class slot wrapper effective-p index))
  519.         slots)))
  520.  
  521. (defvar *early-slot-names* (make-hash-table :test 'eq))
  522.  
  523. (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index)  
  524.   (declare (ignore name))
  525.   (let* ((slotd-class-name (if effective-p
  526.                    'standard-effective-slot-definition
  527.                    'standard-direct-slot-definition))
  528.      (slotd (%allocate-instance--class
  529.                   (early-class-original-static-slot-storage-copy slotd-class-name)))
  530.      (slot-name (getf slot :name)))
  531.     (setf (std-instance-wrapper slotd) wrapper)
  532.     (flet ((get-val (name) (getf slot name))
  533.        (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val)))
  534.       (let ((initfunction (get-val :initfunction))
  535.             (initargs     (get-val :initargs)))
  536.         (set-val 'name         slot-name)
  537.         (set-val 'initform     (get-val :initform))
  538.         (set-val 'initfunction initfunction)
  539.         (set-val 'initargs     initargs)
  540.         (set-val 'readers      (get-val :readers))
  541.         (set-val 'writers      (get-val :writers))
  542.         (set-val 'allocation   :instance)
  543.         (set-val 'type         (get-val :type))
  544.         (set-val 'class        class)
  545.         (set-val 'documentation (get-val :documentation))
  546.         (set-val 'initfunction-side-effect-free-p
  547.                  (get-val :initfunction-side-effect-free-p))
  548.         (when effective-p
  549.       (set-val 'location index)
  550.       (let* ((instance-type 'std-instance)
  551.                  (reader-function
  552.                    (make-optimized-std-reader-method-function 
  553.                  instance-type slot-name index))
  554.                  (writer-function
  555.                    (make-optimized-std-writer-method-function 
  556.                  instance-type slot-name index))
  557.                  (boundp-function
  558.                    (make-optimized-std-boundp-method-function 
  559.                  instance-type slot-name index)))
  560.         (set-val 'reader-function reader-function)
  561.         (set-val 'writer-function writer-function)
  562.         (set-val 'boundp-function boundp-function)
  563.         (set-val 'accessor-flags 7)
  564.             (let ((internal-slotd
  565.                     (make-internal-slotd :name            slot-name
  566.                                          :slot-definition slotd
  567.                                          :location        index
  568.                                          :initargs        initargs
  569.                                          :initfunction    initfunction
  570.                                          :reader-function reader-function
  571.                                          :writer-function writer-function
  572.                                          :boundp-function boundp-function)))
  573.               (set-val 'internal-slotd internal-slotd)))
  574.         (push (cons class slotd) (gethash slot-name *early-slot-names*))))
  575.       slotd)))
  576.  
  577. (defun early-initialize-slot-gfs ()
  578.   (maphash #'(lambda (name class+slotd-list)
  579.            (let ((table (or (gethash name *name->class->slotd-table*)
  580.                 (setf (gethash name *name->class->slotd-table*)
  581.                       (make-hash-table :test 'eq :size 5)))))
  582.          (dolist (c+s class+slotd-list)
  583.            (setf (gethash (car c+s) table) (cdr c+s)))
  584.                  (unless *safe-to-use-slot-value-wrapper-optimizations-p*
  585.                    (initialize-internal-slot-reader-gfs name))
  586.                  (unless *safe-to-use-set-slot-value-wrapper-optimizations-p*
  587.                    (initialize-internal-slot-writer-gfs name))
  588.                  (unless *safe-to-use-slot-boundp-wrapper-optimizations-p*
  589.                    (initialize-internal-slot-boundp-gfs name))))
  590.        *early-slot-names*)
  591.   (clrhash *early-slot-names*))
  592.  
  593. (defun early-initialize-class-predicates ()
  594.   (dolist (definition *early-class-definitions*)
  595.     (let* ((name (ecd-class-name definition))
  596.        (class (find-class name)))
  597.       (setf (find-class-predicate name)
  598.         (make-class-predicate class))))
  599.   (dolist (e *built-in-classes*)
  600.     (let* ((name (car e))
  601.        (class (find-class name))
  602.        (predicate-name (class-predicate-name class)))
  603.       (setf (find-class-predicate name)
  604.         (if (fboundp predicate-name)
  605.         (symbol-function predicate-name)
  606.         (make-class-predicate class))))))
  607.  
  608. (defun bootstrap-built-in-classes ()
  609.   ;;
  610.   ;; First make sure that all the supers listed in *built-in-class-lattice*
  611.   ;; are themselves defined by *built-in-class-lattice*.  This is just to
  612.   ;; check for typos and other sorts of brainos.
  613.   ;; 
  614.   (dolist (e *built-in-classes*)
  615.     (dolist (super (cadr e))
  616.       (unless (or (eq super 't)
  617.           (assq super *built-in-classes*))
  618.     (error "In *built-in-classes*: ~S has ~S as a super,~%~
  619.                 but ~S is not itself a class in *built-in-classes*."
  620.            (car e) super super))))
  621.  
  622.   ;;
  623.   ;; In the first pass, we create a skeletal object to be bound to the
  624.   ;; class name.
  625.   ;;
  626.   (let* ((built-in-class (find-class 'built-in-class))
  627.      (built-in-class-wrapper (class-wrapper built-in-class))
  628.      (built-in-class-original-slot-copy
  629.            (early-class-original-static-slot-storage-copy 'built-in-class)))
  630.     (dolist (e *built-in-classes*)
  631.       (let ((class (%allocate-instance--class built-in-class-original-slot-copy)))
  632.     (setf (std-instance-wrapper class) built-in-class-wrapper)
  633.     (setf (find-class (car e)) class))))
  634.  
  635.   ;;
  636.   ;; In the second pass, we initialize the class objects.
  637.   ;;
  638.   (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
  639.     (dolist (e *built-in-classes*)
  640.       (destructuring-bind (name supers subs cpl prototype predicate-name) e
  641.     (let* ((class (find-class name))
  642.            (wrapper (make-wrapper class)))
  643.       (set (get-built-in-class-symbol name) class)
  644.       (set (get-built-in-wrapper-symbol name) wrapper)
  645.  
  646.       (setf (wrapper-instance-slots-layout wrapper) ()
  647.             (wrapper-class-slots wrapper) ()
  648.                 (wrapper-allocate-static-slot-storage-copy wrapper) *empty-vector*)
  649.  
  650.       (bootstrap-initialize-built-in-class class
  651.                       name class-eq-wrapper nil
  652.                       supers subs
  653.                       (cons name cpl)
  654.                       wrapper prototype predicate-name))))))
  655.  
  656.  
  657. ;;;
  658. ;;;
  659. ;;;
  660.  
  661. (defun wrapper-of (x) 
  662.   (fast-wrapper-of x))
  663.  
  664. (defun class-of (x) (wrapper-class (fast-wrapper-of x)))
  665.  
  666. (defun structure-wrapper (x)
  667.   (class-wrapper (find-class (structure-type x))))
  668.  
  669. (defvar find-structure-class nil)
  670.  
  671. (defun make-defclass-direct-slots-from-defstruct (structure-name)
  672.   ;; Make the slot descriptions for defclass for structure STRUCTURE-NAME.
  673.   ;;   If the structure was defined with PCL's redefined Defstruct macro,
  674.   ;; build them from its trapped source.
  675.   ;;   Otherwise hope that the lisp's low file redefined
  676.   ;; Structure-type-slot-description-list et al. to get the info about
  677.   ;; the structure from the lisp's internal record.  If not, then oh well...
  678.   (let* ((defstruct-form (defstruct-form structure-name))
  679.          (conc-name (defstruct-form-conc-name defstruct-form)))
  680.     (declare (type simple-string conc-name))
  681.     (if defstruct-form
  682.         (mapcar
  683.           #'(lambda (descrip)
  684.               (let* ((name
  685.                        (if (listp descrip) (car descrip) descrip))
  686.                      (accessor-symbol
  687.                       (intern
  688.                         (concatenate 'simple-string
  689.                                      conc-name (symbol-name name))
  690.                         (symbol-package structure-name))))
  691.                 (if (listp descrip)
  692.                     `(:name ,name
  693.                       :initform ,(second descrip)
  694.                       ,@(when (memq :type descrip)
  695.                           `(:type ,(cadr (memq :type descrip))))
  696.                       :defstruct-accessor-symbol ,accessor-symbol)
  697.                     `(:name ,name
  698.                       :initform NIL
  699.                       :defstruct-accessor-symbol ,accessor-symbol))))
  700.           (cdr defstruct-form))
  701.         (if (known-structure-type-p structure-name)
  702.         (mapcar #'(lambda (slotd)
  703.                 `(:name ,(structure-slotd-name slotd)
  704.                   :defstruct-accessor-symbol 
  705.                   ,(structure-slotd-accessor-symbol slotd)
  706.                   :internal-reader-function 
  707.                   ,(structure-slotd-reader-function slotd)
  708.                   :internal-writer-function 
  709.                   ,(structure-slotd-writer-function slotd)))
  710.             (structure-type-slot-description-list structure-name))
  711.            NIL))))
  712.  
  713. (defun find-structure-class (symbol &key warn)
  714.   (when warn
  715.     (if (safe-subtypep symbol 'structure)
  716.         (warn "Creating class for structure ~S even though don't know anything about it.~%Class will likely have incorrect slots and superclass information"
  717.               symbol)
  718.         (warn "Guessing that ~S is a structure-class, even though don't know anything about it.~%Class will likely have incorrect slots and superclass information."
  719.               symbol)))
  720.   (unless (eq find-structure-class symbol)
  721.     (let ((find-structure-class symbol))
  722.        (ensure-class-using-class
  723.            symbol
  724.            NIL
  725.        :metaclass 'structure-class
  726.        :name symbol
  727.        :direct-superclasses
  728.        (when (structure-type-included-type-name symbol)
  729.          (list (structure-type-included-type-name symbol)))
  730.        :direct-slots
  731.              (make-defclass-direct-slots-from-defstruct symbol)))))
  732.  
  733. (eval-when (compile eval)
  734.  
  735. (defun make-built-in-class-subs ()
  736.   (mapcar #'(lambda (e)
  737.           (let ((class (car e))
  738.             (class-subs ()))
  739.         (dolist (s *built-in-classes*)
  740.           (when (memq class (cadr s)) (pushnew (car s) class-subs)))
  741.         (cons class class-subs)))
  742.       (cons '(t) *built-in-classes*)))
  743.  
  744. (defun make-built-in-class-tree ()
  745.   (let ((subs (make-built-in-class-subs)))
  746.     (labels ((descend (class)
  747.            (cons class (mapcar #'descend (cdr (assq class subs))))))
  748.       (descend 't))))
  749.  
  750. (defun make-built-in-wrapper-of-body ()
  751.   (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
  752.                    'x
  753.                    #'get-built-in-wrapper-symbol))
  754.  
  755. (defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
  756.   (let ((*specials* ()))
  757.     (declare (special *specials*))
  758.     (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
  759.       `(locally (declare (special .,*specials*)) ,inner))))
  760.  
  761. (defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
  762.   (declare (special *specials*))
  763.   (let ((symbol (funcall get-symbol (car tree))))
  764.     (push symbol *specials*)
  765.     (let ((sub-tests
  766.         (mapcar #'(lambda (x)
  767.             (make-built-in-wrapper-of-body-2 x var get-symbol))
  768.             (cdr tree))))
  769.       `(and (typep ,var ',(car tree))
  770.         ,(if sub-tests
  771.          `(or ,.sub-tests ,symbol)
  772.          symbol)))))
  773. )
  774.  
  775. (defun built-in-wrapper-of (x)
  776.   #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file
  777.       (make-built-in-wrapper-of-body)))
  778.  
  779.  
  780.  
  781.  
  782. (eval-when (load eval)
  783.   (clrhash *find-class*)
  784.   (bootstrap-meta-braid)
  785.   (bootstrap-built-in-classes)
  786.   (early-initialize-slot-gfs)
  787.   (early-initialize-class-predicates)
  788.   (setq *boot-state* 'braid)
  789.   (setf (symbol-function 'load-defclass) #'real-load-defclass)
  790.   )
  791.  
  792. (deftype slot-object ()
  793.   '(or standard-object structure-object))
  794.  
  795.  
  796. ;;;
  797. ;;; All of these method definitions must appear here because the bootstrap
  798. ;;; only allows one method per generic function until the braid is fully
  799. ;;; built.
  800. ;;;
  801. (defmethod print-object (instance stream)
  802.   (printing-random-thing (instance stream)
  803.     (let ((name (class-name (class-of instance))))
  804.       (if name
  805.       (format stream "~S" name)
  806.       (format stream "Instance")))))
  807.  
  808. (defmethod print-object ((class class) stream)
  809.   (named-object-print-function class stream))
  810.  
  811. (defmethod print-object ((slotd slot-definition) stream)
  812.   (named-object-print-function slotd stream))
  813.  
  814. (defun named-object-print-function (instance stream
  815.                     &optional (extra nil extra-p))
  816.   (printing-random-thing (instance stream)
  817.     (if extra-p                    
  818.     (format stream "~A ~S ~:S"
  819.         (capitalize-words (class-name (class-of instance)))
  820.         (slot-value-or-default instance 'name)
  821.         extra)
  822.     (format stream "~A ~S"
  823.         (capitalize-words (class-name (class-of instance)))
  824.         (slot-value-or-default instance 'name)))))
  825.  
  826.  
  827.  
  828. ;;;
  829. ;;;
  830. ;;;
  831. (defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key)
  832.   (declare (ignore slot-names))
  833.   (if (eq (slot-value slotd 'allocation) :class)
  834.       (setf (slot-value slotd 'allocation)
  835.             (slot-value slotd 'class))))
  836.  
  837. (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names 
  838.                      &key (allocation :instance))
  839.   (declare (ignore slot-names))
  840.   (unless (eq allocation :instance)
  841.     (error "structure slots must have :instance allocation")))
  842.  
  843.  
  844. (defmethod inform-type-system-about-class ((class structure-class) name)
  845.   (inform-type-system-about-std-class name))
  846.  
  847.