From ffjeld at common-lisp.net  Thu Jun  9 22:18:58 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 00:18:58 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <20050609221858.A4AA988030@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Starting to support adjustable and displaced vectors.

Date: Fri Jun 10 00:18:57 2005
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.52 movitz/storage-types.lisp:1.53
--- movitz/storage-types.lisp:1.52	Sun May  8 03:17:05 2005
+++ movitz/storage-types.lisp	Fri Jun 10 00:18:55 2005
@@ -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.52 2005/05/08 01:17:05 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.53 2005/06/09 22:18:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -343,7 +343,8 @@
 		   :u16 3
 		   :u32 4
 		   :bit 5
-		   :code 6)
+		   :code 6
+		   :indirects 7)
     :initarg :element-type
     :reader movitz-vector-element-type)
    (fill-pointer



From ffjeld at common-lisp.net  Thu Jun  9 22:19:03 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 00:19:03 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <20050609221903.0618488030@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Starting to support adjustable and displaced vectors.

Date: Fri Jun 10 00:19:03 2005
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.50 movitz/losp/muerte/arrays.lisp:1.51
--- movitz/losp/muerte/arrays.lisp:1.50	Sun May 22 00:37:53 2005
+++ movitz/losp/muerte/arrays.lisp	Fri Jun 10 00:19:02 2005
@@ -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.50 2005/05/21 22:37:53 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.51 2005/06/09 22:19:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -21,10 +21,6 @@
 
 (in-package muerte)
 
-(defun vector-element-type (object)
-  (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)
 	   (+ (* #x100 (bt:enum-value 'movitz::movitz-vector-element-type et1))
@@ -33,8 +29,8 @@
        #+ignore
        (warn "vdd: ~X" (+ (* #x100 (vector-element-type ,s1))
 	      (vector-element-type ,s2)))
-       (case (+ (ash (vector-element-type ,s1) 8)
-		(vector-element-type ,s2))
+       (case (+ (ash (vector-element-type-code ,s1) 8)
+		(vector-element-type-code ,s2))
 	 ,@(loop for (keys . forms) in clauses
 	       if (atom keys)
 	       collect (cons keys forms)
@@ -42,18 +38,36 @@
 	       collect (cons (make-double-dispatch-value (first keys) (second keys))
 			     forms))))))
 
-(define-compiler-macro vector-element-type (object)
-  `(memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
-	   :type :unsigned-byte8))
+(defmacro with-indirect-vector ((var form &key (check-type t)) &body body)
+  `(let ((,var ,form))
+     ,(when check-type `(check-type ,var indirect-vector))
+     (macrolet ((,var (slot)
+		  (let ((index (position slot '(displaced-to displaced-offset
+						fill-pointer length))))
+		    (assert index () "Unknown indirect-vector slot ~S." slot)
+		    `(memref ,',var (movitz-type-slot-offset 'movitz-basic-vector 'data)
+			     :index ,index))))
+       , at body)))
+
+(define-compiler-macro vector-element-type-code (object)
+  `(let ((x (memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
+		    :type :unsigned-byte8)))
+     (if (/= x ,(bt:enum-value 'movitz::movitz-vector-element-type :indirects))
+	 x
+       (memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'fill-pointer)
+	       :index 1 :type :unsigned-byte8))))
+
+(defun vector-element-type-code (object)
+  (vector-element-type-code object))
 
-(defun (setf vector-element-type) (numeric-element-type vector)
+(defun (setf vector-element-type-code) (numeric-element-type vector)
   (check-type vector vector)
   (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
 		:type :unsigned-byte8)    
     numeric-element-type))
 
 (defun array-element-type (array)
-  (ecase (vector-element-type array)
+  (ecase (vector-element-type-code array)
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
        t)
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
@@ -111,13 +125,17 @@
 
 (defun array-dimension (array axis-number)
   (etypecase array
+    (indirect-vector
+     (assert (eq 0 axis-number))
+     (with-indirect-vector (indirect array :check-type nil)
+       (indirect length)))
     ((simple-array * 1)
-     (assert (zerop axis-number))
+     (assert (eq 0 axis-number))
      (memref array (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
 
 (defun array-dimensions (array)
-  (check-type array array)
-  1)
+  (etypecase array
+    (vector 1)))
 
 (defun shrink-vector (vector new-size)
   (check-type vector vector)
@@ -142,13 +160,18 @@
 
 (defun array-has-fill-pointer-p (array)
   (etypecase array
-    (simple-array
+    (indirect-vector
+     t)
+    ((simple-array * 1)
      (%basic-vector-has-fill-pointer-p array))
     (array nil)))
   
 (defun fill-pointer (vector)
   (etypecase vector
-    (simple-array
+    (indirect-vector
+     (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	     :index 2))
+    ((simple-array * 1)
      (assert (%basic-vector-has-fill-pointer-p vector) (vector)
        "Vector has no fill-pointer.")
      (%basic-vector-fill-pointer vector))))
@@ -157,7 +180,7 @@
   (check-type vector vector)
   (let ((length (the fixnum
 		  (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
-    (ecase (vector-element-type vector)
+    (ecase (vector-element-type-code 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)
@@ -173,14 +196,28 @@
 
 (defun (setf fill-pointer) (new-fill-pointer vector)
   (etypecase vector
-    (simple-array
+    (indirect-vector
      (macrolet
 	 ((do-it ()
 	    `(with-inline-assembly (:returns :eax)
 	       (:compile-two-forms (:eax :ebx) new-fill-pointer vector)
 	       (:testb ,movitz:+movitz-fixnum-zmask+ :al)
 	       (:jnz 'illegal-fill-pointer)
-	       (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+	       (:movl (:ebx (:offset movitz-basic-vector data) 12) :ecx)
+	       (:cmpl :ebx :ecx)
+	       (:jg '(:sub-program (illegal-fill-pointer)
+		       (:compile-form (:result-mode :ignore)
+			(error "Illegal fill-pointer: ~W." new-fill-pointer))))
+	       (:movl :eax (:ebx (:offset movitz-basic-vector data) 8)))))
+       (do-it)))
+    ((simple-array * 1)
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :eax)
+	       (:compile-two-forms (:eax :ebx) new-fill-pointer vector)
+	       (:testb ,movitz:+movitz-fixnum-zmask+ :al)
+	       (:jnz 'illegal-fill-pointer)
+	       (:movl (:ebx (:offset movitz-basic-vector num-elements))
 		      :ecx)
 	       (:testl ,(logxor #xffffffff (1- (expt 2 14))) :ecx)
 	       (:jnz '(:sub-program ()
@@ -190,7 +227,7 @@
 	       (:jc '(:sub-program (illegal-fill-pointer)
 		       (:compile-form (:result-mode :ignore)
 			(error "Illegal fill-pointer: ~W." new-fill-pointer))))
-	       (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer))))))
+	       (:movw :ax (:ebx (:offset movitz-basic-vector fill-pointer))))))
        (do-it)))))
 
 (defun vector-aref%unsafe (vector index)
@@ -263,18 +300,22 @@
   (numargs-case
    (2 (array index)
       (etypecase array
-	(simple-array
+	(indirect-vector
+	 (with-indirect-vector (indirect array :check-type nil)
+	   (aref (indirect displaced-to) (+ index (indirect displaced-offset)))))
+	(vector
 	 (macrolet
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
-		   (:declare-label-set basic-vector-dispatcher
-				       ,(loop with x = (make-list 8 :initial-element 'unknown)
-					    for et in '(:any-t :character :u8 :u32 :code :bit)
-					    do (setf (elt x (bt:enum-value
-							     'movitz::movitz-vector-element-type
-							     et))
-						 et)
-					    finally (return x)))
+		   (:declare-label-set
+		    basic-vector-dispatcher
+		    ,(loop with x = (make-list 8 :initial-element 'unknown)
+			 for et in '(:any-t :character :u8 :u32 :code :bit)
+			 do (setf (elt x (bt:enum-value
+					  'movitz::movitz-vector-element-type
+					  et))
+			      et)
+			 finally (return x)))
 		   (:compile-two-forms (:eax :ebx) array index)
 		   (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 		   (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
@@ -338,7 +379,11 @@
   (numargs-case
    (3 (value vector index)
       (etypecase vector
-	(simple-array
+	(indirect-vector
+	 (with-indirect-vector (indirect vector :check-type nil)
+	   (setf (aref (indirect displaced-to) (+ index (indirect displaced-offset)))
+	     value)))
+	(vector
 	 (macrolet
 	     ((do-it ()
 		`(with-inline-assembly (:returns :eax)
@@ -512,27 +557,36 @@
 ;;; string accessors
 
 (defun char (string index)
-  (check-type string string)
   (assert (below index (array-dimension string 0)))
-  (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
-	  :index index :type :character))
+  (etypecase string
+    (simple-string
+     (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	     :index index :type :character))
+    (string
+     (with-indirect-vector (indirect string)
+       (char (indirect displaced-to) (+ index (indirect displaced-offset)))))))
 
 (defun (setf char) (value string index)
-  (check-type string string)
-  (check-type value character)
   (assert (below index (array-dimension string 0)))
-  (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
-		:index index :type :character) value))
+  (etypecase string
+    (simple-string
+     (check-type value character)
+     (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
+		   :index index :type :character) value))
+    (string
+     (with-indirect-vector (indirect string)
+       (setf (char (indirect displaced-to) (+ index (indirect displaced-offset)))
+	 value)))))
 
 (defun schar (string index)
-  (check-type string string)
+  (check-type string simple-string)
   (assert (below index (length string)))
   (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 	  :index index
 	  :type :character))
 
 (defun (setf schar) (value string index)
-  (check-type string string)
+  (check-type string simple-string)
   (check-type value character)
   (assert (below index (length string)))
   (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
@@ -593,23 +647,31 @@
 (defun subvector-accessors (vector start end)
   "Check that vector is a vector, that start and end are within vector's bounds,
 and return accessors for that subsequence (fast & unsafe accessors, that is)."
-  (check-type vector vector)
   (when (and start end)
     (assert (<= 0 start end))
     (assert (<= end (array-dimension vector 0))))
-  (case (vector-element-type vector)
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
-       (values #'svref%unsafe #'(setf svref%unsafe)))
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
-       (values #'char%unsafe #'(setf char%unsafe)))
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
-       (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
-       (values #'u32ref%unsafe #'(setf u32ref%unsafe)))
-    (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
-       (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
-    (t (warn "don't know about vector's element-type: ~S" vector)
-       (values #'aref #'(setf aref)))))
+  (etypecase vector
+    (indirect-vector
+     (with-indirect-vector (indirect vector)
+       (if (= 0 (indirect displaced-offset))
+	   (values #'aref #'(setf aref))
+	 (let ((offset (indirect displaced-offset)))
+	   (values (lambda (a i) (aref a (+ i offset)))
+		   (lambda (v a i) (setf (aref a (+ i offset)) v)))))))
+    (vector
+     (case (vector-element-type-code vector)
+       (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
+	  (values #'svref%unsafe #'(setf svref%unsafe)))
+       (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
+	  (values #'char%unsafe #'(setf char%unsafe)))
+       (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
+	  (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
+       (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
+	  (values #'u32ref%unsafe #'(setf u32ref%unsafe)))
+       (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
+	  (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
+       (t (warn "don't know about vector's element-type: ~S" vector)
+	  (values #'aref #'(setf aref)))))))
 
 (defmacro with-subvector-accessor ((name vector-form &optional start end) &body body)
   "Installs name as an accessor into vector-form, bound by start and end."
@@ -803,29 +865,125 @@
       (replace array initial-contents)))
     array))
 
+(defun make-indirect-vector (displaced-to displaced-offset fill-pointer length)
+  (let ((x (make-basic-vector%t 4 0 nil nil)))
+    (setf (vector-element-type-code x)
+      #.(bt:enum-value 'movitz::movitz-vector-element-type :indirects))
+    (set-indirect-vector x displaced-to displaced-offset 
+			 (vector-element-type-code displaced-to)
+			 fill-pointer length)))
+
+(defun set-indirect-vector (x displaced-to displaced-offset et-code fill-pointer length)
+  (check-type displaced-to vector)
+  (let ((displaced-offset (or displaced-offset 0)))
+    (assert (<= (+ displaced-offset length) (length displaced-to)) ()
+      "Displaced-to is outside legal range.")
+    (setf (memref x (movitz-type-slot-offset 'movitz-basic-vector 'fill-pointer)
+		  :index 1 :type :unsigned-byte8)
+      et-code)
+    (with-indirect-vector (indirect x)
+      (setf (indirect displaced-to) displaced-to
+	    (indirect displaced-offset) displaced-offset
+	    (indirect fill-pointer) (etypecase fill-pointer
+				 ((eql nil) length)
+				 ((eql t) length)
+				 ((integer 0 *) fill-pointer))
+	    (indirect length) length))
+    x))
+
+(defun make-basic-vector (size element-type fill-pointer initial-element initial-contents)
+  (let ((upgraded-element-type (upgraded-array-element-type element-type)))
+    (cond
+     ;; These should be replaced by subtypep sometime.
+     ((eq upgraded-element-type 'character)
+      (make-basic-vector%character size fill-pointer initial-element initial-contents))
+     ((eq upgraded-element-type 'bit)
+      (make-basic-vector%bit size fill-pointer initial-element initial-contents))
+     ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal)
+      (make-basic-vector%u8 size fill-pointer initial-element initial-contents))
+     ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal)
+      (make-basic-vector%u32 size fill-pointer initial-element initial-contents))
+     ((eq upgraded-element-type 'code)
+      (make-basic-vector%code size fill-pointer initial-element initial-contents))
+     (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))
+
 (defun make-array (dimensions &key element-type initial-element initial-contents adjustable
 				   fill-pointer displaced-to displaced-index-offset)
-  (declare (ignore adjustable displaced-to displaced-index-offset))
   (let ((size (cond ((integerp dimensions)
                      dimensions)
                     ((and (consp dimensions) (null (cdr dimensions)))
                      (car dimensions))
                     (t
                      (error "Multi-dimensional arrays not supported.")))))
-    (let ((upgraded-element-type (upgraded-array-element-type element-type)))
-      (cond
-       ;; These should be replaced by subtypep sometime.
-       ((eq upgraded-element-type 'character)
-	(make-basic-vector%character size fill-pointer initial-element initial-contents))
-       ((eq upgraded-element-type 'bit)
-	(make-basic-vector%bit size fill-pointer initial-element initial-contents))
-       ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal)
-	(make-basic-vector%u8 size fill-pointer initial-element initial-contents))
-       ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal)
-	(make-basic-vector%u32 size fill-pointer initial-element initial-contents))
-       ((eq upgraded-element-type 'code)
-	(make-basic-vector%code size fill-pointer initial-element initial-contents))
-       (t (make-basic-vector%t size fill-pointer initial-element initial-contents))))))
+    (cond
+     (displaced-to
+      (make-indirect-vector displaced-to displaced-index-offset fill-pointer size))
+     ((or adjustable
+	  (and fill-pointer (not (typep size '(unsigned-byte 14)))))
+      (make-indirect-vector (make-basic-vector size element-type nil
+					       initial-element initial-contents)
+			    0 fill-pointer size))
+     (t (make-basic-vector size element-type fill-pointer initial-element initial-contents)))))
+
+(defun adjust-array (array new-dimensions
+		     &key element-type (initial-element nil initial-element-p)
+			  initial-contents fill-pointer
+			  displaced-to displaced-index-offset)
+  (etypecase array
+    (indirect-vector
+     (let ((new-length (cond ((integerp new-dimensions)
+			      new-dimensions)
+			     ((and (consp new-dimensions) (null (cdr new-dimensions)))
+			      (car new-dimensions))
+			     (t (error "Multi-dimensional arrays not supported.")))))
+       (with-indirect-vector (indirect array)
+	 (cond
+	  (displaced-to
+	   (check-type displaced-to vector)
+	   (set-indirect-vector array displaced-to displaced-index-offset
+				(vector-element-type-code array)
+				(case fill-pointer
+				  ((nil) (indirect fill-pointer))
+				  ((t) new-length)
+				  (t fill-pointer))
+				new-length))
+	  ((and (= 0 (indirect displaced-offset))
+		(/= new-length (array-dimension array 0)))
+	   (let* ((old (indirect displaced-to))
+		  (new (make-array new-length :element-type (array-element-type old))))
+	     (dotimes (i (array-dimension old 0))
+	       (setf (aref new i) (aref old i)))
+	     (when initial-element-p
+	       (fill new initial-element :start (array-dimension old 0)))
+	     (setf (indirect displaced-to) new
+		   (indirect length) new-length)
+	     (when fill-pointer
+	       (setf (fill-pointer array) fill-pointer))))
+	  (t (error "Sorry, don't know how to adjust ~S." array)))))
+     array)
+    (vector
+     (let ((new-length (cond ((integerp new-dimensions)
+			      new-dimensions)
+			     ((and (consp new-dimensions) (null (cdr new-dimensions)))
+			      (car new-dimensions))
+			     (t (error "Multi-dimensional arrays not supported.")))))
+       (let ((new (if (= (array-dimension array 0) new-length)
+		      array
+		    (let* ((old array)
+			   (new (make-array new-length :element-type (array-element-type old))))
+		      (dotimes (i (array-dimension old 0))
+			(setf (aref new i) (aref old i)))
+		      (when initial-element-p
+			(fill new initial-element :start (array-dimension old 0)))
+		      new))))
+	 (case fill-pointer
+	   ((nil))
+	   ((t) (setf (fill-pointer new) new-length))
+	   (t (setf (fill-pointer new) fill-pointer)))
+	 new)))))
+
+(defun adjustable-array-p (array)
+  (typep array 'indirect-vector))
 
 (defun vector (&rest objects)
   "=> vector"
@@ -863,15 +1021,19 @@
   (< (fill-pointer vector) (array-dimension vector 0)))
 
 (defun vector-push-extend (new-element vector &optional extension)
-  (declare (ignore extension))
   (check-type vector vector)
   (let ((p (fill-pointer vector)))
-    (declare (type (unsigned-byte 16) p))
     (cond
      ((< p (array-dimension vector 0))
       (setf (aref vector p) new-element
 	    (fill-pointer vector) (1+ p)))
-     (t (error "Vector-push extending not implemented yet.")))
+     ((not (adjustable-array-p vector))
+      (error "Can't extend non-adjustable array."))
+     (t (adjust-array vector (+ (array-dimension vector 0)
+				(or extension
+				    (max 1 (array-dimension vector 0))))
+		      :fill-pointer (1+ p))
+	(setf (aref vector p) new-element)))
     p))
 
 



From ffjeld at common-lisp.net  Thu Jun  9 22:19:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 00:19:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <20050609221906.B2CF988032@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Starting to support adjustable and displaced vectors.

Date: Fri Jun 10 00:19:05 2005
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.20 movitz/losp/muerte/sequences.lisp:1.21
--- movitz/losp/muerte/sequences.lisp:1.20	Sun May 22 00:33:40 2005
+++ movitz/losp/muerte/sequences.lisp	Fri Jun 10 00:19:05 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.20 2005/05/21 22:33:40 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.21 2005/06/09 22:19:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -58,24 +58,27 @@
 
 (defun length (sequence)
   (etypecase sequence
-    (simple-array
+    (list
+     (do ((x sequence (cdr x))
+	  (length 0 (1+ length)))
+	 ((null x) length)
+       (declare (index length))))
+    (indirect-vector
+     (memref sequence (movitz-type-slot-offset 'movitz-basic-vector 'data)
+	     :index 2))
+    ((simple-array * 1)
      (macrolet
 	 ((do-it ()
 	    `(with-inline-assembly (:returns :eax)
 	       (:compile-form (:result-mode :ebx) sequence)
-	       (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+	       (:movl (:ebx (:offset movitz-basic-vector num-elements))
 		      :eax)
 	       (:testl ,(logxor #xffffffff (1- (expt 2 14))) :eax)
 	       (:jnz 'basic-vector-length-ok)
-	       (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::fill-pointer))
+	       (:movzxw (:ebx (:offset movitz-basic-vector fill-pointer))
 			:eax)
 	      basic-vector-length-ok)))
-       (do-it)))
-    (list
-     (do ((x sequence (cdr x))
-	  (length 0 (1+ length)))
-	 ((null x) length)
-       (declare (index length))))))
+       (do-it)))))
 
 (defun length%list (sequence)
   (do ((length 0 (1+ length))



From ffjeld at common-lisp.net  Thu Jun  9 22:19:11 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 00:19:11 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050609221911.847FE880AD@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Starting to support adjustable and displaced vectors.

Date: Fri Jun 10 00:19:10 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.44 movitz/losp/muerte/typep.lisp:1.45
--- movitz/losp/muerte/typep.lisp:1.44	Tue May 24 08:33:46 2005
+++ movitz/losp/muerte/typep.lisp	Fri Jun 10 00:19:10 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.44 2005/05/24 06:33:46 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.45 2005/06/09 22:19:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -127,6 +127,50 @@
 		  (:jnz 'vector-typep-failed)
 		  (:cmpw ,type-code (:eax ,movitz:+other-type-offset+))
 		 vector-typep-failed))))
+	 (make-vector-typep (element-type)
+	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type)
+			   (bt:slot-offset 'movitz::movitz-basic-vector 'movitz::type))))
+	   (let ((basic-type-code
+		  (dpb (bt:enum-value 'movitz::movitz-vector-element-type element-type)
+		       (byte 8 8)
+		       (movitz:tag :basic-vector)))
+		 (indirect-type-code
+		  (logior (ash (movitz:tag :basic-vector) 0)
+			  (ash (bt:enum-value 'movitz::movitz-vector-element-type :indirects) 8)
+			  (ash (bt:enum-value 'movitz::movitz-vector-element-type element-type) 24))))
+	     `(with-inline-assembly-case ()
+		(do-case (:boolean-branch-on-false :same :labels (vector-typep-no-branch))
+		  (:compile-form (:result-mode :eax) ,object)
+		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
+		  (:testb 7 :cl)
+		  (:branch-when :boolean-zf=0)
+		  (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+		  (:cmpw ,basic-type-code :cx)
+		  (:je 'vector-typep-no-branch)
+		  (:cmpl ,indirect-type-code :ecx)
+		  (:branch-when :boolean-zf=0)
+		 vector-typep-no-branch)
+		(do-case (:boolean-branch-on-true :same :labels (vector-typep-failed))
+		  (:compile-form (:result-mode :eax) ,object)
+		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
+		  (:testb 7 :cl)
+		  (:jnz 'vector-typep-failed)
+		  (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+		  (:cmpw ,basic-type-code :cx)
+		  (:branch-when :boolean-zf=1)
+		  (:cmpl ,indirect-type-code :ecx)
+		  (:branch-when :boolean-zf=1)
+		 vector-typep-failed)
+		(do-case (t :boolean-zf=1 :labels (vector-typep-done))
+		  (:compile-form (:result-mode :eax) ,object)
+		  (:leal (:eax ,(- (movitz::tag :other))) :ecx)
+		  (:testb 7 :cl)
+		  (:jnz 'vector-typep-done)
+		  (:movl (:eax ,movitz:+other-type-offset+) :ecx)
+		  (:cmpw ,basic-type-code :cx)
+		  (:je 'vector-typep-done)
+		  (:cmpl ,indirect-type-code :ecx)
+		 vector-typep-done))))
 	 (make-function-typep (funobj-type)
 	   (assert (= 1 (- (bt:slot-offset 'movitz::movitz-funobj 'movitz::funobj-type)
 			   (bt:slot-offset 'movitz::movitz-funobj 'movitz::type))))
@@ -242,23 +286,20 @@
 		    (:cmpb ,(movitz:tag :character) :al)))
 		((function compiled-function)
 		 (make-other-typep :funobj))
-		((basic-vector)
-		 (break "Basic-vector typep?")
-		 (make-other-typep :basic-vector))
-		((vector simple-array array)
+		((vector)
 		 (make-other-typep :basic-vector))
+		(indirect-vector
+		 (make-basic-vector-typep :indirects))
 		(simple-vector
 		 (make-basic-vector-typep :any-t))
-		((string simple-string)
+		(simple-string
 		 (make-basic-vector-typep :character))
-		((bit-vector simple-bit-vector)
+		(string
+		 (make-vector-typep :character))
+		(simple-bit-vector
 		 (make-basic-vector-typep :bit))
-		(vector-u8
-		 (make-basic-vector-typep :u8))
-		(vector-u16
-		 (make-basic-vector-typep :u16))
-		(vector-u32
-		 (make-basic-vector-typep :u32))
+		(bit-vector
+		 (make-vector-typep :bit))
 		(code-vector
 		 (make-basic-vector-typep :code))
 		(unbound-value



From ffjeld at common-lisp.net  Thu Jun  9 22:20:24 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 00:20:24 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp 
Message-ID: <20050609222024.06FE288152@common-lisp.net>

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

Modified Files:
	cpu-id.lisp 
Log Message:
*** empty log message ***
Date: Fri Jun 10 00:20:23 2005
Author: ffjeld

Index: movitz/losp/muerte/cpu-id.lisp
diff -u movitz/losp/muerte/cpu-id.lisp:1.11 movitz/losp/muerte/cpu-id.lisp:1.12
--- movitz/losp/muerte/cpu-id.lisp:1.11	Thu May  5 17:17:15 2005
+++ movitz/losp/muerte/cpu-id.lisp	Fri Jun 10 00:20:22 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Apr 15 22:47:13 2002
 ;;;;                
-;;;; $Id: cpu-id.lisp,v 1.11 2005/05/05 15:17:15 ffjeld Exp $
+;;;; $Id: cpu-id.lisp,v 1.12 2005/06/09 22:20:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -247,8 +247,7 @@
   (setf (eflags) value))
 
 (defun load-idt (idt-vector)
-  (assert (= #.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
-	     (vector-element-type idt-vector)))
+  (check-type idt-vector (simple-array (unsigned-byte 32) 1))
   (let ((limit (- (* (length idt-vector) 4)
 		  1)))
     ;; (format t "Load-idt: ~Z / ~D~%" idt-vector limit)



From ffjeld at common-lisp.net  Thu Jun  9 22:21:08 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 00:21:08 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050609222108.D576388152@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
*** empty log message ***
Date: Fri Jun 10 00:21:08 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.45 movitz/losp/los0.lisp:1.46
--- movitz/losp/los0.lisp:1.45	Sun May  8 03:20:02 2005
+++ movitz/losp/los0.lisp	Fri Jun 10 00:21:08 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.45 2005/05/08 01:20:02 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.46 2005/06/09 22:21:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -26,6 +26,7 @@
 (require :lib/toplevel)
 ;; (require :lib/net/ip6)
 (require :lib/net/ip4)
+(require :lib/net/dhcp)
 (require :lib/repl)
 
 ;; (require :ll-testing)
@@ -876,16 +877,6 @@
 	    with end-time = (+ start-time (* seconds internal-time-units-per-second))
 	    while (< (get-internal-run-time) end-time)))))
   (values))
-
-
-;;;(defun get-internal-run-time ()
-;;;  (multiple-value-bind (lo mid hi)
-;;;      (read-time-stamp-counter)
-;;;    (declare (ignore lo))
-;;;    (dpb hi (byte 5 24) mid)))
-;;;
-;;;(defun get-internal-real-time ()
-;;;  (get-internal-run-time))
 
 
 (defun y-or-n-p (&optional control &rest arguments)



From ffjeld at common-lisp.net  Fri Jun 10 18:35:03 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 20:35:03 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp 
Message-ID: <20050610183503.5297C880E6@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
Added a silly read-from-string.

Date: Fri Jun 10 20:35:02 2005
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.11 movitz/losp/muerte/read.lisp:1.12
--- movitz/losp/muerte/read.lisp:1.11	Mon Oct 11 15:53:11 2004
+++ movitz/losp/muerte/read.lisp	Fri Jun 10 20:35:01 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -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.11 2004/10/11 13:53:11 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.12 2005/06/10 18:35:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -342,6 +342,10 @@
 				  (substring string i token-end))))))))))
       (t (return-from simple-read-from-string
 	   (simple-read-token string :start i :end end))))))
+
+(defun read-from-string (&rest args)
+  (declare (dynamic-extent args))
+  (apply #'simple-read-from-string args))
 
 (defun un-backquote (form level)
   "Dont ask.."



From ffjeld at common-lisp.net  Fri Jun 10 18:35:29 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 20:35:29 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <20050610183529.3BFDB8815F@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
Have (format nil ..) output to an adjustable string.

Date: Fri Jun 10 20:35:28 2005
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.10 movitz/losp/muerte/format.lisp:1.11
--- movitz/losp/muerte/format.lisp:1.10	Tue Jan 25 14:46:10 2005
+++ movitz/losp/muerte/format.lisp	Fri Jun 10 20:35:28 2005
@@ -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.10 2005/01/25 13:46:10 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.11 2005/06/10 18:35:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -30,9 +30,11 @@
   (declare (dynamic-extent args))
   (let ((destination
 	 (case destination
-	   ((nil) (make-array (* 3 (length control))
+	   ((nil) (make-array (+ (length control)
+				 (* 8 (count #\~ control)))
 			      :element-type 'character
-			      :fill-pointer 0))
+			      :fill-pointer 0
+			      :adjustable t))
 	   ((t) *standard-output*)
 	   (otherwise destination))))
     (etypecase control
@@ -180,8 +182,8 @@
 	      (#\/ (let* ((name-end (or (position #\/ control-string :start (incf i))
 					(error "Call function name not terminated in ~S."
 					       control-string)))
-			  (function-name (simple-read-from-string control-string nil nil
-								  :start i :end name-end)))
+			  (function-name (read-from-string control-string nil nil
+							   :start i :end name-end)))
 		     (check-type function-name symbol)
 		     (setf i name-end)
 		     (apply function-name *standard-output* (pop args)



From ffjeld at common-lisp.net  Fri Jun 10 18:35:45 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 20:35:45 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/simple-streams.lisp 
Message-ID: <20050610183545.A974588458@common-lisp.net>

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

Modified Files:
	simple-streams.lisp 
Log Message:
*** empty log message ***
Date: Fri Jun 10 20:35:44 2005
Author: ffjeld

Index: movitz/losp/muerte/simple-streams.lisp
diff -u movitz/losp/muerte/simple-streams.lisp:1.7 movitz/losp/muerte/simple-streams.lisp:1.8
--- movitz/losp/muerte/simple-streams.lisp:1.7	Wed Nov 24 17:19:02 2004
+++ movitz/losp/muerte/simple-streams.lisp	Fri Jun 10 20:35:44 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 2003-2004, 
+;;;;    Copyright (C) 2001, 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 29 13:39:43 2003
 ;;;;                
-;;;; $Id: simple-streams.lisp,v 1.7 2004/11/24 16:19:02 ffjeld Exp $
+;;;; $Id: simple-streams.lisp,v 1.8 2005/06/10 18:35:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -427,9 +427,7 @@
        (%check stream :output)
        (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
     (string
-     (assert (vector-push-extend character stream)
-	 () "Vector-push-extend for string stream failed pushing ~S into ~S."
-	 character stream))))
+     (vector-push-extend character stream))))
 
 (defun %read-line (stream eof-error-p eof-value recursive-p)
   (declare (ignore recursive-p))



From ffjeld at common-lisp.net  Fri Jun 10 21:15:19 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 10 Jun 2005 23:15:19 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050610211519.94C0888458@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Made (setf (segment-register :cs) ..) work.

Date: Fri Jun 10 23:15:18 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.14 movitz/losp/muerte/segments.lisp:1.15
--- movitz/losp/muerte/segments.lisp:1.14	Sun May  8 03:19:41 2005
+++ movitz/losp/muerte/segments.lisp	Fri Jun 10 23:15:18 2005
@@ -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.14 2005/05/08 01:19:41 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.15 2005/06/10 21:15:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -45,11 +45,20 @@
 		  (:movw :cx ,reg))))
     (ecase segment-register-name
       (:ss (set-sreg :ss))
-      (:cs (set-sreg :cs))
       (:ds (set-sreg :ds))
       (:es (set-sreg :es))
       (:fs (set-sreg :fs))
-      (:gs (set-sreg :gs))))
+      (:gs (set-sreg :gs))
+      (:cs (without-interrupts
+	     (with-inline-assembly (:returns :nothing)
+	       (:load-lexical (:lexical-binding value) :untagged-fixnum-ecx)
+	       (:declare-label-set jmp-table (jmp-target))
+	       (:pushl :ecx)		; push selector
+	       (:pushl (:esi (:offset movitz-funobj constant0) 'jmp-table))
+	       (:jmp-segment (:esp))
+	      jmp-target
+	       (:popl :ecx)
+	       (:popl :ecx))))))
   value)
 
 (defun %sgdt ()



From ffjeld at common-lisp.net  Fri Jun 10 22:43:54 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 00:43:54 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp 
Message-ID: <20050610224354.9615A88169@common-lisp.net>

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

Modified Files:
	segments.lisp 
Log Message:
Fixed a nasty bug in (setf global-segment-descriptor-table) that would
install the wrong (about half-size) limit, causing weird crashes.

Date: Sat Jun 11 00:43:53 2005
Author: ffjeld

Index: movitz/losp/muerte/segments.lisp
diff -u movitz/losp/muerte/segments.lisp:1.15 movitz/losp/muerte/segments.lisp:1.16
--- movitz/losp/muerte/segments.lisp:1.15	Fri Jun 10 23:15:18 2005
+++ movitz/losp/muerte/segments.lisp	Sat Jun 11 00:43:52 2005
@@ -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.15 2005/06/10 21:15:18 ffjeld Exp $
+;;;; $Id: segments.lisp,v 1.16 2005/06/10 22:43:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -176,9 +176,9 @@
 
 (defun (setf global-segment-descriptor-table) (table)
   "Install <table> as the GDT.
-NB! you need ensure that the table object isn't garbage-collected."
+NB! you need to ensure that the table object isn't garbage-collected."
   (check-type table (vector (unsigned-byte 32)))
-  (let ((limit (1- (* 2 (length table))))
+  (let ((limit (1- (* 4 (length table))))
 	(base (+ 2 (+ (object-location table)
 		      (location-physical-offset)))))
     (%lgdt base limit)



From ffjeld at common-lisp.net  Fri Jun 10 23:04:46 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:04:46 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050610230446.3663988169@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
Fix format-segment-table: use selector rather than indexes.

Date: Sat Jun 11 01:04:45 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.9 movitz/losp/ll-testing.lisp:1.10
--- movitz/losp/ll-testing.lisp:1.9	Sun May  8 03:18:02 2005
+++ movitz/losp/ll-testing.lisp	Sat Jun 11 01:04:45 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.9 2005/05/08 01:18:02 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.10 2005/06/10 23:04:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -40,12 +40,13 @@
 
 (defun format-segment-table (table &key (start 0) (end (truncate (length table) 2)))
   (loop for i from start below end
-      do (format t "~&~2D: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%"
-		 i
-		 (* 4 (segment-descriptor-base-location table i))
-		 (segment-descriptor-limit table i)
-		 (segment-descriptor-type-s-dpl-p table i)
-		 (segment-descriptor-avl-x-db-g table i)))
+      as selector = (* i 8)
+      do (format t "~&~3X: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%"
+		 selector
+		 (* 4 (segment-descriptor-base-location table selector))
+		 (segment-descriptor-limit table selector)
+		 (segment-descriptor-type-s-dpl-p table selector)
+		 (segment-descriptor-avl-x-db-g table selector)))
   (values))
 
 



From ffjeld at common-lisp.net  Fri Jun 10 23:05:41 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:05:41 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <20050610230541.EEF6F88169@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Define a *gc-hooks* variable, a list of functions to be called after GC.

Date: Sat Jun 11 01:05:40 2005
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.50 movitz/packages.lisp:1.51
--- movitz/packages.lisp:1.50	Sun May 22 00:38:29 2005
+++ movitz/packages.lisp	Sat Jun 11 01:05:38 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Nov 15 21:39:55 2003
 ;;;;                
-;;;; $Id: packages.lisp,v 1.50 2005/05/21 22:38:29 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.51 2005/06/10 23:05:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1253,6 +1253,7 @@
 	   #:cpu-featurep
 	   #:find-cpu-features
 	   #:*cpu-features*
+	   #:*gc-hooks*
 	   #:write-cpu-vendor-string
 	   #:read-time-stamp-counter
 	   #:clear-time-stamp-counter



From ffjeld at common-lisp.net  Fri Jun 10 23:05:45 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:05:45 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <20050610230545.6D72B88169@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Define a *gc-hooks* variable, a list of functions to be called after GC.

Date: Sat Jun 11 01:05:45 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.54 movitz/losp/los0-gc.lisp:1.55
--- movitz/losp/los0-gc.lisp:1.54	Thu May  5 22:51:09 2005
+++ movitz/losp/los0-gc.lisp	Sat Jun 11 01:05:44 2005
@@ -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.54 2005/05/05 20:51:09 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.55 2005/06/10 23:05:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -493,7 +493,8 @@
 	  (format t "Old space: ~/muerte:pprint-clumps/, new space: ~
 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
 		  old-size new-size (- old-size new-size))))
-
+      (dolist (hook *gc-hooks*)
+	(funcall hook))
       (initialize-space oldspace)
       (fill oldspace #x13 :start 2)
       ;; (setf *gc-stack2* *gc-stack*)



From ffjeld at common-lisp.net  Fri Jun 10 23:05:52 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:05:52 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp 
Message-ID: <20050610230552.0FC52884CA@common-lisp.net>

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

Modified Files:
	variables.lisp 
Log Message:
Define a *gc-hooks* variable, a list of functions to be called after GC.

Date: Sat Jun 11 01:05:50 2005
Author: ffjeld

Index: movitz/losp/muerte/variables.lisp
diff -u movitz/losp/muerte/variables.lisp:1.8 movitz/losp/muerte/variables.lisp:1.9
--- movitz/losp/muerte/variables.lisp:1.8	Wed Sep 15 12:22:59 2004
+++ movitz/losp/muerte/variables.lisp	Sat Jun 11 01:05:50 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2003-2004, 
+;;;;    Copyright (C) 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov  5 21:53:34 2003
 ;;;;                
-;;;; $Id: variables.lisp,v 1.8 2004/09/15 10:22:59 ffjeld Exp $
+;;;; $Id: variables.lisp,v 1.9 2005/06/10 23:05:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -42,5 +42,7 @@
 (defvar *multiboot-data* nil)
 
 (defvar internal-time-units-per-second)
+
+(defvar *gc-hooks* nil)
 
 (declaim (special *build-number*))



From ffjeld at common-lisp.net  Fri Jun 10 23:06:41 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:06:41 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <20050610230641.4904E884CA@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Add scavenger support for indirect-vectors.

Date: Sat Jun 11 01:06:40 2005
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.50 movitz/losp/muerte/scavenge.lisp:1.51
--- movitz/losp/muerte/scavenge.lisp:1.50	Thu May  5 22:51:55 2005
+++ movitz/losp/muerte/scavenge.lisp	Sat Jun 11 01:06:39 2005
@@ -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.50 2005/05/05 20:51:55 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.51 2005/06/10 23:06:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -180,8 +180,12 @@
 	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan (1+ (logand (1+ len) -2)))))
 	   ((scavenge-typep x :basic-vector)
-	    (if (scavenge-wide-typep x :basic-vector
-				     #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t))
+	    (if (or (scavenge-wide-typep x :basic-vector
+					 #.(bt:enum-value 'movitz:movitz-vector-element-type
+							  :any-t))
+		    (scavenge-wide-typep x :basic-vector
+					 #.(bt:enum-value 'movitz:movitz-vector-element-type
+							  :indirects)))
 		(setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
 	      (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan)))
 	   ((and (eq x 3) (eq x2 0))



From ffjeld at common-lisp.net  Fri Jun 10 23:07:08 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:07:08 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <20050610230708.93E8C884CB@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
vector-u16 and vector-u32 are obsolete.

Date: Sat Jun 11 01:07:07 2005
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.53 movitz/losp/muerte/inspect.lisp:1.54
--- movitz/losp/muerte/inspect.lisp:1.53	Thu May  5 22:52:02 2005
+++ movitz/losp/muerte/inspect.lisp	Sat Jun 11 01:07:07 2005
@@ -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.53 2005/05/05 20:52:02 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.54 2005/06/10 23:07:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -388,13 +388,13 @@
 	   (+ -1 object-location
 	      (movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 7) 8)))))
-      (vector-u16
+      ((simple-array (unsigned-byte 16) 1)
        (<= object-location
 	   location
 	   (+ -1 object-location
 	      (movitz-type-word-size 'movitz-basic-vector)
 	      (* 2 (truncate (+ (array-dimension object 0) 3) 4)))))
-      ((or vector-u32 simple-vector)
+      ((or simple-vector (simple-array (unsigned-byte 32) 1))
        (<= object-location
 	   location
 	   (+ -1 object-location



From ffjeld at common-lisp.net  Fri Jun 10 23:08:18 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:08:18 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <20050610230818.1868788031@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Make the with-subvector-accessors operator know about indirect-vectors.

Date: Sat Jun 11 01:08:17 2005
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.51 movitz/losp/muerte/arrays.lisp:1.52
--- movitz/losp/muerte/arrays.lisp:1.51	Fri Jun 10 00:19:02 2005
+++ movitz/losp/muerte/arrays.lisp	Sat Jun 11 01:08:16 2005
@@ -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.51 2005/06/09 22:19:02 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.52 2005/06/10 23:08:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -644,9 +644,9 @@
 
 ;;; fast vector access
 
-(defun subvector-accessors (vector start end)
+(defun subvector-accessors (vector &optional start end)
   "Check that vector is a vector, that start and end are within vector's bounds,
-and return accessors for that subsequence (fast & unsafe accessors, that is)."
+and return basic-vector and accessors for that subsequence."
   (when (and start end)
     (assert (<= 0 start end))
     (assert (<= end (array-dimension vector 0))))
@@ -654,37 +654,37 @@
     (indirect-vector
      (with-indirect-vector (indirect vector)
        (if (= 0 (indirect displaced-offset))
-	   (values #'aref #'(setf aref))
+	   (subvector-accessors (indirect displaced-to) start end)
 	 (let ((offset (indirect displaced-offset)))
-	   (values (lambda (a i) (aref a (+ i offset)))
+	   (values vector
+		   (lambda (a i) (aref a (+ i offset)))
 		   (lambda (v a i) (setf (aref a (+ i offset)) v)))))))
     (vector
      (case (vector-element-type-code vector)
        (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
-	  (values #'svref%unsafe #'(setf svref%unsafe)))
+	  (values vector #'svref%unsafe #'(setf svref%unsafe)))
        (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
-	  (values #'char%unsafe #'(setf char%unsafe)))
+	  (values vector #'char%unsafe #'(setf char%unsafe)))
        (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
-	  (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
+	  (values vector #'u8ref%unsafe #'(setf u8ref%unsafe)))
        (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
-	  (values #'u32ref%unsafe #'(setf u32ref%unsafe)))
+	  (values vector #'u32ref%unsafe #'(setf u32ref%unsafe)))
        (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
-	  (values #'u8ref%unsafe #'(setf u8ref%unsafe)))
+	  (values vector #'u8ref%unsafe #'(setf u8ref%unsafe)))
        (t (warn "don't know about vector's element-type: ~S" vector)
-	  (values #'aref #'(setf aref)))))))
+	  (values vector #'aref #'(setf aref)))))))
 
 (defmacro with-subvector-accessor ((name vector-form &optional start end) &body body)
   "Installs name as an accessor into vector-form, bound by start and end."
   (let ((reader (gensym "sub-vector-reader-"))
 	(writer (gensym "sub-vector-writer-"))
 	(vector (gensym "sub-vector-")))
-    `(let ((,vector ,vector-form))
-       (multiple-value-bind (,reader ,writer)
-	   (subvector-accessors ,vector ,start ,end)
-	 (declare (ignorable ,reader ,writer))
-	 (macrolet ((,name (index)
-		      `(accessor%unsafe (,',reader ,',writer) ,',vector ,index)))
-	   , at body)))))
+    `(multiple-value-bind (,vector ,reader ,writer)
+	 (subvector-accessors ,vector-form ,start ,end)
+       (declare (ignorable ,reader ,writer))
+       (macrolet ((,name (index)
+		    `(accessor%unsafe (,',reader ,',writer) ,',vector ,index)))
+	 , at body))))
 
 (defmacro accessor%unsafe ((reader writer) &rest args)
   (declare (ignore writer))



From ffjeld at common-lisp.net  Fri Jun 10 23:09:14 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:09:14 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/threading.lisp 
Message-ID: <20050610230914.A164088031@common-lisp.net>

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

Modified Files:
	threading.lisp 
Log Message:
Have segment-descriptor-table-manager use *gc-hooks* to deal with
moving of descriptor-table.

Date: Sat Jun 11 01:09:14 2005
Author: ffjeld

Index: movitz/losp/lib/threading.lisp
diff -u movitz/losp/lib/threading.lisp:1.7 movitz/losp/lib/threading.lisp:1.8
--- movitz/losp/lib/threading.lisp:1.7	Mon May  9 00:05:13 2005
+++ movitz/losp/lib/threading.lisp	Sat Jun 11 01:09:14 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 28 08:30:01 2005
 ;;;;                
-;;;; $Id: threading.lisp,v 1.7 2005/05/08 22:05:13 ffjeld Exp $
+;;;; $Id: threading.lisp,v 1.8 2005/06/10 23:09:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -33,8 +33,11 @@
   ((table
     :reader segment-descriptor-table
     :initarg :table
-    :initform (setf (muerte::global-segment-descriptor-table)
-		(muerte::dump-global-segment-table :entries 64)))
+    :initform (let ((table (muerte::dump-global-segment-table :entries 64)))
+		(push (lambda ()
+			(setf (muerte::global-segment-descriptor-table) table))
+		      *gc-hooks*)
+		(setf (muerte::global-segment-descriptor-table) table)))
    (clients
     :initform (make-array 64))
    (range-start



From ffjeld at common-lisp.net  Fri Jun 10 23:17:18 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:17:18 +0200 (CEST)
Subject: [movitz-cvs] CVS update: public_html/ChangeLog 
Message-ID: <20050610231718.1648B88031@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Sat Jun 11 01:17:18 2005
Author: ffjeld

Index: public_html/ChangeLog
diff -u public_html/ChangeLog:1.5 public_html/ChangeLog:1.6
--- public_html/ChangeLog:1.5	Sun Apr 24 23:59:59 2005
+++ public_html/ChangeLog	Sat Jun 11 01:17:17 2005
@@ -1,3 +1,7 @@
+2005-06-11  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Started to add support for adjustable and displaced vectors.
+
 2005-04-24  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Fixed a bug in the compilation of (values ...) for more than two



From ffjeld at common-lisp.net  Fri Jun 10 23:19:12 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 01:19:12 +0200 (CEST)
Subject: [movitz-cvs] CVS update: public_html/index.html 
Message-ID: <20050610231912.0252C88031@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
*** empty log message ***
Date: Sat Jun 11 01:19:12 2005
Author: ffjeld

Index: public_html/index.html
diff -u public_html/index.html:1.24 public_html/index.html:1.25
--- public_html/index.html:1.24	Sat Jan 29 11:42:28 2005
+++ public_html/index.html	Sat Jun 11 01:19:12 2005
@@ -15,6 +15,9 @@
 
  <h3>Most recent news</h3>
 
+ <p> <i>June 11, 2005</i> Started to add support for threads (in the
+ "threading" package), and also for adjustable and displaced vectors.
+
  <p> <i>January 29, 2005</i> The stack discipline and associated GC
  scavenging routines have been cleaned up, now hopefully work as they
  should, even in the corner cases when two interrupts occur in rapid
@@ -28,17 +31,7 @@
  just fine (mostly to do with CLisp having CL symbols with e.g. CLOS
  as home package).
 
- <p> QEMU's NE2000 device seems to work ok with Movitz, both in ISA
- and PCI modes.
-
- <p> <i>August 18, 2004:</i> Movitz finally runs in <a
- href="http://fabrice.bellard.free.fr/qemu/">QEMU</a>, which is a very
- nice x86 emulator. It uses some sort of JIT technique, so it's much
- faster than Bochs. There was a bug in QEMU's (version 0.6.0)
- emulation of the x86 <tt>bounds</tt> instruction, which didn't agree
- with Movitz, and which is now fixed in QEMU's CVS.
-
- <p> For more news, see the <a
+ <p> For more and older news, see the <a
  href="ChangeLog"><tt>ChangeLog</tt></a>.
 
  <h3>Introduction</h3>



From ffjeld at common-lisp.net  Sat Jun 11 00:01:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 02:01:10 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <20050611000110.81B2E88031@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Remove a restart.

Date: Sat Jun 11 02:01:09 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.55 movitz/losp/los0-gc.lisp:1.56
--- movitz/losp/los0-gc.lisp:1.55	Sat Jun 11 01:05:44 2005
+++ movitz/losp/los0-gc.lisp	Sat Jun 11 02:01:09 2005
@@ -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.55 2005/06/10 23:05:44 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.56 2005/06/11 00:01:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -411,15 +411,14 @@
 	(dolist (range muerte::%memory-map-roots%)
 	  (map-header-vals evacuator (car range) (cdr range))))
       ;; Scan newspace, Cheney style.
-      (with-simple-restart (nil "Cheney-scanning newspace.")
-	(loop with newspace-location = (+ 2 (object-location newspace))
-	    with scan-pointer = 2
-	    as fresh-pointer = (space-fresh-pointer newspace)
-	    while (< scan-pointer fresh-pointer)
-	    do (map-header-vals evacuator
-				(+ newspace-location scan-pointer)
-				(+ newspace-location (space-fresh-pointer newspace)))
-	       (setf scan-pointer fresh-pointer)))
+      (loop with newspace-location = (+ 2 (object-location newspace))
+	  with scan-pointer = 2
+	  as fresh-pointer = (space-fresh-pointer newspace)
+	  while (< scan-pointer fresh-pointer)
+	  do (map-header-vals evacuator
+			      (+ newspace-location scan-pointer)
+			      (+ newspace-location (space-fresh-pointer newspace)))
+	     (setf scan-pointer fresh-pointer))
       ;; Consistency check..
       (map-stack-vector (lambda (x foo)
 			  (declare (ignore foo))



From ffjeld at common-lisp.net  Sat Jun 11 00:01:57 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 02:01:57 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <20050611000157.6E0DB884CB@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Rename copy-vector to shallow-copy-vector, and have it understand
indirect-vectors. Should fix a GC issue.

Date: Sat Jun 11 02:01:56 2005
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.52 movitz/losp/muerte/arrays.lisp:1.53
--- movitz/losp/muerte/arrays.lisp:1.52	Sat Jun 11 01:08:16 2005
+++ movitz/losp/muerte/arrays.lisp	Sat Jun 11 02:01:56 2005
@@ -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.52 2005/06/10 23:08:16 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.53 2005/06/11 00:01:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -176,23 +176,25 @@
        "Vector has no fill-pointer.")
      (%basic-vector-fill-pointer vector))))
 
-(defun copy-vector (vector)
-  (check-type vector vector)
+(defun shallow-copy-vector (vector)
+  (check-type vector (simple-array * 1))
   (let ((length (the fixnum
 		  (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
-    (ecase (vector-element-type-code 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)))
+    (ecase (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
+		   :type :unsigned-byte8)
+      ((#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
+	#.(bt:enum-value 'movitz::movitz-vector-element-type :indirects))
+       (%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)))))))
+      ((#.(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



From ffjeld at common-lisp.net  Sat Jun 11 00:02:05 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 11 Jun 2005 02:02:05 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <20050611000205.97067884CB@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Rename copy-vector to shallow-copy-vector, and have it understand
indirect-vectors. Should fix a GC issue.

Date: Sat Jun 11 02:02:04 2005
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.54 movitz/losp/muerte/inspect.lisp:1.55
--- movitz/losp/muerte/inspect.lisp:1.54	Sat Jun 11 01:07:07 2005
+++ movitz/losp/muerte/inspect.lisp	Sat Jun 11 02:02:04 2005
@@ -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.54 2005/06/10 23:07:07 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.55 2005/06/11 00:02:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -257,7 +257,7 @@
     (symbol
      (copy-symbol old t))
     (vector
-     (copy-vector old))
+     (shallow-copy-vector old))
     (function
      (copy-funobj old))
     (structure-object



From ffjeld at common-lisp.net  Sun Jun 12 20:01:50 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 12 Jun 2005 22:01:50 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/strings.lisp 
Message-ID: <20050612200150.93158884A9@common-lisp.net>

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

Modified Files:
	strings.lisp 
Log Message:
Use char rather than schar, in general.

Date: Sun Jun 12 22:01:49 2005
Author: ffjeld

Index: movitz/losp/muerte/strings.lisp
diff -u movitz/losp/muerte/strings.lisp:1.2 movitz/losp/muerte/strings.lisp:1.3
--- movitz/losp/muerte/strings.lisp:1.2	Mon Jan 19 12:23:47 2004
+++ movitz/losp/muerte/strings.lisp	Sun Jun 12 22:01:49 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 17:05:25 2001
 ;;;;                
-;;;; $Id: strings.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $
+;;;; $Id: strings.lisp,v 1.3 2005/06/12 20:01:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -30,7 +30,7 @@
        (do ((i start1 (1+ i))
 	    (j start2 (1+ j)))
 	   ((>= i end1) t)
-	 (unless (char= (schar string1 i) (schar string2 j))
+	 (unless (char= (char string1 i) (char string2 j))
 	   (return nil)))))
 
 (defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
@@ -45,7 +45,7 @@
        (do ((i start1 (1+ i))
 	    (j start2 (1+ j)))
 	   ((>= i end1) t)
-	 (unless (char-equal (schar string1 i) (schar string2 j))
+	 (unless (char-equal (char string1 i) (char string2 j))
 	   (return nil)))))
 
 (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
@@ -69,16 +69,16 @@
   (let* ((length (- end start))
 	 (cased-string (make-string length)))
     (dotimes (i length)
-      (setf (schar cased-string i)
-	(char-upcase (schar string (+ i start)))))
+      (setf (char cased-string i)
+	(char-upcase (char string (+ i start)))))
     cased-string))
 
 (defun string-downcase (string &key (start 0) (end (length string)))
   (let* ((length (- end start))
 	 (cased-string (make-string length)))
     (dotimes (i length)
-      (setf (schar cased-string i)
-	(char-downcase (schar string (+ i start)))))
+      (setf (char cased-string i)
+	(char-downcase (char string (+ i start)))))
     cased-string))
 
 (defun string-capitalize (string &key (start 0) end)
@@ -90,8 +90,8 @@
 	  (j 0 (1+ j))
 	  (between-words-p t))
 	((>= i end) capitalized-string)
-      (setf (schar capitalized-string j)
-	(let ((c (schar string i)))
+      (setf (char capitalized-string j)
+	(let ((c (char string i)))
 	  (cond
 	   ((and between-words-p (char-alpha-p c))
 	    (setf between-words-p nil)



From ffjeld at common-lisp.net  Sun Jun 12 20:32:44 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 12 Jun 2005 22:32:44 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <20050612203244.DF0CE884A9@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
Let's be more consistent.

Date: Sun Jun 12 22:32:44 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.56 movitz/losp/los0-gc.lisp:1.57
--- movitz/losp/los0-gc.lisp:1.56	Sat Jun 11 02:01:09 2005
+++ movitz/losp/los0-gc.lisp	Sun Jun 12 22:32:44 2005
@@ -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.56 2005/06/11 00:01:09 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.57 2005/06/12 20:32:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -22,7 +22,7 @@
 (defvar *gc-running* nil)
 (defvar *gc-break* nil)
 (defvar *gc-trigger* nil)
-(defvar *gc-consitency-check* t) 
+(defvar *gc-consistency-check* nil)
 
     
 (defmacro space-fresh-pointer (space)
@@ -397,7 +397,7 @@
 				     forwarded-x)))
 			 (let ((forward-x (shallow-copy x)))
 			   (when (and (typep x 'muerte::pointer)
-				      *gc-consitency-check*)
+				      *gc-consistency-check*)
 			     (let ((a *x*))
 			       (vector-push (%object-lispval x) a)
 			       (vector-push (memref (object-location x) 0 :type :unsigned-byte32) a)
@@ -425,7 +425,7 @@
 			  x)
 			nil
 			(current-stack-frame))
-      (when *gc-consitency-check*
+      (when *gc-consistency-check*
 	(with-simple-restart (continue "Ignore failed GC consistency check.")
 	  (without-interrupts
 	    (let ((a *x*))



From ffjeld at common-lisp.net  Sun Jun 12 21:27:04 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 12 Jun 2005 23:27:04 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp 
Message-ID: <20050612212704.2E135884C2@common-lisp.net>

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

Modified Files:
	cons.lisp 
Log Message:
Wrote copy-tree and changed tree-equal.

Date: Sun Jun 12 23:27:03 2005
Author: ffjeld

Index: movitz/losp/muerte/cons.lisp
diff -u movitz/losp/muerte/cons.lisp:1.10 movitz/losp/muerte/cons.lisp:1.11
--- movitz/losp/muerte/cons.lisp:1.10	Thu May  5 00:47:02 2005
+++ movitz/losp/muerte/cons.lisp	Sun Jun 12 23:27:03 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.10 2005/05/04 22:47:02 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.11 2005/06/12 21:27:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -255,3 +255,19 @@
     (:compile-form (:result-mode :eax) car)
     (:compile-form (:result-mode :ebx) cdr)
     (:call-local-pf fast-cons)))
+
+(defun copy-tree (tree)
+  (if (not (consp tree))
+      tree
+    (cons (copy-tree (car tree))
+	  (copy-tree (cdr tree)))))
+
+(defun tree-equal (tree-1 tree-2 &key test test-not)
+  (labels ((te (tree-1 tree-2 test)
+	     (if (not (consp tree-1))
+		 (funcall test tree-1 tree-2)
+	       (if (not (consp tree-2))
+		   nil
+		 (and (te (car tree-1) (car tree-2) test)
+		      (te (cdr tree-1) (cdr tree-2) test))))))
+    (te tree-1 tree-2 (or test (and test-not (complement test-not)) #'eql))))



From ffjeld at common-lisp.net  Sun Jun 12 21:27:09 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 12 Jun 2005 23:27:09 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp 
Message-ID: <20050612212709.9C89688665@common-lisp.net>

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

Modified Files:
	lists.lisp 
Log Message:
Wrote copy-tree and changed tree-equal.

Date: Sun Jun 12 23:27:08 2005
Author: ffjeld

Index: movitz/losp/muerte/lists.lisp
diff -u movitz/losp/muerte/lists.lisp:1.10 movitz/losp/muerte/lists.lisp:1.11
--- movitz/losp/muerte/lists.lisp:1.10	Fri Nov 19 21:13:44 2004
+++ movitz/losp/muerte/lists.lisp	Sun Jun 12 23:27:07 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 20012000, 2002-2004,
+;;;;    Copyright (C) 20012000, 2002-2005,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      lists.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.10 2004/11/19 20:13:44 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.11 2005/06/12 21:27:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -140,17 +140,6 @@
 
 (defun (setf nth) (value n list)
   (setf (car (nthcdr n list)) value))
-
-(defun tree-equal (tree-1 tree-2 &key (test 'equal))
-  (cond
-   ((atom tree-1)
-    (and (atom tree-2)
-	 (funcall test tree-1 tree-2)))
-   ((atom tree-2)
-    nil)
-   (t (and (tree-equal (car tree-1) (car tree-2) :test test)
-	   (tree-equal (cdr tree-1) (cdr tree-2) :test test)))))
-
 
 (defun nconc (&rest lists)
   (declare (dynamic-extent lists))



From ffjeld at common-lisp.net  Mon Jun 13 23:00:24 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 14 Jun 2005 01:00:24 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <20050613230024.21AA188165@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Improved hash-tables somewhat: dynamically grow and rehash. Also,
decreased the hash-table-size of dumped hash-tables, which apparently
decreased the image-size by 10%.

Date: Tue Jun 14 01:00:19 2005
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.53 movitz/storage-types.lisp:1.54
--- movitz/storage-types.lisp:1.53	Fri Jun 10 00:18:55 2005
+++ movitz/storage-types.lisp	Tue Jun 14 01:00:17 2005
@@ -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.53 2005/06/09 22:18:55 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.54 2005/06/13 23:00:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1021,7 +1021,8 @@
 
 (defun make-movitz-hash-table (lisp-hash)
   (let* ((undef (movitz-read +undefined-hash-key+))
-	 (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3)))
+	 (hash-count (hash-table-count lisp-hash))
+	 (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count)))))
 	 (bucket-data (make-array hash-size :initial-element undef)))
     (multiple-value-bind (hash-test hash-sxhash)
 	(ecase (hash-table-test lisp-hash)
@@ -1044,18 +1045,20 @@
       (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data))
 	     (lh (make-instance 'movitz-struct
 		   :class (muerte::movitz-find-class 'muerte::hash-table)
-		   :length 3
+		   :length 4
 		   :slot-values (list hash-test ; test-function
 				      bucket
-				      hash-sxhash))))
+				      hash-sxhash
+				      hash-count))))
 	lh))))
 
 (defmethod update-movitz-object ((movitz-hash movitz-struct) (lisp-hash hash-table))
   "Keep <movitz-hash> in sync with <lisp-hash>."
-  (assert (= 3 (length (movitz-struct-slot-values movitz-hash))))
+  (assert (= 4 (length (movitz-struct-slot-values movitz-hash))))
   (let* ((undef (movitz-read +undefined-hash-key+))
 	 (old-bucket (second (movitz-struct-slot-values movitz-hash)))
-	 (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3)))
+	 (hash-count (hash-table-count lisp-hash))
+	 (hash-size (logand -2 (truncate (* 2 4/3 (+ 7 hash-count)))))
 	 (bucket-data (or (and old-bucket
 			       (= (length (movitz-vector-symbolic-data old-bucket))
 				  hash-size)
@@ -1082,7 +1085,8 @@
 			 (svref bucket-data (1+ pos)) movitz-value)))
       (setf (first (movitz-struct-slot-values movitz-hash)) hash-test
 	    (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data)
-	    (third (movitz-struct-slot-values movitz-hash)) hash-sxhash)
+	    (third (movitz-struct-slot-values movitz-hash)) hash-sxhash
+	    (fourth (movitz-struct-slot-values movitz-hash)) hash-count)
       movitz-hash)))
 					     
 ;;;



From ffjeld at common-lisp.net  Mon Jun 13 23:00:26 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 14 Jun 2005 01:00:26 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp 
Message-ID: <20050613230026.A320D884CC@common-lisp.net>

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

Modified Files:
	hash-tables.lisp 
Log Message:
Improved hash-tables somewhat: dynamically grow and rehash. Also,
decreased the hash-table-size of dumped hash-tables, which apparently
decreased the image-size by 10%.

Date: Tue Jun 14 01:00:26 2005
Author: ffjeld

Index: movitz/losp/muerte/hash-tables.lisp
diff -u movitz/losp/muerte/hash-tables.lisp:1.6 movitz/losp/muerte/hash-tables.lisp:1.7
--- movitz/losp/muerte/hash-tables.lisp:1.6	Sun May  8 03:18:29 2005
+++ movitz/losp/muerte/hash-tables.lisp	Tue Jun 14 01:00:25 2005
@@ -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.6 2005/05/08 01:18:29 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.7 2005/06/13 23:00:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -31,7 +31,8 @@
 (defstruct (hash-table (:constructor make-hash-table-object))
   test
   bucket
-  sxhash)
+  sxhash
+  count)
 
 (defun make-hash-table (&key (test 'eql) (size 47) rehash-size rehash-threshold)
   (declare (ignore rehash-size rehash-threshold))
@@ -45,16 +46,17 @@
     (make-hash-table-object
      :test test
      :bucket (make-array (* 2 size) :initial-element '--no-hash-key--)
-     :sxhash sxhash)))
+     :sxhash sxhash
+     :count 0)))
 
-(defun hash-table-count (hash-table)
-  (do* ((bucket (hash-table-bucket hash-table))
-	(length (length bucket))
-	(count 0)
-	(i 0 (+ i 2)))
-      ((>= i length) count)
-    (unless (eq (svref bucket i) '--no-hash-key--)
-      (incf count))))
+;;;(defun hash-table-count (hash-table)
+;;;  (do* ((bucket (hash-table-bucket hash-table))
+;;;	(length (length bucket))
+;;;	(count 0)
+;;;	(i 0 (+ i 2)))
+;;;      ((>= i length) count)
+;;;    (unless (eq (svref bucket i) '--no-hash-key--)
+;;;      (incf count))))
 
 (defun hash-table-iterator (bucket index)
   (when index
@@ -182,12 +184,30 @@
       ((>= c bucket-length)
        (error "Hash-table bucket is full, needs rehashing, which isn't implemented."))
     (let ((k (svref%unsafe bucket index2)))
-      (when (or (eq k '--no-hash-key--)
-		(funcall test k key))
+      (cond
+       ((eq k '--no-hash-key--)
+	(let ((new-count (1+ (hash-table-count hash-table))))
+	  (cond
+	   ((>= (truncate (* new-count 8) 3) bucket-length)
+	    ;; Rehash..
+	    (setf (hash-table-bucket hash-table) (make-array (* 2 (+ bucket-length 7))
+							     :initial-element '--no-hash-key--)
+		  (hash-table-count hash-table) 0)
+	    (do ((i 0 (+ i 2)))
+		((>= i bucket-length))
+	      (let ((old-key (svref%unsafe bucket i)))
+		(unless (eq old-key '--no-hash-key--)
+		  (setf (gethash old-key hash-table)
+		    (svref%unsafe bucket (1+ i))))))
+	    (return (setf (gethash key hash-table) value)))
+	   (t (return (setf (hash-table-count hash-table) new-count
+			    (svref%unsafe bucket index2) key
+			    (svref%unsafe bucket (1+ index2)) value))))))
+       ((funcall test k key)
 	(return (setf (svref%unsafe bucket index2) key
-		      (svref%unsafe bucket (1+ index2)) value))))
-    (when (>= (incf index2 2) bucket-length)
-      (setf index2 0))))
+		      (svref%unsafe bucket (1+ index2)) value)))
+       ((>= (incf index2 2) bucket-length)
+	(setf index2 0))))))
 
 (defun gethash-string (key-string start end hash-table &optional default (key 'identity))
   (let ((bucket (hash-table-bucket hash-table)))
@@ -223,6 +243,7 @@
       (when (or (eq x '--no-hash-key--)
 		(funcall (hash-table-test hash-table) x key))
 	(setf (svref bucket index2) '--no-hash-key--)
+	(decf (hash-table-count hash-table))
 	;; Now we must rehash any entries that might have been
 	;; displaced by the one we have now removed.
 	(do ((i (rem (+ index2 2) bucket-length)
@@ -237,6 +258,7 @@
 	(return t)))))
 
 (defun clrhash (hash-table)
+  (setf (hash-table-count hash-table) 0)
   (do* ((bucket (hash-table-bucket hash-table))
 	(bucket-length (length bucket))
 	(i 0 (+ i 2)))



From ffjeld at common-lisp.net  Mon Jun 13 23:00:58 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 14 Jun 2005 01:00:58 +0200 (CEST)
Subject: [movitz-cvs] CVS update: public_html/ChangeLog 
Message-ID: <20050613230058.A1BC9884CC@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Tue Jun 14 01:00:56 2005
Author: ffjeld

Index: public_html/ChangeLog
diff -u public_html/ChangeLog:1.6 public_html/ChangeLog:1.7
--- public_html/ChangeLog:1.6	Sat Jun 11 01:17:17 2005
+++ public_html/ChangeLog	Tue Jun 14 01:00:56 2005
@@ -1,3 +1,7 @@
+2005-06-14  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Added dynamic growing and rehashing of hash-tables.
+
 2005-06-11  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Started to add support for adjustable and displaced vectors.



From ffjeld at common-lisp.net  Wed Jun 15 21:48:20 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 15 Jun 2005 23:48:20 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050615214820.19B9D88027@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Don't use ECX as temporary storage for lisp-vals!

Date: Wed Jun 15 23:48:19 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.144 movitz/compiler.lisp:1.145
--- movitz/compiler.lisp:1.144	Tue May 24 08:32:27 2005
+++ movitz/compiler.lisp	Wed Jun 15 23:48:19 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.144 2005/05/24 06:32:27 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.145 2005/06/15 21:48:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3606,8 +3606,8 @@
 			 (dest-location (new-binding-location destination frame-map :default nil)))
 		    (cond
 		     ((not dest-location) ; unknown, e.g. a borrowed-binding.
-		      (append (install-for-single-value binding binding-location :ecx nil)
-			      (make-store-lexical result-mode :ecx nil funobj frame-map)))
+		      (append (install-for-single-value binding binding-location :edx nil)
+			      (make-store-lexical result-mode :edx nil funobj frame-map)))
 		     ((equal binding-location dest-location)
 		      nil)
 		     ((member binding-location '(:eax :ebx :ecx :edx))
@@ -3655,6 +3655,8 @@
 	  (if (not shared-reference-p)
 	      (let ((tmp-reg (chose-free-register protect-registers)
 			     #+ignore(if (eq source :eax) :ebx :eax)))
+		(when (eq :ecx source)
+		  (break "loading a word from ECX?"))
 		`((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
 			 ,tmp-reg)
 		  (:movl ,source (-1 ,tmp-reg))))



From ffjeld at common-lisp.net  Thu Jun 16 08:46:05 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 16 Jun 2005 10:46:05 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050616084605.9B9198802E@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Be more clever about when function-arguments can be re-ordered. We
were overly optimistic before, which could result in subtle bugs.

Date: Thu Jun 16 10:46:04 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.145 movitz/compiler.lisp:1.146
--- movitz/compiler.lisp:1.145	Wed Jun 15 23:48:19 2005
+++ movitz/compiler.lisp	Thu Jun 16 10:46:04 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.145 2005/06/15 21:48:19 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.146 2005/06/16 08:46:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5549,10 +5549,10 @@
 			  (setf arguments-self-evaluating-p nil)
 			  (assert (eq :load-lexical (caar code)) ()
 			    "comp-lex-var produced for ~S~% ~S" form code)
-			  (pushnew (second code) arguments-lexical-variables))
+			  (pushnew (cadar code) arguments-lexical-variables))
 			 (t (setf arguments-self-evaluating-p nil
 				  arguments-are-load-lexicals-p nil)))
-		       code))))
+			 code))))
 	 (multiple-value-bind (code01 functionalp01 modifies01 all0 all1)
 	     (make-compiled-two-forms-into-registers (first argument-forms) :eax
 						     (second argument-forms) :ebx
@@ -5564,6 +5564,14 @@
 		 (types (list* (type-specifier-primary (compiler-values-getf all0 :type))
 			       (type-specifier-primary (compiler-values-getf all1 :type))
 			       (nreverse arguments-types))))
+	     #+ignore
+	     (when (and (= 4 (length argument-forms))
+			(string= "WINDOW-TREE" (first argument-forms)))
+	       (warn "final0: ~s, f1: ~S, typ: ~S, asep: ~S, aall: ~S"
+		     final0 final1
+		     types
+		     arguments-self-evaluating-p
+		     arguments-are-load-lexicals-p))
 	     (cond
 	      ((or arguments-self-evaluating-p
 		   (and (typep final0 'lexical-binding)
@@ -5592,9 +5600,9 @@
 		       types
 		       arguments-functional-p))
 	      ((and arguments-are-load-lexicals-p
-		    (not (operators-present-in-code-p code01
-						      '(:store-lexical)
-						      arguments-lexical-variables)))
+		    (not (some (lambda (arg-binding)
+				 (code-uses-binding-p code01 arg-binding :store t :load nil))
+			       arguments-lexical-variables)))
 	       (values (append arguments-code code01)
 		       (+ -2 (length argument-forms))
 		       nil



From ffjeld at common-lisp.net  Thu Jun 16 10:00:53 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 16 Jun 2005 12:00:53 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp 
Message-ID: <20050616100053.7007588165@common-lisp.net>

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

Modified Files:
	hash-tables.lisp 
Log Message:
Various tweaks to several hash functions.

Date: Thu Jun 16 12:00:52 2005
Author: ffjeld

Index: movitz/losp/muerte/hash-tables.lisp
diff -u movitz/losp/muerte/hash-tables.lisp:1.7 movitz/losp/muerte/hash-tables.lisp:1.8
--- movitz/losp/muerte/hash-tables.lisp:1.7	Tue Jun 14 01:00:25 2005
+++ movitz/losp/muerte/hash-tables.lisp	Thu Jun 16 12:00:51 2005
@@ -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.7 2005/06/13 23:00:25 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.8 2005/06/16 10:00:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -49,20 +49,11 @@
      :sxhash sxhash
      :count 0)))
 
-;;;(defun hash-table-count (hash-table)
-;;;  (do* ((bucket (hash-table-bucket hash-table))
-;;;	(length (length bucket))
-;;;	(count 0)
-;;;	(i 0 (+ i 2)))
-;;;      ((>= i length) count)
-;;;    (unless (eq (svref bucket i) '--no-hash-key--)
-;;;      (incf count))))
-
 (defun hash-table-iterator (bucket index)
   (when index
     (do ((length (array-dimension bucket 0)))
 	((>= index length) nil)
-      (unless (eq (svref bucket index) '--no-hash-key--)
+      (unless (eq (svref%unsafe bucket index) '--no-hash-key--)
 	(return (+ index 2)))
       (incf index 2))))
 
@@ -75,8 +66,8 @@
 		    `(when (setq ,',bucket-index-var
 			     (hash-table-iterator ,',bucket-var ,',bucket-index-var))
 		       (values t
-			       (svref ,',bucket-var (- ,',bucket-index-var 2))
-			       (svref ,',bucket-var (- ,',bucket-index-var 1))))))
+			       (svref%unsafe ,',bucket-var (- ,',bucket-index-var 2))
+			       (svref%unsafe ,',bucket-var (- ,',bucket-index-var 1))))))
 	 , at declarations-and-body))))
 
 (defun sxhash-subvector (vector start end &optional (limit 8))
@@ -114,7 +105,8 @@
   (typecase object
     (null 0)
     (symbol
-     (movitz-accessor-u16 object movitz-symbol hash-key))
+     (memref object (movitz-type-slot-offset 'movitz-symbol 'hash-key)
+	     :type :unsigned-byte16))
     (t (with-inline-assembly (:returns :eax)
 	 (:compile-form (:result-mode :eax) object)
 	 (:andl #.(cl:logxor #xffffffff movitz::+movitz-fixnum-zmask+) :eax)))))
@@ -128,6 +120,7 @@
 	 (bucket-length (length bucket))
 	 (start-i2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length))
 	 (i2 start-i2))
+    (declare (type index i2))
     (do () (nil)
       (let ((k (svref%unsafe bucket i2)))
 	(cond
@@ -179,10 +172,8 @@
   (do* ((test (hash-table-test hash-table))
 	(bucket (hash-table-bucket hash-table))
 	(bucket-length (length bucket))
-	(index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length))
-	(c 2 (+ c 2)))
-      ((>= c bucket-length)
-       (error "Hash-table bucket is full, needs rehashing, which isn't implemented."))
+	(index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length)))
+      (nil)
     (let ((k (svref%unsafe bucket index2)))
       (cond
        ((eq k '--no-hash-key--)
@@ -262,15 +253,17 @@
   (do* ((bucket (hash-table-bucket hash-table))
 	(bucket-length (length bucket))
 	(i 0 (+ i 2)))
-      ((>= i bucket-length) hash-table)
-    (setf (svref bucket i) '--no-hash-key--)))
+      ((>= i bucket-length))
+    (setf (svref bucket i) '--no-hash-key--))
+  hash-table)
 
 (defun maphash (function hash-table)
-  (with-hash-table-iterator (get-next-entry hash-table)
-    (do () (nil)
-      (multiple-value-bind (entry-p key value)
-	  (get-next-entry)
-	(if (not entry-p)
-	    (return nil)
-	  (funcall function key value))))))
+  (with-funcallable (map function)
+    (with-hash-table-iterator (get-next-entry hash-table)
+      (do () (nil)
+	(multiple-value-bind (entry-p key value)
+	    (get-next-entry)
+	  (if (not entry-p)
+	      (return nil)
+	    (map key value)))))))
 	



From ffjeld at common-lisp.net  Thu Jun 16 20:55:43 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 16 Jun 2005 22:55:43 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050616205543.9122188167@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
*** empty log message ***
Date: Thu Jun 16 22:55:42 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.146 movitz/compiler.lisp:1.147
--- movitz/compiler.lisp:1.146	Thu Jun 16 10:46:04 2005
+++ movitz/compiler.lisp	Thu Jun 16 22:55:42 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.146 2005/06/16 08:46:04 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.147 2005/06/16 20:55:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5564,14 +5564,6 @@
 		 (types (list* (type-specifier-primary (compiler-values-getf all0 :type))
 			       (type-specifier-primary (compiler-values-getf all1 :type))
 			       (nreverse arguments-types))))
-	     #+ignore
-	     (when (and (= 4 (length argument-forms))
-			(string= "WINDOW-TREE" (first argument-forms)))
-	       (warn "final0: ~s, f1: ~S, typ: ~S, asep: ~S, aall: ~S"
-		     final0 final1
-		     types
-		     arguments-self-evaluating-p
-		     arguments-are-load-lexicals-p))
 	     (cond
 	      ((or arguments-self-evaluating-p
 		   (and (typep final0 'lexical-binding)
@@ -5585,15 +5577,6 @@
 	      ((and arguments-are-load-lexicals-p
 		    (typep final0 '(or lexical-binding movitz-object))
 		    (typep final1 '(or lexical-binding movitz-object)))
-	       (values (append arguments-code code01)
-		       (+ -2 (length argument-forms))
-		       nil
-		       types
-		       arguments-functional-p))
-	      ((and (typep final0 '(or lexical-binding movitz-object))
-		    (typep final1 '(or lexical-binding movitz-object))
-		    (not (modifies-member final0 arguments-modifies))
-		    (not (modifies-member final1 arguments-modifies)))
 	       (values (append arguments-code code01)
 		       (+ -2 (length argument-forms))
 		       nil



From ffjeld at common-lisp.net  Sun Jun  5 01:07:51 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun,  5 Jun 2005 03:07:51 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp 
Message-ID: <20050605010751.C8E7C8802E@common-lisp.net>

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

Modified Files:
	ne2k.lisp 
Log Message:
*** empty log message ***
Date: Sun Jun  5 03:07:51 2005
Author: ffjeld

Index: movitz/losp/x86-pc/ne2k.lisp
diff -u movitz/losp/x86-pc/ne2k.lisp:1.14 movitz/losp/x86-pc/ne2k.lisp:1.15
--- movitz/losp/x86-pc/ne2k.lisp:1.14	Tue Nov 30 15:16:38 2004
+++ movitz/losp/x86-pc/ne2k.lisp	Sun Jun  5 03:07:50 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:16:00 2002
 ;;;;                
-;;;; $Id: ne2k.lisp,v 1.14 2004/11/30 14:16:38 ffjeld Exp $
+;;;; $Id: ne2k.lisp,v 1.15 2005/06/05 01:07:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 



From ffjeld at common-lisp.net  Sun Jun  5 01:08:21 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun,  5 Jun 2005 03:08:21 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/arp.lisp 
Message-ID: <20050605010821.DEC748802E@common-lisp.net>

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

Modified Files:
	arp.lisp 
Log Message:
*** empty log message ***
Date: Sun Jun  5 03:08:21 2005
Author: ffjeld

Index: movitz/losp/lib/net/arp.lisp
diff -u movitz/losp/lib/net/arp.lisp:1.9 movitz/losp/lib/net/arp.lisp:1.10
--- movitz/losp/lib/net/arp.lisp:1.9	Wed Nov 24 23:11:43 2004
+++ movitz/losp/lib/net/arp.lisp	Sun Jun  5 03:08:21 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 2003-2004, 
+;;;;    Copyright (C) 2001, 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Mar 20 15:01:15 2003
 ;;;;                
-;;;; $Id: arp.lisp,v 1.9 2004/11/24 22:11:43 ffjeld Exp $
+;;;; $Id: arp.lisp,v 1.10 2005/06/05 01:08:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------