X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmacros.lisp;h=ad4e24f7dcd2173f83c55731043a2f267e7cd65a;hb=7d853ed1882221bc790062e423a74a620f6e4ee1;hp=b0c5f53fc71980667d12a3b0f80bf86cab3fcf24;hpb=24bc431a3403af05c5df601d09c0d0c27cb500b2;p=sbcl.git diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index b0c5f53..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") @@ -216,66 +206,4 @@ (defsetf slot-value set-slot-value) -(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")