From ffjeld at common-lisp.net  Fri Oct  1 12:44:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 01 Oct 2004 14:44:20 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1CDMlo-0000c8-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Removed some dead code.

Date: Fri Oct  1 14:44:20 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.39 movitz/losp/los0-gc.lisp:1.40
--- movitz/losp/los0-gc.lisp:1.39	Wed Sep 22 19:58:56 2004
+++ movitz/losp/los0-gc.lisp	Fri Oct  1 14:44:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.39 2004/09/22 17:58:56 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.40 2004/10/01 12:44:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -323,16 +323,7 @@
 	  (assert (eq space0 (space-other space1)))
 	  (assert (= 2 (space-fresh-pointer space1)))
 	  (setf (%run-time-context-slot 'nursery-space) space1)
-	  (values space1 space0)
-	  #+ignore
-	  (multiple-value-bind (newspace oldspace)
-	      (if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace.
-		     (space-fresh-pointer space1))
-		  (values space0 space1)
-		(values space1 space0))
-	    ;; Ensure newspace is activated.
-	    (setf (%run-time-context-slot 'nursery-space) newspace)
-	    (values newspace oldspace))))
+	  (values space1 space0)))
     ;; Evacuate-oldspace is to be mapped over every potential pointer.
     (let ((evacuator
 	   (or evacuator
@@ -375,45 +366,46 @@
 
       ;; Consistency check..
       (when *gc-consitency-check*
-	(let ((a *x*))
-	  ;; First, restore the state of old-space
-	  (do ((i 0 (+ i 3)))
-	      ((>= i (length a)))
-	    (let ((old (%lispval-object (aref a i)))
-		  (old-class (aref a (+ i 1))))
-	      (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
-	  ;; Then, check that each migrated object is equalp to its new self.
-	  (do ((i 0 (+ i 3)))
-	      ((>= i (length a)))
-	    (let ((old (%lispval-object (aref a i)))
-		  (new (%lispval-object (aref a (+ i 2)))))
-	      (unless (and (object-in-space-p newspace new)
-			   (object-in-space-p oldspace old)
-			   (objects-equalp old new))
-		(let ((*old* old)
-		      (*new* new)
-		      (*old-class* (aref a (+ i 1))))
-		  (declare (special *old* *new* *old-class*))
-		  (with-simple-restart (continue "Ignore failed GC consistency check.")
-		    (error "GC consistency check failed:
+	(without-interrupts
+	  (let ((a *x*))
+	    ;; First, restore the state of old-space
+	    (do ((i 0 (+ i 3)))
+		((>= i (length a)))
+	      (let ((old (%lispval-object (aref a i)))
+		    (old-class (aref a (+ i 1))))
+		(setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
+	    ;; Then, check that each migrated object is equalp to its new self.
+	    (do ((i 0 (+ i 3)))
+		((>= i (length a)))
+	      (let ((old (%lispval-object (aref a i)))
+		    (new (%lispval-object (aref a (+ i 2)))))
+		(unless (and (object-in-space-p newspace new)
+			     (object-in-space-p oldspace old)
+			     (objects-equalp old new))
+		  (let ((*old* old)
+			(*new* new)
+			(*old-class* (aref a (+ i 1))))
+		    (declare (special *old* *new* *old-class*))
+		    (with-simple-restart (continue "Ignore failed GC consistency check.")
+		      (error "GC consistency check failed:
 old object: ~Z: ~S
 new object: ~Z: ~S
 oldspace: ~Z, newspace: ~Z, i: ~D"
-			   old old new new oldspace newspace i))))))
-	  (map-heap-words (lambda (x y)
-			    (declare (ignore y))
-			    (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space))
-							(object-location x))
-			      (break "Seeing old object in values-vector: ~Z" x))
-			    x)
-			  #x38 #xb8)
-	  (let* ((stack (%run-time-context-slot 'muerte::nursery-space))
-		 (stack-start (- (length stack) (muerte::current-control-stack-depth))))
-	    (do ((i 0 (+ i 3)))
-		((>= i (length a)))
-	      (when (find (aref a i) stack :start stack-start)
-		(break "Seeing old object ~S in current stack!"
-		       (aref a i)))))))
+			     old old new new oldspace newspace i))))))
+	    (map-heap-words (lambda (x y)
+			      (declare (ignore y))
+			      (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space))
+							  (object-location x))
+				(break "Seeing old object in values-vector: ~Z" x))
+			      x)
+			    #x38 #xb8)
+	    (let* ((stack (%run-time-context-slot 'muerte::nursery-space))
+		   (stack-start (- (length stack) (muerte::current-control-stack-depth))))
+	      (do ((i 0 (+ i 3)))
+		  ((>= i (length a)))
+		(when (find (aref a i) stack :start stack-start)
+		  (break "Seeing old object ~S in current stack!"
+			 (aref a i))))))))
 
       ;; GC completed, oldspace is evacuated.
       (unless *gc-quiet*




From ffjeld at common-lisp.net  Thu Oct  7 12:41:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:41:42 +0200
Subject: [movitz-cvs] CVS update: movitz/environment.lisp 
Message-ID: <E1CFXaY-0006Wz-00@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Added a tagbody-env class.

Date: Thu Oct  7 14:41:41 2004
Author: ffjeld

Index: movitz/environment.lisp
diff -u movitz/environment.lisp:1.7 movitz/environment.lisp:1.8
--- movitz/environment.lisp:1.7	Thu Aug 12 19:16:46 2004
+++ movitz/environment.lisp	Thu Oct  7 14:41:41 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov  3 11:40:15 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: environment.lisp,v 1.7 2004/08/12 17:16:46 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.8 2004/10/07 12:41:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -225,6 +225,8 @@
    (lexical-catch-tag-variable
     :initarg :lexical-catch-tag-variable
     :reader movitz-env-lexical-catch-tag-variable)))
+
+(defclass tagbody-env (lexical-exit-point-env) ())
 
 (defclass unwind-protect-env (movitz-environment)
   ())




From ffjeld at common-lisp.net  Thu Oct  7 12:42:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:42:38 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1CFXbS-0006Xp-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Minor edit.

Date: Thu Oct  7 14:42:38 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.27 movitz/losp/muerte/interrupt.lisp:1.28
--- movitz/losp/muerte/interrupt.lisp:1.27	Sat Sep 25 17:51:20 2004
+++ movitz/losp/muerte/interrupt.lisp	Thu Oct  7 14:42:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.27 2004/09/25 15:51:20 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.28 2004/10/07 12:42:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -261,7 +261,6 @@
 
 (defun interrupt-default-handler (vector dit-frame)
   (declare (without-check-stack-limit))
-  (cli)
   (macrolet ((dereference (fixnum-address &optional (type :lisp))
 	       "Dereference the fixnum-address."
 	       `(memref ,fixnum-address 0 0 ,type)))
@@ -332,7 +331,7 @@
 			   new-bottom)
 		   (break "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X."
 			  vector $eip
-			  (dit-frame-esp dit-frame)
+			  (dit-frame-esp nil dit-frame)
 			  old-bottom
 			  old-dynamic-env))
 	       (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%"




From ffjeld at common-lisp.net  Thu Oct  7 12:43:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:43:30 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CFXcI-0006YF-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added an :endian keyword parameter to memref. It's not completely
implemented yet.

Date: Thu Oct  7 14:43:29 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.30 movitz/losp/muerte/memref.lisp:1.31
--- movitz/losp/muerte/memref.lisp:1.30	Fri Sep 17 13:06:47 2004
+++ movitz/losp/muerte/memref.lisp	Thu Oct  7 14:43:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.30 2004/09/17 11:06:47 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.31 2004/10/07 12:43:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,10 +18,11 @@
 
 (in-package muerte)
 
-(define-compiler-macro memref (&whole form object offset index type &key (localp nil)
+(define-compiler-macro memref (&whole form object offset index type &key (localp nil) (endian :host)
 			       &environment env)
   (if (or (not (movitz:movitz-constantp type env))
-	  (not (movitz:movitz-constantp localp env)))
+	  (not (movitz:movitz-constantp localp env))
+	  (not (movitz:movitz-constantp endian env)))
       form
     (labels ((sub-extract-constant-delta (form)
 	       "Try to extract at compile-time an integer offset from form."
@@ -88,32 +89,41 @@
 			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 			    (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)))))))
 		(:unsigned-byte16
-		 (cond
-		  ((and (eq 0 offset) (eq 0 index))
-		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-		      (:compile-form (:result-mode :eax) ,object)
-		      (:movzxw (:eax ,(offset-by 2)) :ecx)))
-		  ((eq 0 offset)
-		   (let ((object-var (gensym "memref-object-"))
-			 (index-var (gensym "memref-index-")))
-		     `(let ((,object-var ,object)
-			    (,index-var ,index))
-			(with-inline-assembly (:returns :untagged-fixnum-ecx)
-			  (:compile-two-forms (:eax :ecx) ,object-var ,index-var)
-			  (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
-			  (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))))
-		  (t (let ((object-var (gensym "memref-object-"))
-			   (offset-var (gensym "memref-offset-"))
+		 (let* ((endian (ecase (movitz:movitz-eval endian env)
+				  ((:host :little) :little)
+				  (:big :big)))
+			(endian-fix-ecx (ecase endian
+					  (:little nil)
+					  (:big `((:xchgb :cl :ch))))))
+		   (cond
+		    ((and (eq 0 offset) (eq 0 index))
+		     `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+			(:compile-form (:result-mode :eax) ,object)
+			(:movzxw (:eax ,(offset-by 2)) :ecx)
+			, at endian-fix-ecx))
+		    ((eq 0 offset)
+		     (let ((object-var (gensym "memref-object-"))
 			   (index-var (gensym "memref-index-")))
 		       `(let ((,object-var ,object)
-			      (,offset-var ,offset)
 			      (,index-var ,index))
 			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
-			    (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var)
-			    (:leal (:ecx (:ebx 2)) :ecx)
-			    (:load-lexical (:lexical-binding ,object-var) :eax)
-			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
-			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))))))
+			    (:compile-two-forms (:eax :ecx) ,object-var ,index-var)
+			    (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+			    , at endian-fix-ecx))))
+		    (t (let ((object-var (gensym "memref-object-"))
+			     (offset-var (gensym "memref-offset-"))
+			     (index-var (gensym "memref-index-")))
+			 `(let ((,object-var ,object)
+				(,offset-var ,offset)
+				(,index-var ,index))
+			    (with-inline-assembly (:returns :untagged-fixnum-ecx)
+			      (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var)
+			      (:leal (:ecx (:ebx 2)) :ecx)
+			      (:load-lexical (:lexical-binding ,object-var) :eax)
+			      (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+			      (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+			      , at endian-fix-ecx)))))))
 		(:unsigned-byte14
 		 (cond
 		  ((and (eq 0 offset) (eq 0 index))
@@ -225,6 +235,8 @@
 			    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
 			    (:andl -4 :ecx)))))))
 		(:unsigned-byte32
+		 (let ((endian (movitz:movitz-eval endian env)))
+		   (assert (member endian '(:host :little))))
 		 (assert (= 4 movitz::+movitz-fixnum-factor+))
 		 (cond
 		  ((and (eq 0 offset) (eq 0 index))
@@ -314,22 +326,29 @@
 		(t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil))
 		   form)))))))))
 
-(defun memref (object offset index type)
+(defun memref (object offset index type &key localp (endian :host))
   (ecase type
-    (:lisp              (memref object offset index :lisp))
+    (:lisp              (if localp
+			    (memref object offset index :lisp :localp t)
+			  (memref object offset index :lisp :localp nil)))
     (:unsigned-byte32   (memref object offset index :unsigned-byte32))
     (:character         (memref object offset index :character))
     (:unsigned-byte8    (memref object offset index :unsigned-byte8))
     (:location          (memref object offset index :location))
     (:unsigned-byte14   (memref object offset index :unsigned-byte14))
-    (:unsigned-byte16   (memref object offset index :unsigned-byte16))
+    (:unsigned-byte16   (ecase endian
+			  ((:host :little)
+			   (memref object offset index :unsigned-byte16 :endian :little))
+			  ((:big)
+			   (memref object offset index :unsigned-byte16 :endian :big))))
     (:signed-byte30+2   (memref object offset index :signed-byte30+2))
     (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))
 
 (define-compiler-macro (setf memref) (&whole form &environment env value object offset index type
-				      &key (localp nil))
+				      &key (localp nil) (endian :host))
   (if (or (not (movitz:movitz-constantp type env))
-	  (not (movitz:movitz-constantp localp env)))
+	  (not (movitz:movitz-constantp localp env))
+	  (not (movitz:movitz-constantp endian env)))
       form
     (case (movitz::eval-form type)
       (:character
@@ -370,6 +389,8 @@
 		  (:load-lexical (:lexical-binding ,object-var) :ebx)
 		  (:movb :ah (:ebx :ecx))))))))
       (:unsigned-byte32
+       (let ((endian (movitz:movitz-eval endian env)))
+	 (assert (member endian '(:host :little))))
        (assert (= 4 movitz::+movitz-fixnum-factor+))
        (cond
 	((and (movitz:movitz-constantp value env)
@@ -430,98 +451,116 @@
 		  (:movl :edi :edx)
 		  (:cld)))))))
       (:unsigned-byte16
-       (cond
-	((and (movitz:movitz-constantp value env)
-	      (movitz:movitz-constantp offset env)
-	      (movitz:movitz-constantp index env))
-	 (let ((value (movitz:movitz-eval value env)))
-	   (check-type value (unsigned-byte 16))
-	   `(progn
-	      (with-inline-assembly (:returns :nothing)
-		(:compile-form (:result-mode :ebx) ,object)
-		(:movw ,value (:ebx ,(+ (movitz:movitz-eval offset env)
-					(* 2 (movitz:movitz-eval index env))))))
-	      ,value)))
-	((and (movitz:movitz-constantp offset env)
-	      (movitz:movitz-constantp index env))
-	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-	    (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object)
-	    (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env)
-				 (* 2 (movitz:movitz-eval index env)))))))
-	((and (movitz:movitz-constantp offset env)
-	      (movitz:movitz-constantp value env))
-	 (let ((value (movitz:movitz-eval value env))
-	       (index-var (gensym "memref-index-"))
-	       (object-var (gensym "memref-object-")))
-	   (check-type value (unsigned-byte 16))
-	   `(let ((,object-var ,object)
-		  (,index-var ,index))
-	      (with-inline-assembly (:returns :nothing)
-		(:compile-two-forms (:ecx :ebx) ,index-var ,object-var)
-		(:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
-		(:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env))))
-	      ,value)))
-	((movitz:movitz-constantp offset env)
-	 (let ((value-var (gensym "memref-value-"))
-	       (index-var (gensym "memref-index-"))
-	       (object-var (gensym "memref-object-")))
-	   (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+       (let ((endian (ecase (movitz:movitz-eval endian env)
+		       ((:host :little) :little)
+		       (:big :big))))
+	 (cond
+	  ((and (movitz:movitz-constantp value env)
+		(movitz:movitz-constantp offset env)
+		(movitz:movitz-constantp index env))
+	   (let* ((host-value (movitz:movitz-eval value env))
+		  (value (ecase endian
+			   (:little host-value)
+			   (:big (dpb (ldb (byte 8 0) host-value)
+				      (byte 8 8)
+				      (ldb (byte 8 8) host-value))))))
+	     (check-type value (unsigned-byte 16))
+	     `(progn
+		(with-inline-assembly (:returns :nothing)
+		  (:compile-form (:result-mode :ebx) ,object)
+		  (:movw ,value (:ebx ,(+ (movitz:movitz-eval offset env)
+					  (* 2 (movitz:movitz-eval index env))))))
+		,value)))
+	  ((and (movitz:movitz-constantp offset env)
+		(movitz:movitz-constantp index env))
+	   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+	      (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object)
+	      ,@(ecase endian
+		  (:little nil)
+		  (:big `((:xchg :cl :ch))))
+	      (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env)
+				   (* 2 (movitz:movitz-eval index env)))))))
+	  ((and (movitz:movitz-constantp offset env)
+		(movitz:movitz-constantp value env))
+	   (let ((value (movitz:movitz-eval value env))
+		 (index-var (gensym "memref-index-"))
+		 (object-var (gensym "memref-object-")))
+	     (check-type value (unsigned-byte 16))
+	     `(let ((,object-var ,object)
+		    (,index-var ,index))
+		(with-inline-assembly (:returns :nothing)
+		  (:compile-two-forms (:ecx :ebx) ,index-var ,object-var)
+		  (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+		  (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env))))
+		,value)))
+	  ((movitz:movitz-constantp offset env)
+	   (let ((value-var (gensym "memref-value-"))
+		 (index-var (gensym "memref-index-"))
+		 (object-var (gensym "memref-object-")))
+	     (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+		 `(let ((,value-var ,value)
+			(,object-var ,object)
+			(,index-var ,index))
+		    (with-inline-assembly (:returns :untagged-fixnum-eax)
+		      (:compile-two-forms (:ebx :ecx) ,object-var ,index-var)
+		      (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax)
+		      (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+		      (:movw :ax (:ebx :ecx  ,(movitz:movitz-eval offset env)))))
 	       `(let ((,value-var ,value)
 		      (,object-var ,object)
 		      (,index-var ,index))
-		  (with-inline-assembly (:returns :untagged-fixnum-eax)
+		  (with-inline-assembly (:returns :nothing)
 		    (:compile-two-forms (:ebx :ecx) ,object-var ,index-var)
-		    (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax)
+		    (:load-lexical (:lexical-binding ,value-var) :eax)
 		    (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
-		    (:movw :ax (:ebx :ecx  ,(movitz:movitz-eval offset env)))))
-	     `(let ((,value-var ,value)
-		    (,object-var ,object)
-		    (,index-var ,index))
-		(with-inline-assembly (:returns :nothing)
-		  (:compile-two-forms (:ebx :ecx) ,object-var ,index-var)
-		  (:load-lexical (:lexical-binding ,value-var) :eax)
-		  (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
-		  (:movl :edi :edx)
-		  (:std)
-		  (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
-		  (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env)))
-		  (:movl :edi :eax)
-		  (:cld))
-		,value-var))))
-	(t (let ((value-var (gensym "memref-value-"))
-		 (object-var (gensym "memref-object-"))
-		 (offset-var (gensym "memref-offset-"))
-		 (index-var (gensym "memref-index-")))
-	     (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+		    (:movl :edi :edx)
+		    (:std)
+		    (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
+		    ,@(ecase endian
+			(:little nil)
+			(:big `((:xchgb :al :ah))))
+		    (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env)))
+		    (:movl :edi :eax)
+		    (:cld))
+		  ,value-var))))
+	  (t (let ((value-var (gensym "memref-value-"))
+		   (object-var (gensym "memref-object-"))
+		   (offset-var (gensym "memref-offset-"))
+		   (index-var (gensym "memref-index-")))
+	       (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+		   `(let ((,value-var ,value)
+			  (,object-var ,object)
+			  (,offset-var ,offset)
+			  (,index-var ,index))
+		      (with-inline-assembly (:returns :untagged-fixnum-eax)
+			(:compile-two-forms (:ebx :ecx) ,offset-var ,index-var)
+			(:load-lexical (:lexical-binding ,value-var) :eax)
+			(:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax)
+			(:leal (:ebx (:ecx 2)) :ecx)
+			(:shrl ,movitz:+movitz-fixnum-shift+ :eax)
+			(:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+			(:load-lexical (:lexical-binding ,object-var) :ebx)
+			(:movw :ax (:ebx :ecx))))
 		 `(let ((,value-var ,value)
 			(,object-var ,object)
 			(,offset-var ,offset)
 			(,index-var ,index))
-		    (with-inline-assembly (:returns :untagged-fixnum-eax)
+		    (with-inline-assembly (:returns :nothing)
 		      (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var)
 		      (:load-lexical (:lexical-binding ,value-var) :eax)
-		      (:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax)
 		      (:leal (:ebx (:ecx 2)) :ecx)
-		      (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
 		      (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
 		      (:load-lexical (:lexical-binding ,object-var) :ebx)
-		      (:movw :ax (:ebx :ecx))))
-	       `(let ((,value-var ,value)
-		      (,object-var ,object)
-		      (,offset-var ,offset)
-		      (,index-var ,index))
-		  (with-inline-assembly (:returns :nothing)
-		    (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var)
-		    (:load-lexical (:lexical-binding ,value-var) :eax)
-		    (:leal (:ebx (:ecx 2)) :ecx)
-		    (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
-		    (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
-		    (:load-lexical (:lexical-binding ,object-var) :ebx)
-		    (:movb :ah (:ebx :ecx))
-		    (:andl #xff0000 :eax)
-		    (:shrl 8 :eax)
-		    (:movb :ah (:ebx :ecx 1)))
-		  ,value-var))))))
+		      (:std)
+		      (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
+		      ,@(ecase endian
+			  (:little nil)
+			  (:big `((:xchgb :al :ah))))
+		      (:movw :ax (:ebx :ecx))
+		      (:shll ,movitz:+movitz-fixnum-shift+ :eax)
+		      (:movl :edi :edx)
+		      (:cld))
+		    ,value-var)))))))
       (:unsigned-byte8
        (cond
 	((and (movitz:movitz-constantp value env)
@@ -644,18 +683,24 @@
       (t ;; (warn "Can't handle inline MEMREF: ~S" form)
 	 form))))
 
-(defun (setf memref) (value object offset index type)
+(defun (setf memref) (value object offset index type &key localp (endian :host))
   (ecase type
     (:character
      (setf (memref object offset index :character) value))
     (:unsigned-byte8
      (setf (memref object offset index :unsigned-byte8) value))
     (:unsigned-byte16
-     (setf (memref object offset index :unsigned-byte16) value))
+     (ecase endian
+       ((:host :little)
+	(setf (memref object offset index :unsigned-byte16 :endian :little) value))
+       ((:big)
+	(setf (memref object offset index :unsigned-byte16 :endian :big) value))))
     (:unsigned-byte32
      (setf (memref object offset index :unsigned-byte32) value))
     (:lisp
-     (setf (memref object offset index :lisp) value))))
+     (if localp
+	 (setf (memref object offset index :lisp :localp t) value)
+       (setf (memref object offset index :lisp :localp nil) value)))))
 
 (define-compiler-macro memref-int (&whole form &environment env address offset index type
 				   &optional physicalp)




From ffjeld at common-lisp.net  Thu Oct  7 12:44:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:44:18 +0200
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CFXd4-0006ZN-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Make dynamic-unwind-next preserve EDX.

Date: Thu Oct  7 14:44:18 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.45 movitz/losp/muerte/primitive-functions.lisp:1.46
--- movitz/losp/muerte/primitive-functions.lisp:1.45	Sat Sep 25 17:51:22 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Oct  7 14:44:17 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.45 2004/09/25 15:51:22 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.46 2004/10/07 12:44:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -113,11 +113,10 @@
 (define-primitive-function dynamic-unwind-next (dynamic-env)
   "Locate the next unwind-protect entry between here and dynamic-env.
 If no such entry is found, return (same) dynamic-env in EAX and CF=0.
-Otherwise return the unwind-protect entry in EAX and CF=1."
+Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX."
   (with-inline-assembly (:returns :nothing)
     (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
-
-    (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx))
+    (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx))
     (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))
     
    search-loop
@@ -127,7 +126,7 @@
     (:cmpl :ecx :eax)
     (:je 'found-dynamic-env)
     
-    (:cmpl :edx (:ecx 4))		; unwind-protect entry?
+    (:cmpl :ebx (:ecx 4))		; unwind-protect entry?
     (:je 'found-unwind-protect)
     
     (:movl (:ecx 12) :ecx)		; proceed search




From ffjeld at common-lisp.net  Thu Oct  7 12:45:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:45:12 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/keyboard.lisp 
Message-ID: <E1CFXdw-0006d3-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv25449

Modified Files:
	keyboard.lisp 
Log Message:
Tuning of *scan-codes*.

Date: Thu Oct  7 14:45:10 2004
Author: ffjeld

Index: movitz/losp/x86-pc/keyboard.lisp
diff -u movitz/losp/x86-pc/keyboard.lisp:1.2 movitz/losp/x86-pc/keyboard.lisp:1.3
--- movitz/losp/x86-pc/keyboard.lisp:1.2	Mon Jan 19 12:23:52 2004
+++ movitz/losp/x86-pc/keyboard.lisp	Thu Oct  7 14:45:07 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep 24 16:04:12 2001
 ;;;;                
-;;;; $Id: keyboard.lisp,v 1.2 2004/01/19 11:23:52 ffjeld Exp $
+;;;; $Id: keyboard.lisp,v 1.3 2004/10/07 12:45:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -37,7 +37,8 @@
       #\D      #\F      #\G      #\H      #\J      #\K      #\L      #\: ; #x20
       #\"      #\~      nil      #\|      #\Z      #\X      #\C      #\V ; #x28
       #\B      #\N      #\M      #\<      #\>      #\?      nil      nil ; #x30
-      nil      nil      nil      nil      nil      nil      nil      nil)) ; #x38
+      nil      nil      nil      nil      nil      nil      nil      nil ; #x38
+      nil      nil      nil      nil      nil    :pause     nil      nil)) ; #x40
 
 (defparameter *scan-codes*
     #(#\null   #\esc    #\1      #\2      #\3      #\4      #\5      #\6 ; #x00
@@ -50,7 +51,7 @@
       #\b      #\n      #\m      #\,      #\.      #\/  :shift-right #\esc ; #x30
       :alt-left #\space :caps-lock :f1    :f2      :f3      :f4      :f5 ; #x38
 			       
-      :f6      :f7      :f8      :f9      :f10    :num-lock nil      nil ; #x40
+      :f6      :f7      :f8      :f9      :f10   :break :scroll-lock nil ; #x40
       nil      nil      nil      nil      nil      nil      nil      nil ; #x48
       nil      :kp-ins  nil      :kp-del  nil      nil      nil      :f11 ; #x50
       :f12     nil      nil      nil      nil      nil      nil      nil ; #x58
@@ -112,21 +113,6 @@
        (io-port #x60 :unsigned-byte8))
       (t (values (ldb (byte 7 0) first-code)
 		 (logbitp 7 first-code))))))
-
-;;;(defmacro define-boolbit-accessor (name (bit-pos state-var) &body body)
-;;;  `(progn
-;;;     (defun ,name ()
-;;;       (logbitp ,bit-pos ,state-var))
-;;;     (defun (setf ,name) (value)
-;;;       (setf ,state-var
-;;;	 (dpb (if value 1 0) (byte 1 ,bit-pos) ,state-var))
-;;;       , at body
-;;;       (logbitp ,bit-pos ,state-var))))
-
-
-;;;(define-boolbit-accessor qualifier-shift (0 *qualifier-state*))
-;;;(define-boolbit-accessor qualifier-ctrl  (1 *qualifier-state*))
-;;;(define-boolbit-accessor qualifier-alt   (2 *qualifier-state*))
 
 (define-named-integer qualifier (:only-constants t)
   (0 shift)




From ffjeld at common-lisp.net  Thu Oct  7 12:48:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:48:39 +0200
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1CFXhH-0006pa-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Minor edit, removed false comment.

Date: Thu Oct  7 14:48:39 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.40 movitz/special-operators.lisp:1.41
--- movitz/special-operators.lisp:1.40	Tue Sep 21 15:01:23 2004
+++ movitz/special-operators.lisp	Thu Oct  7 14:48:39 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.40 2004/09/21 13:01:23 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.41 2004/10/07 12:48:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1204,7 +1204,7 @@
 				       (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
 				       (:store-lexical ,next-continuation-step-binding :eax :type t)
 				       ))))
-			;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP..
+			;; now outside of m-v-prog1's cloak, with final dynamic-slot in ..
 			;; ..unwind it and transfer control.
 			;;
 			;; * 12 dynamic-env uplink




From ffjeld at common-lisp.net  Thu Oct  7 12:52:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:52:48 +0200
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CFXlI-0006q4-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Fixed tagbody/go for stack discipline.

Date: Thu Oct  7 14:52:48 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.24 movitz/special-operators-cl.lisp:1.25
--- movitz/special-operators-cl.lisp:1.24	Fri Sep 17 13:12:47 2004
+++ movitz/special-operators-cl.lisp	Thu Oct  7 14:52:47 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.24 2004/09/17 11:12:47 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.25 2004/10/07 12:52:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -624,10 +624,13 @@
 	:returns last-returns
 	:functional-p nil))))
 		  
-(define-special-operator tagbody (&all forward &funobj funobj &form form &env env &result-mode result-mode)
+(define-special-operator tagbody
+    (&all forward &funobj funobj &form form &env env)
   (let* ((save-esp-variable (gensym "tagbody-save-esp"))
 	 (lexical-catch-tag-variable (gensym "tagbody-lexical-catch-tag-"))
-	 (tagbody-env (make-instance 'lexical-exit-point-env
+	 (label-set-name (gensym "label-set-"))
+	 (tagbody-env (make-instance 'tagbody-env
+			:label-set-name label-set-name
 			:uplink env
 			:funobj funobj
 			:save-esp-variable save-esp-variable
@@ -642,8 +645,7 @@
     (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable ,lexical-catch-tag-variable))
 			       tagbody-env nil)
     ;; First generate an assembly-level label for each tag.
-    (let* ((label-set-name (gensym "label-set-"))
-	   (label-set (loop with label-id = 0
+    (let* ((label-set (loop with label-id = 0
 			  for tag-or-statement in (cdr form)
 			  as label = (when (or (symbolp tag-or-statement)
 					       (integerp tag-or-statement))
@@ -654,59 +656,60 @@
 			     (setf (movitz-env-get tag-or-statement 'go-tag-label-id nil tagbody-env)
 			       (post-incf label-id))
 			  and collect label))
-	   (tagbody-functional-p t)
-	   (tagbody-code
+	   (tagbody-codes
 	    (loop for tag-or-statement in (cdr form)
-;;;		when (and (symbolp tag-or-statement)
-;;;			  (movitz-env-get tag-or-statement 'muerte::loop-tag nil tagbody-env))
-;;;		collect '(:align :code :loop)
 		if (or (symbolp tag-or-statement) ; Tagbody tags are "compiled" into..
 		       (integerp tag-or-statement)) ; ..their assembly-level labels.
 		collect (movitz-env-get tag-or-statement 'go-tag nil tagbody-env)
-		else append
-		     (compiler-values-bind (&code code &functional-p functional-p)
-			 (compiler-call #'compile-form
-			   :defaults forward
-			   :form tag-or-statement
-			   :env tagbody-env
-			   :result-mode :ignore)
-		       (unless functional-p
-			 (setf tagbody-functional-p nil))
-		       code))))
-      (let ((maybe-store-esp-code
-	     (when (and (not (eq result-mode :function))
-			(operators-present-in-code-p tagbody-code '(:lexical-control-transfer) nil
-						     :test (lambda (x) (eq tagbody-env (fifth x)))))
-	       `((:init-lexvar ,save-esp-binding
-			       :init-with-register :esp
-			       :init-with-type t)))))
-	(if (not (code-uses-binding-p tagbody-code lexical-catch-tag-binding))
+		else collect
+		     (compiler-call #'compile-form
+		       :defaults forward
+		       :form tag-or-statement
+		       :env tagbody-env
+		       :result-mode :ignore))))
+      (let* ((unlexical-target-p (some (lambda (code)
+					 (when (listp code)
+					   (code-uses-binding-p code save-esp-binding)))
+				       tagbody-codes))
+	     (maybe-store-esp-code
+	      (when (or unlexical-target-p
+			(some (lambda (code)
+				(when (listp code)
+				  (operators-present-in-code-p code '(:lexical-control-transfer) nil
+							       :test (lambda (x)
+								       (eq tagbody-env (fifth x))))))
+			      tagbody-codes))
+		`((:init-lexvar ,save-esp-binding
+				:init-with-register :esp
+				:init-with-type t)))))
+	(if (not unlexical-target-p)
 	    (compiler-values ()
-	      :code (append maybe-store-esp-code tagbody-code)
-	      :functional-p tagbody-functional-p
+	      :code (append maybe-store-esp-code
+			    (loop for code in tagbody-codes
+				if (listp code)
+				append code
+				else append (list code)))
 	      :returns :nothing)
-	  (let ((code (append maybe-store-esp-code
-			      `((:declare-label-set ,label-set-name ,label-set)
-				(:leal ((:esi 8) :esp) :eax) ; generate some semi-unique value
-				(:leal ((:eax 2) :edi) :eax) ; with tag5.
-				(:init-lexvar ,lexical-catch-tag-binding
-					      :init-with-register :eax
-					      :init-with-type t))
-			      ;; catcher
-			      `((:locally (:pushl (:edi (:edi-offset dynamic-env))))
+	  (let ((code (append `((:declare-label-set ,label-set-name ,label-set)
+				;; catcher
+				(:locally (:pushl (:edi (:edi-offset dynamic-env))))
 				(:pushl ',label-set-name)
 				(:pushl :eax)
 				(:pushl :ebp)
 				(:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
-			      tagbody-code
-			      `((:leal (:esp ,(+ -4 16)) :esp)
-				(:locally (:popl (:edi (:edi-offset dynamic-env)))))
+			      maybe-store-esp-code
+			      (loop for code in tagbody-codes
+				  if (listp code)
+				  append code
+				  else append (list code '(:movl (:esp) :ebp)))
+			      `((:movl (:esp 12) :edx)
+				(:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+				(:leal (:esp 16) :esp))
 			      )))
 	    (setf (num-specials tagbody-env) 1
 		  (stack-used tagbody-env) 4)
 	    (compiler-values ()
 	      :code code
-	      :functional-p tagbody-functional-p
 	      :returns :nothing)))))))
 			
 				
@@ -724,8 +727,31 @@
 	    :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
 	;; Perform a lexical "throw" to the tag. Much like a regular throw, except
 	;; no values are transferred, and we step _into_ that dynamic env, not outside it.
-	(let ((label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
+	(let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env))
+	      (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
 	  (assert label-id)
+	  #+ignore
+	  (compiler-call #'compile-form-unprotected
+	    :forward all
+	    :form `(muerte::exact-throw ,(movitz-env-lexical-catch-tag-variable tagbody-env)
+					0 nil))
+	  (compiler-values ()
+	    :returns :non-local-exit
+	    :code `((:load-lexical ,save-esp-binding :edx)
+		    (:movl :edx :eax)
+		    (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
+		    (:jnc '(:sub-program () (:int 63)))
+		    ;; have next-continuation in EAX, final-continuation in EDX
+		    (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
+		    (:locally (:movl :esi (:edi (:edi-offset scratch1))))
+		    (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; exit to next-env
+		    (:movl :eax :esp)	; enter non-local jump stack mode.
+		    (:movl (:esp) :eax)	; target stack-frame EBP
+		    (:movl (:eax -4) :esi) ; get target funobj into ESI
+		    (:movl (:esp 8) :eax) ; target jumper number
+		    (:jmp (:esi :eax
+				,(* 4 label-id) ,(slot-offset 'movitz-funobj 'constant0)))))
+	  #+ignore
 	  (compiler-values ()
 	    :returns :non-local-exit
 	    :code (append (compiler-call #'compile-form




From ffjeld at common-lisp.net  Thu Oct  7 12:54:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 07 Oct 2004 14:54:44 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1CFXnA-0006qi-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Minor edits.

Date: Thu Oct  7 14:54:43 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.40 movitz/losp/los0-gc.lisp:1.41
--- movitz/losp/los0-gc.lisp:1.40	Fri Oct  1 14:44:20 2004
+++ movitz/losp/los0-gc.lisp	Thu Oct  7 14:54:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.40 2004/10/01 12:44:20 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.41 2004/10/07 12:54:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -270,10 +270,6 @@
 	   (+ 1 (object-location space)
 	      (array-dimension space 0)))))
 
-(defun tenure ()
-  (install-old-consing)
-  (install-los0-consing))
-
 (defun report-nursery (x location)
   "Write a message if x is inside newspace."
   (when (object-in-space-p (%run-time-context-slot 'nursery-space) x)
@@ -293,6 +289,12 @@
 	     find-location x location))
     x))
 
+#+ignore
+(defun tenure ()
+  (install-old-consing)
+  (install-los0-consing))
+
+#+ignore
 (defun kill-the-newborns ()
   (let* ((oldspace (%run-time-context-slot 'nursery-space))
 	 (newspace (space-other oldspace)))




From ffjeld at common-lisp.net  Fri Oct  8 10:26:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 08 Oct 2004 12:26:41 +0200
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CFrxR-0002Lj-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Fix non-local go to work across unwind-protects.

Date: Fri Oct  8 12:26:38 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.25 movitz/special-operators-cl.lisp:1.26
--- movitz/special-operators-cl.lisp:1.25	Thu Oct  7 14:52:47 2004
+++ movitz/special-operators-cl.lisp	Fri Oct  8 12:26:38 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.25 2004/10/07 12:52:47 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.26 2004/10/08 10:26:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -725,20 +725,18 @@
 	  (compiler-values ()
 	    :returns :non-local-exit
 	    :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
-	;; Perform a lexical "throw" to the tag. Much like a regular throw, except
-	;; no values are transferred, and we step _into_ that dynamic env, not outside it.
+	;; Perform a lexical "throw" to the tag. Just like a regular (dynamic) throw.
 	(let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env))
 	      (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
 	  (assert label-id)
-	  #+ignore
-	  (compiler-call #'compile-form-unprotected
-	    :forward all
-	    :form `(muerte::exact-throw ,(movitz-env-lexical-catch-tag-variable tagbody-env)
-					0 nil))
 	  (compiler-values ()
 	    :returns :non-local-exit
 	    :code `((:load-lexical ,save-esp-binding :edx)
 		    (:movl :edx :eax)
+		    ,@(when (plusp label-id)
+			;; The target jumper points to the tagbody's label-set.
+			;; Now, install correct jumper within tagbody as target.
+			`((:addl ,(* 4 label-id) (:edx 8))))
 		    (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
 		    (:jnc '(:sub-program () (:int 63)))
 		    ;; have next-continuation in EAX, final-continuation in EDX
@@ -749,26 +747,8 @@
 		    (:movl (:esp) :eax)	; target stack-frame EBP
 		    (:movl (:eax -4) :esi) ; get target funobj into ESI
 		    (:movl (:esp 8) :eax) ; target jumper number
-		    (:jmp (:esi :eax
-				,(* 4 label-id) ,(slot-offset 'movitz-funobj 'constant0)))))
-	  #+ignore
-	  (compiler-values ()
-	    :returns :non-local-exit
-	    :code (append (compiler-call #'compile-form
-			    :result-mode :eax
-			    :forward all
-			    :form (movitz-env-lexical-catch-tag-variable tagbody-env))
-			  `((:xorl :ebx :ebx)
-			    (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag))))
-			    (:jnc '(:sub-program () (:int 108)))
-			    (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
-			    (:movl :eax :esp)
-			    (:movl (:esp) :ebp)
-			    (:movl (:ebp -4) :esi)
-			    (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; enter dynamic env
-			    (:movl (:esp 8) :ecx) ; label-set base
-			    (:jmp (:esi :ecx ,(+ (slot-offset 'movitz-funobj 'constant0)
-						 (* 4 label-id)))))))))))) ; transfer control, finally.
+		    (:clc)
+		    (:jmp (:esi :eax ,(slot-offset 'movitz-funobj 'constant0))))))))))
 
 (define-special-operator block (&all forward &funobj funobj &form form &env env
 				     &result-mode result-mode)




From ffjeld at common-lisp.net  Fri Oct  8 12:16:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 08 Oct 2004 14:16:12 +0200
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CFtfQ-0004Co-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed buglet in stack-delta that would barf in some situations.

Date: Fri Oct  8 14:16:11 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.99 movitz/compiler.lisp:1.100
--- movitz/compiler.lisp:1.99	Wed Sep 15 12:22:52 2004
+++ movitz/compiler.lisp	Fri Oct  8 14:16:08 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.99 2004/09/15 10:22:52 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.100 2004/10/08 12:16:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5789,10 +5789,6 @@
       (:jne ',push-values-loop)
       ,push-values-done)))
 
-;;;(:load-lexical ,numargs-binding :eax)
-;;;      (:addl :ecx :eax)
-;;;      (:store-lexical ,numargs-binding :eax :type fixnum))))
-
 (defun stack-delta (inner-env outer-env)
   "Calculate the amount of stack-space used (in 32-bit stack slots) at the time
 of <inner-env> since <outer-env>,
@@ -5807,9 +5803,8 @@
 	 (cond
 	  ((eq outer-env env)
 	   ;; Each dynamic-slot is 4 stack-distances, so let's check that..
-	   (unless (>= stack-distance (* 4 num-dynamic-slots))
-	     (print-stack-delta inner-env outer-env))
-	   (assert (>= stack-distance (* 4 num-dynamic-slots)) ()
+	   (assert (or (eq t stack-distance)
+		       (>= stack-distance (* 4 num-dynamic-slots))) ()
 	     "The stack-distance ~D is smaller than number of dynamic-slots ~D, which is inconsistent."
 	     stack-distance num-dynamic-slots)
 	   (values stack-distance num-dynamic-slots unwind-protects))




From ffjeld at common-lisp.net  Mon Oct 11 13:44:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:44:05 +0200
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CH0T7-0007eI-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Some variables should be defparameteres, not defvars.

Date: Mon Oct 11 15:44:05 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.100 movitz/compiler.lisp:1.101
--- movitz/compiler.lisp:1.100	Fri Oct  8 14:16:08 2004
+++ movitz/compiler.lisp	Mon Oct 11 15:44:04 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.100 2004/10/08 12:16:08 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.101 2004/10/11 13:44:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -44,14 +44,14 @@
   "Use these assembly-instruction prefixes when accessing the global
 run-time context.")
 
-(defvar *compiler-physical-segment-prefix* '(:gs-override)
+(defparameter *compiler-physical-segment-prefix* '(:gs-override)
   "Use this instruction prefix when accessing a physical memory location (i.e. typically some memory-mapped hardware device).")
 
-(defvar *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override)
+(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override)
   "Use this segment prefix when reading a lispval at (potentially)
 non-local locations.")
 
-(defvar *compiler-nonlocal-lispval-write-segment-prefix* '(:fs-override)
+(defparameter *compiler-nonlocal-lispval-write-segment-prefix* '(:fs-override)
   "Use this segment prefix when writing a lispval at (potentially)
 non-local locations.")
 




From ffjeld at common-lisp.net  Mon Oct 11 13:46:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:46:27 +0200
Subject: [movitz-cvs] CVS update: movitz/environment.lisp 
Message-ID: <E1CH0VP-0007rm-00@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Some tweaking of the environment object for unwind-protects.

Date: Mon Oct 11 15:46:26 2004
Author: ffjeld

Index: movitz/environment.lisp
diff -u movitz/environment.lisp:1.8 movitz/environment.lisp:1.9
--- movitz/environment.lisp:1.8	Thu Oct  7 14:41:41 2004
+++ movitz/environment.lisp	Mon Oct 11 15:46:25 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov  3 11:40:15 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: environment.lisp,v 1.8 2004/10/07 12:41:41 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.9 2004/10/11 13:46:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -229,11 +229,15 @@
 (defclass tagbody-env (lexical-exit-point-env) ())
 
 (defclass unwind-protect-env (movitz-environment)
-  ())
+  ((cleanup-form
+    :initarg :cleanup-form
+    :reader unwind-protect-env-cleanup-form)))
 
 (defmethod num-dynamic-slots ((x unwind-protect-env)) 1)
 
-(defclass simple-dynamic-env (with-things-on-stack-env) ()
+(defclass simple-dynamic-env (with-things-on-stack-env)
+  ((stack-used
+    :initform 4))
   (:documentation "An environment that installs one dynamic-env."))
 
 (defmethod num-dynamic-slots ((x simple-dynamic-env)) 1)




From ffjeld at common-lisp.net  Mon Oct 11 13:46:58 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:46:58 +0200
Subject: [movitz-cvs] CVS update: movitz/eval.lisp 
Message-ID: <E1CH0Vu-0007tS-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Make movitz-constantp and movitz-eval understand compiler-macros.

Date: Mon Oct 11 15:46:57 2004
Author: ffjeld

Index: movitz/eval.lisp
diff -u movitz/eval.lisp:1.7 movitz/eval.lisp:1.8
--- movitz/eval.lisp:1.7	Wed Jul 21 16:14:29 2004
+++ movitz/eval.lisp	Mon Oct 11 15:46:56 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  2 17:45:05 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: eval.lisp,v 1.7 2004/07/21 14:14:29 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.8 2004/10/11 13:46:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -56,29 +56,41 @@
 	   (eq 'muerte.cl::quote (first x)))
        t))
 
-(defun movitz-constantp (form &optional (environment nil))
-  (let ((form (translate-program form :cl :muerte.cl)))
-    (typecase form
-      (keyword t)
-      (symbol (or (movitz-env-get form 'constantp nil environment)
-		  (typep (movitz-binding form environment) 'constant-object-binding)))
-      (cons (case (car form)
-	      ((muerte.cl:quote) t)
-	      ((muerte.cl:not)
-	       (movitz-constantp (second form)))
-	      ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce)
-	       (every (lambda (sub-form)
-			(movitz-constantp sub-form environment))
-		      (cdr form)))))
-      (t t))))				; anything else is self-evaluating.
-
-
-(defun isconst (x)
-  (or (integerp x)
-      (stringp x)
-      (eq t x)
-      (eq nil x)
-      (quote-form-p x)))
+(defun movitz-constantp (form &optional (env nil))
+  (typecase form
+    (keyword t)
+    (symbol
+     (let ((form (translate-program form :cl :muerte.cl)))
+       (or (movitz-env-get form 'constantp nil env)
+	   (typep (movitz-binding form env) 'constant-object-binding))))
+    (cons
+     (let* ((compiler-macro-function (movitz-compiler-macro-function (car form) env))
+	    (compiler-macro-expansion (and compiler-macro-function
+					   (funcall *movitz-macroexpand-hook*
+						    compiler-macro-function
+						    form env))))
+       (or (let ((form (translate-program form :cl :muerte.cl)))
+	     (case (car form)
+	       ((muerte.cl:quote) t)
+	       ((muerte.cl:not)
+		(movitz-constantp (second form)))
+	       ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce)
+		(every (lambda (sub-form)
+			 (movitz-constantp sub-form env))
+		       (cdr form)))))
+	   (and compiler-macro-function
+		(not (movitz-env-get (car form) 'notinline nil env))
+		(not (eq form compiler-macro-expansion))
+		(movitz-constantp compiler-macro-expansion env)))))
+    (t t)))				; anything else is self-evaluating.
+
+
+;;;(defun isconst (x)
+;;;  (or (integerp x)
+;;;      (stringp x)
+;;;      (eq t x)
+;;;      (eq nil x)
+;;;      (quote-form-p x)))
 
 (defun eval-form (&rest args)
   (apply 'movitz-eval args))
@@ -115,11 +127,32 @@
 
 (defun eval-cons (form env top-level-p)
   "3.1.2.1.2 Conses as Forms"
-  (let ((operator (car form)))
-    (declare (ignore operator))
+  (let* ((operator (car form))
+	 (compiler-macro-function (movitz-compiler-macro-function operator env))
+	 (compiler-macro-expansion (and compiler-macro-function
+					(funcall *movitz-macroexpand-hook*
+						 compiler-macro-function
+						 form env))))
     (cond
-     ((movitz-constantp form env)
-      (eval-constant-compound form env top-level-p))
+;;;     ((movitz-constantp form env)
+;;;      (eval-constant-compound form env top-level-p))
+     ((member operator '(cl:quote muerte.cl::quote))
+      (eval-self-evaluating (second form) env top-level-p))
+     ((member operator '(muerte.cl::not))
+      (not (eval-form (second form) env nil)))
+     ((member operator '(muerte.cl:+ muerte.cl:- muerte.cl:*))
+      (apply (translate-program (car form) :muerte.cl :cl)
+	     (mapcar (lambda (sub-form)
+		       (movitz-eval sub-form env nil))
+		     (cdr form))))
+     ((member operator '(muerte.cl:coerce))
+      (apply #'coerce
+	     (mapcar (lambda (arg) (movitz-eval arg env nil))
+		     (cdr form))))
+     ((and compiler-macro-function
+	   (not (movitz-env-get (car form) 'notinline nil env))
+	   (not (eq form compiler-macro-expansion)))
+      (movitz-eval compiler-macro-expansion env top-level-p))
 ;;;     ((lambda-form-p form)
 ;;;      (eval-lambda-form form env top-level-p))
 ;;;     ((symbolp operator)




From ffjeld at common-lisp.net  Mon Oct 11 13:48:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:48:08 +0200
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CH0X2-0007tx-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Make "lexical" unwind-protects work (for some definition of work..)

Date: Mon Oct 11 15:48:07 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.26 movitz/special-operators-cl.lisp:1.27
--- movitz/special-operators-cl.lisp:1.26	Fri Oct  8 12:26:38 2004
+++ movitz/special-operators-cl.lisp	Mon Oct 11 15:48:07 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.26 2004/10/08 10:26:38 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.27 2004/10/11 13:48:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -721,7 +721,9 @@
 	(movitz-env-get tag 'go-tag nil env)
       (assert (and label tagbody-env) ()
 	"Go-tag ~W is not visible." tag)
-      (if (eq funobj (movitz-environment-funobj tagbody-env))
+      (if (and (eq funobj (movitz-environment-funobj tagbody-env))
+	       ;; any unwind-protects between here and there?
+	       (null (nth-value 2 (stack-delta env tagbody-env))))
 	  (compiler-values ()
 	    :returns :non-local-exit
 	    :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
@@ -1210,6 +1212,7 @@
 				    (make-instance 'located-binding
 				      :name (gensym "up-next-continuation-step-"))))
 	   (unwind-protect-env (make-instance 'unwind-protect-env
+				 :cleanup-form (cons 'muerte.cl:progn cleanup-forms)
 				 :uplink continuation-env
 				 :funobj (movitz-environment-funobj env))))
       (with-labels (unwind-protect (cleanup-label cleanup-entry continue continue-label))




From ffjeld at common-lisp.net  Mon Oct 11 13:51:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:51:53 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1CH0af-0007uX-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:51:52 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.41 movitz/losp/los0-gc.lisp:1.42
--- movitz/losp/los0-gc.lisp:1.41	Thu Oct  7 14:54:43 2004
+++ movitz/losp/los0-gc.lisp	Mon Oct 11 15:51:52 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.41 2004/10/07 12:54:43 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.42 2004/10/11 13:51:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -29,7 +29,7 @@
   "Make a space vector at a fixed location."
   (assert (evenp location))
   (macrolet ((x (index)
-	       `(memref location 0 ,index :unsigned-byte32)))
+	       `(memref location 0 :index ,index :type :unsigned-byte32)))
     (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size)
 	  (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32)
 			  (cl:byte 8 8)
@@ -38,10 +38,10 @@
 
 
 (defmacro space-fresh-pointer (space)
-  `(memref ,space -6 2 :lisp))
+  `(memref ,space -6 :index 2))
 
 (defmacro space-other (space)
-  `(memref ,space -6 3 :lisp))
+  `(memref ,space -6 :index 3))
 
 (defun allocate-space (size &optional other-space)
   (let ((space (make-array size :element-type '(unsigned-byte 32))))
@@ -339,8 +339,8 @@
 		   x)
 		  (t (or (and (eq (object-tag x)
 				  (ldb (byte 3 0)
-				       (memref (object-location x) 0 0 :unsigned-byte8)))
-			      (let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
+				       (memref (object-location x) 0 :type :unsigned-byte8)))
+			      (let ((forwarded-x (memref (object-location x) 0)))
 				(and (object-in-space-p newspace forwarded-x)
 				     forwarded-x)))
 			 (let ((forward-x (shallow-copy x)))
@@ -348,9 +348,9 @@
 				      *gc-consitency-check*)
 			     (let ((a *x*))
 			       (vector-push (%object-lispval x) a)
-			       (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a)
+			       (vector-push (memref (object-location x) 0 :type :unsigned-byte32) a)
 			       (assert (vector-push (%object-lispval forward-x) a))))
-			   (setf (memref (object-location x) 0 0 :lisp) forward-x)
+			   (setf (memref (object-location x) 0) forward-x)
 			   forward-x))))))))
       ;; Scavenge roots
       (dolist (range muerte::%memory-map-roots%)
@@ -375,7 +375,7 @@
 		((>= i (length a)))
 	      (let ((old (%lispval-object (aref a i)))
 		    (old-class (aref a (+ i 1))))
-		(setf (memref (object-location old) 0 0 :unsigned-byte32) old-class)))
+		(setf (memref (object-location old) 0 :type :unsigned-byte32) old-class)))
 	    ;; Then, check that each migrated object is equalp to its new self.
 	    (do ((i 0 (+ i 3)))
 		((>= i (length a)))




From ffjeld at common-lisp.net  Mon Oct 11 13:51:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:51:56 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1CH0ai-0007ux-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:51:56 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.22 movitz/losp/los0.lisp:1.23
--- movitz/losp/los0.lisp:1.22	Tue Sep 21 15:11:08 2004
+++ movitz/losp/los0.lisp	Mon Oct 11 15:51:55 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.22 2004/09/21 13:11:08 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.23 2004/10/11 13:51:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -151,6 +151,31 @@
   'jumbo)
 
 #+ignore
+(defun tagbodyxx (x)
+  (tagbody
+    (print 'hello)
+   haha
+    (unwind-protect
+	(when x (go hoho))
+      (warn "unwind.."))
+    (print 'world)
+   hoho
+    (print 'blrugh)))
+
+#+ignore
+(defun tagbodyxx (x)
+  (tagbody
+    (print 'hello)
+   haha
+    (unwind-protect
+	(funcall (lambda ()
+		   (when x (go hoho))))
+      (warn "unwind.."))
+    (print 'world)
+   hoho
+    (print 'blrugh)))
+
+#+ignore
 (defun kumbo (&key a b (c (jumbo 1 2 3)) d)
   (print a)
   (print b)
@@ -384,7 +409,7 @@
 (defun xplus (x)
   (typep x '(integer 0 *)))
 
-(defstruct xxx
+(defstruct (xxx :constructor (:constructor boa-make-xxx (x y z)))
   x y (z 'init-z))
 
 (defun test-struct ()
@@ -1035,7 +1060,7 @@
     (muerte::positive-bignum
      (let ((x (muerte::copy-bignum limit)))
        (dotimes (i (1- (muerte::%bignum-bigits x)))
-	 (setf (memref x 2 i :unsigned-byte32)
+	 (setf (memref x 2 :index i :type :unsigned-byte32)
 	   (muerte::read-time-stamp-counter)))
        (setf x (muerte::bignum-canonicalize x))
        (loop while (>= x limit)
@@ -1049,7 +1074,6 @@
     (:ret)))
 
 (defun test-irq (&optional eax ebx ecx edx)
-  (setf (memref nil #x7f 20 :code-vector) (symbol-value 'test-irq-pf))
   (multiple-value-bind (p1 p2)
       (with-inline-assembly (:returns :multiple-values)
 	(:load-lexical (:lexical-binding eax) :eax)
@@ -1078,18 +1102,30 @@
     (1+ x)))
 
 (defparameter *timer-stack* nil)
+(defparameter *timer-prevstack* nil)
 (defparameter *timer-esi* nil)
 (defparameter *timer-frame* #100())
+(defparameter *timer-base* 2)
+(defparameter *timer-variation* 1000)
+
+(defun test-format (&optional timeout (x #xab))
+  (let ((fasit (format nil "~2,'0X" x)))
+    (test-timer timeout)
+    (format t "~&Fasit: ~S" fasit)
+    (loop
+      (let ((x (format nil "~2,'0X" x)))
+	(assert (string= fasit x) ()
+	  "Failed tesT. Fasit: ~S, X: ~S" fasit x)))))
 
 (defun test-clc (&optional timeout)
   (test-timer timeout)
   (loop
     (funcall (find-symbol (string :test-clc) :clc))))
 
-(defun test-timer (&optional timeout)
+(defun test-timer (&optional timeout (base *timer-base*) (variation *timer-variation*))
   (setf (exception-handler 32)
     (lambda (exception-vector exception-frame)
-      (declare (ignore exception-vector #+ignore exception-frame))
+      (declare (ignore exception-vector exception-frame))
 ;;;      (loop with f = *timer-frame*
 ;;;	  for o from 20 downto -36 by 4 as i upfrom 0
 ;;;	  do (setf (aref f i) (memref exception-frame o 0 :lisp)))
@@ -1102,14 +1138,13 @@
 ;;;		 (vector-push funobj ts)
 ;;;		 (vector-push offset ts)
 ;;;		 (vector-push code-vector ts))))
-      (muerte::cli)
+      ;; (muerte::cli)
       (pic8259-end-of-interrupt 0)
       (with-inline-assembly (:returns :nothing)
 	(:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
 	(:shrl 2 :ecx)
 	((:gs-override) :addb 1 (:ecx 158))
 	((:gs-override) :movb #x40 (:ecx 159)))
-      (setf *timer-esi* (muerte::dit-frame-ref nil exception-frame :esi :unsigned-byte32))
       (do ((frame (stack-frame-uplink nil (current-stack-frame))
 		  (stack-frame-uplink nil frame)))
 	  ((plusp frame))
@@ -1127,21 +1162,22 @@
 			 x)
 		       nil
 		       (current-stack-frame))
-      (setf *timer-stack* (muerte::copy-current-control-stack))
-      (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+
-	    (pit8253-timer-count 0) (or timeout (+ 5 (random 2000))))
       (with-inline-assembly (:returns :nothing)
 	(:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
 	(:shrl 2 :ecx)
-	((:gs-override) :movb #x20 (:ecx 159)))      
-      (muerte::sti)
-      ))
+	((:gs-override) :movb #x20 (:ecx 159)))
+      (setf *timer-prevstack* *timer-stack*
+	    *timer-stack* (muerte::copy-current-control-stack))
+      (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+
+	    (pit8253-timer-count 0) (or timeout (+ base (random variation))))
+      
+      #+ignore (muerte::sti)))
   (with-inline-assembly (:returns :nothing)
     (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
     (:shrl 2 :ecx)
     ((:gs-override) :movw #x4646 (:ecx 158)))
   (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+
-	(pit8253-timer-count 0) (or timeout (+ 10 (random 1000))))
+	(pit8253-timer-count 0) (or timeout (+ base (random variation))))
   (setf (pic8259-irq-mask) #xfffe)
   (pic8259-end-of-interrupt 0)
   (with-inline-assembly (:returns :nothing) (:sti))
@@ -1179,6 +1215,12 @@
 		       (incf (memref-int muerte.x86-pc::*screen* 0 80 :unsigned-byte16 t)))))
 	(incf (memref-int muerte.x86-pc::*screen* 0 160 :unsigned-byte16 t))))))
 
+(defun mumbojumbo ()
+  (with-inline-assembly (:returns :multiple-values)
+    (:leave)
+    (:movl (:ebp -4) :esi)
+    (:break)
+    (:ret)))
 
 (defun genesis ()
   (let ((extended-memsize 0))
@@ -1190,11 +1232,12 @@
     (format t "Extended memory: ~D KB~%" extended-memsize)
 
     (idt-init)
-    (install-los0-consing :kb-size 500)
     #+ignore
+    (install-los0-consing :kb-size 500)
     (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 1024 2048) 2))))
 
   (setf *debugger-function* #'los0-debugger)
+  (clos-bootstrap)
   (let ((*repl-readline-context* (make-readline-context :history-size 16))
 	#+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
 	#+ignore (*error-no-condition-for-debugger* t)
@@ -1208,7 +1251,6 @@
       ;; (muerte:asm :int 49)
 
       (setf *package* (find-package "INIT"))
-      (clos-bootstrap)
       (when muerte::*multiboot-data*
 	(set-textmode +vga-state-90x30+))
       
@@ -1228,7 +1270,7 @@
     (let ((* nil) (** nil) (*** nil)
 	  (/ nil) (// nil) (/// nil)
 	  (+ nil) (++ nil) (+++ nil))
-      (format t "~&Movitz image Los0 build ~D [~Z]." *build-number* (cons 1 2))
+      (format t "~&Movitz image Los0 build ~D." *build-number*)
       (loop
 	(catch :top-level-repl		; If restarts don't work, you can throw this..
 	  (with-simple-restart (abort "Abort to the top command level.")




From ffjeld at common-lisp.net  Mon Oct 11 13:52:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:02 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/lib/malloc-init.lisp 
Message-ID: <E1CH0ao-0007vE-00@common-lisp.net>

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

Modified Files:
	malloc-init.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:01 2004
Author: ffjeld

Index: movitz/losp/lib/malloc-init.lisp
diff -u movitz/losp/lib/malloc-init.lisp:1.5 movitz/losp/lib/malloc-init.lisp:1.6
--- movitz/losp/lib/malloc-init.lisp:1.5	Thu Jul 15 23:06:38 2004
+++ movitz/losp/lib/malloc-init.lisp	Mon Oct 11 15:52:01 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Jan  9 15:57:22 2002
 ;;;;                
-;;;; $Id: malloc-init.lisp,v 1.5 2004/07/15 21:06:38 ffjeld Exp $
+;;;; $Id: malloc-init.lisp,v 1.6 2004/10/11 13:52:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -31,7 +31,7 @@
   (muerte:malloc-initialize start-location end-location)
   (setf (cdar muerte::%memory-map%) end-location)
   (loop for x from kernel-end-location below start-location
-      do (setf (memref x 0 0 :unsigned-byte32) 0))
+      do (setf (memref x 0 :type :unsigned-byte32) 0))
   (values))
 
 




From ffjeld at common-lisp.net  Mon Oct 11 13:52:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:09 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <E1CH0av-0007ve-00@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:05 2004
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.7 movitz/losp/muerte/arithmetic-macros.lisp:1.8
--- movitz/losp/muerte/arithmetic-macros.lisp:1.7	Tue Sep 21 15:09:40 2004
+++ movitz/losp/muerte/arithmetic-macros.lisp	Mon Oct 11 15:52:04 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.7 2004/09/21 13:09:40 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.8 2004/10/11 13:52:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -486,8 +486,8 @@
     done))
 
 (define-compiler-macro %ratio-numerator (x)
-  `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::numerator) 0 :lisp))
+  `(memref ,x (movitz-type-slot-offset 'movitz-ratio 'numerator)))
 
 (define-compiler-macro %ratio-denominator (x)
-  `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::denominator) 0 :lisp))
+  `(memref ,x (movitz-type-slot-offset 'movitz-ratio 'denominator)))
 




From ffjeld at common-lisp.net  Mon Oct 11 13:52:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:13 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1CH0az-0007w4-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:12 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.44 movitz/losp/muerte/arrays.lisp:1.45
--- movitz/losp/muerte/arrays.lisp:1.44	Fri Sep 24 11:31:19 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Oct 11 15:52:12 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.44 2004/09/24 09:31:19 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.45 2004/10/11 13:52:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,8 +22,8 @@
 (in-package muerte)
 
 (defun vector-element-type (object)
-  (memref object #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type) 0
-	  :unsigned-byte8))
+  (memref object (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
+	  :type :unsigned-byte8))
 
 (defmacro vector-double-dispatch ((s1 s2) &rest clauses)
   (flet ((make-double-dispatch-value (et1 et2)
@@ -43,14 +43,13 @@
 			     forms))))))
 
 (define-compiler-macro vector-element-type (object)
-  `(memref ,object 0
-	   ,(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type)
-	   :unsigned-byte8))
+  `(memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
+	   :type :unsigned-byte8))
 
 (defun (setf vector-element-type) (numeric-element-type vector)
   (check-type vector vector)
-  (setf (memref vector #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type) 0
-		:unsigned-byte8)
+  (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
+		:type :unsigned-byte8)    
     numeric-element-type))
 
 (defun array-element-type (array)
@@ -114,15 +113,16 @@
   (etypecase array
     ((simple-array * 1)
      (assert (zerop axis-number))
-     (movitz-accessor array movitz-basic-vector num-elements))))
+     (memref array (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
 
 (defun array-dimensions (array)
   (check-type array array)
   1)
 
 (defun shrink-vector (vector new-size)
-  (setf-movitz-accessor (vector movitz-basic-vector num-elements) new-size)
-  vector)
+  (check-type vector vector)
+  (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))
+    new-size))
 
 (define-compiler-macro %basic-vector-has-fill-pointer-p (vector)
   "Does the basic-vector have a fill-pointer?"
@@ -155,29 +155,21 @@
 
 (defun copy-vector (vector)
   (check-type vector vector)
-  (ecase (vector-element-type vector)
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
-       (%shallow-copy-object
-	vector
-	(+ 2 (movitz-accessor vector movitz-basic-vector num-elements))))
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
-       (%shallow-copy-non-pointer-object
-	vector
-	(+ 2 (movitz-accessor vector movitz-basic-vector num-elements))))
-    ((#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
-      #.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
-      #.(bt:enum-value 'movitz::movitz-vector-element-type :code))
-     (%shallow-copy-non-pointer-object
-      vector
-      (+ 2 (truncate (+ 3 (movitz-accessor vector movitz-basic-vector num-elements)) 4))))
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)
-       (%shallow-copy-non-pointer-object
-	vector
-	(+ 2 (truncate (+ 1 (movitz-accessor vector movitz-basic-vector num-elements)) 2))))
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit)
-       (%shallow-copy-non-pointer-object
-	vector
-	(+ 2 (truncate (+ 31 (movitz-accessor vector movitz-basic-vector num-elements)) 32))))))
+  (let ((length (the fixnum
+		  (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
+    (ecase (vector-element-type vector)
+      (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
+	 (%shallow-copy-object vector (+ 2 length)))
+      (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
+	 (%shallow-copy-non-pointer-object vector (+ 2 length)))
+      ((#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
+	#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
+	#.(bt:enum-value 'movitz::movitz-vector-element-type :code))
+       (%shallow-copy-non-pointer-object vector	(+ 2 (truncate (+ 3 length) 4))))
+      (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)
+	 (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 1 length) 2))))
+      (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit)
+	 (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 31 length) 32)))))))
 
 (defun (setf fill-pointer) (new-fill-pointer vector)
   (etypecase vector
@@ -298,8 +290,7 @@
 			    (error "Index ~D is beyond vector length ~D."
 			     index
 			     (memref array
-			      ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
-			      0 :lisp)))))
+			      (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))))
 		   (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher
 			       ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))
 		   
@@ -454,10 +445,10 @@
 ;;; simple-vector accessors
 
 (define-compiler-macro svref%unsafe (simple-vector index)
-  `(memref ,simple-vector 2 ,index :lisp))
+  `(memref ,simple-vector 2 :index ,index))
 
 (define-compiler-macro (setf svref%unsafe) (value simple-vector index)
-  `(setf (memref ,simple-vector 2 ,index :lisp) ,value))
+  `(setf (memref ,simple-vector 2 :index ,index) ,value))
 
 (defun svref%unsafe (simple-vector index)
 ;;  (compiler-macro-call svref%unsafe simple-vector index))
@@ -522,16 +513,16 @@
 (defun char (string index)
   (check-type string string)
   (assert (below index (array-dimension string 0)))
-  (memref string 2 index :character))
+  (memref string 2 :index index :type :character))
 
 (defun (setf char) (value string index)
   (assert (below index (array-dimension string 0)))
-  (setf (memref string 2 index :character) value))
+  (setf (memref string 2 :index index :type :character) value))
 
 (defun schar (string index)
   (check-type string string)
   (assert (below index (length string)))
-  (memref string 2 index :character))
+  (memref string 2 :index index :type :character))
 
 (defun (setf schar) (value string index)
   (check-type string string)
@@ -539,13 +530,13 @@
   (setf (aref string index) value))
 
 (define-compiler-macro char%unsafe (string index)
-  `(memref ,string 2 ,index :character))
+  `(memref ,string 2 :index ,index :type :character))
 
 (defun char%unsafe (string index)
   (char%unsafe string index))
 
 (define-compiler-macro (setf char%unsafe) (value string index)
-  `(setf (memref ,string 2 ,index :character) ,value))
+  `(setf (memref ,string 2 :index ,index :type :character) ,value))
 
 (defun (setf char%unsafe) (value string index)
   (setf (char%unsafe string index) value))
@@ -553,13 +544,13 @@
 ;;; u8 accessors
 
 (define-compiler-macro u8ref%unsafe (vector index)
-  `(memref ,vector 2 ,index :unsigned-byte8))
+  `(memref ,vector 2 :index ,index :type :unsigned-byte8))
 
 (defun u8ref%unsafe (vector index)
   (u8ref%unsafe vector index))
 
 (define-compiler-macro (setf u8ref%unsafe) (value vector index)
-  `(setf (memref ,vector 2 ,index :unsigned-byte8) ,value))
+  `(setf (memref ,vector 2 :index ,index :type :unsigned-byte8) ,value))
 
 (defun (setf u8ref%unsafe) (value vector index)
   (setf (u8ref%unsafe vector index) value))
@@ -567,7 +558,7 @@
 ;;; u32 accessors
 
 (define-compiler-macro u32ref%unsafe (vector index)
-  `(memref ,vector 2 ,index :unsigned-byte32))
+  `(memref ,vector 2 :index ,index :type :unsigned-byte32))
 
 (defun u32ref%unsafe (vector index)
   (compiler-macro-call u32ref%unsafe vector index))
@@ -576,7 +567,7 @@
   (let ((var (gensym "setf-u32ref-value-")))
     ;; Use var so as to avoid re-boxing of the u32 value.
     `(let ((,var ,value))
-       (setf (memref ,vector 2 ,index :unsigned-byte32) ,var)
+       (setf (memref ,vector 2 :index ,index :type :unsigned-byte32) ,var)
        ,var)))
 
 (defun (setf u32ref%unsafe) (value vector index)




From ffjeld at common-lisp.net  Mon Oct 11 13:52:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:19 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CH0b5-0007wU-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:18 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.41 movitz/losp/muerte/basic-macros.lisp:1.42
--- movitz/losp/muerte/basic-macros.lisp:1.41	Wed Sep 22 18:26:14 2004
+++ movitz/losp/muerte/basic-macros.lisp	Mon Oct 11 15:52:18 2004
@@ -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.41 2004/09/22 16:26:14 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.42 2004/10/11 13:52:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -391,6 +391,13 @@
 				       (find-symbol (string slot-name) :movitz))))
      (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*)))
 	    :eax)))
+
+(define-compiler-macro movitz-type-slot-offset (type slot &environment env)
+  (if (not (and (movitz:movitz-constantp type env)
+		(movitz:movitz-constantp slot env)))
+      (error "Non-constant movitz-type-slot-offset call.")
+    (bt:slot-offset (intern (symbol-name (movitz:movitz-eval type env)) :movitz)
+		    (intern (symbol-name (movitz:movitz-eval slot env)) :movitz))))
 
 
 (define-compiler-macro not (x)




From ffjeld at common-lisp.net  Mon Oct 11 13:52:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:25 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <E1CH0bB-0007wp-00@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:21 2004
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.11 movitz/losp/muerte/bignums.lisp:1.12
--- movitz/losp/muerte/bignums.lisp:1.11	Thu Sep 23 11:17:51 2004
+++ movitz/losp/muerte/bignums.lisp	Mon Oct 11 15:52:21 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.11 2004/09/23 09:17:51 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.12 2004/10/11 13:52:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -82,7 +82,7 @@
 (defun print-bignum (x)
   (check-type x bignum)
   (dotimes (i (1+ (%bignum-bigits x)))
-    (format t "~8,'0X " (memref x -6 i :unsigned-byte32)))
+    (format t "~8,'0X " (memref x -6 :index i :type :unsigned-byte32)))
   (terpri)
   (values))
 
@@ -468,7 +468,8 @@
 (defun bignum-set-zerof (bignum)
   (check-type bignum bignum)
   (dotimes (i (%bignum-bigits bignum))
-    (setf (memref bignum -2 i :lisp) 0))
+    (setf (memref bignum (movitz-type-slot-offset 'movitz-bignum 'bigit0)
+		  :index i :type :unsigned-byte32) 0))
   bignum)
 
 (defun %bignum= (x y)




From ffjeld at common-lisp.net  Mon Oct 11 13:52:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:28 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1CH0bE-0007xK-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:28 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.14 movitz/losp/muerte/defstruct.lisp:1.15
--- movitz/losp/muerte/defstruct.lisp:1.14	Thu Sep 23 11:31:28 2004
+++ movitz/losp/muerte/defstruct.lisp	Mon Oct 11 15:52:27 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.14 2004/09/23 09:31:28 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.15 2004/10/11 13:52:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -21,10 +21,10 @@
 
 (defun structure-object-length (object)
   (check-type object structure-object)
-  (memref object -4 0 :unsigned-byte14))
+  (memref object -4 :type :unsigned-byte14))
 
 (defun structure-object-class (x)
-  (memref x -6 1 :lisp))
+  (memref x -6 :index 1))
 
 (defun copy-structure (object)
   (%shallow-copy-object object (+ 2 (structure-object-length object))))




From ffjeld at common-lisp.net  Mon Oct 11 13:52:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:35 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1CH0bL-0007xb-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:35 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.21 movitz/losp/muerte/functions.lisp:1.22
--- movitz/losp/muerte/functions.lisp:1.21	Wed Sep 22 18:40:32 2004
+++ movitz/losp/muerte/functions.lisp	Mon Oct 11 15:52:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.21 2004/09/22 16:40:32 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.22 2004/10/11 13:52:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -106,12 +106,14 @@
 
 (defun funobj-code-vector (funobj)
   (check-type funobj function)
-  (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector))
+  (memref funobj (movitz-type-slot-offset 'movitz-funobj 'code-vector)
+	  :type :code-vector))
 
 (defun (setf funobj-code-vector) (code-vector funobj)
   (check-type funobj function)
   (check-type code-vector code-vector)
-  (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector)
+  (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'code-vector)
+		:type :code-vector)
     code-vector))
 
 (defun funobj-code-vector%1op (funobj)
@@ -299,12 +301,12 @@
 
 (defun funobj-name (funobj)
   (check-type funobj function)
-  (movitz-accessor funobj movitz-funobj name))
+  (memref funobj (movitz-type-slot-offset 'movitz-funobj 'name)))
 
 (defun (setf funobj-name) (name funobj)
   (check-type funobj function)
-  ;; (check-type name (or symbol list)
-  (setf-movitz-accessor (funobj movitz-funobj name) name))
+  (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'name))
+    name))
 
 (defun funobj-lambda-list (funobj)
   (check-type funobj function)
@@ -342,7 +344,7 @@
   (assert (below index (funobj-num-constants funobj)) (index)
     "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj))
   (if (>= index (funobj-num-jumpers funobj))
-      (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0) index :lisp)
+      (memref funobj (movitz-type-slot-offset 'movitz-funobj 'constant0) :index index)
     ;; For a jumper, return its offset relative to the code-vector.
     ;; This is tricky wrt. to potential GC interrupts, because we're doing
     ;; pointer arithmetics.
@@ -361,8 +363,7 @@
   (assert (below index (funobj-num-constants funobj)) (index)
     "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj))
   (if (>= index (funobj-num-jumpers funobj))
-      (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)
-		    index :lisp)
+      (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'constant0) :index index)
 	value)
     (progn
       (assert (below value (length (funobj-code-vector funobj))) (value)
@@ -382,7 +383,7 @@
 
 (defun funobj-debug-info (funobj)
   (check-type funobj function)
-  (movitz-accessor-u16 funobj movitz-funobj debug-info))
+  (memref funobj (movitz-type-slot-offset 'movitz-funobj 'debug-info) :type :unsigned-byte16))
 
 (defun funobj-frame-num-unboxed (funobj)
   "The number of unboxed slots in this function's stack-frame(s)."




From ffjeld at common-lisp.net  Mon Oct 11 13:52:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:42 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp 
Message-ID: <E1CH0bS-0007yA-00@common-lisp.net>

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

Modified Files:
	hash-tables.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:38 2004
Author: ffjeld

Index: movitz/losp/muerte/hash-tables.lisp
diff -u movitz/losp/muerte/hash-tables.lisp:1.3 movitz/losp/muerte/hash-tables.lisp:1.4
--- movitz/losp/muerte/hash-tables.lisp:1.3	Wed Jun 30 01:19:21 2004
+++ movitz/losp/muerte/hash-tables.lisp	Mon Oct 11 15:52:37 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Feb 19 19:09:05 2001
 ;;;;                
-;;;; $Id: hash-tables.lisp,v 1.3 2004/06/29 23:19:21 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.4 2004/10/11 13:52:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -96,9 +96,6 @@
   (if (not (plusp limit))
       0
     (typecase object
-      #+ignore
-      (std-instance
-       (memref object #x1e 2 :lisp))
       (cons
        (logxor (sxhash-limited (car object) (- limit 2))
 	       (sxhash-limited (cdr object) (1- limit))))




From ffjeld at common-lisp.net  Mon Oct 11 13:52:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:45 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1CH0bV-0007yR-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:44 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.42 movitz/losp/muerte/inspect.lisp:1.43
--- movitz/losp/muerte/inspect.lisp:1.42	Fri Sep 24 11:33:16 2004
+++ movitz/losp/muerte/inspect.lisp	Mon Oct 11 15:52:44 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.42 2004/09/24 09:33:16 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.43 2004/10/11 13:52:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -76,8 +76,8 @@
     (let ((pos (+ frame index)))
       (assert (< -1 pos (length stack))
 	  () "Index ~S, pos ~S, len ~S" index pos (length stack))
-      (memref stack 2 pos type)))
-   (t (memref frame 0 index type))))
+      (memref stack 2 :index pos :type type)))
+   (t (memref frame 0 :index index :type type))))
 
 (defun (setf stack-frame-ref) (value stack frame index &optional (type ':lisp))
   (cond
@@ -86,8 +86,8 @@
     (let ((pos (+ frame index)))
       (assert (< -1 pos (length stack))
 	  () "Index ~S, pos ~S, len ~S" index pos (length stack))
-      (setf (memref stack 2 pos type) value)))
-   (t (setf (memref frame 0 index type) value))))
+      (setf (memref stack 2 :index pos :type type) value)))
+   (t (setf (memref frame 0 :index index :type type) value))))
 
 (defun current-dynamic-context ()
   (with-inline-assembly (:returns :eax)
@@ -248,12 +248,9 @@
 		    (dotimes (i (funobj-num-constants x) t)
 		      (unless (test funobj-constant-ref i)))))
 	      (symbol
-	       (and (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::function-value)
-			  0 :lisp)
-		    (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::name)
-			  0 :lisp)
-		    (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::flags)
-			  0 :lisp)))
+	       (and (test memref (movitz-type-slot-offset 'movitz-symbol 'function-value))
+		    (test memref (movitz-type-slot-offset 'movitz-symbol 'name))
+		    (test memref (movitz-type-slot-offset 'movitz-symbol 'flags))))
 	      (vector
 	       (and (typep y 'vector)
 		    (test array-element-type)




From ffjeld at common-lisp.net  Mon Oct 11 13:52:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:52 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1CH0bc-0007z0-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:51 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.97 movitz/losp/muerte/integers.lisp:1.98
--- movitz/losp/muerte/integers.lisp:1.97	Wed Sep 22 19:40:47 2004
+++ movitz/losp/muerte/integers.lisp	Mon Oct 11 15:52:50 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.97 2004/09/22 17:40:47 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.98 2004/10/11 13:52:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -881,7 +881,7 @@
        (t (check-type integer (integer 0 *))
 	  (let ((result (%make-bignum (ceiling result-length 32))))
 	    (dotimes (i (* 2 (%bignum-bigits result)))
-	      (setf (memref result -2 i :unsigned-byte16)
+	      (setf (memref result -2 :index i :type :unsigned-byte16)
 		(let ((pos (- (* i 16) count)))
 		  (cond
 		   ((minusp (+ pos 16)) 0)
@@ -889,8 +889,12 @@
 		    (ldb (byte 16 pos) integer))
 		   (t (ash (ldb (byte (+ pos 16) 0) integer)
 			   (- pos)))))))
-	    (assert (or (plusp (memref result -2 (+ -1 (* 2 (%bignum-bigits result))) :unsigned-byte16))
-			(plusp (memref result -2 (+ -2 (* 2 (%bignum-bigits result))) :unsigned-byte16))))
+	    (assert (or (plusp (memref result -2
+				       :index (+ -1 (* 2 (%bignum-bigits result)))
+				       :type :unsigned-byte16))
+			(plusp (memref result -2
+				       :index (+ -2 (* 2 (%bignum-bigits result)))
+				       :type :unsigned-byte16))))
 	    (bignum-canonicalize result))))))
    (t (let ((count (- count)))
 	(etypecase integer
@@ -913,9 +917,9 @@
 		     (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
 		       (dotimes (i (* 2 (%bignum-bigits result)))
 			 (let ((src (+ i long)))
-			   (setf (memref result -2 i :unsigned-byte16)
+			   (setf (memref result -2 :index i :type :unsigned-byte16)
 			     (if (< src src-max-bigit)
-				 (memref integer -2 src :unsigned-byte16)
+				 (memref integer -2 :index src :type :unsigned-byte16)
 			       0)))))
 		     (bignum-canonicalize
 		      (macrolet




From ffjeld at common-lisp.net  Mon Oct 11 13:52:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:52:54 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <E1CH0be-0007zH-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:52:54 2004
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.28 movitz/losp/muerte/interrupt.lisp:1.29
--- movitz/losp/muerte/interrupt.lisp:1.28	Thu Oct  7 14:42:38 2004
+++ movitz/losp/muerte/interrupt.lisp	Mon Oct 11 15:52:54 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.28 2004/10/07 12:42:38 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.29 2004/10/11 13:52:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -57,7 +57,7 @@
   (if (not (and (movitz:movitz-constantp stack env)
 		(eq nil (movitz:movitz-eval stack env))))
       form
-    `(memref ,frame (dit-frame-offset ,reg) 0 ,type)))
+    `(memref ,frame (dit-frame-offset ,reg) :type ,type)))
 
 (defun dit-frame-ref (stack frame reg &optional (type :lisp))
   (stack-frame-ref stack frame (dit-frame-index reg) type))
@@ -263,7 +263,7 @@
   (declare (without-check-stack-limit))
   (macrolet ((dereference (fixnum-address &optional (type :lisp))
 	       "Dereference the fixnum-address."
-	       `(memref ,fixnum-address 0 0 ,type)))
+	       `(memref ,fixnum-address 0 :type ,type)))
     (let (($eip (+ dit-frame (dit-frame-index :eip)))
 	  ($eax (+ dit-frame (dit-frame-index :eax)))
 	  ($ebx (+ dit-frame (dit-frame-index :ebx)))




From ffjeld at common-lisp.net  Mon Oct 11 13:53:03 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:53:03 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CH0bn-0007zv-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:53:01 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.31 movitz/losp/muerte/memref.lisp:1.32
--- movitz/losp/muerte/memref.lisp:1.31	Thu Oct  7 14:43:29 2004
+++ movitz/losp/muerte/memref.lisp	Mon Oct 11 15:53:01 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.31 2004/10/07 12:43:29 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.32 2004/10/11 13:53:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,7 +18,8 @@
 
 (in-package muerte)
 
-(define-compiler-macro memref (&whole form object offset index type &key (localp nil) (endian :host)
+(define-compiler-macro memref (&whole form object offset &key (index 0) (type :lisp)
+							      (localp nil) (endian :host)
 			       &environment env)
   (if (or (not (movitz:movitz-constantp type env))
 	  (not (movitz:movitz-constantp localp env))
@@ -323,29 +324,29 @@
 			    (:load-lexical (:lexical-binding ,object-var) :eax)
 			    (:addl :ebx :ecx)
 			    (:movl (:eax :ecx ,(offset-by 4)) :eax)))))))
-		(t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil))
+		(t (error "Unknown memref type: ~S" (movitz:movitz-eval type nil nil))
 		   form)))))))))
 
-(defun memref (object offset index type &key localp (endian :host))
+(defun memref (object offset &key (index 0) (type :lisp) localp (endian :host))
   (ecase type
     (:lisp              (if localp
-			    (memref object offset index :lisp :localp t)
-			  (memref object offset index :lisp :localp nil)))
-    (:unsigned-byte32   (memref object offset index :unsigned-byte32))
-    (:character         (memref object offset index :character))
-    (:unsigned-byte8    (memref object offset index :unsigned-byte8))
-    (:location          (memref object offset index :location))
-    (:unsigned-byte14   (memref object offset index :unsigned-byte14))
+			    (memref object offset :index index :localp t)
+			  (memref object offset :index index :localp nil)))
+    (:unsigned-byte32   (memref object offset :index index :type :unsigned-byte32))
+    (:character         (memref object offset :index  index :type :character))
+    (:unsigned-byte8    (memref object offset :index index :type :unsigned-byte8))
+    (:location          (memref object offset :index index :type :location))
+    (:unsigned-byte14   (memref object offset :index index :type :unsigned-byte14))
     (:unsigned-byte16   (ecase endian
 			  ((:host :little)
-			   (memref object offset index :unsigned-byte16 :endian :little))
+			   (memref object offset :index index :type :unsigned-byte16 :endian :little))
 			  ((:big)
-			   (memref object offset index :unsigned-byte16 :endian :big))))
-    (:signed-byte30+2   (memref object offset index :signed-byte30+2))
-    (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))
+			   (memref object offset :index index :type :unsigned-byte16 :endian :big))))))
+;;;    (:signed-byte30+2   (memref object offset index :signed-byte30+2))
+;;;    (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))
 
