Complete cut-to-width for modular arithmetic

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

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index b0c5f53..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,158 +43,108 @@
   (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
 ;;;;

-;;;; This is documented in the CLOS specification. FIXME: Except that
-;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
-;;;; PCL:FIND-CLASS, alas.
+;;;; This is documented in the CLOS specification.

 
 (/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)
-  (and (symbolp x)
-       (not (keywordp 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")
 
 
 (/show "pcl/macros.lisp 187")
 

-;;; Note that in SBCL as in CMU CL,
-;;;   COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
-;;; (Yes, this is a KLUDGE!)

 (define-compiler-macro find-class (&whole form
 (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 (sb-kernel:class-cell-class
-                          ',(sb-kernel:find-class-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))))
-         (when (and new-value (not (forward-referenced-class-p new-value)))
-
-           (dolist (keys+aok (find-class-cell-make-instance-function-keys
-                              cell))
-             (update-initialize-info-internal
-              (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
-              'make-instance-function))))
-       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")
 

@@ -216,66 +161,4 @@
 
 (defsetf slot-value set-slot-value)
 \f
 
 (defsetf slot-value set-slot-value)
 \f

-(defun misplaced-lambda-list-keyword (lambda-list keyword)
-  (error "Lambda list keyword ~S is misplaced in ~S." keyword lambda-list))
-
-(defmacro process-lambda-list (lambda-list &rest clauses)
-  ;; (process-lambda-list '(a b &optional (c 1))
-  ;;                      (&required)
-  ;;                      ((&optional (print "Started processing optional arguments"))
-  ;;                       (format "Optional argument: ~S~%" it))
-  ;;                      (&rest (print "Rest")))
-  (let ((clauses (loop for clause in clauses
-                    collect
-                      (cond ((symbolp (car clause))
-                             `(,(car clause) nil . ,(cdr clause)))
-                            ((consp (car clause))
-                             `(,(caar clause) ,(cdar clause) . ,(cdr clause)))
-                            (t (error "Invalid clause format: ~S." clause)))))
-        (ll (gensym "LL"))
-        (state (gensym "STATE"))
-        (restp (gensym "RESTP"))
-        (check-state (gensym "CHECK-STATE")))
-    `(let ((,ll ,lambda-list)
-           (,state '&required)
-           (,restp nil))
-       (dolist (it ,ll)
-         (flet ((,check-state (possible)
-                  (unless (memq ,state possible)
-                    (misplaced-lambda-list-keyword ,ll it))))
-           (cond ((memq it lambda-list-keywords)
-                  (case it
-                    (&optional (,check-state '(&required))
-                               ,@(cadr (assoc '&optional clauses)))
-                    (&rest (,check-state '(&required &optional))
-                           ,@(cadr (assoc '&rest clauses)))
-                    (&key (,check-state '(&required &optional &rest))
-                          (when (and (eq ,state '&rest)
-                                     (not ,restp))
-                            (error "Omitted &REST variable in ~S." ,ll))
-                          ,@(cadr (assoc '&key clauses)))
-                    (&allow-other-keys (,check-state '(&key))
-                                       ,@(cadr (assoc '&allow-other-keys clauses)))
-                    (&aux (when (and (eq ,state '&rest)
-                                     (not ,restp))
-                            (error "Omitted &REST variable in ~S." ,ll))
-                          ,@(cadr (assoc '&aux clauses)))
-                    (t (error "Unsupported lambda list keyword ~S in ~S."
-                              it ,ll)))
-                  (setq ,state it))
-                 (t (case ,state
-                      (&required ,@(cddr (assoc '&required clauses)))
-                      (&optional ,@(cddr (assoc '&optional clauses)))
-                      (&rest (when ,restp
-                               (error "Too many variables after &REST in ~S." ,ll))
-                             (setq ,restp t)
-                             ,@(cddr (assoc '&rest clauses)))
-                      (&key ,@(cddr (assoc '&key clauses)))
-                      (&allow-other-keys (error "Variable ~S after &ALLOW-OTHER-KEY in ~S."
-                                                it ,ll))
-                      (&aux ,@(cddr (assoc '&aux clauses))))))))
-       (when (and (eq ,state '&rest)
-                  (not ,restp))
-         (error "Omitted &REST variable in ~S." ,ll)))))
-

 (/show "finished with pcl/macros.lisp")
 (/show "finished with pcl/macros.lisp")