[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue May 3 22:15:14 UTC 2005
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv5864
Modified Files:
los-closette.lisp
Log Message:
Let's rename it with-unbound-protect.
Date: Wed May 4 00:15:10 2005
Author: ffjeld
Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.29 movitz/losp/muerte/los-closette.lisp:1.30
--- movitz/losp/muerte/los-closette.lisp:1.29 Tue May 3 23:34:57 2005
+++ movitz/losp/muerte/los-closette.lisp Wed May 4 00:15:09 2005
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Tue Jul 23 14:29:10 2002
;;;;
-;;;; $Id: los-closette.lisp,v 1.29 2005/05/03 21:34:57 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.30 2005/05/03 22:15:09 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -926,25 +926,6 @@
(define-effective-slot-reader standard-effective-slot-reader%6 6)
(define-effective-slot-reader standard-effective-slot-reader%7 7)
-
-#+ignore
-(defun compute-effective-slot-writer (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)))
- (assert slot-location)
- (etypecase class
- (standard-class
- (lambda (value instance)
- (setf (standard-instance-access instance slot-location)
- value)))
- (funcallable-standard-class
- (lambda (value instance)
- (setf (svref (std-gf-instance-slots instance) slot-location)
- value)))))))
-
(defun make-emfun (method next-emf)
"Make an effective method function from method that will have
next-emf as its target for call-next-method."
@@ -1262,23 +1243,20 @@
(return slot))))
(defun std-slot-value (instance slot-name)
+ "Used while bootstrapping."
(let* ((location (slot-definition-location (find-slot (std-instance-class instance) slot-name)))
- (slots (std-instance-slots instance))
- (val (svref slots location)))
- (if (eq (load-global-constant new-unbound-value) val)
- (error "The slot ~S is unbound in the object ~S."
- slot-name instance)
- val)))
+ (slots (std-instance-slots instance)))
+ (with-unbound-protect (svref slots location)
+ (error "The slot ~S is unbound in the object ~S."
+ slot-name instance))))
(defun std-gf-slot-value (instance slot-name)
(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)))
- (if (eq (load-global-constant new-unbound-value) val)
- (error "The slot ~S is unbound in the object ~S."
- slot-name instance)
- val))))
+ (slots (std-gf-instance-slots instance)))
+ (with-unbound-protect (svref slots location)
+ (error "The slot ~S is unbound in the object ~S."
+ slot-name instance)))))
(defun slot-value (object slot-name)
(let* ((class (class-of object))
@@ -1289,19 +1267,15 @@
(defmethod slot-value-using-class ((class standard-class) object
(slot standard-effective-slot-definition))
- (let ((x (standard-instance-access object (slot-definition-location slot))))
- (if (eq x (load-global-constant new-unbound-value))
- (slot-unbound class object (slot-definition-name slot))
- x)))
+ (with-unbound-protect (standard-instance-access object (slot-definition-location slot))
+ (slot-unbound class object (slot-definition-name slot))))
(defmethod slot-value-using-class ((class funcallable-standard-class) object
(slot standard-effective-slot-definition))
(let* ((location (slot-definition-location slot))
- (slots (std-gf-instance-slots object))
- (val (svref slots location)))
- (if (eq (load-global-constant new-unbound-value) val)
- (slot-unbound class object (slot-definition-name slot))
- val)))
+ (slots (std-gf-instance-slots object)))
+ (with-unbound-protect (svref slots location)
+ (slot-unbound class object (slot-definition-name slot)))))
(defmethod slot-value-using-class ((class structure-class) object slot)
(structure-ref object (structure-slot-location slot)))
@@ -1415,15 +1389,15 @@
(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))))))
+ (with-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)))))
+ (with-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)))
@@ -1757,10 +1731,8 @@
(location (get class-name slot-name)))
;; (warn "access ~S of ~S at ~S" slot-name class-name location)
(assert location)
- (let ((x (standard-instance-access slot location)))
- (if (eq x (load-global-constant new-unbound-value))
- (error "The slot ~S is unbound in the ~S ~Z." slot-name class-name slot)
- x))))
+ (with-unbound-protect (standard-instance-access slot location)
+ (error "The slot ~S is unbound in the ~S ~Z." slot-name class-name slot))))
(defun bootstrap-class-name (class)
(standard-instance-access class 0))
@@ -1849,8 +1821,7 @@
(std-slot-value method 'function)))
(method-specializers
(lambda (method)
- (std-slot-value method 'specializers)))
- )
+ (std-slot-value method 'specializers))))
(case (funobj-name gf)
((compute-applicable-methods-using-classes)
(std-compute-applicable-methods-using-classes gf classes))
More information about the Movitz-cvs
mailing list