X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmacros.lisp;h=437e802990450ceb42b021799491b2175c1e8439;hb=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;hp=bc6fdf1a50d7cc17100d388d298b1b81fe5cd90c;hpb=66b919851a8564e8f21247703d54c01c293414f8;p=sbcl.git diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index bc6fdf1..437e802 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -29,15 +29,10 @@ (/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)) @@ -52,15 +47,6 @@ (/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) @@ -79,59 +65,40 @@ (/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 make-find-class-cell (class-name) - (declare (ignore class-name)) - '(list* nil #'constantly-nil nil)) - -(defun find-class-cell (symbol &optional dont-create-p) - (let ((table *find-class*)) - (with-locked-hash-table (table) - (or (gethash symbol table) - (unless dont-create-p - (unless (legal-class-name-p symbol) - (error "~S is not a legal class name." symbol)) - (setf (gethash symbol table) (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)) - (or (find-class-cell-class cell) - (and *create-classes-from-internal-structure-definitions-p* - (or (structure-type-p symbol) (condition-type-p symbol)) - (ensure-non-standard-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) ((legal-class-name-p symbol) - (error "There is no class named ~S." 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 legal-class-name-p (x) - (symbolp x)) - (defun find-class (symbol &optional (errorp t) environment) (declare (ignore environment)) (find-class-from-cell symbol - (find-class-cell symbol errorp) + (find-classoid-cell symbol) errorp)) ;;; 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") @@ -141,55 +108,41 @@ (if (and (constantp symbol) (legal-class-name-p (setf symbol (constant-form-value symbol))) (constantp errorp) - (member *boot-state* '(braid complete))) + (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) + (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 ,class-cell t) - `(and (classoid-cell-classoid - ',(find-classoid-cell symbol)) - (find-class-from-cell ',symbol ,class-cell nil)))))) + `(find-class-from-cell ',symbol ,cell t) + `(when (classoid-cell-classoid ,cell) + (find-class-from-cell ',symbol ,cell nil)))))) form)) +(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 ~ + (: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)) + (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))))