X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmacros.lisp;h=ad4e24f7dcd2173f83c55731043a2f267e7cd65a;hb=3ea6f2688adf11331a7a9c243f77a602785d1e1b;hp=baec9382f55a137527920f67e64986d3539e491e;hpb=56f96e77ade913d6363a3068c94e60f44ae9b3e7;p=sbcl.git diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index baec938..ad4e24f 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -29,18 +29,18 @@ (/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") @@ -48,36 +48,34 @@ (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)) - (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) - (.dolist-carefully. ,list)) + (.dolist-carefully. ,list)) (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))))) ;;;; 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") @@ -89,9 +87,6 @@ (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)) @@ -99,9 +94,9 @@ (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") @@ -110,34 +105,23 @@ (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) - ((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) - (and (symbolp x) - (not (keywordp x)))) + (symbolp x)) (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)) ;;; This DEFVAR was originally in defs.lisp, now moved here. ;;; @@ -149,57 +133,63 @@ (/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 - symbol &optional (errorp t) environment) + symbol &optional (errorp t) environment) (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)))) + (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)) -(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))) +(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")