micro-optimize SKIP-FAST-SLOT-ACCESS-P

[sbcl.git] / src / pcl / macros.lisp

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index 3c98492..ad4e24f 100644 (file)
--- a/src/pcl/macros.lisp
+++ b/src/pcl/macros.lisp
@@ -29,18 +29,18 @@
 (/show "starting pcl/macros.lisp")
 
 (declaim (declaration
 (/show "starting pcl/macros.lisp")
 
 (declaim (declaration

-         ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration
-         ;; to propagate information needed to set up nice debug
-         ;; names (as seen e.g. in BACKTRACE) for method functions.
-         %method-name
-         ;; These nonstandard declarations seem to be used privately
-         ;; within PCL itself to pass information around, so we can't
-         ;; just delete them.
-         %class
-         %method-lambda-list
-         ;; This declaration may also be used within PCL to pass
-         ;; information around, I'm not sure. -- WHN 2000-12-30
-         %variable-rebinding))
+          ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration
+          ;; to propagate information needed to set up nice debug
+          ;; names (as seen e.g. in BACKTRACE) for method functions.
+          %method-name
+          ;; These nonstandard declarations seem to be used privately
+          ;; within PCL itself to pass information around, so we can't
+          ;; just delete them.
+          %class
+          %method-lambda-list
+          ;; This declaration may also be used within PCL to pass
+          ;; information around, I'm not sure. -- WHN 2000-12-30
+          %variable-rebinding))

 
 (/show "done with DECLAIM DECLARATION")
 
 
 (/show "done with DECLAIM DECLARATION")
 

@@ -48,30 +48,30 @@
   (dolist (d declarations default)
     (dolist (form (cdr d))
       (when (and (consp form) (eq (car form) name))
   (dolist (d declarations default)
     (dolist (form (cdr d))
       (when (and (consp form) (eq (car form) name))

-       (return-from get-declaration (cdr form))))))
+        (return-from get-declaration (cdr form))))))

 
 (/show "pcl/macros.lisp 85")
 
 (defmacro doplist ((key val) plist &body body)
   `(let ((.plist-tail. ,plist) ,key ,val)
      (loop (when (null .plist-tail.) (return nil))
 
 (/show "pcl/macros.lisp 85")
 
 (defmacro doplist ((key val) plist &body body)
   `(let ((.plist-tail. ,plist) ,key ,val)
      (loop (when (null .plist-tail.) (return nil))

-          (setq ,key (pop .plist-tail.))
-          (when (null .plist-tail.)
-            (error "malformed plist, odd number of elements"))
-          (setq ,val (pop .plist-tail.))
-          (progn ,@body))))
+           (setq ,key (pop .plist-tail.))
+           (when (null .plist-tail.)
+             (error "malformed plist, odd number of elements"))
+           (setq ,val (pop .plist-tail.))
+           (progn ,@body))))

 
 (/show "pcl/macros.lisp 101")
 
 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
   `(let ((,var nil)
 
 (/show "pcl/macros.lisp 101")
 
 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
   `(let ((,var nil)

-        (.dolist-carefully. ,list))
+         (.dolist-carefully. ,list))

      (loop (when (null .dolist-carefully.) (return nil))
      (loop (when (null .dolist-carefully.) (return nil))

-          (if (consp .dolist-carefully.)
-              (progn
-                (setq ,var (pop .dolist-carefully.))
-                ,@body)
-              (,improper-list-handler)))))
+           (if (consp .dolist-carefully.)
+               (progn
+                 (setq ,var (pop .dolist-carefully.))
+                 ,@body)
+               (,improper-list-handler)))))

 \f
 ;;;; FIND-CLASS
 ;;;;
 \f
 ;;;; FIND-CLASS
 ;;;;

@@ -87,9 +87,6 @@
 (defmacro find-class-cell-predicate (cell)
   `(cadr ,cell))
 
 (defmacro find-class-cell-predicate (cell)
   `(cadr ,cell))
 

