Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

Diff of /src/clos/builtin.lsp [661db1] .. [e5072a] Maximize Restore

  Switch to side-by-side view

--- a/src/clos/builtin.lsp
+++ b/src/clos/builtin.lsp
@@ -18,45 +18,9 @@
 (defmethod change-class ((instance t) (new-class symbol))
   (funcall #'change-class instance (find-class new-class)))
 
-;;; ----------------------------------------------------------------------
-;;; Structures
-;;; ----------------------------------------------------------------------
-
-(defun create-structure-class (name
-			       superclasses-names
-			       direct-slots all-slots
-			       default-initargs documentation)
-  (declare (ignore default-initargs direct-slots))
-  (dolist (slot all-slots)
-    (unless (eq :INSTANCE (slotd-allocation slot))
-      (error "The structure class ~S can't have shared slots" name)))
-  (let* ((metaclass (find-class 'STRUCTURE-CLASS))
-	 (existing (find-class name nil))
-	 (superclasses (mapcar #'find-class superclasses-names))
-	 (cpl (compute-class-precedence-list name superclasses)))
-
-    (flet ((unchanged-class ()
-	     (and existing
-		  (eq metaclass (si:instance-class existing))
-		  (equal (or superclasses-names '(STRUCTURE-OBJECT))
-			 ;; i.e. class-default-direct-superclasses
-			 (mapcar #'class-name
-				 (class-direct-superclasses existing)))
-		  (equal all-slots (slot-value existing 'SLOTS))
-		  (prog2 (setf (slot-value existing 'DOCUMENTATION)
-			       documentation)
-		      t))))
-
-      (if (unchanged-class)
-	  existing
-	  (make-instance metaclass
-			 :name name
-			 :direct-superclasses superclasses
-			 :slots all-slots
-			 :class-precedence-list cpl)))))
-
-;;; -----------------------------------------------------------------------
-;;; Structure-class
+;;; ======================================================================
+;;; STRUCTURES
+;;;
 
 (defclass structure-class (class)
   (slot-descriptions initial-offset defstruct-form constructors documentation
@@ -67,23 +31,15 @@
   (declare (ignore initargs))
   (error "The structure-class (~A) cannot be instantiated" class))
 
-;;; the method to initialize the instances of structure-class
-(defmethod initialize-instance ((class structure-class)
-				&rest initargs &key &allow-other-keys)
-  (call-next-method)				; from class T
-    
-  ;; if the class has a name register it in hash table
-  (when (system:sl-boundp (class-name class))
-    (setf (find-class (class-name class)) class))
-
-  (dolist (s (class-direct-superclasses class))	; inheritance lattice
-    (push class (class-direct-subclasses s)))
-  (push class (slot-value class 'PRECEDENCE-LIST)) ;; add itself in cpl
-  class)
+(defmethod finalize-inheritance ((class structure-class))
+  (call-next-method)
+  (dolist (slot (class-slots class))
+    (unless (eq :INSTANCE (slotd-allocation slot))
+      (error "The structure class ~S can't have shared slots" name))))
 
 ;;; ----------------------------------------------------------------------
 ;;; Structure-object
-;;; ----------------------------------------------------------------------
+;;;
 
 ;;; Structure-object has no slots and inherits only from t:
 ;;; (defclass structure-object (t) ())
@@ -110,7 +66,7 @@
     (princ ")" stream)
     obj))
 
-;;; ----------------------------------------------------------------------
+;;; ======================================================================
 ;;; Built-in classes
 ;;; ----------------------------------------------------------------------
 ;;;
@@ -126,38 +82,28 @@
 
 (defun create-built-in-class (options)
   (let* ((name (first options))
-	 (direct-superclasses (mapcar #'find-class (rest options))))
-    (make-instance (find-class 'built-in-class)
-		   :name name
-		   :direct-superclasses direct-superclasses
-		   :slots nil)))
+	 (direct-superclasses (mapcar #'find-class (or (rest options)
+						       '(t)))))
+    (setf (find-class name)
+	  (make-instance (find-class 'built-in-class)
+			 :name name
+			 :direct-superclasses direct-superclasses
+			 :direct-slots nil))))
 
 (defmethod make-instance ((class built-in-class) &rest initargs)
   (declare (ignore initargs))
   (error "The built-in class (~A) cannot be instantiated" class))
 
-(defmethod initialize-instance ((class built-in-class)
-				&key name direct-superclasses)
-  (let* ((cpl (compute-class-precedence-list name direct-superclasses)))
-    (setf (class-name class) name
-	  (class-direct-superclasses class) direct-superclasses
-	  (class-direct-subclasses class) nil
-	  (class-precedence-list class) cpl
-	  (find-class name) class)
-    (dolist (s direct-superclasses)
-      (push class (class-direct-subclasses s)))))
-
-(eval-when (compile load eval)
-  (mapcar #'create-built-in-class
+(mapcar #'create-built-in-class
 	  '(;(t object)
-	    (sequence t)
+	    (sequence)
 	      (list sequence)
 	        (cons list)
-	    (array t)
+	    (array)
 	      (vector array sequence)
 	        (string vector)
 	        (bit-vector vector)
-	    (stream t)
+	    (stream)
 	      (file-stream stream)
 	      (echo-stream stream)
 	      (string-stream stream)
@@ -165,21 +111,22 @@
 	      (synonym-stream stream)
 	      (broadcast-stream stream)
 	      (concatenated-stream stream)
-	    (character t)
-	    (number t)
+	    (character)
+	    (number)
 	      (real number)
 	        (rational real)
 		  (integer rational)
 		  (ratio rational)
 	        (float real)
 	      (complex number)
-	    (symbol t)
+	    (symbol)
 	      (null symbol list)
 	      (keyword symbol)
-	    (package t)
-	    (function t)
-	    (pathname t)
+	    (method-combination)
+	    (package)
+	    (function)
+	    (pathname)
 	      (logical-pathname pathname)
-	    (hash-table t)
+	    (hash-table)
 	    (random-state)
-	    (readtable))))
+	    (readtable)))