Fix cut-to-width in the presence of bad constants in dead code.

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

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index 3c98492..437e802 100644 (file)
--- a/src/pcl/macros.lisp
+++ b/src/pcl/macros.lisp
@@ -29,18 +29,13 @@
 (/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))
+          ;; These nonstandard declarations seem to be used privately
+          ;; within PCL itself to pass information around, so we can't
+          ;; just delete them.
+          %class
+          ;; 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 +43,21 @@
   (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")
 
 
 (/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))))
-

 (/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
 ;;;;

@@ -79,115 +65,86 @@
 
 (/show "pcl/macros.lisp 119")
 
 
 (/show "pcl/macros.lisp 119")
 

-(defvar *find-class* (make-hash-table :test 'eq))
-
-(defmacro find-class-cell-class (cell)
-  `(car ,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))
-
-(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)))))
-
-(/show "pcl/macros.lisp 157")
+(declaim (inline legal-class-name-p))
+(defun legal-class-name-p (x)
+  (symbolp x))

 
 (defvar *create-classes-from-internal-structure-definitions-p* t)
 
 (defun find-class-from-cell (symbol cell &optional (errorp t))
 
 (defvar *create-classes-from-internal-structure-definitions-p* t)
 
 (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 (when cell
+        (or (classoid-cell-pcl-class cell)
+            (when *create-classes-from-internal-structure-definitions-p*
+              (let ((classoid (classoid-cell-classoid cell)))
+                (when (and classoid
+                           (or (condition-classoid-p classoid)
+                               (defstruct-classoid-p classoid)))
+                  (ensure-non-standard-class symbol classoid))))))

       (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))
-
-(defun legal-class-name-p (x)
-  (symbolp x))
+            ((legal-class-name-p symbol)
+             (error "There is no class named ~
+                     ~/sb-impl::print-symbol-with-prefix/." symbol))
+            (t
+             (error "~S is not a legal class name." symbol)))))

 
 (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-classoid-cell symbol)
+                        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.
 ;;;
 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
 \f
 ;;; This DEFVAR was originally in defs.lisp, now moved here.
 ;;;
 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.

-;;;
-;;; KLUDGE: This should probably become
-;;;   (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
-(defvar *boot-state* nil)
+(declaim (type (member nil early braid complete) **boot-state**))
+(defglobal **boot-state** nil)

 
 (/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))))
+            (cell (make-symbol "CLASSOID-CELL")))
+        `(let ((,cell (load-time-value (find-classoid-cell ',symbol :create t))))
+           (or (classoid-cell-pcl-class ,cell)
+               ,(if errorp
+                    `(find-class-from-cell ',symbol ,cell t)
+                    `(when (classoid-cell-classoid ,cell)
+                       (find-class-from-cell ',symbol ,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)))
+(declaim (inline class-classoid))
+(defun class-classoid (class)
+  (layout-classoid (class-wrapper class)))
+
+(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)"))
+         (with-world-lock ()
+           (let ((cell (find-classoid-cell name :create new-value)))
+             (cond (new-value
+                    (setf (classoid-cell-pcl-class cell) new-value)
+                    (when (eq **boot-state** 'complete)
+                      (let ((classoid (class-classoid new-value)))
+                        (setf (find-classoid name) classoid)
+                        (%set-class-type-translation new-value classoid))))
+                   (cell
+                    (%clear-classoid name cell)))
+             (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")