-(define-compiler-macro (setf memref) (&whole form &environment env value object offset index type
-				      &key (localp nil) (endian :host))
+(define-compiler-macro (setf memref) (&whole form &environment env value object offset
+				      &key (index 0) (type :lisp) (localp nil) (endian :host))
   (if (or (not (movitz:movitz-constantp type env))
 	  (not (movitz:movitz-constantp localp env))
 	  (not (movitz:movitz-constantp endian env)))
@@ -683,24 +684,29 @@
       (t ;; (warn "Can't handle inline MEMREF: ~S" form)
 	 form))))
 
-(defun (setf memref) (value object offset index type &key localp (endian :host))
+(defun (setf memref) (value object offset &key (index 0) (type :lisp) localp (endian :host))
   (ecase type
     (:character
-     (setf (memref object offset index :character) value))
+     (setf (memref object offset :index index :type :character)
+       value))
     (:unsigned-byte8
-     (setf (memref object offset index :unsigned-byte8) value))
+     (setf (memref object offset :index index :type :unsigned-byte8)
+       value))
     (:unsigned-byte16
      (ecase endian
        ((:host :little)
-	(setf (memref object offset index :unsigned-byte16 :endian :little) value))
+	(setf (memref object offset :index index :type :unsigned-byte16 :endian :little)
+	  value))
        ((:big)
-	(setf (memref object offset index :unsigned-byte16 :endian :big) value))))
+	(setf (memref object offset :index index :type :unsigned-byte16 :endian :big)
+	  value))))
     (:unsigned-byte32
-     (setf (memref object offset index :unsigned-byte32) value))
+     (setf (memref object offset :index index :type :unsigned-byte32)
+       value))
     (:lisp
      (if localp
-	 (setf (memref object offset index :lisp :localp t) value)
-       (setf (memref object offset index :lisp :localp nil) value)))))
+	 (setf (memref object offset :index index :localp t) value)
+       (setf (memref object offset :index index :localp nil) value)))))
 
 (define-compiler-macro memref-int (&whole form &environment env address offset index type
 				   &optional physicalp)




From ffjeld at common-lisp.net  Mon Oct 11 13:53:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:53:09 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1CH0bt-00080Q-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:53:09 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.14 movitz/losp/muerte/print.lisp:1.15
--- movitz/losp/muerte/print.lisp:1.14	Tue Jul 27 17:16:55 2004
+++ movitz/losp/muerte/print.lisp	Mon Oct 11 15:53:09 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep  3 11:48:19 2001
 ;;;;                
-;;;; $Id: print.lisp,v 1.14 2004/07/27 15:16:55 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.15 2004/10/11 13:53:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -395,12 +395,12 @@
     #.(cl:cons 'progn
 	       (cl:loop for octet from 3 downto 1
 		   collecting 
-		     `(let ((n (memref x 0 ,octet :unsigned-byte8)))
+		     `(let ((n (memref x 0 :index ,octet :type :unsigned-byte8)))
 			(when (setq z (or z (<= #x10 n)))
 			  (write-digit (ldb (byte 4 4) n) stream))
 			(when (setq z (or z (plusp n)))
 			  (write-digit (ldb (byte 4 0) n) stream)))))
-    (let ((n (memref x 0 0 :unsigned-byte8)))
+    (let ((n (memref x 0 :type :unsigned-byte8)))
       (when (or z (<= #x10 n))
 	(write-digit (ldb (byte 4 4) n) stream))
       (write-digit (ldb (byte 4 0) n) stream)))




From ffjeld at common-lisp.net  Mon Oct 11 13:53:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:53:12 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp 
Message-ID: <E1CH0bw-00080h-00@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:53:11 2004
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.10 movitz/losp/muerte/read.lisp:1.11
--- movitz/losp/muerte/read.lisp:1.10	Tue Sep 21 15:10:40 2004
+++ movitz/losp/muerte/read.lisp	Mon Oct 11 15:53:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 17 21:50:42 2001
 ;;;;                
-;;;; $Id: read.lisp,v 1.10 2004/09/21 13:10:40 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.11 2004/10/11 13:53:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -93,6 +93,7 @@
 			       (digit-char-p (schar string (1+ start)) *read-base*)
 			       0)))
 	     (denominator nil)
+	     (decimal nil)
 	     (i (1+ start) (1+ i)))
 	    ((or (>= i end)
 		 (member (schar string i) +simple-token-terminators+))
@@ -103,19 +104,19 @@
 			 integer))
 		     (when (and integer denominator (plusp denominator))
 		       denominator)))
