- (classp class)
- (memq *the-class-structure-object* (class-precedence-list class)))
- (let ((slotd (find-slot-definition class slot-name)))
- (ecase read/write
- (:read
- `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
- (:write
- `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
- ,parameter)
- ,new-value))
- (:boundp
- 'T)))
- (let* ((parameter-entry (assq parameter slots))
- (slot-entry (assq slot-name (cdr parameter-entry)))
- (position (posq parameter-entry slots))
- (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
- (unless parameter-entry
- (error "internal error in slot optimization"))
- (unless slot-entry
- (setq slot-entry (list slot-name))
- (push slot-entry (cdr parameter-entry)))
- (push pv-offset-form (cdr slot-entry))
- (ecase read/write
- (:read
- `(instance-read ,pv-offset-form ,parameter ,position
- ',slot-name ',class))
- (:write
- `(let ((.new-value. ,new-value))
- (instance-write ,pv-offset-form ,parameter ,position
- ',slot-name ',class .new-value.)))
- (:boundp
- `(instance-boundp ,pv-offset-form ,parameter ,position
- ',slot-name ',class)))))))
-
-(defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
- (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
- (parameter (if (consp sparameter) (car sparameter) sparameter))
- (parameter-entry (assq parameter slots))
- (name (case read/write
- (:read `(reader ,gf-name))
- (:write `(writer ,gf-name))))
- (slot-entry (assoc name (cdr parameter-entry) :test #'equal))
- (position (posq parameter-entry slots))
- (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
- (unless parameter-entry
- (error "internal error in slot optimization"))
- (unless slot-entry
- (setq slot-entry (list name))
- (push slot-entry (cdr parameter-entry)))
- (push pv-offset-form (cdr slot-entry))
- (ecase read/write
- (:read
- `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
- (:write
- `(let ((.new-value. ,new-value))
- (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
- .new-value.))))))
-
-(defvar *unspecific-arg* '..unspecific-arg..)
-
-(defun optimize-gf-call-internal (form slots env)
- (when (and (consp form)
- (eq (car form) 'the))
- (setq form (caddr form)))
- (or (and (symbolp form)
- (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
- form env)))
- (parameter-or-nil (car (assq (or rebound? form) slots))))
- (when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration
- 'class parameter-or-nil env))))
- (when (and class-name (not (eq class-name t)))
- (position parameter-or-nil slots :key #'car))))))
- (if (constantp form)
- (let ((form (eval form)))
- (if (symbolp form)
- form
- *unspecific-arg*))
- *unspecific-arg*)))
-
-(defun optimize-gf-call (slots calls gf-call-form nreq restp env)
- (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work
- (let* ((args (cdr gf-call-form))
- (all-args-p (eq (car gf-call-form) 'make-instance))
- (non-required-args (nthcdr nreq args))
- (required-args (ldiff args non-required-args))
- (call-spec (list (car gf-call-form) nreq restp
- (mapcar #'(lambda (form)
- (optimize-gf-call-internal form slots env))
- (if all-args-p
- args
- required-args))))
- (call-entry (assoc call-spec calls :test #'equal))
- (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
- (unless (some #'integerp
- (let ((spec-args (cdr call-spec)))
- (if all-args-p
- (ldiff spec-args (nthcdr nreq spec-args))
- spec-args)))
- (return-from optimize-gf-call nil))
- (unless call-entry
- (setq call-entry (list call-spec))
- (push call-entry (cdr calls)))
- (push pv-offset-form (cdr call-entry))
- (if (eq (car call-spec) 'make-instance)
- `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
- `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
- (invoke-effective-method-function .emf. ,restp
- ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
+ (classp class)
+ (memq *the-class-structure-object* (class-precedence-list class)))
+ (let ((slotd (find-slot-definition class slot-name)))
+ (ecase read/write
+ (:read
+ `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
+ (:write
+ `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
+ ,parameter)
+ ,new-value))
+ (:boundp
+ t)))
+ (let* ((parameter-entry (assq parameter slots))
+ (slot-entry (assq slot-name (cdr parameter-entry)))
+ (position (posq parameter-entry slots))
+ (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
+ (unless parameter-entry
+ (bug "slot optimization bewilderment: O-I-A"))
+ (unless slot-entry
+ (setq slot-entry (list slot-name))
+ (push slot-entry (cdr parameter-entry)))
+ (push pv-offset-form (cdr slot-entry))
+ (ecase read/write
+ (:read
+ `(instance-read ,pv-offset-form ,parameter ,position
+ ',slot-name ',class))
+ (:write
+ `(let ((.new-value. ,new-value))
+ (instance-write ,pv-offset-form ,parameter ,position
+ ',slot-name ',class .new-value.)))
+ (:boundp
+ `(instance-boundp ,pv-offset-form ,parameter ,position
+ ',slot-name ',class)))))))