-(defmacro find-class-cell-make-instance-function-keys (cell)
-  `(cddr ,cell))
-

 (defmacro make-find-class-cell (class-name)
   (declare (ignore class-name))
   '(list* nil #'constantly-nil nil))
 (defmacro make-find-class-cell (class-name)
   (declare (ignore class-name))
   '(list* nil #'constantly-nil nil))

@@ -97,9 +94,9 @@
 (defun find-class-cell (symbol &optional dont-create-p)
   (or (gethash symbol *find-class*)
       (unless dont-create-p
 (defun find-class-cell (symbol &optional dont-create-p)
   (or (gethash symbol *find-class*)
       (unless dont-create-p

-       (unless (legal-class-name-p symbol)
-         (error "~S is not a legal class name." symbol))
-       (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
+        (unless (legal-class-name-p symbol)
+          (error "~S is not a legal class name." symbol))
+        (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))

 
 (/show "pcl/macros.lisp 157")
 
 
 (/show "pcl/macros.lisp 157")
 

@@ -108,18 +105,13 @@
 (defun find-class-from-cell (symbol cell &optional (errorp t))
   (or (find-class-cell-class cell)
       (and *create-classes-from-internal-structure-definitions-p*
 (defun find-class-from-cell (symbol cell &optional (errorp t))
   (or (find-class-cell-class cell)
       (and *create-classes-from-internal-structure-definitions-p*

-          (structure-type-p symbol)
-          (find-structure-class symbol))
+           (or (structure-type-p symbol) (condition-type-p symbol))
+           (ensure-non-standard-class symbol))

       (cond ((null errorp) nil)
       (cond ((null errorp) nil)

-           ((legal-class-name-p symbol)
-            (error "There is no class named ~S." symbol))
-           (t
-            (error "~S is not a legal class name." symbol)))))
-
-(defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
-  (unless (find-class-cell-class cell)
-    (find-class-from-cell symbol cell errorp))
-  (find-class-cell-predicate cell))
+            ((legal-class-name-p symbol)
+             (error "There is no class named ~S." symbol))
+            (t
+             (error "~S is not a legal class name." symbol)))))

 
 (defun legal-class-name-p (x)
   (symbolp x))
 
 (defun legal-class-name-p (x)
   (symbolp x))

@@ -127,14 +119,9 @@
 (defun find-class (symbol &optional (errorp t) environment)
   (declare (ignore environment))
   (find-class-from-cell symbol
 (defun find-class (symbol &optional (errorp t) environment)
   (declare (ignore environment))
   (find-class-from-cell symbol

-                       (find-class-cell symbol errorp)
-                       errorp))
+                        (find-class-cell symbol errorp)
+                        errorp))

 
 

-(defun find-class-predicate (symbol &optional (errorp t) environment)
-  (declare (ignore environment))
-  (find-class-predicate-from-cell symbol
-                                 (find-class-cell symbol errorp)
-                                 errorp))

 \f
 ;;; This DEFVAR was originally in defs.lisp, now moved here.
 ;;;
 \f
 ;;; This DEFVAR was originally in defs.lisp, now moved here.
 ;;;

@@ -147,47 +134,62 @@
 (/show "pcl/macros.lisp 187")
 
 (define-compiler-macro find-class (&whole form
 (/show "pcl/macros.lisp 187")
 
 (define-compiler-macro find-class (&whole form

-                                  symbol &optional (errorp t) environment)
+                                   symbol &optional (errorp t) environment)

   (declare (ignore environment))
   (if (and (constantp symbol)
   (declare (ignore environment))
   (if (and (constantp symbol)

-          (legal-class-name-p (eval symbol))
-          (constantp errorp)
-          (member *boot-state* '(braid complete)))
-      (let ((symbol (eval symbol))
-           (errorp (not (null (eval errorp))))
-           (class-cell (make-symbol "CLASS-CELL")))    
-       `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
-          (or (find-class-cell-class ,class-cell)
-              ,(if errorp
-                   `(find-class-from-cell ',symbol ,class-cell t)
-                   `(and (classoid-cell-classoid
-                          ',(find-classoid-cell symbol))
-                         (find-class-from-cell ',symbol ,class-cell nil))))))
+           (legal-class-name-p (setf symbol (constant-form-value symbol)))
+           (constantp errorp)
+           (member *boot-state* '(braid complete)))
+      (let ((errorp (not (null (constant-form-value errorp))))
+            (class-cell (make-symbol "CLASS-CELL")))
+        `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
+           (or (find-class-cell-class ,class-cell)
+               ,(if errorp
+                    `(find-class-from-cell ',symbol ,class-cell t)
+                    `(and (classoid-cell-classoid
+                           ',(find-classoid-cell symbol))
+                          (find-class-from-cell ',symbol ,class-cell nil))))))

       form))
 
       form))
 

-(defun (setf find-class) (new-value symbol)
-  (if (legal-class-name-p symbol)
-      (let ((cell (find-class-cell symbol)))
-       (setf (find-class-cell-class cell) new-value)
-       (when (or (eq *boot-state* 'complete)
-                 (eq *boot-state* 'braid))
-         (when (and new-value (class-wrapper new-value))
-           (setf (find-class-cell-predicate cell)
-                 (fdefinition (class-predicate-name new-value))))
-         (update-ctors 'setf-find-class :class new-value :name symbol))
-       new-value)
-      (error "~S is not a legal class name." symbol)))
-
-(/show "pcl/macros.lisp 230")
-
-(defun (setf find-class-predicate)
-       (new-value symbol)
-  (if (legal-class-name-p symbol)
-    (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
-    (error "~S is not a legal class name." symbol)))
-
-(defun find-wrapper (symbol)
-  (class-wrapper (find-class symbol)))
+(defun (setf find-class) (new-value name &optional errorp environment)
+  (declare (ignore errorp environment))
+  (cond ((legal-class-name-p name)
+         (with-single-package-locked-error
+             (:symbol name "using ~A as the class-name argument in ~
+                           (SETF FIND-CLASS)"))
+         (let* ((cell (find-class-cell name))
+                (class (find-class-cell-class cell)))
+           (setf (find-class-cell-class cell) new-value)
+           (when (eq *boot-state* 'complete)
+             (if (null new-value)
+                 (progn
+                   (setf (find-classoid name) new-value)
+                   (when class
+                     ;; KLUDGE: This horror comes about essentially
+                     ;; because we use the proper name of a classoid
+                     ;; to do TYPEP, which needs to be available
+                     ;; early, and also to determine whether TYPE-OF
+                     ;; should return the name or the class (using
+                     ;; CLASSOID-PROPER-NAME).  So if we are removing
+                     ;; proper nameness, arrange for
+                     ;; CLASSOID-PROPER-NAME to do the right thing
+                     ;; too.  (This is almost certainly not the right
+                     ;; solution; instead, CLASSOID-NAME and
+                     ;; FIND-CLASSOID should be direct parallels to
+                     ;; CLASS-NAME and FIND-CLASS, and TYPEP on
+                     ;; not-yet-final classes should be compileable.
+                     (let ((classoid (layout-classoid (slot-value class 'wrapper))))
+                       (setf (classoid-name classoid) nil))))
+
+                 (let ((classoid (layout-classoid (slot-value new-value 'wrapper))))
+                   (setf (find-classoid name) classoid)
+                   (set-class-type-translation new-value classoid))))
+           (when (or (eq *boot-state* 'complete)
+                     (eq *boot-state* 'braid))
+             (update-ctors 'setf-find-class :class new-value :name name))
+           new-value))
+        (t
+         (error "~S is not a legal class name." name))))

 
 (/show "pcl/macros.lisp 241")
 
 
 (/show "pcl/macros.lisp 241")