-	  (when (char= #\: (schar string i))
-	    (setf colon-position i))
-	  (setf almost-integer integer)
-	  (when integer
-	    (if (and (not denominator)
-		     (char= #\/ (schar string i)))
-		(setf denominator 0)
-	      (let ((digit (digit-char-p (schar string i) *read-base*)))
+	  (let ((c (schar string i)))
+	    (when (char= #\: c)
+	      (setf colon-position i))
+	    (setf almost-integer integer)
+	    (when integer
+	      (let ((digit (digit-char-p c *read-base*)))
 		(cond
-		 ((and denominator (not digit))
-		  (setf integer nil))
 		 (denominator
-		  (setf denominator (+ (* denominator *read-base*) digit)))
+		  (if (not digit)
+		      (setf integer nil)
+		    (setf denominator (+ (* denominator *read-base*) digit))))
+		 ((char= #\/ c)
+		  (setf denominator 0))
 		 (t (setf integer (and digit (+ (* integer *read-base*) digit)))))))))
       (cond
        (token-denominator
@@ -123,14 +124,19 @@
 		token-end))
        (token-integer
 	(values token-integer token-end))
-       ((and almost-integer		; check for base 10 <n>. notation.
+       ((and (char= #\. (schar string (1- token-end))) ; check for base-10 <n>. notation.
 	     (> token-end start)
-	     (char= #\. (schar string (1- token-end))))
-	(if (= *read-base* 10)
-	    (values almost-integer token-end)
-	  (values (parse-integer string :start start :end (1- token-end)
-				 :junk-allowed nil)
-		  token-end)))
+	     (or almost-integer
+		 (and (< *read-base* 10)
+		      (do ((i start (1+ i)))
+			  ((>= i (1- token-end)) t)
+			(unless (digit-char-p (schar string i) 10)
+			  (return nil))))))
+	(let ((x (if (= *read-base* 10)
+		     almost-integer
+		   (parse-integer string :start start :end (1- token-end)
+				  :junk-allowed nil))))
+	  (values x token-end)))
        ((not colon-position)
 	(values (intern-string string *package* :start start :end token-end :key #'char-upcase)
 		token-end))




From ffjeld at common-lisp.net  Mon Oct 11 13:53:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:53:20 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1CH0c4-00080y-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:53:20 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.14 movitz/losp/muerte/run-time-context.lisp:1.15
--- movitz/losp/muerte/run-time-context.lisp:1.14	Mon Sep 27 10:54:53 2004
+++ movitz/losp/muerte/run-time-context.lisp	Mon Oct 11 15:53:19 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.14 2004/09/27 08:54:53 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.15 2004/10/11 13:53:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -35,11 +35,11 @@
   (let ((slot (find-run-time-context-slot context slot-name)))
     (ecase (second slot)
       (word
-       (memref context -6 (third slot) :lisp))
+       (memref context -6 :index (third slot)))
       (code-vector-word
-       (memref context -6 (third slot) :code-vector))
+       (memref context -6 :index (third slot) :type :code-vector))
       (lu32
-       (memref context -6 (third slot) :unsigned-byte32)))))
+       (memref context -6 :index (third slot) :type :unsigned-byte32)))))
 
 (define-compiler-macro (setf %run-time-context-slot) (&whole form &environment env value slot-name
 						      &optional (context '(current-run-time-context)))
@@ -67,11 +67,11 @@
   (let ((slot (find-run-time-context-slot context slot-name)))
     (ecase (second slot)
       (word
-       (setf (memref context -6 (third slot) :lisp) value))
+       (setf (memref context -6 :index (third slot)) value))
       (lu32
-       (setf (memref context -6 (third slot) :unsigned-byte32) value))
+       (setf (memref context -6 :index (third slot) :type :unsigned-byte32) value))
       (code-vector-word
-       (setf (memref context -6 (third slot) :code-vector) value)))))
+       (setf (memref context -6 :index (third slot) :type :code-vector) value)))))
 
 (defun %run-time-context-segment-base (slot-name
 				      &optional (context (current-run-time-context)))
@@ -81,9 +81,9 @@
       (segment-descriptor
        (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)))))))
