Diff of /src/clos/boot.lsp [3fc093] .. [88db3f] Maximize Restore

  Switch to side-by-side view

--- a/src/clos/boot.lsp
+++ b/src/clos/boot.lsp
@@ -12,292 +12,17 @@
 
 (in-package "CLOS")
 
-;;; ----------------------------------------------------------------------
-;;; Class SPECIALIZER
-
-(eval-when (:compile-toplevel :execute)
-  (defparameter +specializer-slots+
-    '((flag :initform nil :accessor eql-specializer-flag)
-      (direct-methods :initform nil :accessor specializer-direct-methods)
-      (direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)))
-  (defparameter +eql-specializer-slots+
-    '((flag :initform t :accessor eql-specializer-flag)
-      (direct-methods :initform nil :accessor specializer-direct-methods)
-      (direct-generic-functions :initform nil :accessor specializer-direct-generic-functions)
-      (object :initarg :object :accessor eql-specializer-object))))
-
-;;; ----------------------------------------------------------------------
-;;; Class METHOD-COMBINATION
-
-(eval-when (:compile-toplevel :execute)
-  (defparameter +method-combination-slots+
-    `((name :initform :name :accessor method-combination-name)
-      (compiler :initform :compiler :accessor method-combination-compiler)
-      (options :initform :options :accessor method-combination-options))))
-
-;;; ----------------------------------------------------------------------
-;;; Class CLASS
-
-(eval-when (:compile-toplevel :execute)
-  (defparameter +class-slots+
-    `(,@+specializer-slots+
-      (name :initarg :name :initform nil :accessor class-id)
-      (direct-superclasses :initarg :direct-superclasses
-       :accessor class-direct-superclasses)
-      (direct-subclasses :initform nil :accessor class-direct-subclasses)
-      (slots :accessor class-slots)
-      (precedence-list :accessor class-precedence-list)
-      (direct-slots :initarg :direct-slots :accessor class-direct-slots)
-      (direct-default-initargs :initarg :direct-default-initargs
-       :initform nil :accessor class-direct-default-initargs)
-      (default-initargs :accessor class-default-initargs)
-      (finalized :initform nil :accessor class-finalized-p)
-      (docstring :initarg :documentation :initform nil)
-      (size :accessor class-size)
-      (sealedp :initarg :sealedp :initform nil :accessor class-sealedp)
-      (prototype)
-      (dependents :initform nil :accessor class-dependents)
-      (valid-initargs :accessor class-valid-initargs)))
-
-  (defconstant +class-name-ndx+
-    (position 'name +class-slots+ :key #'first))
-  (defconstant +class-precedence-list-ndx+
-    (position 'precedence-list +class-slots+ :key #'first)))
-
-;;; ----------------------------------------------------------------------
-;;; STANDARD-CLASS
-
-(eval-when (:compile-toplevel :execute)
-  (defparameter +standard-class-slots+
-    (append +class-slots+
-	    '((slot-table :accessor slot-table)
-	      (optimize-slot-access)
-	      (forward)))))
-
-;;; ----------------------------------------------------------------------
-;;; STANDARD-GENERIC-FUNCTION
-
-(eval-when (:compile-toplevel :execute)
-  (defparameter +standard-generic-function-slots+
-    '((name :initarg :name :initform nil
-       :accessor generic-function-name)
-      (spec-list :initform nil :accessor generic-function-spec-list)
-      (method-combination 
-       :initarg :method-combination :initform (find-method-combination (class-prototype (find-class 'standard-generic-function)) 'standard nil)
-       :accessor generic-function-method-combination)
-      (lambda-list :initarg :lambda-list
-       :accessor generic-function-lambda-list)
-      (argument-precedence-order 
-       :initarg :argument-precedence-order
-       :initform nil
-       :accessor generic-function-argument-precedence-order)
-      (method-class
-       :initarg :method-class
-       :initform (find-class 'standard-method))
-      (docstring :initarg :documentation :initform nil)
-      (methods :initform nil :accessor generic-function-methods)
-      (a-p-o-function :initform nil :accessor generic-function-a-p-o-function)
-      (declarations
-       :initarg :declarations
-       :initform nil
-       :accessor generic-function-declarations)
-      (dependents :initform nil :accessor generic-function-dependents))))
-
-;;; ----------------------------------------------------------------------
-;;; STANDARD-METHOD
-
-(eval-when (:compile-toplevel :execute)
-  (defparameter +standard-method-slots+
-    '((the-generic-function :initarg :generic-function :initform nil
-       :accessor method-generic-function)
-      (lambda-list :initarg :lambda-list
-       :accessor method-lambda-list)
-      (specializers :initarg :specializers :accessor method-specializers)
-      (qualifiers :initform nil :initarg :qualifiers :accessor method-qualifiers)
-      (the-function :initarg :function :accessor method-function)
-      (docstring :initarg :documentation :initform nil)
-      (plist :initform nil :initarg :plist :accessor method-plist)
-      (keywords :initform nil :accessor method-keywords)))
-
-  (defparameter +standard-accessor-method-slots+
-    (append +standard-method-slots+
-	    '((slot-definition :initarg :slot-definition
-		    :initform nil 
-	       ;; FIXME! Should be a :reader
-		    :accessor accessor-method-slot-definition)))))
-
-;;; ----------------------------------------------------------------------
-(eval-when (:compile-toplevel :execute)
-  ;;
-  ;; All changes to this are connected to the changes in 
-  ;; the code of cl_class_of() in src/instance.d
-  ;;
-  (defconstant +builtin-classes-list+
-	 '(;(t object)
-	    (sequence)
-	      (list sequence)
-	        (cons list)
-	    (array)
-	      (vector array sequence)
-	        (string vector)
-                #+unicode
-	        (base-string string vector)
-	        (bit-vector vector)
-	    (stream)
-	      (ext:ansi-stream stream)
-		(file-stream ext:ansi-stream)
-		(echo-stream ext:ansi-stream)
-		(string-stream ext:ansi-stream)
-		(two-way-stream ext:ansi-stream)
-		(synonym-stream ext:ansi-stream)
-		(broadcast-stream ext:ansi-stream)
-		(concatenated-stream ext:ansi-stream)
-		(ext:sequence-stream ext:ansi-stream)
-	    (character)
-	    (number)
-	      (real number)
-	        (rational real)
-		  (integer rational)
-		  (ratio rational)
-	        (float real)
-	      (complex number)
-	    (symbol)
-	      (null symbol list)
-	      (keyword symbol)
-	    (package)
-	    (function)
-	    (pathname)
-	      (logical-pathname pathname)
-	    (hash-table)
-	    (random-state)
-	    (readtable)
-            (si::code-block)
-	    (si::foreign-data)
-	    (si::frame)
-	    (si::weak-pointer)
-	    #+threads (mp::process)
-	    #+threads (mp::lock)
-	    #+threads (mp::rwlock)
-	    #+threads (mp::condition-variable)
-	    #+threads (mp::semaphore)
-	    #+threads (mp::barrier)
-	    #+threads (mp::mailbox)
-	    #+sse2 (ext::sse-pack))))
-
-(defconstant +builtin-classes-pre-array+ (make-array (1+ #.(length +builtin-classes-list+))))
-
-;;; FROM AMOP:
-;;;
-;;;	Metaobject Class		Direct Superclasses
-;;; 	standard-object			(t)
-;;; 	funcallable-standard-object	(standard-object function)
-;;; *	metaobject			(standard-object)
-;;; *	generic-function		(metaobject funcallable-standard-object)
-;;; 	standard-generic-function	(generic-function)
-;;; *	method				(metaobject)
-;;; 	standard-method			(method)
-;;; *	standard-accessor-method	(standard-method)
-;;; 	standard-reader-method		(standard-accessor-method)
-;;; 	standard-writer-method		(standard-accessor-method)
-;;; *	method-combination		(metaobject)
-;;; *	slot-definition			(metaobject)
-;;; *	direct-slot-definition		(slot-definition)
-;;; *	effective-slot-definition	(slot-definition)
-;;; *	standard-slot-definition	(slot-definition)
-;;; 	standard-direct-slot-definition	(standard-slot-definition direct-slot-definition)
-;;; 	standard-effective-slot-definition	(standard-slot-definition effective-slot-definition)
-;;; *	specializer			(metaobject)
-;;; 	eql-specializer			(specializer)
-;;; *	class				(specializer)
-;;; 	built-in-class			(class)
-;;; 	forward-referenced-class	(class)
-;;; 	standard-class			(class)
-;;; 	funcallable-standard-class	(class)
-;;;
-(eval-when (eval)
-  (defconstant +class-hierarchy+
-    `((standard-class
-       :metaclass nil) ; Special-cased below
-      (t
-       :index 0)
-      (standard-object
-       :direct-superclasses (t))
-      (metaobject
-       :direct-superclasses (standard-object))
-      (method-combination
-       :direct-superclasses (metaobject)
-       :direct-slots #.+method-combination-slots+)
-      (specializer
-       :direct-superclasses (metaobject)
-       :direct-slots #.+specializer-slots+)
-      (eql-specializer
-       :direct-superclasses (specializer)
-       :direct-slots #.+eql-specializer-slots+)
-      (class
-       :direct-superclasses (specializer)
-       :direct-slots #.+class-slots+)
-      (forward-referenced-class
-       :direct-superclasses (class)
-       :direct-slots #.+class-slots+)
-      (built-in-class
-       :direct-superclasses (class)
-       :direct-slots #1=#.+standard-class-slots+)
-      (std-class
-       :direct-superclasses (class)
-       :direct-slots #1#)
-      (standard-class
-       :direct-superclasses (std-class)
-       :direct-slots #1#
-       :metaclass standard-class)
-      (funcallable-standard-class
-       :direct-superclasses (std-class)
-       :direct-slots #1#)
-      ,@(loop for (name . rest) in +builtin-classes-list+
-	   for index from 1
-	   collect (list name :metaclass 'built-in-class
-			 :index index
-			 :direct-superclasses (or rest '(t))))
-      (funcallable-standard-object
-       :direct-superclasses (standard-object function))
-      (generic-function
-       :metaclass funcallable-standard-class
-       :direct-superclasses (metaobject funcallable-standard-object))
-      (standard-generic-function
-       :direct-superclasses (generic-function)
-       :direct-slots #.+standard-generic-function-slots+
-       :metaclass funcallable-standard-class)
-      (method
-       :direct-superclasses (metaobject))
-      (standard-method
-       :direct-superclasses (method)
-       :direct-slots #.+standard-method-slots+)
-      (standard-accessor-method
-       :direct-superclasses (standard-method)
-       :direct-slots #2=#.+standard-accessor-method-slots+)
-      (standard-reader-method
-       :direct-superclasses (standard-accessor-method)
-       :direct-slots #2#)
-      (standard-writer-method
-       :direct-superclasses (standard-accessor-method)
-       :direct-slots #2#)
-      )))
+(defconstant +builtin-classes-pre-array+
+  (make-array (1+ #.(length +builtin-classes-list+))))
 
 ;;; ----------------------------------------------------------------------
 ;;; Early accessors and class construction
 ;;;
-
+;;;
+;;; The following macro is also used at bootstap for instantiating
+;;; a class based only on the s-form description.
+;;;
 (eval-when (:compile-toplevel :execute)
-  (defmacro with-early-accessors ((&rest slot-definitions) &rest body)
-    `(macrolet
-	 ,(loop for slots in slot-definitions
-	     nconc (loop for (name . slotd) in (if (symbolp slots)
-						   (symbol-value slots)
-						   slots)
-		      for index from 0
-		      for accessor = (getf slotd :accessor)
-		      when accessor
-		      collect `(,accessor (object) `(si::instance-ref ,object ,,index))))
-       ,@body))
   (defmacro with-early-make-instance (slots (object class &rest key-value-pairs)
 				      &rest body)
     (when (symbolp slots)