X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fmacros.lisp;h=437e802990450ceb42b021799491b2175c1e8439;hb=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;hp=3c984929e42bf856b817e92c47938be077c4bd6d;hpb=a736ac10b709b2d40305f0a6e3764afd246a8ef5;p=sbcl.git diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 3c98492..437e802 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -29,18 +29,13 @@ (/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") @@ -48,30 +43,21 @@ (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)))) - (/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 ;;;; @@ -79,115 +65,86 @@ (/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)) - (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) - ((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 - (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)) ;;; 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 - 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 (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)) -(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")