+	 (+ (memref context (+ -6 2) :index index16 :type :unsigned-byte16)
+	    (ash (memref context (+ -6 4) :index index8 :type :unsigned-byte8) 16)
+	    (ash (memref context (+ -6 7) :index index8 :type :unsigned-byte8) 24)))))))
 
 (defun (setf %run-time-context-segment-base) (value slot-name
 					     &optional (context (current-run-time-context)))
@@ -93,9 +93,9 @@
       (segment-descriptor
        (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)))))
+	 (setf (memref context (+ -6 2) :index index16 :type :unsigned-byte16) (ldb (byte 16 0) value)
+	       (memref context (+ -6 4) :index index8 :type :unsigned-byte8) (ldb (byte 8 16) value)
+	       (memref context (+ -6 7) :index index8 :type :unsigned-byte8) (ldb (byte 6 24) value)))))
     value))
 
 (defun %run-time-context-ref (edi-offset)




From ffjeld at common-lisp.net  Mon Oct 11 13:53:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:53:26 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1CH0cA-00081X-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:53:25 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.32 movitz/losp/muerte/scavenge.lisp:1.33
--- movitz/losp/muerte/scavenge.lisp:1.32	Tue Sep 21 15:56:32 2004
+++ movitz/losp/muerte/scavenge.lisp	Mon Oct 11 15:53:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.32 2004/09/21 13:56:32 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.33 2004/10/11 13:53:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -49,7 +49,7 @@
       (with-simple-restart (continue-map-heap-words
 			    "Continue map-heap-words at location ~S." (1+ scan))
 	(let ((*scan* scan)
-	      (x (memref scan 0 0 :unsigned-byte16)))
+	      (x (memref scan 0 :type :unsigned-byte16)))
 	  (declare (special *scan*))
 	  (when verbose
 	    (format *terminal-io* " [at ~S: ~S]" scan x))
@@ -65,7 +65,7 @@
 	    (assert (evenp scan) ()
 	      "Scanned bignum-header ~S at odd location #x~X." x scan)
 	    ;; Just skip the bigits
-	    (let* ((bigits (memref scan 0 1 :unsigned-byte14))
+	    (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14))
 		   (delta (logior bigits 1)))
 	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan delta)))
