May 2005 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2290 Modified Files: compiler.lisp Log Message: Don't use fast-cdddr. Date: Thu May 5 00:47:39 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.137 movitz/compiler.lisp:1.138 --- movitz/compiler.lisp:1.137 Mon Apr 18 00:24:20 2005 +++ movitz/compiler.lisp Thu May 5 00:47:38 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.137 2005/04/17 22:24:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.138 2005/05/04 22:47:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2317,6 +2317,7 @@ (setq p `((:call (:edi ,(global-constant-offset newf)))) next-pc (nthcdr 2 pc)) (explain nil "Changed [~S ~S] to ~S" i i2 newf))) + #+ignore ((and (global-funcall-p i '(fast-cdr)) (global-funcall-p i2 '(fast-cdr)) (global-funcall-p i3 '(fast-cdr)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2265 Modified Files: run-time-context.lisp Log Message: More dead code. Date: Thu May 5 00:47:18 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.20 movitz/losp/muerte/run-time-context.lisp:1.21 --- movitz/losp/muerte/run-time-context.lisp:1.20 Wed May 4 09:43:27 2005 +++ movitz/losp/muerte/run-time-context.lisp Thu May 5 00:47:17 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.20 2005/05/04 07:43:27 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.21 2005/05/04 22:47:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,9 +28,7 @@ ((name :initarg :name :initform :anonymous - :accessor run-time-context-name) - (stack-vector - :initarg :stack-vector)) + :accessor run-time-context-name)) (:metaclass run-time-context-class) (:size #.(bt:sizeof 'movitz::movitz-run-time-context)) (:slot-map #.(movitz::slot-map 'movitz::movitz-run-time-context @@ -148,18 +146,18 @@ (%run-time-context-slot 'atomically-continuation context) 0) context)) -(defun %run-time-context-install-stack (context - &optional (control-stack - (make-array 8192 :element-type '(unsigned-byte 32))) - (cushion 1024)) - (check-type control-stack vector) - (assert (< cushion (array-dimension control-stack 0))) - (setf (%run-time-context-slot 'control-stack context) control-stack) - (setf (%run-time-context-slot 'stack-top context) - (+ (object-location control-stack) 8 - (* 4 (array-dimension control-stack 0)))) - (setf (%run-time-context-slot 'stack-bottom context) - (+ (object-location control-stack) 8 - (* 4 cushion))) - control-stack) +;;;(defun %run-time-context-install-stack (context +;;; &optional (control-stack +;;; (make-array 8192 :element-type '(unsigned-byte 32))) +;;; (cushion 1024)) +;;; (check-type control-stack vector) +;;; (assert (< cushion (array-dimension control-stack 0))) +;;; (setf (%run-time-context-slot 'control-stack context) control-stack) +;;; (setf (%run-time-context-slot 'stack-top context) +;;; (+ (object-location control-stack) 8 +;;; (* 4 (array-dimension control-stack 0)))) +;;; (setf (%run-time-context-slot 'stack-bottom context) +;;; (+ (object-location control-stack) 8 +;;; (* 4 cushion))) +;;; control-stack)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2238 Modified Files: cons.lisp Log Message: Dead code. Date: Thu May 5 00:47:02 2005 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.9 movitz/losp/muerte/cons.lisp:1.10 --- movitz/losp/muerte/cons.lisp:1.9 Thu Feb 3 10:15:46 2005 +++ movitz/losp/muerte/cons.lisp Thu May 5 00:47:02 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.9 2005/02/03 09:15:46 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.10 2005/05/04 22:47:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,26 +74,6 @@ (:leal (:eax -1) :ecx) (:testb 3 :cl) (:jnz '(:sub-program () (:int 61))) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax 3) :eax) - (:ret))) - -(define-primitive-function fast-cdddr () - "This is the actual CDR code." - (with-inline-assembly (:returns :eax) - (:leal (:eax -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 61))) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax 3) :eax) - (:leal (:eax -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 61))) - (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* - :movl (:eax 3) :eax) - (:leal (:eax -1) :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 61))) (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* :movl (:eax 3) :eax) (:ret)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2199 Modified Files: inspect.lisp Log Message: Dead code. Date: Thu May 5 00:46:44 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.51 movitz/losp/muerte/inspect.lisp:1.52 --- movitz/losp/muerte/inspect.lisp:1.51 Mon Apr 25 00:10:26 2005 +++ movitz/losp/muerte/inspect.lisp Thu May 5 00:46:44 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.51 2005/04/24 22:10:26 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.52 2005/05/04 22:46:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,10 +53,10 @@ (dit-frame-casf stack frame)) (t (stack-frame-ref stack frame 0)))) -(defun stack-vector-designator (stack) - (etypecase stack - (null (%run-time-context-slot 'stack-vector)) - (vector stack))) +;;;(defun stack-vector-designator (stack) +;;; (etypecase stack +;;; (null (%run-time-context-slot 'stack-vector)) +;;; (vector stack))) (define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23533 Modified Files: los-closette.lisp Log Message: Cleaned up print-unreadable-object and its usage a bit. Date: Wed May 4 10:00:42 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.30 movitz/losp/muerte/los-closette.lisp:1.31 --- movitz/losp/muerte/los-closette.lisp:1.30 Wed May 4 00:15:09 2005 +++ movitz/losp/muerte/los-closette.lisp Wed May 4 10:00:42 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.30 2005/05/03 22:15:09 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.31 2005/05/04 08:00:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1667,18 +1667,16 @@ (write object :stream stream))) (defmethod print-object ((object class) stream) - (print-unreadable-object (object stream :identity nil) - (format stream "~W ~W" (class-name (class-of object)) (class-name object))) + (print-unreadable-object (object stream :identity nil :type t) + (write (class-name object) :stream stream)) object) (defmethod print-object ((object standard-object) stream) - (print-unreadable-object (object stream :identity t) - (write (class-name (class-of object)) - :stream stream)) + (print-unreadable-object (object stream :identity t :type t)) object) (defmethod print-object ((object structure-object) stream) - (let* ((class (class-of object))) + (let ((class (class-of object))) (format stream "#S(~S" (class-name class)) (dolist (slot (class-slots class)) (format stream " :~A ~S" @@ -1704,8 +1702,9 @@ object) (defmethod print-object ((x illegal-object) stream) - (error "Won't print illegal-object ~Z." x) - ;; (print-unreadable-object (x stream :type t :identity t)) + (if *print-safely* + (print-unreadable-object (x stream :type t :identity t)) + (error "Won't print illegal-object ~Z." x)) x) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23404 Modified Files: print.lisp Log Message: Cleaned up print-unreadable-object and its usage a bit. Date: Wed May 4 10:00:39 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.18 movitz/losp/muerte/print.lisp:1.19 --- movitz/losp/muerte/print.lisp:1.18 Fri Feb 25 09:00:11 2005 +++ movitz/losp/muerte/print.lisp Wed May 4 10:00:39 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.18 2005/02/25 08:00:11 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.19 2005/05/04 08:00:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,12 +46,14 @@ (defvar *never-use-print-object* :after-clos-bootstrapped) -(defun init-print-unreadable (object stream &optional type-p) +(defun init-print-unreadable (object stream &optional type-p bodyless-p) (when *print-readably* (error 'print-not-readable :object object)) (write-string "#<" stream) (when type-p - (write (type-of object) :stream stream)) + (write (type-of object) :stream stream) + (unless bodyless-p + (write-char #\space stream))) nil) (defmacro print-unreadable-object ((object stream &key type identity) &body body) @@ -60,7 +62,8 @@ `(let ((,stream-var ,stream) (,object-var ,object)) (init-print-unreadable ,object-var ,stream-var - ,@(when type (list type))) + ,@(when type (list type)) + ,@(when (and type (null body)) (list t))) ,@body ,(when identity `(when ,identity @@ -194,7 +197,7 @@ (handler-case (internal-write object) (serious-condition (c) (print-unreadable-object (c *standard-output* :type t :identity t) - (format t " (while printing ~Z)" object)))))))) + (format t "(while printing ~Z)" object)))))))) (defun internal-write (object) (let ((stream *standard-output*)) @@ -311,8 +314,7 @@ (write-char #\space stream)) (write (aref object i))) (write-char #\) stream)))) - (t (print-unreadable-object (object stream :identity t) - (princ (type-of object) stream)))))) + (t (print-unreadable-object (object stream :identity t :type t)))))) (standard-gf-instance (print-unreadable-object (object stream) (format stream "gf ~S" (funobj-name object))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21525 Modified Files: run-time-context.lisp Log Message: *** empty log message *** Date: Wed May 4 09:43:27 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.19 movitz/losp/muerte/run-time-context.lisp:1.20 --- movitz/losp/muerte/run-time-context.lisp:1.19 Wed May 4 08:17:21 2005 +++ movitz/losp/muerte/run-time-context.lisp Wed May 4 09:43:27 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.19 2005/05/04 06:17:21 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.20 2005/05/04 07:43:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,6 +27,7 @@ (defclass run-time-context (t) ((name :initarg :name + :initform :anonymous :accessor run-time-context-name) (stack-vector :initarg :stack-vector)) @@ -92,8 +93,8 @@ (let ((slot-location (slot-definition-location slot))) (check-type slot-location positive-fixnum) (lambda (instance) - (unbound-protect (svref (%run-time-context-slot 'slots instance) slot-location) - (slot-unbound-trampoline instance slot-location))))) + (with-unbound-protect (svref (%run-time-context-slot 'slots instance) slot-location) + (slot-unbound-trampoline instance slot-location))))) (defmethod compute-effective-slot-writer ((class run-time-context-class) slot) (let ((slot-location (slot-definition-location slot))) @@ -104,7 +105,7 @@ (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))) + (format stream "~S" (run-time-context-name x))) x) ;;; @@ -142,7 +143,7 @@ (name :anonymous)) (check-type parent run-time-context) (let ((context (%shallow-copy-object parent (movitz-type-word-size 'movitz-run-time-context)))) - (setf (%run-time-context-slot 'name context) name + (setf (%run-time-context-slot 'slots context) (copy-seq (%run-time-context-slot 'slots parent)) (%run-time-context-slot 'self context) context (%run-time-context-slot 'atomically-continuation context) 0) context))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 04 May '05

04 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15096 Modified Files: run-time-context.lisp Log Message: Use with-unbound-protect. Date: Wed May 4 08:17:21 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.18 movitz/losp/muerte/run-time-context.lisp:1.19 --- movitz/losp/muerte/run-time-context.lisp:1.18 Tue May 3 23:25:34 2005 +++ movitz/losp/muerte/run-time-context.lisp Wed May 4 08:17:21 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.18 2005/05/03 21:25:34 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.19 2005/05/04 06:17:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,11 +39,9 @@ (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))) + (with-unbound-protect (svref (%run-time-context-slot 'slots object) + (slot-definition-location slot)) + (slot-unbound class object (slot-definition-name slot)))) (defmethod (setf slot-value-using-class) (new-value (class run-time-context-class) object (slot standard-effective-slot-definition))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6026 Modified Files: basic-macros.lisp Log Message: Let's rename it with-unbound-protect. Date: Wed May 4 00:15:38 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.60 movitz/losp/muerte/basic-macros.lisp:1.61 --- movitz/losp/muerte/basic-macros.lisp:1.60 Tue May 3 23:25:30 2005 +++ movitz/losp/muerte/basic-macros.lisp Wed May 4 00:15:38 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.60 2005/05/03 21:25:30 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.61 2005/05/03 22:15:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -690,7 +690,7 @@ (t form))) -(defmacro unbound-protect (x &optional error-continuation &environment env) +(defmacro with-unbound-protect (x &body error-continuation &environment env) (cond ((movitz:movitz-constantp x env) `(values ,x)) @@ -700,14 +700,14 @@ (:compile-form (:result-mode :register) ,x) (:cmpl -1 (:result-register)) (:jo '(:sub-program (unbound) - (:compile-form (:result-mode :eax) ,error-continuation) + (:compile-form (:result-mode :eax) (progn ,@error-continuation)) (:jmp ',unbound-continue))) ,unbound-continue))) (t (let ((var (gensym))) `(let ((,var ,x)) (if (not (eq ,var (load-global-constant new-unbound-value))) ,var - ,error-continuation)))))) + (progn ,@error-continuation))))))) (define-compiler-macro current-run-time-context () `(with-inline-assembly (:returns :register)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 03 May '05

03 May '05

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(a)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))

1 0