Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27216

Modified Files: los-closette.lisp Log Message: Cleaned up compute-effective-slot-reader/writer: made it a generic function.

Date: Tue May 3 22:07:51 2005 Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.27 movitz/losp/muerte/los-closette.lisp:1.28 --- movitz/losp/muerte/los-closette.lisp:1.27 Sun May 1 01:22:19 2005 +++ movitz/losp/muerte/los-closette.lisp Tue May 3 22:07:50 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.27 2005/04/30 23:22:19 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.28 2005/05/03 20:07:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -872,23 +872,40 @@

(defmacro define-effective-slot-reader (name location) - `(defun ,name (instance) - (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :eax) instance) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax (:offset movitz-std-instance slots)) - :eax) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax) - (#.movitz:*compiler-global-segment-prefix* - :cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset - 'new-unbound-value))) - (:je '(:sub-program (unbound) - (:compile-form (:result-mode :multiple-values) - (slot-unbound-trampoline instance ,location)) - (:jmp 'done))) - (:clc) - done))) + (if movitz::*compiler-use-into-unbound-protocol* + `(defun ,name (instance) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :eax) instance) + (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-std-instance slots)) + :eax) + (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax) + (#.movitz:*compiler-global-segment-prefix* + :cmpl -1 :eax) + (:jo '(:sub-program (unbound) + (:compile-form (:result-mode :multiple-values) + (slot-unbound-trampoline instance ,location)) + (:jmp 'done))) + (:clc) + done)) + `(defun ,name (instance) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :eax) instance) + (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-std-instance slots)) + :eax) + (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-basic-vector data ,(* location 4))) :eax) + (#.movitz:*compiler-global-segment-prefix* + :cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset + 'new-unbound-value))) + (:je '(:sub-program (unbound) + (:compile-form (:result-mode :multiple-values) + (slot-unbound-trampoline instance ,location)) + (:jmp 'done))) + (:clc) + done))))

(defparameter *standard-effective-slot-readers* #(standard-effective-slot-reader%0 @@ -911,30 +928,8 @@ (define-effective-slot-reader standard-effective-slot-reader%6 6) (define-effective-slot-reader standard-effective-slot-reader%7 7)

-(defun compute-effective-slot-reader (class slot-definition) - (let* ((slot-name (slot-definition-name slot-definition)) - (slot (find-slot class slot-name))) - (assert slot (slot-name) - "No slot named ~S in class ~S." slot-name class) - (let ((slot-location (slot-definition-location slot))) - (check-type slot-location (integer 0 #xffff)) - (etypecase class - (standard-class - (if (and (< slot-location (length *standard-effective-slot-readers*)) - (svref *standard-effective-slot-readers* slot-location)) - (symbol-function (svref *standard-effective-slot-readers* slot-location)) - (lambda (instance) - (let ((x (standard-instance-access instance slot-location))) - (if (not (eq x (load-global-constant new-unbound-value))) - x - (slot-unbound-trampoline instance slot-location)))))) - (funcallable-standard-class - (lambda (instance) - (let ((x (svref (std-gf-instance-slots instance) slot-location))) - (if (not (eq x (load-global-constant new-unbound-value))) - x - (slot-unbound-trampoline instance slot-location)))))))))

+#+ignore (defun compute-effective-slot-writer (class slot-definition) (let* ((slot-name (slot-definition-name slot-definition)) (slot (find-slot class slot-name))) @@ -1211,7 +1206,7 @@ (push indicator initargs))))))) initargs)

-(defmethod make-instance ((class standard-class) &rest initargs) +(defmethod make-instance ((class std-slotted-class) &rest initargs) (declare (dynamic-extent initargs)) (let ((defaulted-initargs (compute-defaulted-initargs class initargs))) (apply 'initialize-instance @@ -1274,10 +1269,14 @@ (define-slot-reader-method slot-definition-initform (standard-slot-definition initform))

-(defun find-slot (class slot-name) +(defun find-slot (class slot-name &optional error-instance operation new-value) (dolist (slot (if (eq class *the-class-standard-class*) *the-slots-of-standard-class* - (class-slots class)) #+ignore (error "The slot ~S doesn't exist in ~S." slot-name class)) + (class-slots class)) + (case error-instance + ((nil)) + ((t) (error "No slot named ~S in class ~S." slot-name class)) + (t (slot-missing class error-instance slot-name operation new-value)))) (when (eql slot-name (slot-definition-name slot)) (return slot))))

@@ -1291,8 +1290,7 @@ val)))

(defun std-gf-slot-value (instance slot-name) - (let ((slot (find-slot (std-gf-instance-class instance) slot-name))) - (assert slot) + (let ((slot (find-slot (std-gf-instance-class instance) slot-name t))) (let* ((location (slot-definition-location slot)) (slots (std-gf-instance-slots instance)) (val (svref slots location))) @@ -1396,6 +1394,7 @@ (when (eql slot-name (slot-definition-name slot)) (return t)))))

+ ;;; Specializers

(defun eql-specializer-p (specializer) @@ -1426,6 +1425,41 @@ (typep object specializer)))

+;;;; + +(defmethod compute-effective-slot-reader ((class standard-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (if (and (< slot-location (length *standard-effective-slot-readers*)) + (svref *standard-effective-slot-readers* slot-location)) + (symbol-function (svref *standard-effective-slot-readers* slot-location)) + (lambda (instance) + (unbound-protect (standard-instance-access instance slot-location) + (slot-unbound-trampoline instance slot-location)))))) + +(defmethod compute-effective-slot-reader ((class funcallable-standard-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (lambda (instance) + (unbound-protect (svref (std-gf-instance-slots instance) slot-location) + (slot-unbound-trampoline instance slot-location))))) + +(defmethod compute-effective-slot-writer ((class standard-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (lambda (value instance) + (setf (standard-instance-access instance slot-location) + value)))) + +(defmethod compute-effective-slot-writer ((class funcallable-standard-class) slot) + (let ((slot-location (slot-definition-location slot))) + (check-type slot-location positive-fixnum) + (lambda (value instance) + (setf (svref (std-gf-instance-slots instance) slot-location) + value)))) + + + ;;; compute-applicable-methods-using-classes

(defun std-compute-applicable-methods-using-classes (gf classes) @@ -1560,8 +1594,12 @@ *standard-slot-value-using-class*) (class-of object) object (accessor-method-slot-definition primary-method)))))) - (compute-effective-slot-reader (specializer-class (car specializers)) - (accessor-method-slot-definition primary-method))) + (let* ((class (specializer-class (car specializers))) + (slot (find-slot class + (slot-definition-name + (accessor-method-slot-definition primary-method)) + t))) + (compute-effective-slot-reader class slot))) ((and (typep primary-method 'standard-writer-method) ;; May we shortcut this writer method? (or (not *standard-setf-slot-value-using-class*) ; still bootstrapping.. @@ -1573,8 +1611,12 @@ *standard-setf-slot-value-using-class*) value (class-of object) object (accessor-method-slot-definition primary-method)))))) - (compute-effective-slot-writer (specializer-class (cadr specializers)) - (accessor-method-slot-definition primary-method))) + (let* ((class (specializer-class (cadr specializers))) + (slot (find-slot class + (slot-definition-name + (accessor-method-slot-definition primary-method)) + t))) + (compute-effective-slot-writer class slot))) (t (compute-primary-emfun primaries)))) ((null reverse-afters) (let ((emfun (compute-primary-emfun primaries)) @@ -1901,32 +1943,3 @@ (values))))

-;;;; - -(defclass run-time-context-class (std-slotted-class built-in-class) ()) - -(defclass run-time-context (t) - ((name - :initarg :name - :accessor run-time-context-name) - (stack-vector - :initarg :stack-vector)) - (:metaclass run-time-context-class) - (:size #.(bt:sizeof 'movitz::movitz-run-time-context)) - (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context - (cl:+ (bt:slot-offset 'movitz::movitz-run-time-context - 'movitz::run-time-context-start) - 0)))) - -(defmethod slot-value-using-class ((class run-time-context-class) object - (slot standard-effective-slot-definition)) - (let ((x (svref (%run-time-context-slot 'slots object) - (slot-definition-location slot)))) - (if (eq x (load-global-constant new-unbound-value)) - (slot-unbound class object (slot-definition-name slot)) - x))) - -(defmethod print-object ((x run-time-context) stream) - (print-unreadable-object (x stream :type t :identity t) - (format stream " ~S" (%run-time-context-slot 'name x))) - x)