@@ -76,7 +76,7 @@
 	   ((scavenge-typep x :funobj)
 	    (assert (evenp scan) ()
 	      "Scanned funobj-header ~S at odd location #x~X." 
-	      (memref scan 0 0 :unsigned-byte32) scan)
+	      (memref scan 0 :type :unsigned-byte32) scan)
 	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	    ;; Process code-vector pointers specially..
 	    (let* ((funobj (%word-offset scan #.(movitz:tag :other)))
@@ -88,7 +88,7 @@
 		(check-type new-code-vector code-vector)
 		(unless (eq code-vector new-code-vector)
 		  (error "Code-vector migration is not implemented.")
-		  (setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2))
+		  (setf (memref scan 0 :index -1) (%word-offset new-code-vector 2))
 		  ;; Do more stuff here to update code-vectors and jumpers
 		  ))
 	      (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers.
@@ -104,21 +104,21 @@
 				     #.(bt:enum-value 'movitz:movitz-vector-element-type :code)))
 	    (assert (evenp scan) ()
 	      "Scanned u8-vector-header ~S at odd location #x~X." x scan)
-	    (let ((len (memref scan 0 1 :lisp)))
+	    (let ((len (memref scan 0 :index 1 :type :lisp)))
 	      (check-type len positive-fixnum)
 	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan (1+ (* 2 (truncate (+ 7 len) 8))))))
 	   ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
 	    (assert (evenp scan) ()
 	      "Scanned u16-vector-header ~S at odd location #x~X." x scan)
-	    (let ((len (memref scan 0 1 :lisp)))
+	    (let ((len (memref scan 0 :index 1)))
 	      (check-type len positive-fixnum)
 	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan (1+ (* 2 (truncate (+ 3 len) 4))))))
 	   ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
 	    (assert (evenp scan) ()
 	      "Scanned u32-vector-header ~S at odd location #x~X." x scan)
-	    (let ((len (memref scan 0 1 :lisp)))
+	    (let ((len (memref scan 4)))
 	      (assert (typep len 'positive-fixnum) ()
 		"Scanned basic-vector at ~S with illegal length ~S." scan len)
 	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
@@ -133,17 +133,17 @@
 	   ((eq x 3)
 	    (setf *scan-last* scan)
 	    (incf scan)
-	    (let ((delta (memref scan 0 0 :lisp)))
+	    (let ((delta (memref scan 0)))
 	      (check-type delta positive-fixnum)
 	      ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta))
 	      (incf scan delta)))
 	   (t ;; (typep x 'pointer)
-	    (let* ((old (memref scan 0 0 :lisp))
+	    (let* ((old (memref scan 0))
 		   (new (funcall function old scan)))
 	      (when verbose
 		(format *terminal-io* " [~Z => ~Z]" old new))
 	      (unless (eq old new)
-		(setf (memref scan 0 0 :lisp) new)))))))))
+		(setf (memref scan 0) new)))))))))
   (values))
 
 (defun map-stack-words (function stack start-frame)
@@ -229,14 +229,14 @@
 						(dit-frame-ref stack dit-frame :eip :location))
 			  (cond
 			   ((let ((x0-tag (ldb (byte 3 0)
-					       (memref interrupted-esp 0 0 :unsigned-byte8))))
+					       (memref interrupted-esp 0 :type :unsigned-byte8))))
 			      (and (member x0-tag '(1 5 6 7))
 				   (location-in-object-p casf-code-vector
-							 (memref interrupted-esp 0 0 :location))))
+							 (memref interrupted-esp 0 :type :location))))
 			    ;; When code-vector migration is implemented...
 			    (warn "Scanning at ~S X0 call ~S in ~S."
 				  (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
-				  (memref interrupted-esp 0 0 :unsigned-byte32)
+				  (memref interrupted-esp 0 :type :unsigned-byte32)
 				  (funobj-name casf-funobj))
 			    #+ignore (map-heap-words function (+ interrupted-esp 1) frame)
 			    (when (eq 0 (stack-frame-ref stack frame -1))
@@ -244,14 +244,14 @@
 			    (setf next-frame frame
 				  next-nether-frame (+ interrupted-esp 1 -2)))
 			   ((let ((x1-tag (ldb (byte 3 0)
-					       (memref interrupted-esp 4 0 :unsigned-byte8))))
+					       (memref interrupted-esp 4 :type :unsigned-byte8))))
 			      (and (member x1-tag '(1 5 6 7))
 				   (location-in-object-p casf-code-vector
-							 (memref interrupted-esp 0 1 :location))))
+							 (memref interrupted-esp 4 :type :location))))
 			    ;; When code-vector migration is implemented...
 			    (warn "Scanning at ~S X1 call ~S in ~S."
 				  (dit-frame-ref stack dit-frame :eip :unsigned-byte32)
-				  (memref interrupted-esp 0 1 :unsigned-byte32)
+				  (memref interrupted-esp 4 :type :unsigned-byte32)
 				  (funobj-name casf-funobj))
 			    (when (eq 0 (stack-frame-ref stack frame -1))
 			      (break "X1 call in DIT-frame."))
@@ -263,10 +263,10 @@
 			    (setf next-frame frame
 				  next-nether-frame (- interrupted-esp 2))
 			    )))
-			 ((eq casf-frame (memref interrupted-esp 0 0 :location))
+			 ((eq casf-frame (memref interrupted-esp 0 :type :location))
 			  ;; Situation ii. esp(0)=CASF, esp(1)=code-vector
 			  (assert (location-in-object-p casf-code-vector
-							(memref interrupted-esp 0 1 :location))
+							(memref interrupted-esp 4 :type :location))
 
 			      () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S"
 			      casf-frame interrupted-esp interrupted-ebp)
@@ -275,7 +275,7 @@
 				next-nether-frame (+ interrupted-esp 2 -2)))
 			 (t ;; Situation iii. esp(0)=code-vector.
 			  (assert (location-in-object-p casf-code-vector
-							(memref interrupted-esp 0 0 :location))
+							(memref interrupted-esp 0 :type :location))
 			      () "Stack discipline situation iii. invariant broken. CASF=#x~X"
 			      casf-frame)
 			  #+ignore (map-heap-words function (+ interrupted-esp 1) frame)




From ffjeld at common-lisp.net  Mon Oct 11 13:53:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 11 Oct 2004 15:53:29 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CH0cD-00081o-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Changed the signature of memref and (setf memref) to use keywords also
for the index and type arguments.

Date: Mon Oct 11 15:53:28 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.19 movitz/losp/muerte/symbols.lisp:1.20
--- movitz/losp/muerte/symbols.lisp:1.19	Wed Sep 22 20:49:24 2004
+++ movitz/losp/muerte/symbols.lisp	Mon Oct 11 15:53:28 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.19 2004/09/22 18:49:24 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.20 2004/10/11 13:53:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -74,13 +74,13 @@
   (setf (symbol-value symbol) value))
 
 (define-compiler-macro %symbol-global-value (symbol)
-  `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp))
+  `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)))
 
 (defun %symbol-global-value (symbol)
   (%symbol-global-value symbol))
 
 (define-compiler-macro (setf %symbol-global-value) (value symbol)
-  `(setf (memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp)
+  `(setf (memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value))
      ,value))
 
 (defun (setf %symbol-global-value) (value symbol)
@@ -94,7 +94,8 @@
 
 (defun %unbounded-symbol-function (symbol)
   (check-type symbol symbol)
-  (movitz-accessor symbol movitz-symbol function-value))
+  (memref symbol (movitz-type-slot-offset 'movitz-symbol 'function-value)))
+  ;; (movitz-accessor symbol movitz-symbol function-value))
 
 (defun (setf symbol-function) (value symbol)
   (check-type symbol symbol)
@@ -109,7 +110,8 @@
     (null
      (error "Can't change the name of NIL."))
     (symbol
-     (setf-movitz-accessor (symbol movitz-symbol name) value))))
+     (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'name))
+       value))))
 
 (defun symbol-plist (symbol)
   (get-symbol-slot symbol plist))
@@ -119,7 +121,8 @@
     (null
      (error "Can't change the plist of NIL."))
     (symbol
-     (setf-movitz-accessor (symbol movitz-symbol plist) value))))
+     (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'plist))
+       value))))
 
 (defun symbol-package (symbol)
   (get-symbol-slot symbol package))




From ffjeld at common-lisp.net  Tue Oct 12 09:37:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 12 Oct 2004 11:37:26 +0200
Subject: [movitz-cvs] CVS update: ia-x86/proglist.lisp 
Message-ID: <E1CHJ5y-0001qu-00@common-lisp.net>

Update of /project/movitz/cvsroot/ia-x86
In directory common-lisp.net:/tmp/cvs-serv7116

Modified Files:
	proglist.lisp 
Log Message:
Removed warning about "assumption bigger than.."

Date: Tue Oct 12 11:37:25 2004
Author: ffjeld

