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

Modified Files: run-time-context.lisp Log Message: Use memref a bit more cleverly in the %run-time-context-segment-base accessor functions.

Date: Wed Mar 31 11:47:40 2004 Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.3 movitz/losp/muerte/run-time-context.lisp:1.4 --- movitz/losp/muerte/run-time-context.lisp:1.3 Tue Mar 30 04:12:35 2004 +++ movitz/losp/muerte/run-time-context.lisp Wed Mar 31 11:47:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.3 2004/03/30 09:12:35 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.4 2004/03/31 16:47:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -98,10 +98,11 @@ (let ((slot (find-run-time-context-slot context slot-name))) (ecase (second slot) (segment-descriptor - (let ((offset (+ -6 (* 4 (third slot))))) - (+ (memref context offset 1 :unsigned-byte16) - (ash (memref context offset 4 :unsigned-byte8) 16) - (ash (memref context offset 7 :unsigned-byte8) 24))))))) + (let ((index8 (* 4 (third slot))) + (index16 (* 2 (third slot)))) + (+ (memref context (+ -6 2) index16 :unsigned-byte16) + (ash (memref context (+ -6 4) index8 :unsigned-byte8) 16) + (ash (memref context (+ -6 7) index8 :unsigned-byte8) 24)))))))

(defun (setf %run-time-context-segment-base) (value slot-name &optional (context (current-run-time-context))) @@ -109,10 +110,11 @@ (let ((slot (find-run-time-context-slot context slot-name))) (ecase (second slot) (segment-descriptor - (let ((offset (+ -6 (* 4 (third slot))))) - (setf (memref context offset 1 :unsigned-byte16) (ldb (byte 16 0) value) - (memref context offset 4 :unsigned-byte8) (ldb (byte 8 16) value) - (memref context offset 7 :unsigned-byte8) (ldb (byte 6 24) value))))) + (let ((index8 (* 4 (third slot))) + (index16 (* 2 (third slot)))) + (setf (memref context (+ -6 2) index16 :unsigned-byte16) (ldb (byte 16 0) value) + (memref context (+ -6 4) index8 :unsigned-byte8) (ldb (byte 8 16) value) + (memref context (+ -6 7) index8 :unsigned-byte8) (ldb (byte 6 24) value))))) value))

(defun clone-run-time-context (&key (parent (current-run-time-context))