-(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)))
-
-(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)))
-
-(defmacro gathering1 (gatherer &body body)
- `(gathering ((.gathering1. ,gatherer))
- (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
- ,@body)))
-
-(defmacro vectorizing (&key (size 0))
- `(let* ((limit ,size)
- (result (make-array limit))
- (index 0))
- (values #'(lambda (value)
- (if (= index limit)
- (error "vectorizing more elements than promised")
- (progn
- (setf (svref result index) value)
- (incf index)
- value)))
- #'(lambda () result))))
-
-;;; These are augmented definitions of LIST-ELEMENTS and LIST-TAILS from
-;;; iterate.lisp. These versions provide the extra :BY keyword which can
-;;; be used to specify the step function through the list.
-(defmacro *list-elements (list &key (by #'cdr))
- `(let ((tail ,list))
- #'(lambda (finish)
- (if (endp tail)
- (funcall finish)
- (prog1 (car tail)
- (setq tail (funcall ,by tail)))))))
-
-(defmacro *list-tails (list &key (by #'cdr))
- `(let ((tail ,list))
- #'(lambda (finish)
- (prog1 (if (endp tail)
- (funcall finish)
- tail)
- (setq tail (funcall ,by tail))))))
+(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")