Index: ia-x86/proglist.lisp
diff -u ia-x86/proglist.lisp:1.5 ia-x86/proglist.lisp:1.6
--- ia-x86/proglist.lisp:1.5	Thu Sep  2 11:02:40 2004
+++ ia-x86/proglist.lisp	Tue Oct 12 11:37:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon May 15 13:43:55 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: proglist.lisp,v 1.5 2004/09/02 09:02:40 ffjeld Exp $
+;;;; $Id: proglist.lisp,v 1.6 2004/10/12 09:37:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -101,7 +101,6 @@
 							 :current-pc referring-pc)
 				      optimize-teo)))
       (when (< (imagpart cdatum) assumed-length)
-	(warn "Assumption ~D bigger than actual ~D" assumed-length (imagpart cdatum))
 	(setf cdatum
 	  (instruction-encode instruction
 			      (make-assemble-env :symtab (assemble-env-symtab env)




From ffjeld at common-lisp.net  Tue Oct 12 10:51:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 12 Oct 2004 12:51:48 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1CHKFw-00034r-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed one-operand - and two-operand / on ratios.

Date: Tue Oct 12 12:51:47 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.98 movitz/losp/muerte/integers.lisp:1.99
--- movitz/losp/muerte/integers.lisp:1.98	Mon Oct 11 15:52:50 2004
+++ movitz/losp/muerte/integers.lisp	Tue Oct 12 12:51:47 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.98 2004/10/11 13:52:50 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.99 2004/10/12 10:51:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -688,44 +688,23 @@
   (declare (dynamic-extent subtrahends))
   (numargs-case
    (1 (x)
-      (macrolet
-	  ((do-it ()
-	     `(with-inline-assembly (:returns :eax)
-		(:compile-form (:result-mode :eax) x)
-		(:testb ,movitz:+movitz-fixnum-zmask+ :al)
-		(:jnz '(:sub-program (not-fixnum)
-			(:leal (:eax ,(- (movitz:tag :other))) :ecx)
-			(:testb 7 :cl)
-			(:jnz '(:sub-program (not-a-number)
-				(:compile-form (:result-mode :ignore)
-				 (if (typep x 'ratio)
-				     (make-rational (- (%ratio-numerator x))
-				      (%ratio-denominator x))
-				   (error 'type-error :expected-type 'number :datum x)))))
-			(:movl (:eax ,movitz:+other-type-offset+) :ecx)
-			(:cmpb ,(movitz:tag :bignum) :cl)
-			(:jne 'not-a-number)
-			(:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx)
-			(:jne 'not-most-negative-fixnum)
-			(:cmpl ,(- most-negative-fixnum) (:eax (:offset movitz-bignum bigit0)))
-			(:jne 'not-most-negative-fixnum)
-			(:movl ,(ldb (byte 32 0)
-				 (* most-negative-fixnum movitz::+movitz-fixnum-factor+))
-			 :eax)
-			(:jmp 'fix-ok)
-			not-most-negative-fixnum
-			(:compile-form (:result-mode :eax)
-			 (copy-bignum x))
-			(:notb (:eax (:offset movitz-bignum sign)))
-			(:jmp 'fix-ok)))
-		(:negl :eax)
-		(:jo '(:sub-program (fix-overflow)
-		       (:compile-form (:result-mode :eax)
-			,(1+ movitz:+movitz-most-positive-fixnum+))
-		       (:jmp 'fix-ok)))
-	       fix-ok
-		)))
-	(do-it)))
+      (etypecase x
+	(fixnum
+	 (macrolet
+	     ((do-it ()
+		`(with-inline-assembly (:returns :eax)
+		   (:compile-form (:result-mode :eax) x)
+		   (:negl :eax)
+		   (:jo '(:sub-program (fix-overflow)
+			  (:compile-form (:result-mode :eax)
+			   ,(1+ movitz:+movitz-most-positive-fixnum+))
+			  (:jmp 'fix-ok)))
+		  fix-ok)))
+	   (do-it)))
+	(bignum
+	 (%bignum-negate (copy-bignum x)))
+	(ratio
+	 (make-ratio (- (ratio-numerator x)) (ratio-denominator x)))))
    (2 (minuend subtrahend)
       (macrolet
 	  ((do-it ()
@@ -1421,9 +1400,11 @@
    (2 (x y)
       (multiple-value-bind (q r)
 	  (truncate x y)
-	(if (= 0 r)
-	    q
-	  (make-rational x y))))
+	(cond
+	 ((= 0 r)
+	  q)
+	 (t (make-rational (* (numerator x) (denominator y))
+			   (* (denominator x) (numerator y)))))))
    (t (number &rest denominators)
       (declare (dynamic-extent denominators))
       (cond




From ffjeld at common-lisp.net  Tue Oct 12 14:42:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 12 Oct 2004 16:42:43 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <E1CHNrP-0006o5-00@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
Fixed format-float (used by ~F) to handle negative numbers.

Date: Tue Oct 12 16:42:42 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.7 movitz/losp/muerte/format.lisp:1.8
--- movitz/losp/muerte/format.lisp:1.7	Sat Jul 31 00:15:23 2004
+++ movitz/losp/muerte/format.lisp	Tue Oct 12 16:42:41 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Mar 23 01:18:36 2002
 ;;;;                
-;;;; $Id: format.lisp,v 1.7 2004/07/30 22:15:23 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.8 2004/10/12 14:42:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -60,26 +60,29 @@
       (write x))))
 
 (defun format-float (x &optional at-sign-p colon-p w d (k 0) overflowchar padchar)
-  (declare (ignore w overflowchar padchar at-sign-p colon-p))
-  (if (eql 0 d)
-      (write-integer (round x) *standard-output* 10 nil)
-    (multiple-value-bind (integer-part decimal-part)
-	(truncate x)
-      (write-integer integer-part *standard-output* 10 nil)
-      (dotimes (i k)
-	(write-char #\0))
-      (write-char #\.)
-      (do ((remainder decimal-part)
-	   (last-i (if d (1- d) 15))
-	   (i 0 (1+ i)))
-	  ((or (and (not d) (plusp i) (zerop remainder))
-	       (> i last-i)))
-	(multiple-value-bind (next-digit next-remainder)
-	    (if (= i last-i)
-		(round (* 10 remainder))
-	      (truncate (* 10 remainder)))
-	  (setf remainder next-remainder)
-	  (write-digit next-digit *standard-output*))))))
+  (cond
+   ((eql 0 d)
+    (write-integer (round x) *standard-output* 10 nil))
+   ((minusp x)
+    (write-char #\-)
+    (format-float (- x) at-sign-p colon-p w d k overflowchar padchar))
+   (t (multiple-value-bind (integer-part decimal-part)
+	  (truncate x)
+	(write-integer integer-part *standard-output* 10 nil)
+	(dotimes (i k)
+	  (write-char #\0))
+	(write-char #\.)
+	(do ((remainder decimal-part)
+	     (last-i (if d (1- d) 15))
+	     (i 0 (1+ i)))
+	    ((or (and (not d) (plusp i) (zerop remainder))
+		 (> i last-i)))
+	  (multiple-value-bind (next-digit next-remainder)
+	      (if (= i last-i)
+		  (round (* 10 remainder))
+		(truncate (* 10 remainder)))
+	    (setf remainder next-remainder)
+	    (write-digit next-digit *standard-output*)))))))
 
 (defun find-directive (string i directive &optional recursive-skip-start
 						    (recursive-skip-end directive))




From ffjeld at common-lisp.net  Tue Oct 12 14:43:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 12 Oct 2004 16:43:28 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1CHNs8-0006ob-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Removed some usage of the deprecated mode :untagged-fixnum-eax.

Date: Tue Oct 12 16:43:28 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.22 movitz/losp/muerte/functions.lisp:1.23
--- movitz/losp/muerte/functions.lisp:1.22	Mon Oct 11 15:52:34 2004
+++ movitz/losp/muerte/functions.lisp	Tue Oct 12 16:43:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.22 2004/10/11 13:52:34 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.23 2004/10/12 14:43:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -166,15 +166,14 @@
        (:compile-form (:result-mode :ebx) funobj)
        (:compile-form (:result-mode :eax) code-vector)
        (:addl 2 :eax)			; this cell stores word+2
-       (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op)))))
+       (:movl :eax (:ebx (:offset movitz-funobj code-vector%1op)))))
     (integer
      (with-inline-assembly (:returns :nothing)
        (:compile-form (:result-mode :ebx) funobj)
-       (:movl (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :eax)
-       (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op)))
-       (:compile-form (:result-mode :untagged-fixnum-eax) code-vector)
-       (:addl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op)))
-       (:xorl :eax :eax))))
+       (:movl (:ebx (:offset movitz-funobj code-vector)) :eax)
+       (:movl :eax (:ebx (:offset movitz-funobj code-vector%1op)))
+       (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector)
+       (:addl :ecx (:ebx (:offset movitz-funobj code-vector%1op))))))
   code-vector)
 
 (defun funobj-code-vector%2op (funobj)
@@ -227,15 +226,14 @@
        (:compile-form (:result-mode :ebx) funobj)
        (:compile-form (:result-mode :eax) code-vector)
        (:addl 2 :eax)			; this cell stores word+2
-       (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op)))))
+       (:movl :eax (:ebx (:offset movitz-funobj code-vector%2op)))))
     (integer
      (with-inline-assembly (:returns :nothing)
        (:compile-form (:result-mode :ebx) funobj)
-       (:movl (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :eax)
-       (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op)))
-       (:compile-form (:result-mode :untagged-fixnum-eax) code-vector)
-       (:addl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op)))
-       (:xorl :eax :eax))))
+       (:movl (:ebx (:offset movitz-funobj code-vector)) :eax)
+       (:movl :eax (:ebx (:offset movitz-funobj code-vector%2op)))
+       (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector)
+       (:addl :ecx (:ebx (:offset movitz-funobj code-vector%2op))))))
   code-vector)
 
 (defun funobj-code-vector%3op (funobj)
@@ -288,15 +286,14 @@
        (:compile-form (:result-mode :ebx) funobj)
        (:compile-form (:result-mode :eax) code-vector)
        (:addl 2 :eax)			; this cell stores word+2
-       (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%3op)))))
+       (:movl :eax (:ebx (:offset movitz-funobj code-vector%3op)))))
     (integer
      (with-inline-assembly (:returns :nothing)
        (:compile-form (:result-mode :ebx) funobj)
-       (:movl (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :eax)
-       (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%3op)))
-       (:compile-form (:result-mode :untagged-fixnum-eax) code-vector)
-       (:addl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%3op)))
-       (:xorl :eax :eax))))
+       (:movl (:ebx (:offset movitz-funobj code-vector)) :eax)
+       (:movl :eax (:ebx (:offset movitz-funobj code-vector%3op)))
+       (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector)
+       (:addl :ecx (:ebx (:offset movitz-funobj code-vector%3op))))))
   code-vector)
 
 (defun funobj-name (funobj)




From ffjeld at common-lisp.net  Tue Oct 12 14:44:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 12 Oct 2004 16:44:06 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <E1CHNsk-0006p7-00@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed incredibly stupid bug in ratio multiplication.

Date: Tue Oct 12 16:43:56 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.99 movitz/losp/muerte/integers.lisp:1.100
--- movitz/losp/muerte/integers.lisp:1.99	Tue Oct 12 12:51:47 2004
+++ movitz/losp/muerte/integers.lisp	Tue Oct 12 16:43:55 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.99 2004/10/12 10:51:47 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.100 2004/10/12 14:43:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1152,7 +1152,7 @@
 		     (incf r (ash (* x (ldb (byte 29 i) y)) i)))))
 		((ratio ratio)
 		 (make-rational (* (ratio-numerator x) (ratio-numerator y))
-				(* (ratio-denominator x) (ratio-denominator x))))
+				(* (ratio-denominator x) (ratio-denominator y))))
 		((ratio t)
 		 (make-rational (* y (ratio-numerator x))
 				(ratio-denominator x)))




From ffjeld at common-lisp.net  Tue Oct 12 14:45:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 12 Oct 2004 16:45:19 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CHNtv-0006tg-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Fixed some symbol accessors to use memref rather than inline assembly.

Date: Tue Oct 12 16:45:17 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.20 movitz/losp/muerte/symbols.lisp:1.21
--- movitz/losp/muerte/symbols.lisp:1.20	Mon Oct 11 15:53:28 2004
+++ movitz/losp/muerte/symbols.lisp	Tue Oct 12 16:45:16 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.20 2004/10/11 13:53:28 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.21 2004/10/12 14:45:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -211,19 +211,16 @@
   (etypecase symbol
     (null #.(bt:enum-value 'movitz::movitz-symbol-flags '(:constant-variable)))
     (symbol
-     (with-inline-assembly (:returns :untagged-fixnum-eax)
-       (:compile-form (:result-mode :eax) symbol)
-       (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::flags)) :eax)))))
+     (memref symbol (movitz-type-slot-offset 'movitz-symbol 'flags)
+	     :type :unsigned-byte16))))
 
 (defun (setf symbol-flags) (flags symbol)
   (etypecase symbol
     (null (error "Can't set NIL's flags."))
     (symbol
-     (with-inline-assembly (:returns :nothing)
-       (:compile-form (:result-mode :ebx) symbol)
-       (:compile-form (:result-mode :untagged-fixnum-eax) flags)
-       (:movw :ax (:ebx #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::flags))))
-     flags)))
+     (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'flags)
+		   :type :unsigned-byte16)
+       flags))))
 
 (defun symbol-special-variable-p (symbol)
   (logbitp 3 (symbol-flags symbol)))




From ffjeld at common-lisp.net  Tue Oct 12 14:52:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 12 Oct 2004 16:52:08 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CHO0W-00074y-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Have memref provide the correct type in more cases. I.e. an
:unsigned-byte16 memref becomes a (unsigned-byte 16) type etc.

Date: Tue Oct 12 16:52:07 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.32 movitz/losp/muerte/memref.lisp:1.33
--- movitz/losp/muerte/memref.lisp:1.32	Mon Oct 11 15:53:01 2004
+++ movitz/losp/muerte/memref.lisp	Tue Oct 12 16:52:07 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.32 2004/10/11 13:53:01 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.33 2004/10/12 14:52:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -98,7 +98,8 @@
 					  (:big `((:xchgb :cl :ch))))))
 		   (cond
 		    ((and (eq 0 offset) (eq 0 index))
-		     `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		     `(with-inline-assembly (:returns :untagged-fixnum-ecx
+						      :type (unsigned-byte 16))
 			(:compile-form (:result-mode :eax) ,object)
 			(:movzxw (:eax ,(offset-by 2)) :ecx)
 			, at endian-fix-ecx))
@@ -118,7 +119,8 @@
 			 `(let ((,object-var ,object)
 				(,offset-var ,offset)
 				(,index-var ,index))
-			    (with-inline-assembly (:returns :untagged-fixnum-ecx)
+			    (with-inline-assembly (:returns :untagged-fixnum-ecx
+							    :type (unsigned-byte 16))
 			      (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var)
 			      (:leal (:ecx (:ebx 2)) :ecx)
 			      (:load-lexical (:lexical-binding ,object-var) :eax)
@@ -217,18 +219,18 @@
 		 (assert (= 4 movitz::+movitz-fixnum-factor+))
 		 (cond
 		  ((and (eq 0 offset) (eq 0 index))
-		   `(with-inline-assembly (:returns :ecx)
+		   `(with-inline-assembly (:returns :ecx :type (unsigned-byte 29))
 		      (:compile-form (:result-mode :eax) ,object)
 		      (:movl (:eax ,(offset-by 4)) :ecx)
 		      (:andl -4 :ecx)))
 		  ((eq 0 offset)
-		   `(with-inline-assembly (:returns :ecx)
+		   `(with-inline-assembly (:returns :ecx :type (unsigned-byte 29))
 		      (:compile-two-forms (:eax :ecx) ,object ,index)
 		      (:movl (:eax :ecx ,(offset-by 4)) :ecx)
 		      (:andl -4 :ecx)))
 		  (t (let ((object-var (gensym "memref-object-")))
 		       `(let ((,object-var ,object))
-			  (with-inline-assembly (:returns :ecx)
+			  (with-inline-assembly (:returns :ecx :type (unsigned-byte 29))
 			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
 			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 			    (:load-lexical (:lexical-binding ,object-var) :eax)
@@ -241,16 +243,19 @@
 		 (assert (= 4 movitz::+movitz-fixnum-factor+))
 		 (cond
 		  ((and (eq 0 offset) (eq 0 index))
-		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx
+						    :type (unsigned-byte 32))
 		      (:compile-form (:result-mode :eax) ,object)
 		      (:movl (:eax ,(offset-by 4)) :ecx)))
 		  ((eq 0 offset)
-		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx
+						    :type (unsigned-byte 32))
 		      (:compile-two-forms (:eax :ecx) ,object ,index)
 		      (:movl (:eax :ecx ,(offset-by 4)) :ecx)))
 		  (t (let ((object-var (gensym "memref-object-")))
 		       `(let ((,object-var ,object))
-			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+			  (with-inline-assembly (:returns :untagged-fixnum-ecx
+							  :type (unsigned-byte 32))
 			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
 			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 			    (:load-lexical (:lexical-binding ,object-var) :eax)




From ffjeld at common-lisp.net  Wed Oct 20 10:51:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 20 Oct 2004 12:51:07 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CKE3f-0001Z6-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Improved (memref :code-vector), and bug-fixed (memref-int
:unsigned-byte8) which in fact behaved as :unsigned-byte16.

Date: Wed Oct 20 12:51:07 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.33 movitz/losp/muerte/memref.lisp:1.34
--- movitz/losp/muerte/memref.lisp:1.33	Tue Oct 12 16:52:07 2004
+++ movitz/losp/muerte/memref.lisp	Wed Oct 20 12:51:06 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.33 2004/10/12 14:52:07 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.34 2004/10/20 10:51:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -316,6 +316,20 @@
 		      (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,offset)
 		      (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax)
 		      (:addl (:ebx :ecx ,(offset-by 4)) :eax)))
+		  (t (let ((object-var (gensym "memref-object-"))
+			   (offset-var (gensym "memref-offset-"))
+			   (index-var (gensym "memref-index-")))
+		       `(let ((,object-var ,object)
+			      (,offset-var ,offset)
+			      (,index-var ,index))
+			  (with-inline-assembly (:returns :eax)
+			    (:load-lexical (:lexical-binding ,offset-var) :untagged-fixnum-ecx)
+			    (:load-lexical (:lexical-binding ,object-var) :ebx)
+			    (:load-lexical (:lexical-binding ,index-var) :edx)
+			    (:addl :edx :ecx)
+			    (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax)
+			    (:addl (:ebx :ecx ,(offset-by 4)) :eax)))))
+		  #+ignore
 		  (t (error "variable memref type :code-vector not implemented."))
 		  #+ignore
 		  (t (assert (not (movitz:movitz-constantp offset env)))
@@ -341,12 +355,13 @@
     (:character         (memref object offset :index  index :type :character))
     (:unsigned-byte8    (memref object offset :index index :type :unsigned-byte8))
     (:location          (memref object offset :index index :type :location))
-    (:unsigned-byte14   (memref object offset :index index :type :unsigned-byte14))
     (:unsigned-byte16   (ecase endian
 			  ((:host :little)
 			   (memref object offset :index index :type :unsigned-byte16 :endian :little))
 			  ((:big)
-			   (memref object offset :index index :type :unsigned-byte16 :endian :big))))))
+			   (memref object offset :index index :type :unsigned-byte16 :endian :big))))
+    (:code-vector       (memref object offset :index index :type :code-vector))
+    (:unsigned-byte14   (memref object offset :index index :type :unsigned-byte14))))
 ;;;    (:signed-byte30+2   (memref object offset index :signed-byte30+2))
 ;;;    (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))
 
@@ -756,18 +771,20 @@
 	(:unsigned-byte8
 	 (cond
 	  ((and (eq 0 offset) (eq 0 index))
-	   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+	   `(with-inline-assembly (:returns :untagged-fixnum-ecx
+					    :type (unsigned-byte 8))
 	      (:compile-form (:result-mode :untagged-fixnum-ecx) ,address)
-	      (,prefixes :movzxw (:ecx) :ecx)))
+	      (,prefixes :movzxb (:ecx) :ecx)))
 	  (t (let ((address-var (gensym "memref-int-address-")))
 	       `(let ((,address-var ,address))
-		  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+		  (with-inline-assembly (:returns :untagged-fixnum-ecx
+						  :type (unsigned-byte 8))
 		    (:compile-two-forms (:eax :ecx) ,offset ,index)
 		    (:load-lexical (:lexical-binding ,address-var) :ebx)
 		    (:addl :eax :ecx)
 		    (:addl :ebx :ecx)
 		    (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
-		    (,prefixes :movzxw (:ecx) :ecx)))))))
+		    (,prefixes :movzxb (:ecx) :ecx)))))))
 	(:unsigned-byte16
 	 (cond
 	  ((and (eq 0 offset) (eq 0 index))




From ffjeld at common-lisp.net  Thu Oct 21 16:31:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 18:31:42 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CKfqo-0006e9-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added :signed-byte8 to memref-int compiler-macro.

Date: Thu Oct 21 18:31:36 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.34 movitz/losp/muerte/memref.lisp:1.35
--- movitz/losp/muerte/memref.lisp:1.34	Wed Oct 20 12:51:06 2004
+++ movitz/losp/muerte/memref.lisp	Thu Oct 21 18:31:35 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.34 2004/10/20 10:51:06 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.35 2004/10/21 16:31:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -785,6 +785,23 @@
 		    (:addl :ebx :ecx)
 		    (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
 		    (,prefixes :movzxb (:ecx) :ecx)))))))
+	(:signed-byte8
+	 (cond
+	  ((and (eq 0 offset) (eq 0 index))
+	   `(with-inline-assembly (:returns :ecx :type (signed-byte 8))
+	      (:compile-form (:result-mode :untagged-fixnum-ecx) ,address)
+	      (,prefixes :movsxb (:ecx) :ecx)
+	      (:shll ,movitz:+movitz-fixnum-shift+ :ecx)))
+	  (t (let ((address-var (gensym "memref-int-address-")))
+	       `(let ((,address-var ,address))
+		  (with-inline-assembly (:returns :ecx :type (signed-byte 8))
+		    (:compile-two-forms (:eax :ecx) ,offset ,index)
+		    (:load-lexical (:lexical-binding ,address-var) :ebx)
+		    (:addl :eax :ecx)
+		    (:addl :ebx :ecx)
+		    (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
+		    (,prefixes :movsxb (:ecx) :ecx)
+		    (:shll ,movitz:+movitz-fixnum-shift+ :ecx)))))))
 	(:unsigned-byte16
 	 (cond
 	  ((and (eq 0 offset) (eq 0 index))




From ffjeld at common-lisp.net  Thu Oct 21 20:27:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:27:01 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1CKjWX-0000db-00@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv2447

Modified Files:
	debugger.lisp 
Log Message:
Typo: slot-value should be symbol-value.

Date: Thu Oct 21 22:27:00 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.26 movitz/losp/x86-pc/debugger.lisp:1.27
--- movitz/losp/x86-pc/debugger.lisp:1.26	Sat Sep 25 17:53:25 2004
+++ movitz/losp/x86-pc/debugger.lisp	Thu Oct 21 22:27:00 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.26 2004/09/25 15:53:25 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.27 2004/10/21 20:27:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -500,7 +500,7 @@
 			(cond
 			 ((eq 0 casf-funobj)
 			  (values 'default-interrupt-trampoline
-				  (code-vector-offset (slot-value 'default-interrupt-trampoline)
+				  (code-vector-offset (symbol-value 'default-interrupt-trampoline)
 						      eip)))
 			 ((not (typep casf-funobj 'function))
 			  ;; Hm.. very suspicius




From ffjeld at common-lisp.net  Thu Oct 21 20:30:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:30:10 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1CKjZa-0000h0-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Minor edits.

Date: Thu Oct 21 22:30:08 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.45 movitz/losp/muerte/arrays.lisp:1.46
--- movitz/losp/muerte/arrays.lisp:1.45	Mon Oct 11 15:52:12 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Oct 21 22:30:07 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.45 2004/10/11 13:52:12 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.46 2004/10/21 20:30:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -764,8 +764,9 @@
 			  (:addl 4 :ecx)
 			  (:andl -8 :ecx)
 			  (:jz 'init-done)
+			  (:load-lexical (:lexical-binding initial-element) :edx)
 			  init-loop
-			  (:movl :edi (:eax (:offset movitz-basic-vector data) :ecx -4))
+			  (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4))
 			  (:subl 4 :ecx)
 			  (:jnz 'init-loop)
 			  init-done
@@ -779,6 +780,7 @@
     (cond
      (initial-contents
       (replace array initial-contents))
+     #+ignore
      (initial-element
       (dotimes (i dimension)
 	(setf (svref%unsafe array i) initial-element))))




From ffjeld at common-lisp.net  Thu Oct 21 20:33:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:33:57 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1CKjdF-0000sj-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Improve accessors to observe
*compiler-nonlocal-lispval-read/write-segment-prefix* more.  Also
don't use the movitz-accessor etc. macros anymore, use memref and
movitz-type-slot-offset instead.

Date: Thu Oct 21 22:33:57 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.42 movitz/losp/muerte/basic-macros.lisp:1.43
--- movitz/losp/muerte/basic-macros.lisp:1.42	Mon Oct 11 15:52:18 2004
+++ movitz/losp/muerte/basic-macros.lisp	Thu Oct 21 22:33:57 2004
@@ -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.42 2004/10/11 13:52:18 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.43 2004/10/21 20:33:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -362,16 +362,20 @@
 				      ',(mapcar #'first clauses)))))
 
 (defmacro movitz-accessor (object-form type slot-name)
+  (warn "movitz-accesor deprecated.")
   `(with-inline-assembly (:returns :register :side-effects nil)
      (:compile-form (:result-mode :eax) ,object-form)
-     (:movl (:eax ,(bt:slot-offset (find-symbol (string type) :movitz)
+     (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+      :movl (:eax ,(bt:slot-offset (find-symbol (string type) :movitz)
 				   (find-symbol (string slot-name) :movitz)))
 	    (:result-register))))
 
 (defmacro setf-movitz-accessor ((object-form type slot-name) value-form)
+  (warn "setf-movitz-accesor deprecated.")
   `(with-inline-assembly (:returns :eax :side-effects t)
      (:compile-two-forms (:eax :ebx) ,value-form ,object-form)
-     (:movl :eax (:ebx ,(bt:slot-offset (find-symbol (string type) :movitz)
+     (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+      :movl :eax (:ebx ,(bt:slot-offset (find-symbol (string type) :movitz)
 					(find-symbol (string slot-name) :movitz))))))
 
 (defmacro movitz-accessor-u16 (object-form type slot-name)
@@ -563,9 +567,14 @@
    (t (if (member type '(standard-gf-instance function pointer atom
 			 integer fixnum positive-fixnum cons symbol character null list
 			 string vector simple-vector vector-u8 vector-u16 code-vector))
-	  `(unless (typep ,place ',type)
-	     (with-inline-assembly (:returns :non-local-exit)
-	       (:int 66)))
+	  `(with-inline-assembly (:returns :nothing :labels (fail))
+	     (:compile-form (:result-mode (:boolean-branch-on-false . check-type-failed))
+			    (typep ,place ',type))
+	     (() () '(:sub-program (check-type-failed) (:int 66))))
+	#+ignore
+	`(unless (typep ,place ',type)
+	   (with-inline-assembly (:returns :non-local-exit)
+	     (:int 66)))
 	form))))
 
 (defmacro assert (test-form &optional places datum-form &rest argument-forms)
@@ -623,7 +632,8 @@
 	 (:leal (:eax -1) :ecx)
 	 (:testb 7 :cl)
 	 (:jnz '(:sub-program () (:int 61)))
-	 (:movl :edi (:eax -1)))
+	 (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+	  :movl :edi (:eax -1)))
     `(with-inline-assembly (:returns :eax)
        (:compile-two-forms (:eax :ebx) ,value ,cell)
        (:leal (:ebx -1) :ecx)
@@ -631,7 +641,8 @@
        (:jnz '(:sub-program ()
 	       (:movl :ebx :eax)
 	       (:int 61)))
-       (:movl :eax (:ebx -1)))))
+       (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+	:movl :eax (:ebx -1)))))
 
 (define-compiler-macro (setf cdr) (value cell &environment env)
   (if (and (movitz:movitz-constantp value env)
@@ -641,7 +652,8 @@
 	 (:leal (:eax -1) :ecx)
 	 (:testb 7 :cl)
 	 (:jnz '(:sub-program () (:int 61)))
-	 (:movl :edi (:eax 3)))
+	 (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+	  :movl :edi (:eax 3)))
     `(with-inline-assembly (:returns :eax)
        (:compile-two-forms (:eax :ebx) ,value ,cell)
        (:leal (:ebx -1) :ecx)
@@ -649,7 +661,8 @@
        (:jnz '(:sub-program ()
 	       (:movl :ebx :eax)
 	       (:int 61)))
-       (:movl :eax (:ebx 3)))))
+       (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+	:movl :eax (:ebx 3)))))
 
 (define-compiler-macro rplaca (cons object)
   `(with-inline-assembly (:returns :eax)
@@ -657,7 +670,8 @@
      (:leal (:eax -1) :ecx)
      (:testb 7 :cl)
      (:jnz '(:sub-program () (:int 61)))
-     (:movl :ebx (:eax -1))))
+     (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+      :movl :ebx (:eax -1))))
 
 (define-compiler-macro rplacd (cons object)
   `(with-inline-assembly (:returns :eax)
@@ -665,7 +679,8 @@
      (:leal (:eax -1) :ecx)
      (:testb 7 :cl)
      (:jnz '(:sub-program () (:int 61)))
-     (:movl :ebx (:eax 3))))
+     (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+      :movl :ebx (:eax 3))))
 
 (define-compiler-macro endp (x)
   `(let ((cell ,x))
@@ -709,7 +724,7 @@
        (:leal (:edx -7) :ecx)
        (:andb 7 :cl)
        (:jnz 'not-symbol)
-       (:movl (:edx ,(bt:slot-offset 'movitz::movitz-symbol 'movitz::function-value)) :esi)
+       (:movl (:edx (:offset movitz-symbol function-value)) :esi)
        (:jmp 'funobj-ok)
       not-symbol
        (:cmpb 7 :cl)
@@ -925,7 +940,8 @@
 		:ecx)
 	 (:testb 7 :cl)
 	 (:jnz '(:sub-program () (:int 66)))
-	 (:movl ((:result-register) ,(bt:slot-offset 'movitz::movitz-std-instance slot))
+	 (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+	  :movl ((:result-register) ,(bt:slot-offset 'movitz::movitz-std-instance slot))
 		(:result-register))))))
 
 (defmacro std-instance-writer (slot value instance-form)
@@ -937,8 +953,8 @@
 		:ecx)
 	 (:testb 7 :cl)
 	 (:jnz '(:sub-program () (:int 66)))
-	 (:movl :eax
-		(:ebx ,(bt:slot-offset 'movitz::movitz-std-instance slot)))))))
+	 (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+	  :movl :eax (:ebx ,(bt:slot-offset 'movitz::movitz-std-instance slot)))))))
 
 (define-compiler-macro std-instance-class (instance)
   `(std-instance-reader class ,instance))




From ffjeld at common-lisp.net  Thu Oct 21 20:33:59 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:33:59 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp 
Message-ID: <E1CKjdH-0000t0-00@common-lisp.net>

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

Modified Files:
	cons.lisp 
Log Message:
Improve accessors to observe
*compiler-nonlocal-lispval-read/write-segment-prefix* more.  Also
don't use the movitz-accessor etc. macros anymore, use memref and
movitz-type-slot-offset instead.

Date: Thu Oct 21 22:33:59 2004
Author: ffjeld

Index: movitz/losp/muerte/cons.lisp
diff -u movitz/losp/muerte/cons.lisp:1.7 movitz/losp/muerte/cons.lisp:1.8
--- movitz/losp/muerte/cons.lisp:1.7	Fri Aug  6 16:46:06 2004
+++ movitz/losp/muerte/cons.lisp	Thu Oct 21 22:33:59 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.7 2004/08/06 14:46:06 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.8 2004/10/21 20:33:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -24,8 +24,10 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax -1) :ebx)
-    (:movl (:eax 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax -1) :ebx)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax 3) :eax)
     (:ret)))
 
 (define-primitive-function fast-car ()
@@ -34,7 +36,8 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax -1) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax -1) :eax)
     (:ret)))
 
 (define-primitive-function fast-car-ebx ()
@@ -46,7 +49,8 @@
     (:jnz '(:sub-program ()
 	    (:movl :ebx :eax)
 	    (:int 66)))
-    (:movl (:ebx -1) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:ebx -1) :eax)
     (:ret)))
 
 (define-primitive-function fast-cdr ()
@@ -55,7 +59,8 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax 3) :eax)
     (:ret)))
 
 (define-primitive-function fast-cddr ()
@@ -64,11 +69,13 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax 3) :eax)
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax 3) :eax)
     (:ret)))
 
 (define-primitive-function fast-cdddr ()
@@ -77,15 +84,18 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program (not-cons) (:int 61)))
-    (:movl (:eax 3) :eax)
+    (#.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)))
-    (:movl (:eax 3) :eax)
+    (#.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)))
-    (:movl (:eax 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax 3) :eax)
     (:ret)))
 
 (define-primitive-function fast-cdr-ebx ()
@@ -97,7 +107,8 @@
     (:jnz '(:sub-program ()
 	    (:movl :ebx :eax)
 	    (:int 61)))
-    (:movl (:ebx 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:ebx 3) :eax)
     (:ret)))
 
 ;; Prefetching versions. Only works on .. PII or so and upwards.
@@ -109,8 +120,10 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax -1) :ebx)
-    (:movl (:eax 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax -1) :ebx)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax 3) :eax)
     (:ret)))
 
 (define-primitive-function prefetching-fast-car ()
@@ -120,7 +133,8 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax -1) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax -1) :eax)
     (:ret)))
 
 (define-primitive-function prefetching-fast-car-ebx ()
@@ -133,7 +147,8 @@
     (:jnz '(:sub-program ()
 	    (:movl :ebx :eax)
 	    (:int 61)))
-    (:movl (:ebx -1) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:ebx -1) :eax)
     (:ret)))
 
 (define-primitive-function prefetching-fast-cdr ()
@@ -143,7 +158,8 @@
     (:leal (:eax -1) :ecx)
     (:testb 3 :cl)
     (:jnz '(:sub-program () (:int 61)))
-    (:movl (:eax 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax 3) :eax)
     (:prefetch-nta (:eax))
     (:ret)))
 
@@ -157,7 +173,8 @@
     (:jnz '(:sub-program ()
 	    (:movl :ebx :eax)
 	    (:int 61)))
-    (:movl (:ebx 3) :eax)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:ebx 3) :eax)
     (:prefetch-nta (:eax))
     (:ret)))
 
@@ -170,7 +187,8 @@
     (:jnz '(:sub-program ()
 	    (:movl :ebx :eax)
 	    (:int 61)))
-    (:movl :eax (:ebx -1))))
+    (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+     :movl :eax (:ebx -1))))
 
 (defun (setf cdr) (value cell)
   (with-inline-assembly (:returns :eax)
@@ -181,8 +199,8 @@
     (:jnz '(:sub-program ()
 	    (:movl :ebx :eax)
 	    (:int 61)))
-    (:movl :eax (:ebx 3))))
-
+    (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+     :movl :eax (:ebx 3))))
 
 (defun car (x) (car x))
 (defun cdr (x) (cdr x))




From ffjeld at common-lisp.net  Thu Oct 21 20:34:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:34:02 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1CKjdK-0000tH-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
Improve accessors to observe
*compiler-nonlocal-lispval-read/write-segment-prefix* more.  Also
don't use the movitz-accessor etc. macros anymore, use memref and
movitz-type-slot-offset instead.

Date: Thu Oct 21 22:34:02 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.15 movitz/losp/muerte/defstruct.lisp:1.16
--- movitz/losp/muerte/defstruct.lisp:1.15	Mon Oct 11 15:52:27 2004
+++ movitz/losp/muerte/defstruct.lisp	Thu Oct 21 22:34:02 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.15 2004/10/11 13:52:27 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.16 2004/10/21 20:34:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -56,12 +56,13 @@
 	    (:jne '(:sub-program (type-error) (:int 66)))
 	    ;; type test passed, read slot
 	    ,@(if (= 4 movitz::+movitz-fixnum-factor+)
-		  `((:compile-form  (:result-mode :ebx) slot-number)
-		    (:movl (:eax :ebx (:offset movitz-struct slot0))
+		  `((:compile-form  (:result-mode :ecx) slot-number)
+		    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+		     :movl (:eax :ecx (:offset movitz-struct slot0))
 			   :eax))
 		`((:compile-form  (:result-mode :untagged-fixnum-ecx) slot-number)
-		  (:movl (:eax (:ecx 4) (:offset movitz-struct slot0))
-			 :eax))))))
+		  (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+		   :movl (:eax (:ecx 4) (:offset movitz-struct slot0)) :eax))))))
     (do-it)))
 
 (defun (setf structure-ref) (value object slot-number)
@@ -83,7 +84,8 @@
 	    (:jae '(:sub-program (out-of-range) (:int 65)))
 	    ;; type test passed, write slot
 	    (:compile-form (:result-mode :edx) value)
-	    (:movl :edx (:eax :ebx (:offset movitz-struct slot0))))))
+	    (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+	     :movl :edx (:eax :ebx (:offset movitz-struct slot0))))))
     (do-it)))
 
 (defun struct-accessor-prototype (object)
@@ -101,8 +103,9 @@
 ;;;    (:jne '(:sub-program (type-error) (:int 66)))
     ;; type test passed, read slot
     (:load-constant slot-number :ecx)
-    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
-    (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0))
+;;;    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
+    (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+     :movl (:eax (:ecx 1) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0))
 	   :eax)))
 
 (defun (setf struct-accessor-prototype) (value obj)
@@ -120,8 +123,9 @@
 ;;;    (:jne '(:sub-program (type-error) (:int 66)))
     ;; type test passed, write slot
     (:load-constant slot-number :ecx)
-    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
-    (:movl :eax (:ebx (:ecx 4) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)))))
+;;;    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
+    (#.movitz:*compiler-nonlocal-lispval-write-segment-prefix*
+     :movl :eax (:ebx (:ecx 1) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)))))
 
 (defun list-struct-accessor-prototype (s)
   (nth 'slot-number s))




From ffjeld at common-lisp.net  Thu Oct 21 20:34:04 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:34:04 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1CKjdM-0000tY-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Improve accessors to observe
*compiler-nonlocal-lispval-read/write-segment-prefix* more.  Also
don't use the movitz-accessor etc. macros anymore, use memref and
movitz-type-slot-offset instead.

Date: Thu Oct 21 22:34:04 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.23 movitz/losp/muerte/functions.lisp:1.24
--- movitz/losp/muerte/functions.lisp:1.23	Tue Oct 12 16:43:27 2004
+++ movitz/losp/muerte/functions.lisp	Thu Oct 21 22:34:04 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.23 2004/10/12 14:43:27 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.24 2004/10/21 20:34:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -307,31 +307,37 @@
 
 (defun funobj-lambda-list (funobj)
   (check-type funobj function)
-  (movitz-accessor funobj movitz-funobj lambda-list))
+  (memref funobj (movitz-type-slot-offset 'movitz-funobj 'lambda-list)))
 
 (defun (setf funobj-lambda-list) (lambda-list funobj)
   (check-type funobj function)
   (check-type lambda-list list)
-  (setf-movitz-accessor (funobj movitz-funobj lambda-list) lambda-list))
+  (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'lambda-list))
+    lambda-list))
 
 (defun funobj-num-constants (funobj)
   (check-type funobj function)
-  (movitz-accessor-u16 funobj movitz-funobj num-constants))
+  (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-constants)
+	  :type :unsigned-byte16))
 
 (defun (setf funobj-num-constants) (num-constants funobj)
   (check-type funobj function)
   (check-type num-constants (unsigned-byte 16))
-  (set-movitz-accessor-u16 funobj movitz-funobj num-constants num-constants))
+  (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-constants)
+		:type :unsigned-byte16)
+    num-constants))
 
 (defun funobj-num-jumpers (funobj)
   (check-type funobj function)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) funobj)
-    (:movzxw (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)) :eax)))
+  (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-jumpers)
+	  :type :unsigned-byte14))
 
 (defun (setf funobj-num-jumpers) (num-jumpers funobj)
   (check-type funobj function)
-  (check-type num-jumpers (unsigned-byte 14))
+  (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'num-jumpers)
+		:type :unsigned-byte14)
+    num-jumpers)
+  #+ignore
   (with-inline-assembly (:returns :eax)
     (:compile-two-forms (:eax :ebx) num-jumpers funobj)
     (:movw :ax (:ebx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)))))




From ffjeld at common-lisp.net  Thu Oct 21 20:34:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:34:07 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1CKjdP-0000tp-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Improve accessors to observe
*compiler-nonlocal-lispval-read/write-segment-prefix* more.  Also
don't use the movitz-accessor etc. macros anymore, use memref and
movitz-type-slot-offset instead.

Date: Thu Oct 21 22:34:06 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.21 movitz/losp/muerte/los-closette.lisp:1.22
--- movitz/losp/muerte/los-closette.lisp:1.21	Sat Sep 25 17:38:47 2004
+++ movitz/losp/muerte/los-closette.lisp	Thu Oct 21 22:34:06 2004
@@ -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.21 2004/09/25 15:38:47 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.22 2004/10/21 20:34:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -150,37 +150,40 @@
 
 (defun std-gf-instance-class (instance)
   (check-type instance standard-gf-instance)
-  (movitz-accessor instance movitz-funobj-standard-gf standard-gf-class))
+  (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-class))
+  #+ignore (movitz-accessor instance movitz-funobj-standard-gf standard-gf-class))
 
 (defun std-gf-instance-slots (instance)
   (check-type instance standard-gf-instance)
-  (movitz-accessor instance movitz-funobj-standard-gf standard-gf-slots))
+  (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-slots)))
+
+(define-compiler-macro std-gf-num-required-arguments (instance)
+  `(memref ,instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'num-required-arguments)))
 
 (defun std-gf-num-required-arguments (instance)
   (check-type instance standard-gf-instance)
-  (movitz-accessor instance movitz-funobj-standard-gf num-required-arguments))
-
-(define-compiler-macro std-gf-num-required-arguments (instance)
-  `(movitz-accessor ,instance movitz-funobj-standard-gf num-required-arguments))
+  (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'num-required-arguments)))
 
 (defun std-gf-classes-to-emf-table (instance)
   (check-type instance standard-gf-instance)
-  (movitz-accessor instance movitz-funobj-standard-gf classes-to-emf-table))
+  (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'classes-to-emf-table)))
 
 (define-compiler-macro std-gf-classes-to-emf-table (instance)
-  `(movitz-accessor ,instance movitz-funobj-standard-gf classes-to-emf-table))
+  `(memref ,instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'classes-to-emf-table)))
 
 (defun (setf std-gf-classes-to-emf-table) (value instance)
   (check-type instance standard-gf-instance)
-  (setf-movitz-accessor (instance movitz-funobj-standard-gf classes-to-emf-table) value))
+  (setf (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'classes-to-emf-table))
+    value))
 
 (defun std-gf-eql-specializer-table (instance)
   (check-type instance standard-gf-instance)
-  (movitz-accessor instance movitz-funobj-standard-gf eql-specializer-table))
+  (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'eql-specializer-table)))
 
 (defun (setf std-gf-eql-specializer-table) (value instance)
   (check-type instance standard-gf-instance)
-  (setf-movitz-accessor (instance movitz-funobj-standard-gf eql-specializer-table) value))
+  (setf (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'eql-specializer-table))
+    value))
 
 (defun set-funcallable-instance-function (funcallable-instance function)
   "This function is called to set or to change the function of a funcallable instance.
@@ -188,13 +191,17 @@
 funcallable-instance will run the new function."
   (check-type funcallable-instance standard-gf-instance)
   (check-type function function)
-  (setf-movitz-accessor (funcallable-instance movitz-funobj-standard-gf standard-gf-function)
-			function)
+  (setf (memref funcallable-instance (movitz-type-slot-offset 'movitz-funobj-standard-gf
+							      'standard-gf-function))
+    function)
+;;;  (setf-movitz-accessor (funcallable-instance movitz-funobj-standard-gf standard-gf-function)
+;;;			function)
   (values))
 
 (defun funcallable-instance-function (funcallable-instance)
   (check-type funcallable-instance standard-gf-instance)
-  (movitz-accessor funcallable-instance movitz-funobj-standard-gf standard-gf-function))
+  (memref funcallable-instance (movitz-type-slot-offset 'movitz-funobj-standard-gf
+							'standard-gf-function)))
 
 (defun instance-slot-p (slot)
   (eq (slot-definition-allocation slot) :instance))
@@ -868,12 +875,13 @@
   `(defun ,name (instance)
      (with-inline-assembly (:returns :multiple-values)
        (:compile-form (:result-mode :eax) instance)
-       (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::slots))
-	      :eax)
-       (:movl (:eax ,(+ (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::data)
-			(* location 4)))
+       (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix*
+	:movl (:eax (:offset movitz-std-instance slots))
 	      :eax)
-       (:cmpl :eax ,(movitz::make-indirect-reference :edi (movitz::global-constant-offset 'unbound-value)))
+       (#.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 'unbound-value)))
        (:je '(:sub-program (unbound)
 	      (:compile-form (:result-mode :multiple-values) (slot-unbound-trampoline instance ,location))
 	      (:jmp 'done)))
@@ -968,7 +976,7 @@
 (defclass sequence (t) () (:metaclass built-in-class))
 (defclass array (t) () (:metaclass built-in-class))
 (defclass character (t) () (:metaclass built-in-class))
-;; (defclass hash-table (t) () (:metaclass built-in-class))
+;;;(defclass hash-table (t) () (:metaclass built-in-class))
 ;;;(defclass package (t) () (:metaclass built-in-class))
 ;;;(defclass pathname (t) () (:metaclass built-in-class))
 ;;;(defclass readtable (t) () (:metaclass built-in-class))




From ffjeld at common-lisp.net  Thu Oct 21 20:34:09 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:34:09 +0200
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1CKjdR-0000u6-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Improve accessors to observe
*compiler-nonlocal-lispval-read/write-segment-prefix* more.  Also
don't use the movitz-accessor etc. macros anymore, use memref and
movitz-type-slot-offset instead.

Date: Thu Oct 21 22:34:09 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.46 movitz/losp/muerte/primitive-functions.lisp:1.47
--- movitz/losp/muerte/primitive-functions.lisp:1.46	Thu Oct  7 14:44:17 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Oct 21 22:34:09 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.46 2004/10/07 12:44:17 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.47 2004/10/21 20:34:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -306,7 +306,8 @@
     (:movl :ebx (:ecx 8))		; Store VALUE in binding.
     (:ret)
    no-binding
-    (:movl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value)))
+    (#.movitz::*compiler-nonlocal-lispval-write-segment-prefix*
+     :movl :ebx (:eax (:offset movitz-symbol value)))
     (:ret)))
 
 (define-primitive-function keyword-search ()
@@ -595,9 +596,9 @@
     (ratio
      (find-class 'ratio))
     (std-instance
-     (movitz-accessor object movitz-std-instance class))
+     (memref object (movitz-type-slot-offset 'movitz-std-instance 'class)))
     (standard-gf-instance
-     (movitz-accessor object movitz-funobj-standard-gf standard-gf-class))
+     (memref object (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-class)))
     (string
      (find-class 'string))
     (bit-vector




From ffjeld at common-lisp.net  Thu Oct 21 20:34:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:34:11 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1CKjdT-0000uN-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Improve accessors to observe
*compiler-nonlocal-lispval-read/write-segment-prefix* more.  Also
don't use the movitz-accessor etc. macros anymore, use memref and
movitz-type-slot-offset instead.

Date: Thu Oct 21 22:34:11 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.21 movitz/losp/muerte/symbols.lisp:1.22
--- movitz/losp/muerte/symbols.lisp:1.21	Tue Oct 12 16:45:16 2004
+++ movitz/losp/muerte/symbols.lisp	Thu Oct 21 22:34:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.21 2004/10/12 14:45:16 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.22 2004/10/21 20:34:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -95,12 +95,12 @@
 (defun %unbounded-symbol-function (symbol)
   (check-type symbol symbol)
   (memref symbol (movitz-type-slot-offset 'movitz-symbol 'function-value)))
-  ;; (movitz-accessor symbol movitz-symbol function-value))
 
 (defun (setf symbol-function) (value symbol)
   (check-type symbol symbol)
   (check-type value compiled-function)
-  (setf-movitz-accessor (symbol movitz-symbol function-value) value))
+  (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'function-value))
+    value))
 
 (defun symbol-name (symbol)
   (get-symbol-slot symbol name string))




From ffjeld at common-lisp.net  Thu Oct 21 20:38:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:38:29 +0200
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1CKjhd-0000v7-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Depreacated the :untagged-fixnum-eax more. It's incompatible with
stack discipline.

Date: Thu Oct 21 22:38:28 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.101 movitz/compiler.lisp:1.102
--- movitz/compiler.lisp:1.101	Mon Oct 11 15:44:04 2004
+++ movitz/compiler.lisp	Thu Oct 21 22:38:28 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.101 2004/10/11 13:44:04 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.102 2004/10/21 20:38:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -51,7 +51,7 @@
   "Use this segment prefix when reading a lispval at (potentially)
 non-local locations.")
 
-(defparameter *compiler-nonlocal-lispval-write-segment-prefix* '(:fs-override)
+(defparameter *compiler-nonlocal-lispval-write-segment-prefix* '(:es-override)
   "Use this segment prefix when writing a lispval at (potentially)
 non-local locations.")
 
@@ -2607,7 +2607,10 @@
 			     (cdr instruction)
 			   (assert (not (getf jumper-sets name)) ()
 			     "Duplicate jumper declaration for ~S." name)
-			   (setf (getf jumper-sets name) set))))
+			   (setf (getf jumper-sets name) set)))
+			(t (when (listp instruction)
+			     (dolist (binding (find-read-bindings instruction))
+			       (process-binding binding)))))
 		   do (let ((sub (instruction-sub-program instruction)))
 			(when sub (process sub))))))
       (process code)
@@ -4801,6 +4804,7 @@
 	    (values (append code
 			    `((:load-lexical ,returns-provided ,desired-result)))
 		    desired-result))))
+	#+ignore
 	(:untagged-fixnum-eax
 	 (case returns-provided
 	   (:untagged-fixnum-eax
@@ -4977,7 +4981,8 @@
 	    (values code returns-provided))
 	   (:multiple-values
 	    (values code :values))
-	   (t (values (make-result-and-returns-glue :eax returns-provided code)
+	   (t (values (make-result-and-returns-glue :eax returns-provided code
+						    :type type)
 		      '(:values 1)))))
 	((:multiple-values :function)
 	 (case (operator returns-provided)
@@ -4990,16 +4995,21 @@
 	      (1 (values (append code '((:clc)))
 			 :multiple-values))
 	      ((nil) (values code :multiple-values))
-	      (t (values (append code (make-immediate-move (first (operands returns-provided)) :ecx) '((:stc)))
+	      (t (values (append code
+				 (make-immediate-move (first (operands returns-provided)) :ecx)
+				 '((:stc)))
 			 :multiple-values))))
 	   (t (values (append (make-result-and-returns-glue :eax
 							    returns-provided
-							    code)
+							    code
+							    :type type
+							    :provider provider
+							    :really-desired desired-result)
 			      '((:clc)))
 		      :multiple-values)))))
     (unless new-returns-provided
       (multiple-value-setq (new-code new-returns-provided glue-side-effects-p)
-	(case (operator returns-provided)
+	(ecase (operator returns-provided)
 	  (#.+boolean-modes+
 	   (make-result-and-returns-glue desired-result :eax
 					 (make-result-and-returns-glue :eax returns-provided code
@@ -5009,16 +5019,28 @@
 					 :type type
 					 :provider provider))
 	  (:untagged-fixnum-ecx
-	   (case (result-mode-type desired-result)
-	     ((:eax :single-value)
-	      (values (append code
-			      `((:call (:edi ,(global-constant-offset 'box-u32-ecx)))))
-		      desired-result))
-	     (t (make-result-and-returns-glue desired-result :eax
-					      (make-result-and-returns-glue :eax :untagged-fixnum-ecx code
-									    :provider provider
-									    :really-desired desired-result)
-					      :provider provider))))
+	   (let ((fixnump (subtypep type `(integer 0 ,+movitz-most-positive-fixnum+))))
+	     (cond
+	      ((and fixnump
+		    (member (result-mode-type desired-result) '(:eax :ebx :ecx :edx)))
+	       (values (append code
+			       `((:leal ((:ecx ,+movitz-fixnum-factor+))
+					,(result-mode-type desired-result))))
+		       desired-result))
+	      ((and (not fixnump)
+		    (member (result-mode-type desired-result) '(:eax :single-value)))
+	       (values (append code
+			       `((:call (:edi ,(global-constant-offset 'box-u32-ecx)))))
+		       desired-result))
+	      (t (make-result-and-returns-glue
+		  desired-result :eax
+		  (make-result-and-returns-glue :eax :untagged-fixnum-ecx code
+						:provider provider
+						:really-desired desired-result
+						:type type)
+		  :provider provider
+		  :type type)))))
+	  #+ignore
 	  (:untagged-fixnum-eax
 	   (make-result-and-returns-glue desired-result :eax
 					 (make-result-and-returns-glue :eax :untagged-fixnum-eax code
@@ -5542,7 +5564,7 @@
 			  (:lexical-binding
 			   result-mode)
 			  ((:ebx :ecx :edx :esi :push
-			    :untagged-fixnum-eax
+			    ;; :untagged-fixnum-eax
 			    :untagged-fixnum-ecx
 			    :boolean-branch-on-true
 			    :boolean-branch-on-false)




From ffjeld at common-lisp.net  Thu Oct 21 20:40:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:40:33 +0200
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1CKjjd-0000vj-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Removed dead code.

Date: Thu Oct 21 22:40:32 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.71 movitz/image.lisp:1.72
--- movitz/image.lisp:1.71	Sat Sep 25 17:40:30 2004
+++ movitz/image.lisp	Thu Oct 21 22:40:32 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.71 2004/09/25 15:40:30 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.72 2004/10/21 20:40:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1457,21 +1457,7 @@
 	     (make-movitz-hash-table expr))
 	    (ratio
 	     (make-instance 'movitz-ratio
-	       :value expr)
-	     #+ignore
-	     (let ((slot-descriptions (gethash 'muerte.cl::ratio
-					       (image-struct-slot-descriptions *image*)
-					       nil)))
-	       (unless slot-descriptions
-		 (error "Don't know how to movitz-read ratios (yet)." expr))
-	       (let ((movitz-object (make-instance 'movitz-struct
-				      :class (muerte::movitz-find-class 'muerte.cl::ratio)
-				      :length (length slot-descriptions))))
-		 (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
-		 (setf (slot-value movitz-object 'slot-values)
-		   (list (movitz-read (numerator expr))
-			 (movitz-read (denominator expr))))
-		 movitz-object)))
+	       :value expr))
 	    (structure-object
 	     (let ((slot-descriptions (gethash (type-of expr)
 					       (image-struct-slot-descriptions *image*)




From ffjeld at common-lisp.net  Thu Oct 21 20:41:56 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:41:56 +0200
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1CKjky-0000wS-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Fix returned type-specifier to corret pacakge.

Date: Thu Oct 21 22:41:56 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.41 movitz/special-operators.lisp:1.42
--- movitz/special-operators.lisp:1.41	Thu Oct  7 14:48:39 2004
+++ movitz/special-operators.lisp	Thu Oct 21 22:41:56 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.41 2004/10/07 12:48:39 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.42 2004/10/21 20:41:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -598,7 +598,7 @@
 			 (compiler-values ()
 			   :code code
 			   :returns returns
-			   :type type
+			   :type (translate-program type :muerte.cl :cl)
 			   :modifies modifies
 			   :functional-p (not side-effects))))))))))))
 




From ffjeld at common-lisp.net  Thu Oct 21 20:47:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:47:27 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1CKjqJ-0001C1-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added (setf (memref :unsigned-byte14))

Date: Thu Oct 21 22:47:27 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.35 movitz/losp/muerte/memref.lisp:1.36
--- movitz/losp/muerte/memref.lisp:1.35	Thu Oct 21 18:31:35 2004
+++ movitz/losp/muerte/memref.lisp	Thu Oct 21 22:47:26 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.35 2004/10/21 16:31:35 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.36 2004/10/21 20:47:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -634,6 +634,37 @@
 		  (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 		  (:movb :ah (:ebx :ecx)))
 		,value-var)))))
+      (:unsigned-byte14
+       (cond
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-two-forms (:eax :ebx) ,value ,object)
+	    (:andl ,(mask-field (byte 14 2) -1) :eax)
+	    (:movw :ax (:ebx ,(+ (movitz:movitz-eval offset env)
+				 (* 4 (movitz:movitz-eval index env)))))))
+	((movitz:movitz-constantp offset env)
+	 (let ((value-var (gensym "memref-value-")))
+	   `(let ((,value-var ,value))
+	      (with-inline-assembly (:returns :eax)
+		(:compile-two-forms (:ebx :ecx) ,object ,index)
+		(:load-lexical (:lexical-binding ,value-var) :eax)
+		,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2))
+		    `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx))
+		(:andl ,(mask-field (byte 14 2) -1) :eax)
+		(:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env)))))))
+	(t (let ((value-var (gensym "memref-value-"))
+		 (object-var (gensym "memref-object-")))
+	     `(let ((,value-var ,value) (,object-var ,object))
+		(with-inline-assembly (:returns :eax)
+		  (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index)
+		  (:load-lexical (:lexical-binding ,value-var) :eax)
+		  ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
+		      `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx))
+		  (:addl :ebx :ecx)	; index += offset
+		  (:load-lexical (:lexical-binding ,object-var) :ebx)
+		  (:andl ,(mask-field (byte 14 2) -1) :eax)
+		  (:movl :ax (:ebx :ecx))))))))
       (:lisp
        (let* ((localp (movitz:movitz-eval localp env))
 	      (prefixes (if localp




From ffjeld at common-lisp.net  Thu Oct 21 20:50:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:50:20 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp 
Message-ID: <E1CKjt6-0001CP-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Don't use movitz-accessor.

Date: Thu Oct 21 22:50:19 2004
Author: ffjeld

Index: movitz/losp/muerte/packages.lisp
diff -u movitz/losp/muerte/packages.lisp:1.4 movitz/losp/muerte/packages.lisp:1.5
--- movitz/losp/muerte/packages.lisp:1.4	Sat Sep 25 17:36:16 2004
+++ movitz/losp/muerte/packages.lisp	Thu Oct 21 22:50:19 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 30 15:19:43 2001
 ;;;;                
-;;;; $Id: packages.lisp,v 1.4 2004/09/25 15:36:16 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.5 2004/10/21 20:50:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -82,14 +82,14 @@
       (unless status
 	(let ((name (subseq name start end)))
 	  (map-into name key name)
-	  (setf symbol (make-symbol name))
+	  (setf symbol (%create-symbol name package))
 	  (when (eq package (find-package :keyword))
 	    (setf (symbol-flags symbol)
 	      #.(bt:enum-value 'movitz::movitz-symbol-flags '(:constant-variable)))
 	    (setf (symbol-value symbol)
 	      symbol))))
       (unless (symbol-package symbol)
-	(setf-movitz-accessor (symbol movitz-symbol package) package))
+	(setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'package)) package))
       (unless status
 	(if (eq package (find-package :keyword))
 	    (setf (gethash (symbol-name symbol) (package-object-external-symbols package)) symbol)




From ffjeld at common-lisp.net  Thu Oct 21 20:51:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:51:13 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <E1CKjtx-0001Cp-00@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Add operator control-register to read the x86 CPU's control registers.

Date: Thu Oct 21 22:51:13 2004
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.3 movitz/losp/muerte/segments.lisp:1.4
--- movitz/losp/muerte/segments.lisp:1.3	Tue Apr  6 16:32:00 2004
+++ movitz/losp/muerte/segments.lisp	Thu Oct 21 22:51:13 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu May  8 14:25:06 2003
 ;;;;                
-;;;; $Id: segments.lisp,v 1.3 2004/04/06 14:32:00 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.4 2004/10/21 20:51:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -90,6 +90,16 @@
     (:lgdt (:ecx))))
 
 ;;;
+
+(defun control-register (name)
+  (macrolet ((creg (reg)
+	       `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		  (:movcr ,reg :ecx))))
+    (ecase name
+      (:cr0 (creg :cr0))
+      (:cr2 (creg :cr2))
+      (:cr3 (creg :cr3))
+      (:cr4 (creg :cr4)))))
 
 (defun control-register-lo12 (name)
   "Return the low 12 bits of an x86 control register, such as :cr0 or :cr1."




From ffjeld at common-lisp.net  Thu Oct 21 20:52:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:52:11 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp 
Message-ID: <E1CKjut-0001DC-00@common-lisp.net>

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

Modified Files:
	ip4.lisp 
Log Message:
*** empty log message ***
Date: Thu Oct 21 22:52:11 2004
Author: ffjeld

Index: movitz/losp/lib/net/ip4.lisp
diff -u movitz/losp/lib/net/ip4.lisp:1.6 movitz/losp/lib/net/ip4.lisp:1.7
--- movitz/losp/lib/net/ip4.lisp:1.6	Thu Apr  1 19:29:44 2004
+++ movitz/losp/lib/net/ip4.lisp	Thu Oct 21 22:52:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr 30 13:52:57 2003
 ;;;;                
-;;;; $Id: ip4.lisp,v 1.6 2004/04/01 17:29:44 ffjeld Exp $
+;;;; $Id: ip4.lisp,v 1.7 2004/10/21 20:52:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -252,10 +252,27 @@
 
 ;;;; UDP
 
+(defun udp-src-port (packet &optional (start 34))
+  (bvref-u16 packet start 0))
+
+(defun (setf udp-src-port) (value packet &optional (start 34))
+  (setf (bvref-u16 packet start 0) value))
+
+(defun udp-dst-port (packet &optional (start 34))
+  (bvref-u16 packet start 2))
+
+(defun udp-length (packet &optional (start 34))
+  (bvref-u16 packet start 4))
+
+(defun udp-checksum (packet &optional (start 34))
+  (bvref-u16 packet start 6))
+
+
 (defmethod udp-input ((stack ip4-stack) packet ip-start udp-start)
   (warn "Got UDP packet of length ~D from ~@v/ip4:pprint-ip4/."
 	(- (length packet) udp-start)
 	ip-start packet))
+
 
 ;;;; TCP
 




From ffjeld at common-lisp.net  Thu Oct 21 20:42:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:42:51 +0200
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1CKjlr-0000wo-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Somewhat improved support for movitz-ratio objects.

Date: Thu Oct 21 22:42:51 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.42 movitz/storage-types.lisp:1.43
--- movitz/storage-types.lisp:1.42	Tue Sep 21 15:04:02 2004
+++ movitz/storage-types.lisp	Thu Oct 21 22:42:51 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.42 2004/09/21 13:04:02 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.43 2004/10/21 20:42:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -73,11 +73,11 @@
   
   :old-vector #x1a
   :basic-vector #x22
+  :defstruct #x2a
   :funobj #x3a
   :bignum #x4a
   :ratio #x52
   :complex #x5a
-  :defstruct #x2a
   :std-instance #x40
   :run-time-context #x50
   :illegal #x13
@@ -1237,6 +1237,7 @@
   (assert (= (movitz-bignum-value object) lisp-object))
   object)
 
+
 (defmethod read-binary-record ((type-name (eql 'movitz-bignum)) stream &key)
   (let* ((header (call-next-method))
 	 (x (loop for i from 0 below (movitz-bignum-length header)
@@ -1280,3 +1281,14 @@
     (setf (slot-value obj 'numerator) (numerator value)
 	  (slot-value obj 'denominator) (denominator value))
     (call-next-method)))
+
+
+(defmethod update-movitz-object ((object movitz-ratio) lisp-object)
+  (assert (= (movitz-ratio-value object) lisp-object))
+  object)
+
+(defmethod print-object ((x movitz-ratio) stream)
+  (print-unreadable-object (x stream :type t)
+    (format stream "~D" (slot-value x 'value)))
+  x)
+




From ffjeld at common-lisp.net  Thu Oct 21 20:44:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:44:53 +0200
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1CKjnp-0000x7-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
In go, don't check if dynamic-unwind-next finds an unwind-protect or
not, since there's noe sense in doing that.

Date: Thu Oct 21 22:44:52 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.27 movitz/special-operators-cl.lisp:1.28
--- movitz/special-operators-cl.lisp:1.27	Mon Oct 11 15:48:07 2004
+++ movitz/special-operators-cl.lisp	Thu Oct 21 22:44:52 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.27 2004/10/11 13:48:07 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.28 2004/10/21 20:44:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -740,7 +740,6 @@
 			;; Now, install correct jumper within tagbody as target.
 			`((:addl ,(* 4 label-id) (:edx 8))))
 		    (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
-		    (:jnc '(:sub-program () (:int 63)))
 		    ;; have next-continuation in EAX, final-continuation in EDX
 		    (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
 		    (:locally (:movl :esi (:edi (:edi-offset scratch1))))




From ffjeld at common-lisp.net  Thu Oct 21 20:45:49 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 21 Oct 2004 22:45:49 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp 
Message-ID: <E1CKjoj-000196-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Add eval of unwind-protect.

Date: Thu Oct 21 22:45:48 2004
Author: ffjeld

Index: movitz/losp/muerte/eval.lisp
diff -u movitz/losp/muerte/eval.lisp:1.11 movitz/losp/muerte/eval.lisp:1.12
--- movitz/losp/muerte/eval.lisp:1.11	Tue Sep 21 15:02:57 2004
+++ movitz/losp/muerte/eval.lisp	Thu Oct 21 22:45:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.11 2004/09/21 13:02:57 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.12 2004/10/21 20:45:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -102,6 +102,9 @@
     ((throw)
      (throw (eval-form (second form) env)
        (eval-form (third form) env)))
+    ((unwind-protect)
+     (unwind-protect (eval-form (second form) env)
+       (eval-progn (cddr form) env)))
     (t (eval-funcall form env))))
 
 (defun eval-progn (forms env)




From ffjeld at common-lisp.net  Fri Oct 22 07:57:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 22 Oct 2004 09:57:27 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1CKuIh-0004Xf-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Remove the *scan* variable that was used for debugging before. Also
improve detection of non-pointers in the scanner.

Date: Fri Oct 22 09:57:25 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.33 movitz/losp/muerte/scavenge.lisp:1.34
--- movitz/losp/muerte/scavenge.lisp:1.33	Mon Oct 11 15:53:25 2004
+++ movitz/losp/muerte/scavenge.lisp	Fri Oct 22 09:57:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.33 2004/10/11 13:53:25 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.34 2004/10/22 07:57:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -48,12 +48,13 @@
 	((>= scan end-location))
       (with-simple-restart (continue-map-heap-words
 			    "Continue map-heap-words at location ~S." (1+ scan))
-	(let ((*scan* scan)
-	      (x (memref scan 0 :type :unsigned-byte16)))
-	  (declare (special *scan*))
+	(let ((x (memref scan 0 :type :unsigned-byte16))
+	      (x2 (memref scan 1 :type :unsigned-byte16)))
 	  (when verbose
 	    (format *terminal-io* " [at ~S: ~S]" scan x))
 	  (cond
+	   ((or (and (= 0 x2) (= 2 x))
+		(and (= #xffff x2) (= #xfffe x))))
 	   ((let ((tag (ldb (byte 3 0) x)))
 	      (or (= tag #.(movitz:tag :null))
 		  (= tag #.(movitz:tag :even-fixnum))




From ffjeld at common-lisp.net  Fri Oct 22 12:31:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 22 Oct 2004 14:31:35 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp 
Message-ID: <E1CKyZz-00011T-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Added parse-docstring-declarations-and-body, and made the parsing of
lambda-forms use it, so that e.g.

  (lambda (..) "docstring" (declare ..) ..)

should now work in eval.

Date: Fri Oct 22 14:31:34 2004
Author: ffjeld

Index: movitz/losp/muerte/eval.lisp
diff -u movitz/losp/muerte/eval.lisp:1.12 movitz/losp/muerte/eval.lisp:1.13
--- movitz/losp/muerte/eval.lisp:1.12	Thu Oct 21 22:45:48 2004
+++ movitz/losp/muerte/eval.lisp	Fri Oct 22 14:31:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.12 2004/10/21 20:45:48 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.13 2004/10/22 12:31:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -152,6 +152,16 @@
     (dolist (d (cdar p))
       (push d declarations))))
 
+(defun parse-docstring-declarations-and-body (forms)
+  "From the list of FORMS, return first the list of non-declaration forms, ~
+second the list of declaration-specifiers, third any docstring."
+  (if (or (not (cdr forms))
+	  (not (stringp (car forms))))
+      (parse-declarations-and-body forms)
+    (multiple-value-call #'values
+      (parse-declarations-and-body (cdr forms))
+      (car forms))))
+
 (defun declared-special-p (var declarations)
   (dolist (d declarations nil)
     (when (and (consp d)
@@ -315,7 +325,7 @@
 	(symbol-function (lookup-setf-function (second function-name))))
        ((lambda)
 	(let ((lambda-list (cadr function-name))
-	      (lambda-body (cddr function-name)))
+	      (lambda-body (parse-docstring-declarations-and-body (cddr function-name))))
 	  (install-funobj-name :anonymous-lambda
 			       (lambda (&rest args)
 				 (declare (dynamic-extent args))




From ffjeld at common-lisp.net  Fri Oct 22 12:33:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 22 Oct 2004 14:33:28 +0200
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp 
Message-ID: <E1CKybo-00011t-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Added interpretation of the catch special operator.

Date: Fri Oct 22 14:33:28 2004
Author: ffjeld

Index: movitz/losp/muerte/eval.lisp
diff -u movitz/losp/muerte/eval.lisp:1.13 movitz/losp/muerte/eval.lisp:1.14
--- movitz/losp/muerte/eval.lisp:1.13	Fri Oct 22 14:31:34 2004
+++ movitz/losp/muerte/eval.lisp	Fri Oct 22 14:33:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.13 2004/10/22 12:31:34 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.14 2004/10/22 12:33:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -99,6 +99,9 @@
       (make-destructuring-env (cadr form)
 			      (eval-form (caddr form) env)
 			      env)))
+    ((catch)
+     (catch (eval-form (second form) env)
+       (eval-progn (cddr form) env)))
     ((throw)
      (throw (eval-form (second form) env)
        (eval-form (third form) env)))