From ffjeld at common-lisp.net  Mon Mar  8 13:17:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 08 Mar 2004 08:17:38 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B0KdW-0002hV-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Improved (setf aref).

Date: Mon Mar  8 08:17:38 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.2 movitz/losp/muerte/arrays.lisp:1.3
--- movitz/losp/muerte/arrays.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Mar  8 08:17:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.3 2004/03/08 13:17:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -252,8 +252,6 @@
     (:testb 7 :cl)
     (:jnz '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not other-type
     (:movzxw (:eax -2) :edx)
-    (:cmpb #.(movitz::tag :vector) :dl)
-    (:jne '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not vector-type
     
     (:compile-form (:result-mode :ecx) index)
     (:testb #.movitz::+movitz-fixnum-zmask+ :cl)
@@ -262,27 +260,64 @@
     (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
 
     (:cmpw (:eax -4) :cx)
-    (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4))))	; index out of bounds
-    (:testb :dh :dh)			; element-type 0?
+    (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
+
+    (:cmpl #.(movitz:vector-type-tag :any-t) :edx)
     (:jnz 'not-any-t)
 
     (:movl :ebx (:eax (:ecx 4) 2))
     (:jmp 'done)
 
-    not-any-t
-    (:decb :dh)				; element-type 1?
+   not-any-t
+    (:cmpl #.(movitz:vector-type-tag :character) :edx)
     (:jnz 'not-character)
+    (:cmpb #.(movitz:tag :character) :bl)
+    (:jnz '(:sub-program (not-character-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not character: ~S" value))))
     (:movb :bh (:eax :ecx 2))
     (:jmp 'done)
     
-    not-character
-    (:decb :dh)
-    (:jnz '(:sub-program (not-u8) (:int 62) (:jmp (:pc+ -4))))
-    (:shll #.(cl:- 8 movitz::+movitz-fixnum-shift+) :ebx)
-    (:movb :bh (:eax :ecx 2))
-    (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) :ebx)
+   not-character
+    (:cmpl #.(movitz:vector-type-tag :u8) :edx)
+    (:jnz 'not-u8)
+    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xff movitz:+movitz-fixnum-factor+))) :ebx)
+    (:jnz '(:sub-program (not-u8-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not (unsigned-byte 8): ~S" value))))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+    (:movb :bl (:eax (:ecx 1) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+    (:jmp 'done)
+    
+    
+   not-u8
+    (:cmpl #.(movitz:vector-type-tag :u16) :edx)
+    (:jnz 'not-u16)
+    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffff movitz:+movitz-fixnum-factor+))) :ebx)
+    (:jnz '(:sub-program (not-u16-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not (unsigned-byte 16): ~S" value))))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+    (:movw :bx (:eax (:ecx 2) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+    (:jmp 'done)
 
-    done))
+   not-u16
+    (:cmpl #.(movitz:vector-type-tag :u32) :edx)
+    (:jnz 'not-u32)
+    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx)
+    (:jnz '(:sub-program (not-u32-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not (unsigned-byte 32): ~S" value))))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+    (:movw :bx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+    (:jmp 'done)
+
+   not-u32
+    (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector))
+   done))
 
 
 ;;; simple-vector accessors




From ffjeld at common-lisp.net  Mon Mar  8 14:26:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 08 Mar 2004 09:26:13 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B0Lht-0005Kq-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Minor fixes to aref and (setf aref).

Date: Mon Mar  8 09:26:13 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.3 movitz/losp/muerte/arrays.lisp:1.4
--- movitz/losp/muerte/arrays.lisp:1.3	Mon Mar  8 08:17:38 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Mar  8 09:26:13 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.3 2004/03/08 13:17:38 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.4 2004/03/08 14:26:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -183,141 +183,163 @@
     done))
 
 
-(defun aref (vector index)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) vector)
-    (:compile-form (:result-mode :ebx) index)
-    (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx)
-    (:testb #.movitz::+movitz-fixnum-zmask+ :bl)
-    (:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum
-    (:andl #.(cl:ash #x000ffff movitz::+movitz-fixnum-shift+) :ebx)
-    (:testb 7 :cl)
-    (:jnz '(:sub-program () (:int 60)))	; not other-type
-    (:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
-    (:movw (:eax -2) :cx)
-    (:cmpb #.(movitz::tag :vector) :cl)
-    (:jne '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not vector-type
-    (:cmpw (:eax -4) :bx)
-    (:jae '(:sub-program ()
-	    (:movzxw :bx :eax)
-	    (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
-    (:testb :ch :ch)			; element-type 0?
-    (:jnz 'not-any-t)
-    (:movl (:eax (:ebx 4) 2) :eax)
-    (:jmp 'done)
-
-   not-any-t
-    (:decb :ch)				; element-type 1?
-    (:jnz 'not-character)
-    (:movb (:eax :ebx 2) :bl)
-    (:xorl :eax :eax)
-    (:movb :bl :ah)
-    (:movb #.(movitz::tag :character) :al) ; character
-    (:jmp 'done)
-    
-   not-character
-    (:decb :ch)
-    (:jnz 'not-u8)
-    (:movzxb (:eax :ebx 2) :eax)	; u8
-    (:shll #.movitz::+movitz-fixnum-shift+ :eax)
-    (:jmp 'done)
-    
-   not-u8
-    (:decb :ch)
-    (:jnz 'not-u16)
-    (:movzxw (:eax (:ebx 2) 2) :eax)	; u16
-    (:jmp 'done)
-
-   not-u16
-    (:decb :ch)
-    (:jnz 'not-u32)
-    (:movl (:eax (:ebx 4) 2) :ecx)	; u32
-    (:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx)
-    (:jg '(:sub-program (:overflowing-u32)
-	   (:int 107)))
-    (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :eax)
-    (:jmp 'done)
-
-   not-u32
-    (:int 107)
-
-   done))
-
-(defun (setf aref) (value vector index)
-  (with-inline-assembly (:returns :ebx)
-    (:compile-form (:result-mode :ebx) value)
-    (:compile-form (:result-mode :eax) vector)
-
-    (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx)
-    (:testb 7 :cl)
-    (:jnz '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not other-type
-    (:movzxw (:eax -2) :edx)
-    
-    (:compile-form (:result-mode :ecx) index)
-    (:testb #.movitz::+movitz-fixnum-zmask+ :cl)
-    (:jnz '(:sub-program () (:int 107))) ; index not fixnum
-    (:andl #.(cl:ash #xffff movitz::+movitz-fixnum-shift+) :ecx)
-    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
-
-    (:cmpw (:eax -4) :cx)
-    (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
-
-    (:cmpl #.(movitz:vector-type-tag :any-t) :edx)
-    (:jnz 'not-any-t)
-
-    (:movl :ebx (:eax (:ecx 4) 2))
-    (:jmp 'done)
-
-   not-any-t
-    (:cmpl #.(movitz:vector-type-tag :character) :edx)
-    (:jnz 'not-character)
-    (:cmpb #.(movitz:tag :character) :bl)
-    (:jnz '(:sub-program (not-character-value)
-	    (:compile-form (:result-mode :ignore)
-	     (error "Value not character: ~S" value))))
-    (:movb :bh (:eax :ecx 2))
-    (:jmp 'done)
-    
-   not-character
-    (:cmpl #.(movitz:vector-type-tag :u8) :edx)
-    (:jnz 'not-u8)
-    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xff movitz:+movitz-fixnum-factor+))) :ebx)
-    (:jnz '(:sub-program (not-u8-value)
-	    (:compile-form (:result-mode :ignore)
-	     (error "Value not (unsigned-byte 8): ~S" value))))
-    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
-    (:movb :bl (:eax (:ecx 1) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
-    (:jmp 'done)
-    
-    
-   not-u8
-    (:cmpl #.(movitz:vector-type-tag :u16) :edx)
-    (:jnz 'not-u16)
-    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffff movitz:+movitz-fixnum-factor+))) :ebx)
-    (:jnz '(:sub-program (not-u16-value)
-	    (:compile-form (:result-mode :ignore)
-	     (error "Value not (unsigned-byte 16): ~S" value))))
-    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
-    (:movw :bx (:eax (:ecx 2) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
-    (:jmp 'done)
-
-   not-u16
-    (:cmpl #.(movitz:vector-type-tag :u32) :edx)
-    (:jnz 'not-u32)
-    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx)
-    (:jnz '(:sub-program (not-u32-value)
-	    (:compile-form (:result-mode :ignore)
-	     (error "Value not (unsigned-byte 32): ~S" value))))
-    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
-    (:movw :bx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
-    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
-    (:jmp 'done)
-
-   not-u32
-    (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector))
-   done))
+(defun aref (vector &rest subscripts)
+  (numargs-case
+   (2 (vector index)
+      (with-inline-assembly (:returns :eax)
+	(:compile-form (:result-mode :eax) vector)
+	(:compile-form (:result-mode :ebx) index)
+	(:leal (:eax #.(cl:- (movitz::tag :other))) :ecx)
+	(:testb #.movitz::+movitz-fixnum-zmask+ :bl)
+	(:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum
+	(:andl #.(cl:ash #x000ffff movitz::+movitz-fixnum-shift+) :ebx)
+
+	(:testb 7 :cl)
+	(:jnz '(:sub-program ()
+		(:compile-form (:result-mode :ignore)
+		 (error "Not a vector: ~S" vector))))
+		
+;;;	(:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
+	(:movzxw (:eax -2) :ecx)
+
+	(:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx)
+	(:jae '(:sub-program ()
+		(:compile-form (:result-mode :ignore)
+		 (error "Index ~D out of bounds ~D." index (length vector)))))
+
+	(:cmpl #.(movitz:vector-type-tag :any-t) :ecx)
+	(:jne 'not-any-t)
+	(:movl (:eax :ebx 2) :eax)
+	(:jmp 'done)
+
+       not-any-t
+	(:cmpl #.(movitz:vector-type-tag :character) :ecx)
+	(:jne 'not-character)
+	(:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
+	(:movb (:eax :ebx 2) :bl)
+	(:xorl :eax :eax)
+	(:movb :bl :ah)
+	(:movb #.(movitz::tag :character) :al) ; character
+	(:jmp 'done)
+    
+       not-character
+	(:cmpl #.(movitz:vector-type-tag :u8) :ecx)
+	(:jne 'not-u8)
+	(:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
+	(:movzxb (:eax :ebx 2) :eax)	; u8
+	(:shll #.movitz::+movitz-fixnum-shift+ :eax)
+	(:jmp 'done)
+    
+       not-u8
+	(:cmpl #.(movitz:vector-type-tag :u16) :ecx)
+	(:je 'not-u16)
+	(:shrl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx)
+	(:movzxw (:eax :ebx 2) :eax)	; u16
+	(:jmp 'done)
+
+       not-u16
+	(:cmpl #.(movitz:vector-type-tag :u32) :ecx)
+	(:je 'not-u32)
+	(:movl (:eax :ebx 2) :ecx)	; u32
+	(:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx)
+	(:jg '(:sub-program (:overflowing-u32)
+	       (:int 107)))
+	(:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :eax)
+	(:jmp 'done)
+
+       not-u32
+	(:compile-form (:result-mode :ignore)
+		       (error "Not a vector: ~S" vector))
+
+       done))
+   (t (vector &rest subscripts)
+      (declare (dynamic-extent subscripts)
+	       (ignore vector subscripts))
+      (error "Multi-dimensional arrays not implemented."))))
+
+(defun (setf aref) (value vector &rest subscripts)
+  (numargs-case
+   (3 (value vector index)
+      (with-inline-assembly (:returns :ebx)
+	(:compile-form (:result-mode :ebx) value)
+	(:compile-form (:result-mode :eax) vector)
+
+	(:leal (:eax #.(cl:- (movitz::tag :other))) :ecx)
+	(:testb 7 :cl)
+	(:jnz '(:sub-program ()
+		(:compile-form (:result-mode :ignore)
+		 (error "Not a vector: ~S" vector))))
+	(:movzxw (:eax -2) :edx)
+    
+	(:compile-form (:result-mode :ecx) index)
+	(:testb #.movitz::+movitz-fixnum-zmask+ :cl)
+	(:jnz '(:sub-program () (:int 107))) ; index not fixnum
+	(:andl #.(cl:ash #xffff movitz::+movitz-fixnum-shift+) :ecx)
+	(:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
+
+	(:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx)
+	(:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
+
+	(:cmpl #.(movitz:vector-type-tag :any-t) :edx)
+	(:jnz 'not-any-t)
+
+	(:movl :ebx (:eax (:ecx 4) 2))
+	(:jmp 'done)
+
+       not-any-t
+	(:cmpl #.(movitz:vector-type-tag :character) :edx)
+	(:jnz 'not-character)
+	(:cmpb #.(movitz:tag :character) :bl)
+	(:jnz '(:sub-program (not-character-value)
+		(:compile-form (:result-mode :ignore)
+		 (error "Value not character: ~S" value))))
+	(:movb :bh (:eax :ecx 2))
+	(:jmp 'done)
+    
+       not-character
+	(:cmpl #.(movitz:vector-type-tag :u8) :edx)
+	(:jnz 'not-u8)
+	(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xff movitz:+movitz-fixnum-factor+))) :ebx)
+	(:jnz '(:sub-program (not-u8-value)
+		(:compile-form (:result-mode :ignore)
+		 (error "Value not (unsigned-byte 8): ~S" value))))
+	(:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+	(:movb :bl (:eax (:ecx 1) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+	(:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+	(:jmp 'done)
+    
+    
+       not-u8
+	(:cmpl #.(movitz:vector-type-tag :u16) :edx)
+	(:jnz 'not-u16)
+	(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffff movitz:+movitz-fixnum-factor+))) :ebx)
+	(:jnz '(:sub-program (not-u16-value)
+		(:compile-form (:result-mode :ignore)
+		 (error "Value not (unsigned-byte 16): ~S" value))))
+	(:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+	(:movw :bx (:eax (:ecx 2) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+	(:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+	(:jmp 'done)
+
+       not-u16
+	(:cmpl #.(movitz:vector-type-tag :u32) :edx)
+	(:jnz 'not-u32)
+	(:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx)
+	(:jnz '(:sub-program (not-u32-value)
+		(:compile-form (:result-mode :ignore)
+		 (error "Value not (unsigned-byte 32): ~S" value))))
+	(:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+	(:movw :bx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+	(:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+	(:jmp 'done)
+
+       not-u32
+	(:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector))
+       done))
+   (t (value vector &rest subscripts)
+      (declare (dynamic-extent subscripts)
+	       (ignore value vector subscripts))
+      (error "Multi-dimensional arrays not implemented."))))
 
 
 ;;; simple-vector accessors
@@ -329,7 +351,9 @@
   `(setf (memref ,simple-vector 2 ,index :lisp) ,value))
 
 (defun svref%unsafe (simple-vector index)
-  (svref%unsafe simple-vector index))
+  (with-inline-assembly (:returns :eax)
+    (:compile-two-forms (:eax :ebx) simple-vector index)
+    (:movl (:eax :ebx #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)) :eax)))
 
 (defun (setf svref%unsafe) (value simple-vector index)
   (setf (svref%unsafe simple-vector index) value))
@@ -447,10 +471,6 @@
        (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 :u16)
-;;;	 '(unsigned-byte 16))
-;;;      (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
-;;;	 '(unsigned-byte 32))
     (t (warn "don't know about vector's element-type: ~S" vector)
        (values #'aref #'(setf aref)))))
 




From ffjeld at common-lisp.net  Mon Mar  8 14:33:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 08 Mar 2004 09:33:53 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B0LpJ-0002VM-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed stupid bug in aref in previous check-in.

Date: Mon Mar  8 09:33:52 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.4 movitz/losp/muerte/arrays.lisp:1.5
--- movitz/losp/muerte/arrays.lisp:1.4	Mon Mar  8 09:26:13 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Mar  8 09:33:52 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.4 2004/03/08 14:26:13 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.5 2004/03/08 14:33:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -199,7 +199,7 @@
 		(:compile-form (:result-mode :ignore)
 		 (error "Not a vector: ~S" vector))))
 		
-;;;	(:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
+	(:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
 	(:movzxw (:eax -2) :ecx)
 
 	(:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx)
@@ -209,13 +209,12 @@
 
 	(:cmpl #.(movitz:vector-type-tag :any-t) :ecx)
 	(:jne 'not-any-t)
-	(:movl (:eax :ebx 2) :eax)
+	(:movl (:eax (:ebx 4) 2) :eax)
 	(:jmp 'done)
 
        not-any-t
 	(:cmpl #.(movitz:vector-type-tag :character) :ecx)
 	(:jne 'not-character)
-	(:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
 	(:movb (:eax :ebx 2) :bl)
 	(:xorl :eax :eax)
 	(:movb :bl :ah)
@@ -225,7 +224,6 @@
        not-character
 	(:cmpl #.(movitz:vector-type-tag :u8) :ecx)
 	(:jne 'not-u8)
-	(:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
 	(:movzxb (:eax :ebx 2) :eax)	; u8
 	(:shll #.movitz::+movitz-fixnum-shift+ :eax)
 	(:jmp 'done)
@@ -233,14 +231,13 @@
        not-u8
 	(:cmpl #.(movitz:vector-type-tag :u16) :ecx)
 	(:je 'not-u16)
-	(:shrl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx)
-	(:movzxw (:eax :ebx 2) :eax)	; u16
+	(:movzxw (:eax (:ebx 2) 2) :eax) ; u16
 	(:jmp 'done)
 
        not-u16
 	(:cmpl #.(movitz:vector-type-tag :u32) :ecx)
 	(:je 'not-u32)
-	(:movl (:eax :ebx 2) :ecx)	; u32
+	(:movl (:eax (:ebx 4) 2) :ecx)	; u32
 	(:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx)
 	(:jg '(:sub-program (:overflowing-u32)
 	       (:int 107)))




From ffjeld at common-lisp.net  Fri Mar 12 11:47:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Mar 2004 06:47:42 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <E1B1l8g-000493-00@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
Improved error message in signal-simple.

Date: Fri Mar 12 06:47:42 2004
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.2 movitz/losp/muerte/conditions.lisp:1.3
--- movitz/losp/muerte/conditions.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/conditions.lisp	Fri Mar 12 06:47:41 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.3 2004/03/12 11:47:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -250,7 +250,8 @@
   (declare (dynamic-extent arguments))
   (let* ((class (etypecase datum
 		  (symbol
-		   (find-class datum))
+		   (or (find-class datum nil)
+		       (error "No condition class named ~S." datum)))
 		  (string
 		   (find-class default-type))
 		  (condition




From ffjeld at common-lisp.net  Wed Mar 17 08:26:50 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Mar 2004 03:26:50 -0500
Subject: [movitz-cvs] CVS update: movitz/slime-movitz.el 
Message-ID: <E1B3WO2-0008VU-00@common-lisp.net>

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

Added Files:
	slime-movitz.el 
Log Message:
>From Aleksandar Bakic.

Date: Wed Mar 17 03:26:50 2004
Author: ffjeld





From ffjeld at common-lisp.net  Wed Mar 17 16:36:36 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 17 Mar 2004 11:36:36 -0500
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1B3e20-0001ha-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Various symbols added and removed.

Date: Wed Mar 17 11:36:36 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.6 movitz/packages.lisp:1.7
--- movitz/packages.lisp:1.6	Thu Feb 26 06:31:31 2004
+++ movitz/packages.lisp	Wed Mar 17 11:36:36 2004
@@ -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.6 2004/02/26 11:31:31 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.7 2004/03/17 16:36:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1118,7 +1118,7 @@
 	   #:package-object-use-list
 	   #:package-object-internal-symbols
 	   #:package-object-external-symbols
-	   
+
 	   vector-element-type
 	   vector-element-size
 	   with-subvector-accessor
@@ -1268,6 +1268,8 @@
 	   #:code-vector%1op
 	   #:code-vector%2op
 	   #:code-vector%3op
+	   #:code-vector-word
+	   #:lu32
 	   
 	   #:+movitz-fixnum-factor+
 	   #:+movitz-fixnum-shift+
@@ -1280,6 +1282,7 @@
 	   #:movitz-vector-num-elements
 	   #:movitz-vector-element-type
 	   #:movitz-vector-symbolic-data
+	   #:vector-type-tag
 	   
 	   #:movitz-symbol
 	   #:movitz-string




From ffjeld at common-lisp.net  Thu Mar 18 09:16:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Mar 2004 04:16:38 -0500
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1B3tdm-0006j5-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Added function vector-type-tag.

Date: Thu Mar 18 04:16:38 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.9 movitz/storage-types.lisp:1.10
--- movitz/storage-types.lisp:1.9	Fri Feb 13 10:25:34 2004
+++ movitz/storage-types.lisp	Thu Mar 18 04:16:38 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.9 2004/02/13 15:25:34 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.10 2004/03/18 09:16:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -362,6 +362,11 @@
     :initarg :symbolic-data
     :accessor movitz-vector-symbolic-data))
   (:slot-align type -2))
+
+(defun vector-type-tag (element-type)
+  (dpb (enum-value 'movitz-vector-element-type element-type)
+       (byte 8 8)
+       (enum-value 'other-type-byte :vector)))
 
 (define-binary-class movitz-new-vector (movitz-heap-object-other)
   ((length




From ffjeld at common-lisp.net  Thu Mar 18 09:19:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Mar 2004 04:19:46 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B3tgo-0004uW-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Aref tune-up.

Date: Thu Mar 18 04:19:45 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.5 movitz/losp/muerte/arrays.lisp:1.6
--- movitz/losp/muerte/arrays.lisp:1.5	Mon Mar  8 09:33:52 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Mar 18 04:19:45 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.5 2004/03/08 14:33:52 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.6 2004/03/18 09:19:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -230,13 +230,13 @@
     
        not-u8
 	(:cmpl #.(movitz:vector-type-tag :u16) :ecx)
-	(:je 'not-u16)
+	(:jne 'not-u16)
 	(:movzxw (:eax (:ebx 2) 2) :eax) ; u16
 	(:jmp 'done)
 
        not-u16
 	(:cmpl #.(movitz:vector-type-tag :u32) :ecx)
-	(:je 'not-u32)
+	(:jne 'not-u32)
 	(:movl (:eax (:ebx 4) 2) :ecx)	; u32
 	(:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx)
 	(:jg '(:sub-program (:overflowing-u32)




From ffjeld at common-lisp.net  Thu Mar 18 09:21:18 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Mar 2004 04:21:18 -0500
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1B3tiI-0007VD-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Minor optimizations regarding register usage.

Date: Thu Mar 18 04:21:18 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.4 movitz/losp/muerte/primitive-functions.lisp:1.5
--- movitz/losp/muerte/primitive-functions.lisp:1.4	Thu Feb 26 08:43:51 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Thu Mar 18 04:21:17 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.4 2004/02/26 13:43:51 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.5 2004/03/18 09:21:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -466,9 +466,8 @@
     (:shrl 1 :eax)))
 
 (define-primitive-function fast-cons ()
-  "Call with car in eax and cdr in ebx. Preserves EDX."
+  "Allocate a cons cell. Call with car in eax and cdr in ebx."
   (with-inline-assembly (:returns :multiple-values)
-    (:pushl :edx)
     (:xchgl :eax :ecx)
     (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax))
     (:movl (:eax 4) :edx)
@@ -483,24 +482,21 @@
     (:movl :ecx (:eax))
     (:movl :ebx (:eax 4))
     (:incl :eax)
-    (:popl :edx)
     (:ret)))
 
 (define-primitive-function ensure-heap-cons-variable ()
   "Call with lended variable (a cons) in EAX. Preserves EDX."
   (with-inline-assembly (:returns :multiple-values)
-    ;; (:movl (:ebp :ecx) :eax)		; stack-frame variable's content into eax
     (:cmpl :ebp :eax)			; is cons above stack-frame?
     (:jge 'return-ok)
     (:cmpl :esp :eax)			; is cons below stack-frame?
     (:jl 'return-ok)
     ;; must migrate cell onto heap
+    (:pushl :edx)
     (:movl (:eax 3) :ebx)		; cdr
     (:movl (:eax -1) :eax)		; car
-    ;; (:pushl :ecx)
     (:locally (:call (:edi (:edi-offset fast-cons))))
-    ;; (:popl :ecx)
-    ;; (:movl :eax (:ebx :ecx))
+    (:popl :edx)
     return-ok
     (:ret)))
 




From ffjeld at common-lisp.net  Thu Mar 18 09:23:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Mar 2004 04:23:02 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1B3tjy-0001lx-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
Tune-up of %run-time-context-slot.

Date: Thu Mar 18 04:23:02 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.1.1.1 movitz/losp/muerte/run-time-context.lisp:1.2
--- movitz/losp/muerte/run-time-context.lisp:1.1.1.1	Tue Jan 13 06:05:06 2004
+++ movitz/losp/muerte/run-time-context.lisp	Thu Mar 18 04:23:01 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.1.1.1 2004/01/13 11:05:06 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.2 2004/03/18 09:23:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -67,13 +67,18 @@
       form
     (let ((slot-name (movitz::eval-form slot-name env)))
       (ecase (bt:binary-slot-type 'movitz::movitz-constant-block (intern (symbol-name slot-name) :movitz))
-	(movitz::word
+	(movitz:word
 	 `(with-inline-assembly (:returns :eax)
 	    (:compile-form (:result-mode :eax) ,value)
 	    (:locally (:movl :eax (:edi (:edi-offset ,slot-name))))))
-	(movitz::lu32
+	(movitz:lu32
 	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 	    (:compile-form (:result-mode :untagged-fixnum-ecx) ,value)
+	    (:locally (:movl :ecx (:edi (:edi-offset ,slot-name))))))
+	(movitz:code-vector-word
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-form (:result-mode :eax) ,value)
+	    (:leal (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)) :ecx)
 	    (:locally (:movl :ecx (:edi (:edi-offset ,slot-name))))))))))
 
 (defun (setf %run-time-context-slot) (value slot-name &optional (context (current-run-time-context)))
@@ -83,6 +88,8 @@
       (word
        (setf (memref context -6 (third slot) :lisp) value))
       (lu32
+       (setf (memref context -6 (third slot) :unsigned-byte32) value))
+      (code-vector-word
        (setf (memref context -6 (third slot) :unsigned-byte32) value)))))
 
 (defun %run-time-context-segment-base (slot-name




From ffjeld at common-lisp.net  Thu Mar 18 09:24:24 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 18 Mar 2004 04:24:24 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp 
Message-ID: <E1B3tlI-0005yu-00@common-lisp.net>

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

Modified Files:
	lists.lisp 
Log Message:
Have nthcdr bail out when nil is encountered.

Date: Thu Mar 18 04:24:23 2004
Author: ffjeld

Index: movitz/losp/muerte/lists.lisp
diff -u movitz/losp/muerte/lists.lisp:1.3 movitz/losp/muerte/lists.lisp:1.4
--- movitz/losp/muerte/lists.lisp:1.3	Tue Feb  3 04:57:49 2004
+++ movitz/losp/muerte/lists.lisp	Thu Mar 18 04:24:23 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.3 2004/02/03 09:57:49 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.4 2004/03/18 09:24:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -133,7 +133,7 @@
 
 (defun nthcdr (n list)
   (do ()
-      ((= 0 n) list)
+      ((or (null list) (not (plusp n))) list)
     (decf n)
     (setf list (cdr list))))
 
@@ -200,10 +200,10 @@
 (defun copy-list (list)
   (if (null list)
       nil
-    (do* ((new-list (cons (pop list) nil))
-	  (new-tail new-list (cdr new-tail)))
-	((null list) new-list)
-      (setf (cdr new-tail) (cons (pop list) nil)))))
+    (let ((new-list (cons (pop list) nil)))
+      (do ((new-tail new-list (cdr new-tail)))
+	  ((null list) new-list)
+	(setf (cdr new-tail) (cons (pop list) nil))))))
 
 (defun list (&rest objects)
   (numargs-case




From ffjeld at common-lisp.net  Fri Mar 19 10:49:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 19 Mar 2004 05:49:40 -0500
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1B4HZM-0006QD-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Some not-too-big changes of certain symbolic constants in preparation
of supporting GC scanning.

Date: Fri Mar 19 05:49:40 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.10 movitz/storage-types.lisp:1.11
--- movitz/storage-types.lisp:1.10	Thu Mar 18 04:16:38 2004
+++ movitz/storage-types.lisp	Fri Mar 19 05:49:39 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.10 2004/03/18 09:16:38 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.11 2004/03/19 10:49:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -67,13 +67,13 @@
   :other 6
   :symbol 7
   
-  :vector #x08
-  :defstruct #x09
-  :funobj #x10
-  :std-instance #x14
-  :run-time-context #x15
+  :vector #x10
+  :defstruct #x20
+  :funobj #x30
+  :std-instance #x40
+  :run-time-context #x50
 
-  :simple-vector #x20
+  ;; :simple-vector #x20
   ;; :character-vector 
   
   :basic-restart #x32
@@ -326,9 +326,9 @@
     :initarg :flags
     :initform nil
     :binary-type (define-bitfield movitz-vector-flags (u8)
-		   (((:bits) :fill-pointer-p 0
-			     :code-vector-p 1
-			     :std-instance-slots-p 2))))
+		   (((:bits) :fill-pointer-p 2
+			     :code-vector-p 3
+			     :std-instance-slots-p 4))))
    (alignment-power
     :binary-lisp-type u8		; align to 2^(high-nibble+3) + low-nibble
     :initform 0
@@ -585,18 +585,18 @@
     :map-binary-read-delayed 'movitz-word
     :initform *movitz-nil*
     :accessor movitz-symbol-package)
-   (hash-key
-    :binary-lisp-type lu16
-    :reader movitz-symbol-hash-key
-    :initarg :hash-key)
    (flags
     :binary-type (define-bitfield movitz-symbol-flags (lu16)
 		   (((:bits)
-		     :special-variable 0
-		     :constant-variable 1
-		     :setf-placeholder 4)))
+		     :special-variable 3
+		     :constant-variable 4
+		     :setf-placeholder 5)))
     :accessor movitz-symbol-flags
     :initform nil)
+   (hash-key
+    :binary-lisp-type lu16
+    :reader movitz-symbol-hash-key
+    :initarg :hash-key)
    (lisp-symbol
     :initform nil
     :initarg :lisp-symbol))
@@ -793,10 +793,18 @@
     :accessor movitz-funobj-name
     :initarg :name)
    (num-jumpers				; how many of the first constants are jumpers.
-    :binary-type lu16
-    :initform 0
+    :binary-type lu16			; 14 bits, the lower 16 bits of a fixnum.
+    :initform 0				; This, in order to see this as a fixnum while
+    :accessor movitz-funobj-num-jumpers	; GC scanning.
     :initarg :num-jumpers
-    :accessor movitz-funobj-num-jumpers)
+    :map-binary-write (lambda (x &optional type)
+			(declare (ignore type))
+			(check-type x (unsigned-byte 14))
+			(* x +movitz-fixnum-factor+))
+    :map-binary-read (lambda (x &optional type)
+		       (declare (ignore type))
+		       (assert (zerop (ldb (byte 2 0) x)))
+		       (/ x +movitz-fixnum-factor+)))
    (num-constants
     :binary-type lu16
     :initform 0
@@ -932,8 +940,13 @@
    (num-jumpers
     :binary-type lu16
     :initform 0
-    :initarg :num-constants
-    :accessor movitz-funobj-num-jumpers)
+    :accessor movitz-funobj-num-jumpers
+    :map-binary-write (lambda (x &optional type)
+		       (declare (ignore typE))
+			(* x +movitz-fixnum-factor+))
+    :map-binary-read (lambda (x &optional type)
+		       (declare (ignore typE))
+		       (/ x +movitz-fixnum-factor+)))
    (num-constants
     :binary-type lu16
     :initform (/ (- (sizeof 'movitz-funobj-standard-gf)




From ffjeld at common-lisp.net  Mon Mar 22 09:49:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 04:49:11 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1B5M3T-0006S0-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Bind *, **, etc. around the top-level REPL. Also several minor edits.

Date: Mon Mar 22 04:49:11 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.3 movitz/losp/los0.lisp:1.4
--- movitz/losp/los0.lisp:1.3	Tue Feb 10 18:38:20 2004
+++ movitz/losp/los0.lisp	Mon Mar 22 04:49:11 2004
@@ -9,17 +9,18 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.3 2004/02/10 23:38:20 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.4 2004/03/22 09:49:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (provide :los0 :load-priority 0)
 
 (require :common-lisp)
+(require :x86-pc/interrupt)
 (require :x86-pc/all)
 (require :x86-pc/io-space)
 (require :x86-pc/ne2k)
-;; (require :x86-pc/floppy)
+(require :x86-pc/floppy)
 
 (require :lib/readline)
 (require :lib/toplevel)
@@ -28,7 +29,10 @@
 (require :lib/repl)
 
 (defpackage muerte.init
-  (:use muerte.cl muerte muerte.lib muerte.x86-pc muerte.readline muerte.toplevel
+  (:use muerte.cl muerte muerte.lib
+	muerte.x86-pc
+	muerte.readline
+	muerte.toplevel
 	muerte.ethernet
 	muerte.ip6
 	muerte.ip4
@@ -225,9 +229,10 @@
   (format t "~&test-funcall args: ~S~%" args))
 
 #+ignore
-(defun test-rest (&optional a0 a1 a3 &rest args)
+(defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args)
   (declare (dynamic-extent args))
-  (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args))
+  (when a0-p
+    (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args)))
 
 
 (defun test-return ()
@@ -316,8 +321,10 @@
     (print 'hello)))
 
 #+ignore
-(defun sloo (x y)
-  'sllooo)
+(defun sloo (&rest x)
+  (declare (dynamic-extent x))
+  (let ((y (car x)))
+    (sloo y)))
 
 #+ignore
 (defun test-throw (tag)
@@ -343,7 +350,11 @@
 (defun test-up (tag)
  (unwind-protect
       (test-throw tag)
-    (print 'hello-cleanup)))
+   (print 'hello-cleanup)))
+
+(defun test-cons (x)
+  (let ((c (cons x x)))
+    (cdr c)))
 
 (defun test-fixed (x y z)
   (warn "x: ~W, y: ~W, z: ~W" x y z))
@@ -469,6 +480,17 @@
     (return-from dingu 'fooob))
   (+ x y))
 
+
+(defun foo (&edx edx x &optional (y nil yp))
+  (format t "~@{ ~A~}" x y yp edx))
+
+(defun wefwe (&rest args)
+  (declare (dynamic-extent args))
+  (do ((p args (cdr p)))
+      ((endp p))
+    (let ((x (car p)))
+      (print x))))
+
 ;;;;;
 
 (defclass food () ())
@@ -487,53 +509,62 @@
   (declare (ignore f))
   (print "Cooking some food."))
 
-(defun foo (x &optional (y nil yp))
-  (format t "~@{ ~A~}" yp))
-
 (defun test-pie (n pie)
   (dotimes (i n)
     (pie-filling pie)))
 
+(defun test-inc (n)
+  (dotimes (i n)
+    (warn "foo: ~S" (lambda ()
+		      (setf i 5)))))
+
+(defun test-id (n x)
+  (dotimes (i n)
+    (identity x)))
+
+(defun test-inc2 (x)
+  (print (prog1 x (incf x)))
+  (print x))
+
 (defclass pie (food)
   ((filling :accessor pie-filling 
 	    :initarg :filling
 	    :initform 'apple))
   #+ignore (:default-initargs :filling (if (foo) 'apple 'banana)))
 
-#+ignore
 (defclass pie2 (food)
   ((filling :accessor pie-filling 
 	    :initarg :filling
 	    :initform nil)))
 
-;;;(defmethod cook ((p (eql 'pie)))
-;;;  (warn "Won't really cook a symbolic pie!")
-;;;  (values))
-;;;
-;;;(defmethod cook ((p (eql 'pudding)))
-;;;  'cooked-pudding)
-
-;;;(defmethod slot-value-using-class :after (class (pie pie2) slot)
-;;;  (warn "HEy, don't poke inside my pie2!"))
-
-;;;(defmethod cook :after ((p symbol))
-;;;  (warn "A symbol may or may not have been cooked."))
-
-;;;(defmethod cook ((p pie))
-;;;  (cond
-;;;   ((eq 'banana (pie-filling p))
-;;;    (print "Won't cook a banana-pie, trying next.")
-;;;    (call-next-method))
-;;;   (t (print "Cooking a pie.")
-;;;      (setf (pie-filling p) (list 'cooked (pie-filling p))))))
-
-;;;(defmethod cook :before ((p pie))
-;;;  (declare (ignore p))
-;;;  (print "A pie is about to be cooked."))
-;;;
-;;;(defmethod cook :after ((p pie))
-;;;  (declare (ignore p))
-;;;  (print "A pie has been cooked."))
+(defmethod cook ((p (eql 'pie)))
+  (warn "Won't really cook a symbolic pie!")
+  (values))
+
+(defmethod cook ((p (eql 'pudding)))
+  'cooked-pudding)
+
+(defmethod slot-value-using-class :after (class (pie pie2) slot)
+  (warn "HEy, don't poke inside my pie2!"))
+
+(defmethod cook :after ((p symbol))
+  (warn "A symbol may or may not have been cooked."))
+
+(defmethod cook ((p pie))
+  (cond
+   ((eq 'banana (pie-filling p))
+    (print "Won't cook a banana-pie, trying next.")
+    (call-next-method))
+   (t (print "Cooking a pie.")
+      (setf (pie-filling p) (list 'cooked (pie-filling p))))))
+
+(defmethod cook :before ((p pie))
+  (declare (ignore p))
+  (print "A pie is about to be cooked."))
+
+(defmethod cook :after ((p pie))
+  (declare (ignore p))
+  (print "A pie has been cooked."))
 
 (defun assess-cpu-frequency ()
   "Assess the CPU's frequency in units of 1024 Hz."
@@ -828,10 +859,13 @@
 		       *standard-input* s
 		       *terminal-io* s
 		       *debug-io* s)))
-    (loop 
-      (catch 'top-level-repl		; If restarts don't work, you can throw this..
-	(with-simple-restart (abort "Abort to the top command level.")
-	  (read-eval-print)))))
+    (let ((* nil) (** nil) (*** nil)
+	  (/ nil) (// nil) (/// nil)
+	  (+ nil) (++ nil) (+++ nil))
+      (loop
+	(catch :top-level-repl		; If restarts don't work, you can throw this..
+	  (with-simple-restart (abort "Abort to the top command level.")
+	    (read-eval-print))))))
   
   (error "What's up? [~S]" 'hey))
 
@@ -884,6 +918,7 @@
        ,(when error-spec
 	  `(error , at error-spec))))
 
+#+ignore
 (defun bridge (&optional (inside (do-default (*inside* "No inside NIC.")
 				   (muerte.x86-pc.ne2k:ne2k-probe #x300)))
 			 (outside (do-default (*outside* "No outside NIC.")




From ffjeld at common-lisp.net  Mon Mar 22 14:38:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 09:38:14 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1B5QZC-0000zy-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Fixed :gensym argument to write.

Date: Mon Mar 22 09:38:13 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.2 movitz/losp/muerte/print.lisp:1.3
--- movitz/losp/muerte/print.lisp:1.2	Mon Jan 19 06:23:47 2004
+++ movitz/losp/muerte/print.lisp	Mon Mar 22 09:38:13 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep  3 11:48:19 2001
 ;;;;                
-;;;; $Id: print.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.3 2004/03/22 14:38:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -150,7 +150,7 @@
 (defun write (object &key stream case circle
 			  (array *print-array*) (base *print-base*)
 			  ((:escape *print-escape*) *print-escape*)
-			  ((:gensym *print-gensym*) *print-readably*)
+			  ((:gensym *print-gensym*) *print-gensym*)
 			  (length *print-length*)
 			  (level *print-level*) lines miser-width pprint-dispatch
 			  (pretty *print-pretty*) (radix *print-radix*)




From ffjeld at common-lisp.net  Mon Mar 22 14:42:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 09:42:32 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp 
Message-ID: <E1B5QdM-0004Fa-00@common-lisp.net>

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

Modified Files:
	cons.lisp 
Log Message:
Removed some dead code.

Date: Mon Mar 22 09:42:32 2004
Author: ffjeld

Index: movitz/losp/muerte/cons.lisp
diff -u movitz/losp/muerte/cons.lisp:1.2 movitz/losp/muerte/cons.lisp:1.3
--- movitz/losp/muerte/cons.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/cons.lisp	Mon Mar 22 09:42:31 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.3 2004/03/22 14:42:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -215,10 +215,3 @@
     (:compile-form (:result-mode :eax) car)
     (:compile-form (:result-mode :ebx) cdr)
     (:call-global-constant fast-cons)))
-
-#+ignore
-(defun cons (car cdr)
-  (let ((cell (inline-malloc 8 :tag :cons)))
-    (setf (car cell) car
-	  (cdr cell) cdr)
-    cell))




From ffjeld at common-lisp.net  Mon Mar 22 16:37:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:37:47 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B5SQt-0004Cl-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
A small change in strategy for allocating memory.

Date: Mon Mar 22 11:37:47 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.6 movitz/losp/muerte/arrays.lisp:1.7
--- movitz/losp/muerte/arrays.lisp:1.6	Thu Mar 18 04:19:45 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Mar 22 11:37:47 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.6 2004/03/18 09:19:45 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.7 2004/03/22 16:37:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -549,19 +549,26 @@
 	  (initial-contents
 	   (replace a initial-contents)))
 	 a))
-      (t (let ((a (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) (* 4 dimensions))
-				 :other-tag :vector
-				 :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
-								  :any-t))))
-	   (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
+      (t (let ((array (malloc-words dimensions)
+		      #+ignore
+		      (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) (* 4 dimensions))
+				     :other-tag :vector
+				     :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
+								      :any-t))))
+	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
+			 0 :unsigned-byte16)
+	     #.(movitz:vector-type-tag :any-t))
+	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 			 0 :unsigned-byte16)
 	     dimensions)
-	   (setf (fill-pointer a) fill-pointer)
-	   (if initial-contents
-	       (replace a initial-contents)
+	   (setf (fill-pointer array) fill-pointer)
+	   (cond
+	    (initial-contents
+	     (replace array initial-contents))
+	    (initial-element
 	     (dotimes (i dimensions)
-	       (setf (svref%unsafe a i) initial-element)))
-	   a))))))
+	       (setf (svref%unsafe array i) initial-element))))
+	   array))))))
 
 (defun vector (&rest objects)
   "=> vector"




From ffjeld at common-lisp.net  Mon Mar 22 16:37:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:37:52 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1B5SQy-0004Du-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
A small change in strategy for allocating memory.

Date: Mon Mar 22 11:37:51 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.3 movitz/losp/muerte/basic-functions.lisp:1.4
--- movitz/losp/muerte/basic-functions.lisp:1.3	Thu Feb 26 08:44:29 2004
+++ movitz/losp/muerte/basic-functions.lisp	Mon Mar 22 11:37:51 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.3 2004/02/26 13:44:29 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.4 2004/03/22 16:37:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -342,3 +342,17 @@
 
 (defun halt-cpu ()
   (halt-cpu))
+
+(defun malloc-words (words)
+  (malloc-clumps (1+ (truncate (1+ words) 2))))
+
+(defun malloc-clumps (clumps)
+  (let ((x (with-inline-assembly (:returns :eax :side-effects t)
+	     (:compile-form (:result-mode :ebx) clumps)
+	     (:shll 1 :ebx)
+	     (:globally (:call (:edi (:edi-offset malloc))))
+	     (:addl #.(movitz::tag :other) :eax))))
+    (dotimes (i clumps)
+      (setf (memref x -6 i :lisp) nil
+	    (memref x -2 i :lisp) nil))
+    x))




From ffjeld at common-lisp.net  Mon Mar 22 16:38:00 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:38:00 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1B5SR6-0004Rc-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
A small change in strategy for allocating memory.

Date: Mon Mar 22 11:37:59 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.2 movitz/losp/muerte/defstruct.lisp:1.3
--- movitz/losp/muerte/defstruct.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/defstruct.lisp	Mon Mar 22 11:37:59 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.3 2004/03/22 16:37:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -212,8 +212,7 @@
 		      if (and constructor (symbolp constructor))
 		      collect
 			`(defun ,constructor (&key , at key-lambda)
-			   (let ((s (inline-malloc ,(logand -8 (+ #.(bt:sizeof 'movitz::movitz-struct)
-								  (* 4 (1+ (length slot-names))))))))
+			   (let ((s (malloc-words ,(length slot-names))))
 			     (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
 						    0 :lisp)
 			       ',struct-name)
@@ -235,8 +234,7 @@
 			       (boa-lambda-list (cdr constructor))
 			       (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list)))
 			  `(defun ,boa-constructor ,boa-lambda-list
-			     (let ((s (inline-malloc ,(logand -8 (+ #.(bt:sizeof 'movitz::movitz-struct)
-								  (* 4 (1+ (length slot-names))))))))
+			     (let ((s (malloc-words ,(length slot-names))))
 			       (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
 						      0 :lisp)
 				 ',struct-name)




From ffjeld at common-lisp.net  Mon Mar 22 16:38:05 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:38:05 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1B5SRB-0005Fd-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
A small change in strategy for allocating memory.

Date: Mon Mar 22 11:38:05 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.2 movitz/losp/muerte/functions.lisp:1.3
--- movitz/losp/muerte/functions.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/functions.lisp	Mon Mar 22 11:38:05 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.3 2004/03/22 16:38:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -265,12 +265,16 @@
 
 (defun funobj-num-jumpers (funobj)
   (check-type funobj compiled-function)
-  (movitz-accessor-u16 funobj movitz-funobj num-jumpers))
+  (with-inline-assembly (:returns :eax)
+    (:compile-form (:result-mode :eax) funobj)
+    (:movzxw (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)) :eax)))
 
 (defun (setf funobj-num-jumpers) (num-jumpers funobj)
   (check-type funobj compiled-function)
-  (check-type num-jumpers (unsigned-byte 16))
-  (set-movitz-accessor-u16 funobj movitz-funobj num-jumpers num-jumpers))
+  (check-type num-jumpers (unsigned-byte 14))
+  (with-inline-assembly (:returns :eax)
+    (:compile-two-forms (:eax :ebx) num-jumpers funobj)
+    (:movw :ax (:ebx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)))))
 
 (defun funobj-constant-ref (funobj index)
   (check-type funobj compiled-function)
@@ -333,9 +337,10 @@
        (make-array (length code-vector)
 		   :element-type 'u8
 		   :initial-contents code-vector))))
-  (let ((funobj (inline-malloc (+ #.(bt:sizeof 'movitz:movitz-funobj)
-				  (* 4 (length constants)))
-			       :other-tag :funobj)))
+  (let ((funobj (malloc-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
+				 (length constants)))))
+    (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)
+      #.(movitz:tag :funobj))
     (setf (funobj-name funobj) name
 	  (funobj-code-vector funobj) code-vector
 	  ;; revert to default trampolines for now..
@@ -376,9 +381,10 @@
 
 (defun copy-funobj (old-funobj &optional (name (funobj-name old-funobj)))
   (let* ((num-constants (funobj-num-constants old-funobj))
-	 (funobj (inline-malloc (+ #.(bt:sizeof 'movitz:movitz-funobj)
-				   (* 4 num-constants))
-				:other-tag :funobj)))
+	 (funobj (malloc-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
+				  num-constants))))
+    (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)
+      (memref old-funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16))
     (setf (funobj-num-constants funobj) num-constants)
     (replace-funobj funobj old-funobj name)))
 




From ffjeld at common-lisp.net  Mon Mar 22 16:38:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:38:10 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <E1B5SRG-0005VH-00@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
A small change in strategy for allocating memory.

Date: Mon Mar 22 11:38:10 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.5 movitz/losp/muerte/los-closette.lisp:1.6
--- movitz/losp/muerte/los-closette.lisp:1.5	Thu Feb 26 06:40:44 2004
+++ movitz/losp/muerte/los-closette.lisp	Mon Mar 22 11:38:10 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.5 2004/02/26 11:40:44 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.6 2004/03/22 16:38:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -119,7 +119,7 @@
 
 
 (defun allocate-std-instance (class slots)
-  (let ((instance (inline-malloc #.(bt:sizeof 'movitz:movitz-std-instance) :tag :other)))
+  (let ((instance (malloc-clumps 2)))
     (setf (memref instance #.(bt:slot-offset 'movitz:movitz-struct 'movitz:type)
 		  0 :unsigned-byte8)
       #.(movitz:tag :std-instance))
@@ -1137,9 +1137,7 @@
     (check-type class structure-class)
     (let* ((slots (structure-slots class))
 	   (num-slots (length slots))
-	   (struct (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-struct)
-				     (* 4 num-slots)
-				     (if (evenp num-slots) 0 1)))))
+	   (struct (malloc-words num-slots)))
       (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)
 		    0 :lisp)
 	(class-name class))




From ffjeld at common-lisp.net  Mon Mar 22 16:38:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:38:20 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1B5SRQ-00062s-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
A small change in strategy for allocating memory.

Date: Mon Mar 22 11:38:20 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.2 movitz/losp/muerte/symbols.lisp:1.3
--- movitz/losp/muerte/symbols.lisp:1.2	Mon Jan 19 06:23:47 2004
+++ movitz/losp/muerte/symbols.lisp	Mon Mar 22 11:38:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.3 2004/03/22 16:38:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -120,8 +120,20 @@
      (not (eq (movitz-accessor symbol movitz-symbol function-value)
 	      (load-global-constant movitz::unbound-function))))))
 
+(defun %other-to-symbol (x)
+  (with-inline-assembly (:returns :eax)
+    (:compile-form (:result-mode :eax) x)
+    (:leal (:eax 2) :ecx)
+    (:testb 7 :cl)
+    (:jnz '(:sub-program ()
+	    (:compile-form (:result-mode :ignore)
+	     (error "Not an other heap-object: ~S" x))
+	    (:jmp 'continue)))
+   continue
+    (:addl 1 :eax)))
+
 (defun make-symbol (name)
-  (let ((symbol (inline-malloc #.(bt:sizeof 'movitz::movitz-symbol) :tag :symbol)))
+  (let ((symbol (%other-to-symbol (malloc-clumps 3))))
     (setf-movitz-accessor (symbol movitz-symbol package) nil)
     (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name))
     (setf (symbol-flags symbol) 0




From ffjeld at common-lisp.net  Mon Mar 22 16:42:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:42:54 -0500
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1B5SVq-0000gV-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added a slot nursery-space to constant-block.

Date: Mon Mar 22 11:42:54 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.16 movitz/image.lisp:1.17
--- movitz/image.lisp:1.16	Fri Feb 13 17:03:16 2004
+++ movitz/image.lisp	Mon Mar 22 11:42:53 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.16 2004/02/13 22:03:16 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.17 2004/03/22 16:42:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -355,6 +355,13 @@
    (physical-address-offset
     :binary-type lu32
     :initform (image-ds-segment-base *image*))
+   (nursery-space
+    :binary-type word
+    :initform nil
+    :map-binary-write 'movitz-read-and-intern
+    :map-binary-read-delayed (lambda (x type)
+			       (declare (ignore x type))
+			       (movitz-read nil)))
    (stack-vector
     :binary-type word
     :initform nil
@@ -694,12 +701,11 @@
 
 (defun create-image (&key (init-file *default-image-init-file*)
 			  (start-address #x100000))
-  (#+allegro excl:tenuring #-allegro progn
-	     (psetq *image* (let ((*image* (make-movitz-image start-address)))
-			      (when init-file
-				(movitz-compile-file init-file))
-			      *image*)
-		    *i* (when (boundp '*image*) *image*)))
+  (psetq *image* (let ((*image* (make-movitz-image start-address)))
+		   (when init-file
+		     (movitz-compile-file init-file))
+		   *image*)
+	 *i* (when (boundp '*image*) *image*))
   *image*)
 
 (defun dump-image (&key (path *default-image-file*) ((:image *image*) *image*)




From ffjeld at common-lisp.net  Mon Mar 22 16:45:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 11:45:40 -0500
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1B5SYW-0002Rl-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Added a type-tag of a kind that probably won't ever be used for
anything, but who knows. I'll document this when GC works.

Date: Mon Mar 22 11:45:40 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.11 movitz/storage-types.lisp:1.12
--- movitz/storage-types.lisp:1.11	Fri Mar 19 05:49:39 2004
+++ movitz/storage-types.lisp	Mon Mar 22 11:45:39 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.11 2004/03/19 10:49:39 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.12 2004/03/22 16:45:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -72,6 +72,7 @@
   :funobj #x30
   :std-instance #x40
   :run-time-context #x50
+  :infant-object #x65
 
   ;; :simple-vector #x20
   ;; :character-vector 




From ffjeld at common-lisp.net  Mon Mar 22 17:08:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Mar 2004 12:08:15 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/io-space.lisp 
Message-ID: <E1B5SuN-0000a4-00@common-lisp.net>

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

Modified Files:
	io-space.lisp 
Log Message:
Make print-object method for io-space-devices more safe.

Date: Mon Mar 22 12:08:14 2004
Author: ffjeld

Index: movitz/losp/x86-pc/io-space.lisp
diff -u movitz/losp/x86-pc/io-space.lisp:1.2 movitz/losp/x86-pc/io-space.lisp:1.3
--- movitz/losp/x86-pc/io-space.lisp:1.2	Mon Jan 19 06:23:52 2004
+++ movitz/losp/x86-pc/io-space.lisp	Mon Mar 22 12:08:14 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue May  6 10:50:36 2003
 ;;;;                
-;;;; $Id: io-space.lisp,v 1.2 2004/01/19 11:23:52 ffjeld Exp $
+;;;; $Id: io-space.lisp,v 1.3 2004/03/22 17:08:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -79,8 +79,10 @@
 (defmethod print-object ((device io-space-device) stream)
   (print-unreadable-object (device stream :type t)
     (format stream "~@[ ~A~]~@[ @ I/O #x~X~]"
-	    (device-name device)
-	    (io-range-start (first (io-space device)))))
+	    (when (slot-boundp device 'device-name)
+	      (device-name device))
+	    (when (slot-boundp device 'allocated-io-space)
+	      (io-range-start (first (io-space device))))))
   device)
 
 (defvar *io-space-register* nil)	; a list of io-space devices.




From ffjeld at common-lisp.net  Tue Mar 23 10:53:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Mar 2004 05:53:25 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1B5jXB-00087F-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Added operator %word-offset that constructs a new word by adding some
offset. Use with extreme care, obviously.

Date: Tue Mar 23 05:53:25 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.4 movitz/losp/muerte/basic-functions.lisp:1.5
--- movitz/losp/muerte/basic-functions.lisp:1.4	Mon Mar 22 11:37:51 2004
+++ movitz/losp/muerte/basic-functions.lisp	Tue Mar 23 05:53:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.4 2004/03/22 16:37:51 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.5 2004/03/23 10:53:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -343,16 +343,15 @@
 (defun halt-cpu ()
   (halt-cpu))
 
-(defun malloc-words (words)
-  (malloc-clumps (1+ (truncate (1+ words) 2))))
+(define-compiler-macro %word-offset (&environment env word offset)
+  (if (movitz:movitz-constantp offset env)
+      `(with-inline-assembly (:returns :eax)
+	 (:compile-form (:result-mode :eax) ,word)
+	 (:addl ,(movitz:movitz-eval offset env) :eax))
+    `(with-inline-assembly (:returns :eax)
+       (:compile-two-forms (:eax :ecx) ,word ,offset)
+       (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+       (:addl :ecx :eax))))
 
-(defun malloc-clumps (clumps)
-  (let ((x (with-inline-assembly (:returns :eax :side-effects t)
-	     (:compile-form (:result-mode :ebx) clumps)
-	     (:shll 1 :ebx)
-	     (:globally (:call (:edi (:edi-offset malloc))))
-	     (:addl #.(movitz::tag :other) :eax))))
-    (dotimes (i clumps)
-      (setf (memref x -6 i :lisp) nil
-	    (memref x -2 i :lisp) nil))
-    x))
+(defun %word-offset (word offset)
+  (%word-offset word offset))
\ No newline at end of file




From ffjeld at common-lisp.net  Tue Mar 23 11:18:30 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Mar 2004 06:18:30 -0500
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1B5jvS-0003FD-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Added funobj-num-jumpers.

Date: Tue Mar 23 06:18:30 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.7 movitz/packages.lisp:1.8
--- movitz/packages.lisp:1.7	Wed Mar 17 11:36:36 2004
+++ movitz/packages.lisp	Tue Mar 23 06:18:30 2004
@@ -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.7 2004/03/17 16:36:36 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.8 2004/03/23 11:18:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1165,6 +1165,7 @@
 	   funobj-lambda-list
 	   funobj-name
 	   funobj-num-constants
+	   funobj-num-jumpers
 	   funobj-constant-ref
 	   funobj-debug-info
 	   install-function




From ffjeld at common-lisp.net  Wed Mar 24 11:24:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 06:24:43 -0500
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1B66V1-00045F-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Added a type pointer, which is approximately (not (or character fixnum null)).

Date: Wed Mar 24 06:24:39 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.8 movitz/packages.lisp:1.9
--- movitz/packages.lisp:1.8	Tue Mar 23 06:18:30 2004
+++ movitz/packages.lisp	Wed Mar 24 06:24:35 2004
@@ -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.8 2004/03/23 11:18:30 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.9 2004/03/24 11:24:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1155,6 +1155,7 @@
 	   vector-u8
 	   vector-u16
 	   vector-u32
+	   pointer
 	   
 	   make-funobj
 	   funobj-type




From ffjeld at common-lisp.net  Wed Mar 24 11:24:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 06:24:54 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1B66VC-0004zg-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Added a type pointer, which is approximately (not (or character fixnum null)).

Date: Wed Mar 24 06:24:53 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.3 movitz/losp/muerte/typep.lisp:1.4
--- movitz/losp/muerte/typep.lisp:1.3	Thu Feb 26 08:43:00 2004
+++ movitz/losp/muerte/typep.lisp	Wed Mar 24 06:24:52 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.3 2004/02/26 13:43:00 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.4 2004/03/24 11:24:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -187,6 +187,15 @@
 		(tag4 (make-tag-typep :tag4))
 		(tag5 (make-tag-typep :null))
 		(tag6 (make-tag-typep :other))
+		(pointer
+		 `(with-inline-assembly-case ()
+		    (do-case (t :boolean-zf=0 :labels (done))
+		      (:compile-form (:result-mode :eax) ,object)
+		      (:testb ,movitz::+movitz-fixnum-zmask+ :al)
+		      (:jz 'done)
+		      (:leal (:eax 6) :ecx) ; => cons:7, other:4, symbol:5, fixnum:6
+		      (:testb #b100 :cl)
+		     done)))
 		(std-instance 
 		 (make-other-typep :std-instance)
 		 #+ignore (make-tag-typep :std-instance))
@@ -205,7 +214,7 @@
 		(character
 		 `(with-inline-assembly (:returns :boolean-zf=1)
 		    (:compile-form (:result-mode :eax) ,object)
-		    (:cmpb ,(movitz::tag :character) :al)))
+		    (:cmpb ,(movitz:tag :character) :al)))
 		((function compiled-function)
 		 (make-other-typep :funobj))
 		((vector array)
@@ -327,10 +336,14 @@
 (define-simple-typep (cons consp) (obj)
   (typep obj 'cons))
 
+(define-simple-typep (pointer pointerp) (obj)
+  (typep obj 'pointer))
+
 (define-typep cons (x &optional (car '*) (cdr '*))
   (and (typep x 'cons)
        (or (eq '* car) (typep (car x) car))
        (or (eq '* cdr) (typep (cdr x) cdr))))
+
 
 (define-simple-typep (atom atom) (x)
   (typep x 'atom))




From ffjeld at common-lisp.net  Wed Mar 24 13:20:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:20:28 -0500
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1B68J2-0008FQ-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Re-arranged storage for multi-boot header so that it doesn't mess up
(GC) scanning.

Date: Wed Mar 24 08:20:25 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.17 movitz/image.lisp:1.18
--- movitz/image.lisp:1.17	Mon Mar 22 11:42:53 2004
+++ movitz/image.lisp	Wed Mar 24 08:20:24 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.17 2004/03/22 16:42:53 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.18 2004/03/24 13:20:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -870,8 +870,12 @@
 		      (format t "~&;; No multiboot header.")
 		    ;; Update multiboot header, symbolic and in the file..
 		    (let* ((mb (image-multiboot-header *image*))
-			   (mb-address (+ (movitz-intern mb) (image-ds-segment-base *image*)))
-			   (mb-file-position (- (+ mb-address 512) load-address)))
+			   (mb-address (+ (movitz-intern mb)
+					  (slot-offset 'multiboot-header 'magic)
+					  (image-ds-segment-base *image*)))
+			   (mb-file-position (- (+ mb-address 512)
+						load-address
+						(slot-offset 'multiboot-header 'magic))))
 		      (when (< load-address #x100000)
 			(warn "Multiboot load-address #x~x is below the 1MB mark."
 			      load-address))




From ffjeld at common-lisp.net  Wed Mar 24 13:20:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:20:52 -0500
Subject: [movitz-cvs] CVS update: movitz/multiboot.lisp 
Message-ID: <E1B68JQ-0000af-00@common-lisp.net>

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

Modified Files:
	multiboot.lisp 
Log Message:
Re-arranged storage for multi-boot header so that it doesn't mess up
(GC) scanning.

Date: Wed Mar 24 08:20:50 2004
Author: ffjeld

Index: movitz/multiboot.lisp
diff -u movitz/multiboot.lisp:1.2 movitz/multiboot.lisp:1.3
--- movitz/multiboot.lisp:1.2	Mon Jan 19 06:23:41 2004
+++ movitz/multiboot.lisp	Wed Mar 24 08:20:49 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Jun 12 12:14:12 2002
 ;;;;                
-;;;; $Id: multiboot.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $
+;;;; $Id: multiboot.lisp,v 1.3 2004/03/24 13:20:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -36,7 +36,16 @@
 (defconstant +multiboot-header-magic-value+  #x1BADB002)
 
 (define-binary-class multiboot-header (movitz-heap-object)
-  ((magic
+  ((scan-skip-header
+    :binary-type word
+    :initform +scan-skip-word+)
+   (scan-skip-length
+    :binary-type word
+    :initform 0
+    :map-binary-write (lambda (x type)
+			(declare (ignore x y))
+			(- (sizeof 'multiboot-header) 8)))
+   (magic
     :accessor magic
     :initform +multiboot-header-magic-value+
     :initarg :magic




From ffjeld at common-lisp.net  Wed Mar 24 13:22:33 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:22:33 -0500
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1B68L3-0002yH-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
More small changes for GC scanning.

Date: Wed Mar 24 08:22:31 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.12 movitz/storage-types.lisp:1.13
--- movitz/storage-types.lisp:1.12	Mon Mar 22 11:45:39 2004
+++ movitz/storage-types.lisp	Wed Mar 24 08:22:27 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.12 2004/03/22 16:45:39 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.13 2004/03/24 13:22:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -67,9 +67,9 @@
   :other 6
   :symbol 7
   
-  :vector #x10
+  :vector #x1a
   :defstruct #x20
-  :funobj #x30
+  :funobj #x3a
   :std-instance #x40
   :run-time-context #x50
   :infant-object #x65
@@ -81,6 +81,8 @@
   )
 
 (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum))
+(defparameter +scan-skip-word+ #x00000003)
+
 
 (defun tag (type)
   (bt:enum-value 'other-type-byte type))




From ffjeld at common-lisp.net  Wed Mar 24 13:25:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:25:13 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1B68Nd-0002xt-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Add local *package* binding around top-level.

Date: Wed Mar 24 08:25:13 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.4 movitz/losp/los0.lisp:1.5
--- movitz/losp/los0.lisp:1.4	Mon Mar 22 04:49:11 2004
+++ movitz/losp/los0.lisp	Wed Mar 24 08:25:13 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.4 2004/03/22 09:49:11 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.5 2004/03/24 13:25:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -840,7 +840,8 @@
   (let ((*repl-readline-context* (make-readline-context :history-size 16))
 	(*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
 	#+ignore (*error-no-condition-for-debugger* t)
-	(*debugger-function* #'los0-debugger))
+	(*debugger-function* #'los0-debugger)
+	(*package* nil))
 
     (with-simple-restart (continue "Abort LOS0 boot-up initialization.")
       (setf *cpu-features*




From ffjeld at common-lisp.net  Wed Mar 24 13:31:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:31:46 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1B68Ty-0004lj-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
In make-symbol, use %word-offset rather than %other-to-symbol.

Date: Wed Mar 24 08:31:45 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.3 movitz/losp/muerte/symbols.lisp:1.4
--- movitz/losp/muerte/symbols.lisp:1.3	Mon Mar 22 11:38:20 2004
+++ movitz/losp/muerte/symbols.lisp	Wed Mar 24 08:31:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.3 2004/03/22 16:38:20 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.4 2004/03/24 13:31:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -120,20 +120,10 @@
      (not (eq (movitz-accessor symbol movitz-symbol function-value)
 	      (load-global-constant movitz::unbound-function))))))
 
-(defun %other-to-symbol (x)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) x)
-    (:leal (:eax 2) :ecx)
-    (:testb 7 :cl)
-    (:jnz '(:sub-program ()
-	    (:compile-form (:result-mode :ignore)
-	     (error "Not an other heap-object: ~S" x))
-	    (:jmp 'continue)))
-   continue
-    (:addl 1 :eax)))
-
 (defun make-symbol (name)
-  (let ((symbol (%other-to-symbol (malloc-clumps 3))))
+  (eval-when (:compile-toplevel)
+    (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other)))))
+  (let ((symbol (%word-offset (malloc-clumps 3) 1)))
     (setf-movitz-accessor (symbol movitz-symbol package) nil)
     (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name))
     (setf (symbol-flags symbol) 0




From ffjeld at common-lisp.net  Wed Mar 24 13:33:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:33:21 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1B68VV-00069m-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Rewrote %funobj-code-vector accessor in terms of memref and
%word-offset. The reader apparently compiles to the same as my
hand-written assembly :-)

Date: Wed Mar 24 08:33:21 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.3 movitz/losp/muerte/functions.lisp:1.4
--- movitz/losp/muerte/functions.lisp:1.3	Mon Mar 22 11:38:05 2004
+++ movitz/losp/muerte/functions.lisp	Wed Mar 24 08:33:21 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.3 2004/03/22 16:38:05 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.4 2004/03/24 13:33:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -86,20 +86,14 @@
 
 (defun funobj-code-vector (funobj)
   (check-type funobj compiled-function)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) funobj)
-    (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :eax)
-    (:subl 2 :eax)))			; this cell stores word+2
+  (%word-offset (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :lisp)
+		-2))
 
 (defun (setf funobj-code-vector) (code-vector funobj)
   (check-type funobj compiled-function)
   (check-type code-vector vector-u8)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :ebx) funobj)
-    (:compile-form (:result-mode :eax) code-vector)
-    (:addl 2 :eax)			; this cell stores word+2
-    (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)))
-    (:subl 2 :eax)))
+  (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :lisp)
+    (%word-offset code-vector 2)))
 
 (defun funobj-code-vector%1op (funobj)
   "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either




From ffjeld at common-lisp.net  Wed Mar 24 13:34:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:34:54 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <E1B68X0-0002te-00@common-lisp.net>

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

Modified Files:
	debugger.lisp 
Log Message:
Take pains not to have backtrace do any consing. It used to cons up
the print-leadin flet, because it closed over a couple of variables
and the compiler isn't too smart about such closures (yet).

Date: Wed Mar 24 08:34:53 2004
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.3 movitz/losp/x86-pc/debugger.lisp:1.4
--- movitz/losp/x86-pc/debugger.lisp:1.3	Fri Feb 13 17:11:38 2004
+++ movitz/losp/x86-pc/debugger.lisp	Wed Mar 24 08:34:53 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.3 2004/02/13 22:11:38 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.4 2004/03/24 13:34:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -69,6 +69,7 @@
 (defvar *backtrace-do-fresh-lines* t)
 (defvar *backtrace-print-length* 3)
 (defvar *backtrace-print-level* 2)
+(defvar *backtrace-print-frames* nil)
 
 (defun pointer-in-range (x)
   (with-inline-assembly (:returns :boolean-cf=1)
@@ -443,16 +444,17 @@
 			(or *debugger-invoked-stack-frame*
 			    (current-stack-frame)))
 		       ((:spartan *backtrace-be-spartan-p*))
+		       ((:fresh-lines *backtrace-do-fresh-lines*) *backtrace-do-fresh-lines*)
 		       (conflate *backtrace-do-conflate*)
 		       (length *backtrace-length*)
-		       print-frames)
+		       ((:print-frames *backtrace-print-frames*) *backtrace-print-frames*))
   (let ((*standard-output* *debug-io*)
 	(*print-length* *backtrace-print-length*)
 	(*print-level* *backtrace-print-level*))
     (loop with conflate-count = 0 with count = 0
 	for stack-frame = initial-stack-frame then (stack-frame-uplink stack-frame)
 	as funobj = (stack-frame-funobj stack-frame t)
-	do (flet ((print-leadin (count conflate-count)
+	do (flet ((print-leadin (stack-frame count conflate-count)
 		    (when *backtrace-do-fresh-lines*
 		      (fresh-line))
 		    (cond
@@ -463,8 +465,8 @@
 			(write-string "="))
 		      (write-char #\space))
 		     (t (format t "~& |= ")))
-		    (when print-frames
-		       (format t "#x~X " stack-frame))))
+		    (when *backtrace-print-frames*
+		      (format t "#x~X " stack-frame))))
 	     (typecase funobj
 	       (integer
 		(let* ((int-frame funobj)
@@ -476,7 +478,7 @@
 		      (incf conflate-count)
 		    (progn
 		      (incf count)
-		      (print-leadin count conflate-count)
+		      (print-leadin stack-frame count conflate-count)
 		      (setf conflate-count 0)
 		      (let ((exception (int-frame-ref int-frame :exception :unsigned-byte32))
 			    (eip (int-frame-ref int-frame :eip :unsigned-byte32)))
@@ -504,7 +506,7 @@
 				  (< count length))
 			(write-string " ...")
 			(return))
-		      (print-leadin count conflate-count)
+		      (print-leadin stack-frame count conflate-count)
 		      (setf conflate-count 0)
 		      (write-char #\()
 		      (let* ((numargs (stack-frame-numargs stack-frame))




From ffjeld at common-lisp.net  Wed Mar 24 13:36:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 08:36:27 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp 
Message-ID: <E1B68YV-0004UF-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Interrupts 67 and 68 are used as a very primitive tracing mechanism.

Date: Wed Mar 24 08:36:26 2004
Author: ffjeld

Index: movitz/losp/x86-pc/interrupt.lisp
diff -u movitz/losp/x86-pc/interrupt.lisp:1.3 movitz/losp/x86-pc/interrupt.lisp:1.4
--- movitz/losp/x86-pc/interrupt.lisp:1.3	Mon Jan 19 06:23:52 2004
+++ movitz/losp/x86-pc/interrupt.lisp	Wed Mar 24 08:36:26 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri May  4 18:08:50 2001
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.4 2004/03/24 13:36:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -176,7 +176,12 @@
 		     (int-frame-ref int-frame :error-code :unsigned-byte32)
 		     $eax $ebx $ecx))
 	  (68 (warn "EIP: ~@Z EAX: ~@Z EBX: ~@Z  ECX: ~@Z EDX: ~@Z"
-		    $eip $eax $ebx $ecx $edx))
+		    $eip $eax $ebx $ecx $edx)
+	      (dotimes (i 100000)
+		(with-inline-assembly (:returns :nothing) (:nop))))
+	  (67 (muerte.debug:backtrace :fresh-lines nil :length 6)
+	      (dotimes (i 100000)
+		(with-inline-assembly (:returns :nothing) (:nop))))
 	  (66 (error "Unspecified type error in ~S with EAX=~@Z, ECX=~@Z."
 		     (@ (+ int-frame (int-frame-index :esi)))
 		     $eax $ecx))




From ffjeld at common-lisp.net  Wed Mar 24 18:36:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 13:36:41 -0500
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1B6DF3-0007rE-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
The compiler for m-v-bind was buggy when its binding were lended. This
should fix it.

Date: Wed Mar 24 13:36:41 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.11 movitz/special-operators-cl.lisp:1.12
--- movitz/special-operators-cl.lisp:1.11	Sat Feb 14 12:33:40 2004
+++ movitz/special-operators-cl.lisp	Wed Mar 24 13:36:41 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.11 2004/02/14 17:33:40 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.12 2004/03/24 18:36:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -468,7 +468,8 @@
 					     :protect-carry t
 					     :protect-registers (:eax :ebx))
 			       (:store-lexical ,(first lexical-bindings) :eax
-					       :type ,(type-specifier-primary values-type))
+					       :type ,(type-specifier-primary values-type)
+					       :protect-registers (:ebx))
 			       (:init-lexvar ,(second lexical-bindings)
 					     :protect-carry t
 					     :protect-registers (:ebx))
@@ -490,14 +491,17 @@
 				     append
 				       (case pos
 					 (0 `((:init-lexvar ,binding
-							    :protect-registers '(:eax :ebx :ecx))
-					      (:store-lexical ,binding :eax :type ,type)))
+							    :protect-registers (:eax :ebx :ecx))
+					      (:store-lexical ,binding :eax :type ,type
+							      :protect-registers (:eax :ebx :ecx))))
 					 (1 `((:init-lexvar ,binding
-							    :protect-registers '(:ebx :ecx))
-					      (:store-lexical ,binding :edi :type null)
+							    :protect-registers (:ebx :ecx))
+					      (:store-lexical ,binding :edi :type null
+							      :protect-registers (:ecx))
 					      (:cmpl 1 :ecx)
 					      (:jbe ',skip-label)
-					      (:store-lexical ,binding :ebx :type ,type)
+					      (:store-lexical ,binding :ebx :type ,type
+							      :protect-registers (:ecx))
 					      ,skip-label))
 					 (t (if *compiler-use-cmov-p*
 						`((:init-lexvar ,binding :protect-registers '(:ecx))
@@ -506,7 +510,8 @@
 						  (:locally (:cmova (:edi (:edi-offset values
 										       ,(* 4 (- pos 2))))
 								    :eax))
-						  (:store-lexical ,binding :eax :type ,type))
+						  (:store-lexical ,binding :eax :type ,type
+								  :protect-registers (:eax)))
 					      `((:init-lexvar ,binding :protect-registers '(:ecx))
 						(:movl :edi :eax)
 						(:cmpl ,pos :ecx)
@@ -515,7 +520,8 @@
 										    ,(* 4 (- pos 2))))
 								 :eax))
 						,skip-label
-						(:store-lexical ,binding :eax :type ,type)))))))))))))))
+						(:store-lexical ,binding :eax :type ,type
+								:protect-registers (:ecx))))))))))))))))
 	  (compiler-values-bind (&code body-code &returns body-returns-mode)
 	      (compiler-call #'compile-form-unprotected
 		:defaults forward




From ffjeld at common-lisp.net  Wed Mar 24 18:38:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 13:38:19 -0500
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1B6DGd-0002xE-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Improved propagation of :protect-registers somewhat.

Date: Wed Mar 24 13:38:18 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.33 movitz/compiler.lisp:1.34
--- movitz/compiler.lisp:1.33	Thu Feb 26 08:48:42 2004
+++ movitz/compiler.lisp	Wed Mar 24 13:38:18 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.33 2004/02/26 13:48:42 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.34 2004/03/24 18:38:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2436,9 +2436,12 @@
 	  (destructuring-bind (binding &key init-with-register init-with-type
 					    protect-registers protect-carry)
 	      (cdr i)
-	    (declare (ignore binding protect-registers protect-carry init-with-type))
+	    (declare (ignore binding protect-carry init-with-type))
 	    (when init-with-register
-	      (setf free-so-far (remove init-with-register free-so-far)))))
+	      (setf free-so-far (remove-if (lambda (x)
+					     (or (eq x init-with-register)
+						 (member x protect-registers)))
+					   free-so-far)))))
 	 (t (case (instruction-is i)
 	      ((nil :call)
 	       (return nil))
@@ -5575,12 +5578,13 @@
     (list source)))
 
 (define-extended-code-expander :store-lexical (instruction funobj frame-map)
-  (destructuring-bind (destination source &key shared-reference-p type)
+  (destructuring-bind (destination source &key shared-reference-p type protect-registers)
       (cdr instruction)
     (declare (ignore type))
     (make-store-lexical (ensure-local-binding destination funobj)
 			(ensure-local-binding source funobj)
-			shared-reference-p frame-map)))
+			shared-reference-p frame-map
+			:protect-registers protect-registers)))
 
 ;;;;;;;;;;;;;;;;;; Init-lexvar
 




From ffjeld at common-lisp.net  Wed Mar 24 18:39:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 13:39:42 -0500
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1B6DHy-0007ou-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added muerte:*build-number* magic variable that gets initialized to
the build number, aka. bootblock ID.

Date: Wed Mar 24 13:39:42 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.18 movitz/image.lisp:1.19
--- movitz/image.lisp:1.18	Wed Mar 24 08:20:24 2004
+++ movitz/image.lisp	Wed Mar 24 13:39:42 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.18 2004/03/24 13:20:24 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.19 2004/03/24 18:39:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -718,6 +718,8 @@
     (format t "~&;; Doing initiating dump..")
     (dump-image :path path :multiboot-p multiboot-p :ignore-dump-count t)
     (assert (plusp (dump-count *image*))))
+  (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*))
+    (1+ *bootblock-build*))
   (let ((load-address (image-start-address *image*)))
     (setf (image-cons-pointer *image*) (- load-address
 					  (image-ds-segment-base *image*))




From ffjeld at common-lisp.net  Wed Mar 24 18:39:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 13:39:47 -0500
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1B6DI3-0007rc-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Added muerte:*build-number* magic variable that gets initialized to
the build number, aka. bootblock ID.

Date: Wed Mar 24 13:39:47 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.9 movitz/packages.lisp:1.10
--- movitz/packages.lisp:1.9	Wed Mar 24 06:24:35 2004
+++ movitz/packages.lisp	Wed Mar 24 13:39:47 2004
@@ -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.9 2004/03/24 11:24:35 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.10 2004/03/24 18:39:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1111,7 +1111,8 @@
 	   stack-frame-call-site
 	   stack-frame-ref
 	   check-stack-limit
-	   
+
+	   *build-number*
 	   *error-no-condition-for-debugger*
 	   formatted-error
 




From ffjeld at common-lisp.net  Wed Mar 24 18:39:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 13:39:53 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp 
Message-ID: <E1B6DI9-00085t-00@common-lisp.net>

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

Modified Files:
	variables.lisp 
Log Message:
Added muerte:*build-number* magic variable that gets initialized to
the build number, aka. bootblock ID.

Date: Wed Mar 24 13:39:53 2004
Author: ffjeld

Index: movitz/losp/muerte/variables.lisp
diff -u movitz/losp/muerte/variables.lisp:1.1.1.1 movitz/losp/muerte/variables.lisp:1.2
--- movitz/losp/muerte/variables.lisp:1.1.1.1	Tue Jan 13 06:05:06 2004
+++ movitz/losp/muerte/variables.lisp	Wed Mar 24 13:39:53 2004
@@ -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.1.1.1 2004/01/13 11:05:06 ffjeld Exp $
+;;;; $Id: variables.lisp,v 1.2 2004/03/24 18:39:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -37,3 +37,5 @@
 (defparameter *debugger-hook* nil)
 
 (defvar internal-time-units-per-second)
+
+(defvar *build-number* :unknown)
\ No newline at end of file




From ffjeld at common-lisp.net  Wed Mar 24 19:30:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 14:30:15 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <E1B6E4t-00047n-00@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
Fixed ~{ format directive which didn't play quite right with ~^.

Date: Wed Mar 24 14:30:15 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.2 movitz/losp/muerte/format.lisp:1.3
--- movitz/losp/muerte/format.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/format.lisp	Wed Mar 24 14:30:15 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Mar 23 01:18:36 2002
 ;;;;                
-;;;; $Id: format.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.3 2004/03/24 19:30:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -241,10 +241,10 @@
 			   (multiple-value-setq (i args)
 			     (format-by-string control-string (1+ i) (1- loop-limit) args))))
 			(t (let ((loop-args (pop args)))
-			     (if (or (zerop loop-limit) (null loop-args))
-				 (setf i (skip-iteration control-string (1+ i)))
-			       (setf i (format-by-string control-string (1+ i)
-							 (1- loop-limit) loop-args)))))))))
+			     (unless (or (zerop loop-limit) (null loop-args))
+			       (format-by-string control-string (1+ i)
+						 (1- loop-limit) loop-args))
+			     (setf i (skip-iteration control-string (1+ i)))))))))
 	      (#\} (if (and args (or (not loop-limit) (not (zerop loop-limit))))
 		       (setf loop-limit (and loop-limit (1- loop-limit))
 			     i (1- start))




From ffjeld at common-lisp.net  Wed Mar 24 19:33:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 14:33:40 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <E1B6E8C-0007VX-00@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Re-wrote trace-wrapper not to cons.

Date: Wed Mar 24 14:33:40 2004
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.2 movitz/losp/muerte/environment.lisp:1.3
--- movitz/losp/muerte/environment.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/environment.lisp	Wed Mar 24 14:33:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Oct 20 00:41:57 2001
 ;;;;                
-;;;; $Id: environment.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.3 2004/03/24 19:33:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -88,14 +88,16 @@
 	      (write-string "  " *trace-output*))
 	    (format *trace-output* "~D: (~S~{ ~S~})~%"
 		    *trace-level* function-name args))
-	  (let ((result (let ((*trace-level* (1+ *trace-level*)))
-			  (multiple-value-list (apply function args))))
-		(*trace-escape* t))
-	    (fresh-line *trace-output*)
-	    (dotimes (i *trace-level*)
-	      (write-string "  " *trace-output*))
-	    (format *trace-output* "~D: => ~:S~%" *trace-level* result)
-	    (values-list result)))))))
+	  (multiple-value-call
+	      (lambda (&rest results)
+		(declare (dynamic-extent results))
+		(let ((*trace-escape* t))
+		  (fresh-line *trace-output*)
+		  (dotimes (i *trace-level*)
+		    (write-string "  " *trace-output*))
+		  (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results)
+		  (values-list results)))
+	    (apply function args)))))))
 
 (defun do-trace (function-name &key (callers t))
   (when (assoc function-name *trace-map* :test #'equal)




From ffjeld at common-lisp.net  Wed Mar 24 20:40:42 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 15:40:42 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1B6FB4-0007lW-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Removed small pieces of dead code.

Date: Wed Mar 24 15:40:41 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.4 movitz/losp/muerte/functions.lisp:1.5
--- movitz/losp/muerte/functions.lisp:1.4	Wed Mar 24 08:33:21 2004
+++ movitz/losp/muerte/functions.lisp	Wed Mar 24 15:40:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.4 2004/03/24 13:33:21 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.5 2004/03/24 20:40:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -56,8 +56,7 @@
 			       complement-prototype
 			       (function ,(movitz:movitz-eval (translate-program function-form
 									      :cl :muerte.cl)))))
-   (t #+ignore (error "Non-constant complement forms not yet supported: ~S" form)
-      form)))
+   (t form)))
 
 (defun complement (function)
   (lambda (&rest args)
@@ -72,8 +71,7 @@
 			 (compiled-function
 			  (funobj-name edx))
 			 (t '(unknown)))))
-    (error 'undefined-function :name function-name)
-    #+ignore (error "Unbound function-name ~S called with arguments ~S." function-name args)))
+    (error 'undefined-function :name function-name)))
 
 ;;; funobj object
 




From ffjeld at common-lisp.net  Wed Mar 24 23:42:49 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 18:42:49 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp 
Message-ID: <E1B6I1J-000111-00@common-lisp.net>

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

Modified Files:
	variables.lisp 
Log Message:
Use declaim rather than defvar for *build-number*.

Date: Wed Mar 24 18:42:49 2004
Author: ffjeld

Index: movitz/losp/muerte/variables.lisp
diff -u movitz/losp/muerte/variables.lisp:1.2 movitz/losp/muerte/variables.lisp:1.3
--- movitz/losp/muerte/variables.lisp:1.2	Wed Mar 24 13:39:53 2004
+++ movitz/losp/muerte/variables.lisp	Wed Mar 24 18:42:49 2004
@@ -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.2 2004/03/24 18:39:53 ffjeld Exp $
+;;;; $Id: variables.lisp,v 1.3 2004/03/24 23:42:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -38,4 +38,4 @@
 
 (defvar internal-time-units-per-second)
 
-(defvar *build-number* :unknown)
\ No newline at end of file
+(declaim (special *build-number*))
\ No newline at end of file




From ffjeld at common-lisp.net  Thu Mar 25 00:40:37 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 19:40:37 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <E1B6IvF-00045w-00@common-lisp.net>

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

Modified Files:
	repl.lisp 
Log Message:
Some refactoring of read-eval-print. Now supports *repl-consless*
which basically disables the / // /// variables, in order not to cons
up lists for them.

Date: Wed Mar 24 19:40:37 2004
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.4 movitz/losp/lib/repl.lisp:1.5
--- movitz/losp/lib/repl.lisp:1.4	Wed Feb 18 06:48:20 2004
+++ movitz/losp/lib/repl.lisp	Wed Mar 24 19:40:35 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 19 14:58:12 2003
 ;;;;                
-;;;; $Id: repl.lisp,v 1.4 2004/02/18 11:48:20 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.5 2004/03/25 00:40:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,8 +23,9 @@
 (defparameter *repl-level* -1)
 (defparameter *repl-prompter* 'default-repl-prompter)
 (defparameter *repl-prompt-context* nil)
-(defparameter *repl-print-format* "~{~&~W~}")
+(defparameter *repl-print-format* "~@{~&~W~}")
 (defvar *repl-readline-context*)
+(defvar *repl-consless* nil)
 
 (defun default-repl-prompter ()
   (fresh-line)
@@ -44,37 +45,41 @@
 	  (terpri)
 	  (multiple-value-bind (form buffer-pointer)
 	      (handler-bind
-		  ((muerte::missing-delimiter
-		    (lambda (c)
-		      (declare (ignore c))
-		      (format t "~&> ")
-		      (invoke-restart 'muerte::next-line
-				      (muerte.readline:contextual-readline *repl-readline-context*)))))
+		  (#+ignore (muerte::missing-delimiter
+			     (lambda (c)
+			       (declare (ignore c))
+			       (format t "~&> ")
+			       (invoke-restart 'muerte::next-line
+					       (muerte.readline:contextual-readline *repl-readline-context*)))))
 		(simple-read-from-string buffer-string t t))
-	    (let ((results (multiple-value-list
-			    (if (keywordp form)
-				(apply 'muerte.toplevel:invoke-toplevel-command
-				       form
-				       (loop for arg = (multiple-value-bind (arg x)
-							   (simple-read-from-string
-							    buffer-string nil 'eof
-							    :start buffer-pointer)
-							 (setq buffer-pointer x)
-							 arg)
-					   until (eq arg 'eof)
-					   collect arg))
-			      (eval form)))))
-	      (unless (boundp '*)
-		(warn "* was unbound!")
-		(setf * nil))
-	      (format t *repl-print-format* results)
-	      (psetq +++ ++ ++ + + form)
-	      (psetq *** ** ** * * (first results))
-	      (psetq /// // // / / results))
-	    (unless (packagep *package*)
-	      (warn "Resetting *package*..")
-	      (setf *package* previous-package))))
-	(values-list /))
+	    (multiple-value-call
+		(lambda (form previous-package &rest results)
+		  (declare (dynamic-extent results))
+		  (unless (packagep *package*)
+		    (warn "Resetting *package*")
+		    (setf *package* previous-package))
+		  (unless (boundp '*)
+		    (warn "* was unbound!")
+		    (setf * nil))
+		  (apply #'format t *repl-print-format* results)
+		  (psetq +++ ++ ++ + + form)
+		  (psetq *** ** ** * * (car results))
+		  (psetq /// // // / / (if *repl-consless*
+					   nil
+					 (copy-list results)))
+		  (values-list results))
+	      form previous-package
+	      (if (not (keywordp form))
+		  (eval form)
+		(apply 'muerte.toplevel:invoke-toplevel-command
+		       form
+		       (loop for arg = (multiple-value-bind (arg x)
+					   (simple-read-from-string buffer-string nil 'eof
+								    :start buffer-pointer)
+					 (setq buffer-pointer x)
+					 arg)
+			   until (eq arg 'eof)
+			   collect arg)))))))
     #+ignore (muerte.readline::readline-break (c)
 	       (declare (ignore c))
 	       (values))))




From ffjeld at common-lisp.net  Thu Mar 25 00:52:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 19:52:54 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <E1B6J78-0001Uw-00@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Re-wrote the way tracing works. Use a designated closure for each
traced function, rather than the same trace-wrapper function for
everyone. Seems to work much better.

Date: Wed Mar 24 19:52:54 2004
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.3 movitz/losp/muerte/environment.lisp:1.4
--- movitz/losp/muerte/environment.lisp:1.3	Wed Mar 24 14:33:40 2004
+++ movitz/losp/muerte/environment.lisp	Wed Mar 24 19:52:54 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Oct 20 00:41:57 2001
 ;;;;                
-;;;; $Id: environment.lisp,v 1.3 2004/03/24 19:33:40 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.4 2004/03/25 00:52:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -67,60 +67,52 @@
        ((equal name 'eval)
 	(return nil))))))
 
-(defun trace-wrapper (&edx function-name-symbol &rest args)
-  (declare (dynamic-extent args))
-  (check-type function-name-symbol symbol)
-  (let ((map (assoc function-name-symbol *trace-map*
-		    :key #'function-name-symbol)))
-    (assert map ()
-      "~S is not traced!?" function-name-symbol)
-    (let ((function-name (car map))
-	  (function (cadr map))
-	  (callers (caddr map)))
-      (cond
-       ((or *trace-escape*
-	    (and (not (eq t callers))
-		 (notany 'match-caller callers)))
-	(apply function args))
-       (t (let ((*trace-escape* t))
-	    (fresh-line *trace-output*)
-	    (dotimes (i *trace-level*)
-	      (write-string "  " *trace-output*))
-	    (format *trace-output* "~D: (~S~{ ~S~})~%"
-		    *trace-level* function-name args))
-	  (multiple-value-call
-	      (lambda (&rest results)
-		(declare (dynamic-extent results))
-		(let ((*trace-escape* t))
-		  (fresh-line *trace-output*)
-		  (dotimes (i *trace-level*)
-		    (write-string "  " *trace-output*))
-		  (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results)
-		  (values-list results)))
-	    (apply function args)))))))
-
 (defun do-trace (function-name &key (callers t))
   (when (assoc function-name *trace-map* :test #'equal)
     (do-untrace function-name))
   (let ((function-symbol (function-name-symbol function-name)))
     (assert (fboundp function-symbol) (function-name)
       "Can't trace undefined function ~S." function-name)
-    (push (list function-name
-		(symbol-function function-symbol)
-		callers)
-	  *trace-map*)
-    (setf (symbol-function function-symbol)
-      #'trace-wrapper))
+    (let* ((real-function (symbol-function function-symbol))
+	   (wrapper (lambda (&rest args)
+		      (declare (dynamic-extent args))
+		      (if *trace-escape*
+			  (apply real-function args)
+			(let ((*trace-escape* t))
+			  (cond
+			   ((and (not (eq t callers))
+				 (notany 'match-caller callers))
+			    (apply real-function args))
+			   (t (let ((*trace-escape* t))
+				(fresh-line *trace-output*)
+				(dotimes (i *trace-level*)
+				  (write-string "  " *trace-output*))
+				(format *trace-output* "~D: (~S~{ ~S~})~%"
+					*trace-level* function-name args))
+			      (multiple-value-call
+				  (lambda (&rest results)
+				    (declare (dynamic-extent results))
+				    (let ((*trace-escape* t))
+				      (fresh-line *trace-output*)
+				      (dotimes (i *trace-level*)
+					(write-string "  " *trace-output*))
+				      (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results)
+				      (values-list results)))
+				(let ((*trace-level* (1+ *trace-level*))
+				      (*trace-escape* nil))
+				  (apply real-function args))))))))))
+      (push (cons function-name
+		  real-function)
+	    *trace-map*)
+      (setf (symbol-function function-symbol)
+	wrapper)))
   (values))
 
 (defun do-untrace (name)
   (let ((map (assoc name *trace-map*)))
     (assert map () "~S is not traced." name)
     (let ((function-name-symbol (function-name-symbol name))
-	  (function (cadr map)))
-      (unless (eq (symbol-function function-name-symbol)
-		  #'trace-wrapper)
-	(warn "~S was traced, but not fbound to trace-wrapper." name))
+	  (function (cdr map)))
       (setf (symbol-function function-name-symbol)
 	function)
       (setf *trace-map*




From ffjeld at common-lisp.net  Thu Mar 25 00:54:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 19:54:08 -0500
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1B6J8K-0002z2-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed nasty little bug in assign-bindings that would mess up
everything if a function argument variable was lended to some closure.

Date: Wed Mar 24 19:54:07 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.34 movitz/compiler.lisp:1.35
--- movitz/compiler.lisp:1.34	Wed Mar 24 13:38:18 2004
+++ movitz/compiler.lisp	Wed Mar 24 19:54:07 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.34 2004/03/24 18:38:18 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.35 2004/03/25 00:54:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2619,7 +2619,7 @@
 				   ((typep binding 'forwarding-binding))
 				   ((typep binding 'borrowed-binding))
 				   ((typep binding 'fixed-required-function-argument)
-				    (prog1 t
+				    (prog1 nil ; may need lending-cons
 				      (setf (new-binding-location binding frame-map)
 					:argument-stack)))
 				   ((not (plusp (or (car (gethash binding var-counts)) 0)))




From ffjeld at common-lisp.net  Thu Mar 25 00:55:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Mar 2004 19:55:12 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <E1B6J9M-0000xO-00@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Add "pointer" to the set of types that check-type inlines.

Date: Wed Mar 24 19:55:12 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.4 movitz/losp/muerte/basic-macros.lisp:1.5
--- movitz/losp/muerte/basic-macros.lisp:1.4	Fri Feb 20 10:10:43 2004
+++ movitz/losp/muerte/basic-macros.lisp	Wed Mar 24 19:55:12 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.4 2004/02/20 15:10:43 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.5 2004/03/25 00:55:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -510,7 +510,7 @@
    ((movitz:movitz-constantp place env)
     (assert (typep (movitz::eval-form place env) type))
     nil)
-   (t (if (member type '(standard-gf-instance  function
+   (t (if (member type '(standard-gf-instance  function pointer
 			 integer fixnum cons symbol character null list
 			 string vector simple-vector vector-u8 vector-u16))
 	  `(unless (typep ,place ',type)




From ffjeld at common-lisp.net  Thu Mar 25 09:24:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 04:24:01 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1B6R5l-0004xo-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Add notification about *build-number* in genesis.

Date: Thu Mar 25 04:24:01 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.5 movitz/losp/los0.lisp:1.6
--- movitz/losp/los0.lisp:1.5	Wed Mar 24 08:25:13 2004
+++ movitz/losp/los0.lisp	Thu Mar 25 04:24:00 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.5 2004/03/24 13:25:13 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.6 2004/03/25 09:24:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -595,9 +595,6 @@
 	(memref-int #x1000004 0 0 :unsigned-byte8)))
 
 
-
-
-
 ;;;;;
 
 ;;;;;;;;;;;;;;; CL
@@ -863,6 +860,7 @@
     (let ((* nil) (** nil) (*** nil)
 	  (/ nil) (// nil) (/// nil)
 	  (+ nil) (++ nil) (+++ nil))
+      (format t "~&Movitz image Los0 build ~D." *build-number*)
       (loop
 	(catch :top-level-repl		; If restarts don't work, you can throw this..
 	  (with-simple-restart (abort "Abort to the top command level.")




From ffjeld at common-lisp.net  Thu Mar 25 11:17:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 06:17:23 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B6SrT-00009o-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Remember to initialize flags fields when constructing simple-vectors.

Date: Thu Mar 25 06:17:22 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.7 movitz/losp/muerte/arrays.lisp:1.8
--- movitz/losp/muerte/arrays.lisp:1.7	Mon Mar 22 11:37:47 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Mar 25 06:17:22 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.7 2004/03/22 16:37:47 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.8 2004/03/25 11:17:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -555,12 +555,15 @@
 				     :other-tag :vector
 				     :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
 								      :any-t))))
-	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
-			 0 :unsigned-byte16)
-	     #.(movitz:vector-type-tag :any-t))
 	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 			 0 :unsigned-byte16)
 	     dimensions)
+	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
+			 0 :unsigned-byte16)
+	     0)
+	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
+			 0 :unsigned-byte16)
+	     #.(movitz:vector-type-tag :any-t))
 	   (setf (fill-pointer array) fill-pointer)
 	   (cond
 	    (initial-contents




From ffjeld at common-lisp.net  Thu Mar 25 11:27:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 06:27:02 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1B6T0o-0005GQ-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
The functions malloc-words and malloc-clumps are needed to do
anything, of course..

Date: Thu Mar 25 06:27:01 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.5 movitz/losp/muerte/basic-functions.lisp:1.6
--- movitz/losp/muerte/basic-functions.lisp:1.5	Tue Mar 23 05:53:25 2004
+++ movitz/losp/muerte/basic-functions.lisp	Thu Mar 25 06:27:00 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.5 2004/03/23 10:53:25 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.6 2004/03/25 11:27:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -354,4 +354,18 @@
        (:addl :ecx :eax))))
 
 (defun %word-offset (word offset)
-  (%word-offset word offset))
\ No newline at end of file
+  (%word-offset word offset))
+
+(defun malloc-words (words)
+  (malloc-clumps (1+ (truncate (1+ words) 2))))
+
+(defun malloc-clumps (clumps)
+  (let ((x (with-inline-assembly (:returns :eax :side-effects t)
+	     (:compile-form (:result-mode :ebx) clumps)
+	     (:shll 1 :ebx)
+	     (:globally (:call (:edi (:edi-offset malloc))))
+	     (:addl #.(movitz::tag :other) :eax))))
+    (dotimes (i clumps)
+      (setf (memref x -6 i :lisp) nil
+	    (memref x -2 i :lisp) nil))
+    x))




From ffjeld at common-lisp.net  Fri Mar 26 01:34:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:34:13 -0500
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1B6gEf-00054K-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Forgot to :init-lexvar &key bindings. Caused a nasty bug.

Date: Thu Mar 25 20:34:13 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.35 movitz/compiler.lisp:1.36
--- movitz/compiler.lisp:1.35	Wed Mar 24 19:54:07 2004
+++ movitz/compiler.lisp	Thu Mar 25 20:34:13 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.35 2004/03/25 00:54:07 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.36 2004/03/26 01:34:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -4079,7 +4079,9 @@
 		 (cond
 		  ((and (movitz-constantp (optional-function-argument-init-form binding))
 			(< 1 position))
-		   `(
+		   `((:init-lexvar ,binding)
+		     ,@(when supplied-p-var
+			 `((:init-lexvar ,supplied-p-binding)))
 		     ,@(compiler-call #'compile-self-evaluating
 			 :form (eval-form (optional-function-argument-init-form binding) env nil)
 			 :funobj funobj
@@ -4105,7 +4107,10 @@
 		     (:movl (:ebp (:ecx 4) ,(* -4 (1- (1+ position)))) :ebx)
 		     default-done
 		     (:store-lexical ,binding :ebx :type t)))
-		  (t `((:arg-cmp ,(+ 2 position))
+		  (t `((:init-lexvar ,binding)
+		       ,@(when supplied-p-var
+			   `((:init-lexvar ,supplied-p-binding)))
+		       (:arg-cmp ,(+ 2 position))
 		       (:jb '(:sub-program (default)
 			      ,@(append
 				 (when supplied-p-var




From ffjeld at common-lisp.net  Fri Mar 26 01:35:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:35:29 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <E1B6gFt-0007BI-00@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Put a maximum on the tracing indenting.

Date: Thu Mar 25 20:35:29 2004
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.4 movitz/losp/muerte/environment.lisp:1.5
--- movitz/losp/muerte/environment.lisp:1.4	Wed Mar 24 19:52:54 2004
+++ movitz/losp/muerte/environment.lisp	Thu Mar 25 20:35:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Oct 20 00:41:57 2001
 ;;;;                
-;;;; $Id: environment.lisp,v 1.4 2004/03/25 00:52:54 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.5 2004/03/26 01:35:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -94,9 +94,10 @@
 				    (declare (dynamic-extent results))
 				    (let ((*trace-escape* t))
 				      (fresh-line *trace-output*)
-				      (dotimes (i *trace-level*)
+				      (dotimes (i (min *trace-level* 10))
 					(write-string "  " *trace-output*))
-				      (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results)
+				      (format *trace-output* "~D: =>~{ ~W~^,~}.~%"
+					      *trace-level* results)
 				      (values-list results)))
 				(let ((*trace-level* (1+ *trace-level*))
 				      (*trace-escape* nil))




From ffjeld at common-lisp.net  Fri Mar 26 01:36:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:36:31 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <E1B6gGt-0007zV-00@common-lisp.net>

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

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

Date: Thu Mar 25 20:36:30 2004
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.5 movitz/losp/lib/repl.lisp:1.6
--- movitz/losp/lib/repl.lisp:1.5	Wed Mar 24 19:40:35 2004
+++ movitz/losp/lib/repl.lisp	Thu Mar 25 20:36:30 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 19 14:58:12 2003
 ;;;;                
-;;;; $Id: repl.lisp,v 1.5 2004/03/25 00:40:35 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.6 2004/03/26 01:36:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -45,12 +45,12 @@
 	  (terpri)
 	  (multiple-value-bind (form buffer-pointer)
 	      (handler-bind
-		  (#+ignore (muerte::missing-delimiter
-			     (lambda (c)
-			       (declare (ignore c))
-			       (format t "~&> ")
-			       (invoke-restart 'muerte::next-line
-					       (muerte.readline:contextual-readline *repl-readline-context*)))))
+		  ((muerte::missing-delimiter
+		    (lambda (c)
+		      (declare (ignore c))
+		      (format t "~&> ")
+		      (invoke-restart 'muerte::next-line
+				      (muerte.readline:contextual-readline *repl-readline-context*)))))
 		(simple-read-from-string buffer-string t t))
 	    (multiple-value-call
 		(lambda (form previous-package &rest results)
@@ -74,11 +74,11 @@
 		(apply 'muerte.toplevel:invoke-toplevel-command
 		       form
 		       (loop for arg = (multiple-value-bind (arg x)
-					   (simple-read-from-string buffer-string nil 'eof
+					   (simple-read-from-string buffer-string nil '#0=#:eof
 								    :start buffer-pointer)
 					 (setq buffer-pointer x)
 					 arg)
-			   until (eq arg 'eof)
+			   until (eq arg '#0#)
 			   collect arg)))))))
     #+ignore (muerte.readline::readline-break (c)
 	       (declare (ignore c))




From ffjeld at common-lisp.net  Fri Mar 26 01:42:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:42:45 -0500
Subject: [movitz-cvs] CVS update: movitz/multiboot.lisp 
Message-ID: <E1B6gMv-0002te-00@common-lisp.net>

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

Modified Files:
	multiboot.lisp 
Log Message:
Changed type word to lu32.

Date: Thu Mar 25 20:42:45 2004
Author: ffjeld

Index: movitz/multiboot.lisp
diff -u movitz/multiboot.lisp:1.3 movitz/multiboot.lisp:1.4
--- movitz/multiboot.lisp:1.3	Wed Mar 24 08:20:49 2004
+++ movitz/multiboot.lisp	Thu Mar 25 20:42:45 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Jun 12 12:14:12 2002
 ;;;;                
-;;;; $Id: multiboot.lisp,v 1.3 2004/03/24 13:20:49 ffjeld Exp $
+;;;; $Id: multiboot.lisp,v 1.4 2004/03/26 01:42:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -37,10 +37,10 @@
 
 (define-binary-class multiboot-header (movitz-heap-object)
   ((scan-skip-header
-    :binary-type word
+    :binary-type lu32
     :initform +scan-skip-word+)
    (scan-skip-length
-    :binary-type word
+    :binary-type lu32
     :initform 0
     :map-binary-write (lambda (x type)
 			(declare (ignore x y))




From ffjeld at common-lisp.net  Fri Mar 26 01:43:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:43:46 -0500
Subject: [movitz-cvs] CVS update: movitz/eval.lisp 
Message-ID: <E1B6gNu-0003oP-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
This is a fix, but I'm not really sure how sound it is.

Date: Thu Mar 25 20:43:46 2004
Author: ffjeld

Index: movitz/eval.lisp
diff -u movitz/eval.lisp:1.2 movitz/eval.lisp:1.3
--- movitz/eval.lisp:1.2	Mon Jan 19 06:23:41 2004
+++ movitz/eval.lisp	Thu Mar 25 20:43:46 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  2 17:45:05 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: eval.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.3 2004/03/26 01:43:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -97,7 +97,8 @@
   (declare (ignore top-level-p))
   (cond
    ((typep (movitz-binding form env) 'constant-object-binding)
-    (movitz-print (constant-object (movitz-binding form env))))
+    (translate-program (movitz-print (constant-object (movitz-binding form env)))
+		       :cl :muerte.cl))
    ((movitz-constantp form env)
     (symbol-value form))
 ;;;   ((movitz-lexical-binding form env)




From ffjeld at common-lisp.net  Fri Mar 26 01:44:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:44:46 -0500
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <E1B6gOs-0007G4-00@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added two bochs-flags fields to run-time-context.

Date: Thu Mar 25 20:44:46 2004
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.19 movitz/image.lisp:1.20
--- movitz/image.lisp:1.19	Wed Mar 24 13:39:42 2004
+++ movitz/image.lisp	Thu Mar 25 20:44:46 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.19 2004/03/24 18:39:42 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.20 2004/03/26 01:44:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -128,6 +128,12 @@
    (stack-top				; stack-top must be right after stack-bottom
     :binary-type word			; in order for the bound instruction to work.
     :initform #x100000)
+   (bochs-flags
+    :binary-type lu32
+    :initform 0)
+   (bochs-flags2
+    :binary-type lu32
+    :initform 0)
    ;;
    (unbound-value
     :binary-type word




From ffjeld at common-lisp.net  Fri Mar 26 01:46:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:46:47 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/lib/toplevel.lisp 
Message-ID: <E1B6gQp-0002Xw-00@common-lisp.net>

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

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

Date: Thu Mar 25 20:46:47 2004
Author: ffjeld

Index: movitz/losp/lib/toplevel.lisp
diff -u movitz/losp/lib/toplevel.lisp:1.4 movitz/losp/lib/toplevel.lisp:1.5
--- movitz/losp/lib/toplevel.lisp:1.4	Fri Feb 13 17:11:24 2004
+++ movitz/losp/lib/toplevel.lisp	Thu Mar 25 20:46:47 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Sep  5 15:56:26 2002
 ;;;;                
-;;;; $Id: toplevel.lisp,v 1.4 2004/02/13 22:11:24 ffjeld Exp $
+;;;; $Id: toplevel.lisp,v 1.5 2004/03/26 01:46:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -43,10 +43,10 @@
 	(apply f arguments)
       (multiple-value-bind (completion completion-count)
 	  (muerte.readline:complete-symbol-name (string name)
-					      :package :keyword
-					      :filter-matches (lambda (x)
-								(and (gethash x *toplevel-commands*)
-								     t)))
+						:package :keyword
+						:filter-matches (lambda (x)
+								  (and (gethash x *toplevel-commands*)
+								       t)))
 	(case completion-count
 	  (0 (format t "~&No toplevel command named ~S." name)
 	     name)




From ffjeld at common-lisp.net  Fri Mar 26 01:47:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:47:39 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B6gRf-0004DS-00@common-lisp.net>

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

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

Date: Thu Mar 25 20:47:39 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.8 movitz/losp/muerte/arrays.lisp:1.9
--- movitz/losp/muerte/arrays.lisp:1.8	Thu Mar 25 06:17:22 2004
+++ movitz/losp/muerte/arrays.lisp	Thu Mar 25 20:47:39 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.8 2004/03/25 11:17:22 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.9 2004/03/26 01:47:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -555,12 +555,12 @@
 				     :other-tag :vector
 				     :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
 								      :any-t))))
-	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
-			 0 :unsigned-byte16)
-	     dimensions)
 	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
 			 0 :unsigned-byte16)
 	     0)
+	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
+			 0 :unsigned-byte16)
+	     dimensions)
 	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
 			 0 :unsigned-byte16)
 	     #.(movitz:vector-type-tag :any-t))




From ffjeld at common-lisp.net  Fri Mar 26 01:49:07 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:49:07 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1B6gT5-00089o-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Move malloc functions to inspect.lisp, for now.

Date: Thu Mar 25 20:49:07 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.6 movitz/losp/muerte/basic-functions.lisp:1.7
--- movitz/losp/muerte/basic-functions.lisp:1.6	Thu Mar 25 06:27:00 2004
+++ movitz/losp/muerte/basic-functions.lisp	Thu Mar 25 20:49:06 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.6 2004/03/25 11:27:00 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.7 2004/03/26 01:49:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -356,16 +356,3 @@
 (defun %word-offset (word offset)
   (%word-offset word offset))
 
-(defun malloc-words (words)
-  (malloc-clumps (1+ (truncate (1+ words) 2))))
-
-(defun malloc-clumps (clumps)
-  (let ((x (with-inline-assembly (:returns :eax :side-effects t)
-	     (:compile-form (:result-mode :ebx) clumps)
-	     (:shll 1 :ebx)
-	     (:globally (:call (:edi (:edi-offset malloc))))
-	     (:addl #.(movitz::tag :other) :eax))))
-    (dotimes (i clumps)
-      (setf (memref x -6 i :lisp) nil
-	    (memref x -2 i :lisp) nil))
-    x))




From ffjeld at common-lisp.net  Fri Mar 26 01:49:11 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:49:11 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1B6gT9-0008FL-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Move malloc functions to inspect.lisp, for now.

Date: Thu Mar 25 20:49:11 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.2 movitz/losp/muerte/inspect.lisp:1.3
--- movitz/losp/muerte/inspect.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/inspect.lisp	Thu Mar 25 20:49:11 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.3 2004/03/26 01:49:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -168,3 +168,17 @@
        (when (member :catch types)
 	 (format t "~&catch:   ~Z: ~S" tag tag))))))
 
+
+(defun malloc-words (words)
+  (malloc-clumps (1+ (truncate (1+ words) 2))))
+
+(defun malloc-clumps (clumps)
+  (let ((x (with-inline-assembly (:returns :eax :side-effects t)
+	     (:compile-form (:result-mode :ebx) clumps)
+	     (:shll 1 :ebx)
+	     (:globally (:call (:edi (:edi-offset malloc))))
+	     (:addl #.(movitz::tag :other) :eax))))
+    (dotimes (i clumps)
+      (setf (memref x -6 i :lisp) nil
+	    (memref x -2 i :lisp) nil))
+    x))




From ffjeld at common-lisp.net  Fri Mar 26 01:50:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:50:32 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <E1B6gUS-0003kk-00@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
With-bochs-tracing is a new debugging tool for use under modified bochs.

Date: Thu Mar 25 20:50:32 2004
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.3 movitz/losp/muerte/more-macros.lisp:1.4
--- movitz/losp/muerte/more-macros.lisp:1.3	Fri Feb 20 10:38:28 2004
+++ movitz/losp/muerte/more-macros.lisp	Thu Mar 25 20:50:32 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.3 2004/02/20 15:38:28 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.4 2004/03/26 01:50:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -205,7 +205,14 @@
        ,eof-value))
 
 
-
+(defmacro with-bochs-tracing ((&optional (value 1)) &body body)
+  "Bochs magic."
+  `(let ((old-flags (muerte::%run-time-context-slot 'bochs-flags)))
+     (unwind-protect
+	 (progn
+	   (setf (muerte::%run-time-context-slot 'bochs-flags) ,value)
+	   , at body)
+       (setf (muerte::%run-time-context-slot 'bochs-flags) old-flags))))
 
   
   




From ffjeld at common-lisp.net  Fri Mar 26 01:51:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:51:22 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp 
Message-ID: <E1B6gVG-0004jA-00@common-lisp.net>

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

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

Date: Thu Mar 25 20:51:21 2004
Author: ffjeld

Index: movitz/losp/x86-pc/interrupt.lisp
diff -u movitz/losp/x86-pc/interrupt.lisp:1.4 movitz/losp/x86-pc/interrupt.lisp:1.5
--- movitz/losp/x86-pc/interrupt.lisp:1.4	Wed Mar 24 08:36:26 2004
+++ movitz/losp/x86-pc/interrupt.lisp	Thu Mar 25 20:51:21 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri May  4 18:08:50 2001
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.4 2004/03/24 13:36:26 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.5 2004/03/26 01:51:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -182,8 +182,8 @@
 	  (67 (muerte.debug:backtrace :fresh-lines nil :length 6)
 	      (dotimes (i 100000)
 		(with-inline-assembly (:returns :nothing) (:nop))))
-	  (66 (error "Unspecified type error in ~S with EAX=~@Z, ECX=~@Z."
-		     (@ (+ int-frame (int-frame-index :esi)))
+	  (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z."
+		     $eip (@ (+ int-frame (int-frame-index :esi)))
 		     $eax $ecx))
 	  (62 (error "Trying to save too many values: ~@Z." $ecx))
 	  ((5 55)




From ffjeld at common-lisp.net  Fri Mar 26 01:53:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:53:54 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1B6gXi-0007w0-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Top-level command :Bochs-trace provides interactive access to the
with-bochs-tracing macro.

Date: Thu Mar 25 20:53:53 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.6 movitz/losp/los0.lisp:1.7
--- movitz/losp/los0.lisp:1.6	Thu Mar 25 04:24:00 2004
+++ movitz/losp/los0.lisp	Thu Mar 25 20:53:53 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.6 2004/03/25 09:24:00 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.7 2004/03/26 01:53:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -789,6 +789,10 @@
     (describe (gethash x *toplevel-commands*)))
    (t (describe x)))
   (values))
+
+(muerte.toplevel:define-toplevel-command :bochs-trace (form)
+  (muerte::with-bochs-tracing ()
+    (eval form)))
 
 (muerte.toplevel:define-toplevel-command :mapkey (code-char)
   (let ((char (etypecase code-char




From ffjeld at common-lisp.net  Fri Mar 26 01:55:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 25 Mar 2004 20:55:22 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/floppy.lisp 
Message-ID: <E1B6gZ8-0006Wf-00@common-lisp.net>

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

Added Files:
	floppy.lisp 
Log Message:
This file has been missing from the repository for some time, I think.

Date: Thu Mar 25 20:55:22 2004
Author: ffjeld





From ffjeld at common-lisp.net  Fri Mar 26 10:45:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 05:45:01 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B6oph-0001qV-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
(setf aref) of an u32 vector should translate to a :movl, not a
:movw.

Date: Fri Mar 26 05:45:00 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.9 movitz/losp/muerte/arrays.lisp:1.10
--- movitz/losp/muerte/arrays.lisp:1.9	Thu Mar 25 20:47:39 2004
+++ movitz/losp/muerte/arrays.lisp	Fri Mar 26 05:45:00 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.9 2004/03/26 01:47:39 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.10 2004/03/26 10:45:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -326,7 +326,7 @@
 		(:compile-form (:result-mode :ignore)
 		 (error "Value not (unsigned-byte 32): ~S" value))))
 	(:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
-	(:movw :bx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+       	(:movl :ebx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
 	(:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
 	(:jmp 'done)
 




From ffjeld at common-lisp.net  Fri Mar 26 13:53:08 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 08:53:08 -0500
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1B6rlk-00008n-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
Added an illegal type-tag for some (memory) consistency checks. And a
function that computes the size of a class in words.

Date: Fri Mar 26 08:53:08 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.13 movitz/storage-types.lisp:1.14
--- movitz/storage-types.lisp:1.13	Wed Mar 24 08:22:27 2004
+++ movitz/storage-types.lisp	Fri Mar 26 08:53:06 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.13 2004/03/24 13:22:27 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.14 2004/03/26 13:53:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -73,6 +73,7 @@
   :std-instance #x40
   :run-time-context #x50
   :infant-object #x65
+  :illegal #x13
 
   ;; :simple-vector #x20
   ;; :character-vector 
@@ -397,7 +398,8 @@
     :accessor movitz-vector-symbolic-data))
   (:slot-align type -2))
 
-
+(defun movitz-type-word-size (type)
+  (truncate (sizeof (intern (symbol-name type) :movitz)) 4))
 
 (defun movitz-svref (vector index)
   (elt (movitz-vector-symbolic-data vector) index))




From ffjeld at common-lisp.net  Fri Mar 26 13:54:45 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 08:54:45 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <E1B6rnJ-0002MZ-00@common-lisp.net>

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

Modified Files:
	repl.lisp 
Log Message:
Include the handler for Control-C in the REPL.

Date: Fri Mar 26 08:54:45 2004
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.6 movitz/losp/lib/repl.lisp:1.7
--- movitz/losp/lib/repl.lisp:1.6	Thu Mar 25 20:36:30 2004
+++ movitz/losp/lib/repl.lisp	Fri Mar 26 08:54:45 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 19 14:58:12 2003
 ;;;;                
-;;;; $Id: repl.lisp,v 1.6 2004/03/26 01:36:30 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.7 2004/03/26 13:54:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -80,7 +80,7 @@
 					 arg)
 			   until (eq arg '#0#)
 			   collect arg)))))))
-    #+ignore (muerte.readline::readline-break (c)
-	       (declare (ignore c))
-	       (values))))
+    (muerte.readline::readline-break (c)
+      (declare (ignore c))
+      (values))))
 




From ffjeld at common-lisp.net  Fri Mar 26 13:56:53 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 08:56:53 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B6rpN-0001I1-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Initialize fresh vectors properly.

Date: Fri Mar 26 08:56:53 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.10 movitz/losp/muerte/arrays.lisp:1.11
--- movitz/losp/muerte/arrays.lisp:1.10	Fri Mar 26 05:45:00 2004
+++ movitz/losp/muerte/arrays.lisp	Fri Mar 26 08:56:53 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.10 2004/03/26 10:45:00 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.11 2004/03/26 13:56:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -509,6 +509,9 @@
 			       :other-tag :vector
 			       :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
 								:character))))
+	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
+		       0 :unsigned-byte16)
+	   0)
 	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 		       0 :unsigned-byte16)
 	   dimensions)
@@ -522,6 +525,9 @@
 			       :other-tag :vector
 			       :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
 								:u8))))
+	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
+		       0 :unsigned-byte16)
+	   0)
 	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 		       0 :unsigned-byte16)
 	   dimensions)
@@ -538,6 +544,9 @@
 			       :other-tag :vector
 			       :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
 								:u32))))
+	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
+		       0 :unsigned-byte16)
+	   0)
 	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 		       0 :unsigned-byte16)
 	   dimensions)




From ffjeld at common-lisp.net  Fri Mar 26 13:57:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 08:57:13 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1B6rph-0001q5-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
Added function structure-object-length.

Date: Fri Mar 26 08:57:12 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.3 movitz/losp/muerte/defstruct.lisp:1.4
--- movitz/losp/muerte/defstruct.lisp:1.3	Mon Mar 22 11:37:59 2004
+++ movitz/losp/muerte/defstruct.lisp	Fri Mar 26 08:57:12 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.3 2004/03/22 16:37:59 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.4 2004/03/26 13:57:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,6 +18,10 @@
 (provide :muerte/defstruct)
 
 (in-package muerte)
+
+(defun structure-object-length (obj)
+  (check-type obj structure-object)
+  (movitz-accessor-u16 obj movitz-struct length))
 
 (defun struct-predicate-prototype (obj)
   "Prototype function for predicates of user-defined struct.




From ffjeld at common-lisp.net  Fri Mar 26 13:58:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 08:58:01 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1B6rqT-0002m3-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
In copy-funobj, calculate the size of the new object correctly.

Date: Fri Mar 26 08:58:01 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.5 movitz/losp/muerte/functions.lisp:1.6
--- movitz/losp/muerte/functions.lisp:1.5	Wed Mar 24 15:40:40 2004
+++ movitz/losp/muerte/functions.lisp	Fri Mar 26 08:58:01 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.5 2004/03/24 20:40:40 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.6 2004/03/26 13:58:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -373,13 +373,12 @@
 
 (defun copy-funobj (old-funobj &optional (name (funobj-name old-funobj)))
   (let* ((num-constants (funobj-num-constants old-funobj))
-	 (funobj (malloc-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
+	 (funobj (malloc-words (+ -2 #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4)
 				  num-constants))))
     (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)
       (memref old-funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16))
     (setf (funobj-num-constants funobj) num-constants)
     (replace-funobj funobj old-funobj name)))
-
 
 (defun install-funobj-name (name funobj)
   (setf (funobj-name funobj) name)




From ffjeld at common-lisp.net  Fri Mar 26 13:58:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 08:58:28 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1B6rqu-0003P8-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added a rather stupid version of (setf memref) for :unsigned-byte32

Date: Fri Mar 26 08:58:28 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.2 movitz/losp/muerte/memref.lisp:1.3
--- movitz/losp/muerte/memref.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/memref.lisp	Fri Mar 26 08:58:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.3 2004/03/26 13:58:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -250,7 +250,11 @@
     (:unsigned-byte8
      (setf (memref object offset index :unsigned-byte8) value))
     (:unsigned-byte16
-     (setf (memref object offset index :unsigned-byte8) value))
+     (setf (memref object offset index :unsigned-byte16) value))
+    (:unsigned-byte32
+     (setf (memref object offset (* index 2) :unsigned-byte16) (ldb (byte 16 0) value)
+	   (memref object offset (+ 1 (* index 2)) :unsigned-byte16) (ldb (byte 14 16) value))
+     value)
     (:lisp
      (setf (memref object offset index :lisp) value))))
 




From ffjeld at common-lisp.net  Fri Mar 26 14:05:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Mar 2004 09:05:21 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1B6rxZ-0005o8-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Initialize properly with nil the fresh objects from malloc-clumps.

Date: Fri Mar 26 09:05:20 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.3 movitz/losp/muerte/inspect.lisp:1.4
--- movitz/losp/muerte/inspect.lisp:1.3	Thu Mar 25 20:49:11 2004
+++ movitz/losp/muerte/inspect.lisp	Fri Mar 26 09:05:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.3 2004/03/26 01:49:11 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.4 2004/03/26 14:05:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -179,6 +179,6 @@
 	     (:globally (:call (:edi (:edi-offset malloc))))
 	     (:addl #.(movitz::tag :other) :eax))))
     (dotimes (i clumps)
-      (setf (memref x -6 i :lisp) nil
-	    (memref x -2 i :lisp) nil))
+      (setf (memref x -6 (* i 2) :lisp) nil
+	    (memref x -2 (* i 2) :lisp) nil))
     x))




From ffjeld at common-lisp.net  Sun Mar 28 13:23:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 08:23:57 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp 
Message-ID: <E1B7aGb-00051E-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Have eval-let properly parse declarations. So now evaluating let will
properly interpret e.g.
  (let ((#0=#:foo 2))
    (declare (special #0#))
    (symbol-value '#0#))
=> 2

Date: Sun Mar 28 08:23:57 2004
Author: ffjeld

Index: movitz/losp/muerte/eval.lisp
diff -u movitz/losp/muerte/eval.lisp:1.2 movitz/losp/muerte/eval.lisp:1.3
--- movitz/losp/muerte/eval.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/eval.lisp	Sun Mar 28 08:23:57 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.3 2004/03/28 13:23:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -276,7 +276,7 @@
 	special-values
 	(local-env env))
     (multiple-value-bind (body declarations)
-	declarations-and-body
+	(parse-declarations-and-body declarations-and-body)
       (dolist (var-spec var-specs)
 	(multiple-value-bind (var init-form)
 	    (if (atom var-spec)




From ffjeld at common-lisp.net  Sun Mar 28 13:35:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 08:35:46 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp 
Message-ID: <E1B7aS2-0002jI-00@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Added a dependency on x86-pc/debugger, so as to fix the package
error. Actually, the debugger should be relocated to inside Muerte
proper.

Date: Sun Mar 28 08:35:45 2004
Author: ffjeld

Index: movitz/losp/x86-pc/interrupt.lisp
diff -u movitz/losp/x86-pc/interrupt.lisp:1.5 movitz/losp/x86-pc/interrupt.lisp:1.6
--- movitz/losp/x86-pc/interrupt.lisp:1.5	Thu Mar 25 20:51:21 2004
+++ movitz/losp/x86-pc/interrupt.lisp	Sun Mar 28 08:35:45 2004
@@ -10,11 +10,12 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri May  4 18:08:50 2001
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.5 2004/03/26 01:51:21 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.6 2004/03/28 13:35:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
 (require :x86-pc/pic8259)
+(require :x86-pc/debugger)
 (provide :x86-pc/interrupt)
 
 (in-package muerte.x86-pc)




From ffjeld at common-lisp.net  Sun Mar 28 13:37:16 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 08:37:16 -0500
Subject: [movitz-cvs] CVS update: movitz/slime-movitz.el 
Message-ID: <E1B7aTU-0004C8-00@common-lisp.net>

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

Modified Files:
	slime-movitz.el 
Log Message:
Undid broken line in header.

Date: Sun Mar 28 08:37:16 2004
Author: ffjeld

Index: movitz/slime-movitz.el
diff -u movitz/slime-movitz.el:1.1 movitz/slime-movitz.el:1.2
--- movitz/slime-movitz.el:1.1	Wed Mar 17 03:26:50 2004
+++ movitz/slime-movitz.el	Sun Mar 28 08:37:16 2004
@@ -1,5 +1,4 @@
-;;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;*";
-indent-tabs-mode: nil -*-
+;;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: nil *indent-tabs-mode: nil -*-
 ;; movitz-slime.el -- Slime key bindings for Movitz, adapted from
 ;;                    movitz-mode.el by Frode Vatvedt Fjeld
 ;; Copyright (C) 2004 Aleksandar Bakic




From ffjeld at common-lisp.net  Sun Mar 28 15:09:27 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 10:09:27 -0500
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1B7buh-0007WZ-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
A small fix to assign-bindings so that certain lambda-variables are
not erroneously assumed to be used when they really aren't.

Date: Sun Mar 28 10:09:27 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.36 movitz/compiler.lisp:1.37
--- movitz/compiler.lisp:1.36	Thu Mar 25 20:34:13 2004
+++ movitz/compiler.lisp	Sun Mar 28 10:09:27 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.36 2004/03/26 01:34:13 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.37 2004/03/28 15:09:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2618,7 +2618,8 @@
 				   ((typep binding 'constant-object-binding))
 				   ((typep binding 'forwarding-binding))
 				   ((typep binding 'borrowed-binding))
-				   ((typep binding 'fixed-required-function-argument)
+				   ((and (typep binding 'fixed-required-function-argument)
+					 (plusp (or (car (gethash binding var-counts)) 0)))
 				    (prog1 nil ; may need lending-cons
 				      (setf (new-binding-location binding frame-map)
 					:argument-stack)))




From ffjeld at common-lisp.net  Sun Mar 28 16:19:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 11:19:20 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1B7d0K-0000Y4-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added a proper (setf memref .. :unsigned-byte32).

Date: Sun Mar 28 11:19:20 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.3 movitz/losp/muerte/memref.lisp:1.4
--- movitz/losp/muerte/memref.lisp:1.3	Fri Mar 26 08:58:27 2004
+++ movitz/losp/muerte/memref.lisp	Sun Mar 28 11:19:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.3 2004/03/26 13:58:27 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.4 2004/03/28 16:19:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -205,6 +205,18 @@
 	  (:sarl #.movitz::+movitz-fixnum-shift+ :ebx)
 	  (:popl :ecx)			; object
 	  (:movb :ah (:ebx :ecx))))
+      (:unsigned-byte32
+       (assert (= 4 movitz::+movitz-fixnum-factor+))
+       `(with-inline-assembly (:returns :untagged-fixnum-eax)
+	  (:compile-form (:result-mode :push) ,object)
+	  (:compile-form (:result-mode :push) ,offset)
+	  (:compile-two-forms (:ebx :eax) ,index ,value)
+	  (:popl :ecx)			; offset
+	  (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
+	  (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+	  (:addl :ebx :ecx)		; index += offset
+	  (:popl :ebx)			; object
+	  (:movl :eax (:ebx :ecx))))
       (:unsigned-byte16
        `(with-inline-assembly (:returns :untagged-fixnum-eax)
 	  (:compile-form (:result-mode :push) ,object)
@@ -214,8 +226,8 @@
 	  (:popl :ecx)			; offset
 	  (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
 	  (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
-	  (:addl :ecx :ebx)		; index += offset
-	  (:popl :ecx)			; object
+	  (:addl :ebx :ecx)		; index += offset
+	  (:popl :ebx)			; object
 	  (:movw :ax (:ebx :ecx))))
       (:unsigned-byte8
        `(with-inline-assembly (:returns :untagged-fixnum-eax)
@@ -252,9 +264,7 @@
     (:unsigned-byte16
      (setf (memref object offset index :unsigned-byte16) value))
     (:unsigned-byte32
-     (setf (memref object offset (* index 2) :unsigned-byte16) (ldb (byte 16 0) value)
-	   (memref object offset (+ 1 (* index 2)) :unsigned-byte16) (ldb (byte 14 16) value))
-     value)
+     (setf (memref object offset index :unsigned-byte32) value))
     (:lisp
      (setf (memref object offset index :lisp) value))))
 




From ffjeld at common-lisp.net  Sun Mar 28 16:20:06 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 11:20:06 -0500
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1B7d14-0002H4-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Removed a couple of useless warnings.

Date: Sun Mar 28 11:20:05 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.15 movitz/special-operators.lisp:1.16
--- movitz/special-operators.lisp:1.15	Fri Feb 20 21:04:50 2004
+++ movitz/special-operators.lisp	Sun Mar 28 11:20:05 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.15 2004/02/21 02:04:50 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.16 2004/03/28 16:20:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -958,15 +958,16 @@
 						  :protect-registers ,(cons protected-register
 									    protect-registers))))))))
 	     (t ;; just put the (singular) result of form1 on the stack..
-	      (when (not (typep cover-returns 'keyword))
-		;; if it's a (non-modified) lexical-binding, we can do better..
-		(warn "Covering non-register ~S" cover-returns))
-	      (when (type-specifier-singleton (type-specifier-primary cover-type))
-		(warn "Covering constant ~S"
-		      (type-specifier-singleton cover-type)))  
+;;;	      (when (not (typep cover-returns 'keyword))
+;;;		;; if it's a (non-modified) lexical-binding, we can do better..
+;;;		(warn "Covering non-register ~S" cover-returns))
+;;;	      (when (type-specifier-singleton (type-specifier-primary cover-type))
+;;;		(warn "Covering constant ~S"
+;;;		      (type-specifier-singleton cover-type)))  
 	      (let ((protected-register (case cover-returns
 					  ((:ebx :ecx :edx) cover-returns)
 					  (t :eax))))
+		#+ignore
 		(when (>= 2 (length cloaked-code))
 		  (warn "simple-cloaking for ~S: ~{~&~S~}" cover-returns cloaked-code))
 		(setf (stack-used cloaked-env) 1)




From ffjeld at common-lisp.net  Sun Mar 28 16:20:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 11:20:44 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B7d1g-0003N2-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Set initial-contents when make-array a string.

Date: Sun Mar 28 11:20:44 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.11 movitz/losp/muerte/arrays.lisp:1.12
--- movitz/losp/muerte/arrays.lisp:1.11	Fri Mar 26 08:56:53 2004
+++ movitz/losp/muerte/arrays.lisp	Sun Mar 28 11:20:44 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.11 2004/03/26 13:56:53 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.12 2004/03/28 16:20:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -516,9 +516,14 @@
 		       0 :unsigned-byte16)
 	   dimensions)
 	 (setf (fill-pointer a) fill-pointer)
-	 (when initial-element
+	 (cond
+	  (initial-element
+	   (check-type initial-element character)
 	   (dotimes (i dimensions)
 	     (setf (char%unsafe a i) initial-element)))
+	  (initial-contents
+	   (dotimes (i dimensions)
+	     (setf (char a i) (elt initial-contents i)))))
 	 a))
       ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
        (let ((a (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) dimensions)




From ffjeld at common-lisp.net  Sun Mar 28 17:31:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 12:31:41 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp 
Message-ID: <E1B7e8L-0001vQ-00@common-lisp.net>

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

Modified Files:
	functions.lisp 
Log Message:
Added placeholder function funobj-frame-num-unboxed. The idea is that
when the compiler supports local unboxed variables, a field in the
funobj is used to mark off such sections of the stack-frame (each
stack-frame also holds a reference to the funobj).

Date: Sun Mar 28 12:31:41 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.6 movitz/losp/muerte/functions.lisp:1.7
--- movitz/losp/muerte/functions.lisp:1.6	Fri Mar 26 08:58:01 2004
+++ movitz/losp/muerte/functions.lisp	Sun Mar 28 12:31:41 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.6 2004/03/26 13:58:01 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.7 2004/03/28 17:31:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -312,6 +312,11 @@
 (defun funobj-debug-info (funobj)
   (check-type funobj compiled-function)
   (movitz-accessor-u16 funobj movitz-funobj debug-info))
+
+(defun funobj-frame-num-unboxed (funobj)
+  "The number of unboxed slots in this function's stack-frame(s)."
+  (declare (ignore funobj))
+  0)
 
 (defun make-funobj (&key (name :unnamed)
 			 (code-vector (funobj-code-vector #'constantly-prototype))




From ffjeld at common-lisp.net  Sun Mar 28 17:33:47 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 12:33:47 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1B7eAN-0003kb-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Added functions copy-symbol, create-symbol, %unbounded-symbol-value,
and %unbounded-symbol-function, and rewrote make-symbol in terms of create-symbol.

Date: Sun Mar 28 12:33:46 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.4 movitz/losp/muerte/symbols.lisp:1.5
--- movitz/losp/muerte/symbols.lisp:1.4	Wed Mar 24 08:31:43 2004
+++ movitz/losp/muerte/symbols.lisp	Sun Mar 28 12:33:46 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.4 2004/03/24 13:31:43 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.5 2004/03/28 17:33:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -30,6 +30,19 @@
        (:compile-form (:result-mode :eax) symbol)
        (:call-global-constant dynamic-load)))))
 
+(defun %unbounded-symbol-value (symbol)
+  "Return the symbol's value without checking if it's bound or not."
+  (check-type symbol symbol)
+  (with-inline-assembly (:returns :eax)
+    (:compile-form (:result-mode :eax) symbol)
+    (:call-global-constant dynamic-find-binding)
+    (:jnc 'no-local-binding)
+    (:movl (:eax) :eax)
+    (:jmp 'done)
+   no-local-binding
+    (:movl (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value)) :eax)
+   done))
+
 (defun (setf symbol-value) (value symbol)
   (etypecase symbol
     (null
@@ -62,6 +75,10 @@
       (error 'undefined-function :name symbol))
     function-value))
 
+(defun %unbounded-symbol-function (symbol)
+  (check-type symbol symbol)
+  (movitz-accessor symbol movitz-symbol function-value))
+
 (defun (setf symbol-function) (value symbol)
   (check-type symbol symbol)
   (check-type value compiled-function)
@@ -120,17 +137,39 @@
      (not (eq (movitz-accessor symbol movitz-symbol function-value)
 	      (load-global-constant movitz::unbound-function))))))
 
-(defun make-symbol (name)
+(defun create-symbol (name &optional (package nil)
+				     (plist nil)
+				     (value (load-global-constant unbound-value))
+				     (function (load-global-constant movitz::unbound-function))
+				     (flags 0))
   (eval-when (:compile-toplevel)
     (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other)))))
   (let ((symbol (%word-offset (malloc-clumps 3) 1)))
-    (setf-movitz-accessor (symbol movitz-symbol package) nil)
+    (setf-movitz-accessor (symbol movitz-symbol package) package)
     (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name))
-    (setf (symbol-flags symbol) 0
-	  (symbol-function symbol) (load-global-constant movitz::unbound-function)
+    (setf (symbol-flags symbol) flags
+	  (symbol-plist symbol) plist
+	  (symbol-function symbol) function
 	  (symbol-name symbol) name
-	  (symbol-value symbol) (load-global-constant unbound-value))
+	  (symbol-value symbol) value)
     symbol))
+
+(defun make-symbol (name)
+  (create-symbol name))
+
+(defun copy-symbol (symbol &optional copy-properties) 
+  "copy-symbol returns a fresh, uninterned symbol, the name of which
+  is string= to and possibly the same as the name of the given
+  symbol."
+  (if (or (eq nil symbol)
+	  (not copy-properties))
+      (create-symbol (symbol-name symbol))
+    (create-symbol (symbol-name symbol)
+		   nil
+		   (symbol-plist symbol)
+		   (%unbounded-symbol-value symbol)
+		   (%unbounded-symbol-function symbol)
+		   (symbol-flags symbol))))
 
 (defun symbol-flags (symbol)
   (etypecase symbol




From ffjeld at common-lisp.net  Mon Mar 29 01:09:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 20:09:46 -0500
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/primitive-functions.lisp 
Message-ID: <E1B7lHe-0005Be-00@common-lisp.net>

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

Modified Files:
	primitive-functions.lisp 
Log Message:
Re-arranged complicated-class-of so as to do the "other" types first,
since the classes with their own tags are likely to be caught before
this function is ever called. Also, make sure that (class-of "foo")
returns the string class, not vector.

Date: Sun Mar 28 20:09:46 2004
Author: ffjeld

Index: movitz/losp/muerte/primitive-functions.lisp
diff -u movitz/losp/muerte/primitive-functions.lisp:1.5 movitz/losp/muerte/primitive-functions.lisp:1.6
--- movitz/losp/muerte/primitive-functions.lisp:1.5	Thu Mar 18 04:21:17 2004
+++ movitz/losp/muerte/primitive-functions.lisp	Sun Mar 28 20:09:46 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Oct  2 21:02:18 2001
 ;;;;                
-;;;; $Id: primitive-functions.lisp,v 1.5 2004/03/18 09:21:17 ffjeld Exp $
+;;;; $Id: primitive-functions.lisp,v 1.6 2004/03/29 01:09:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -577,22 +577,12 @@
      (movitz-accessor object movitz-std-instance class))
     (standard-gf-instance
      (movitz-accessor object movitz-funobj-standard-gf standard-gf-class))
-    (null
-     (find-class 'null))
-    (cons
-     (find-class 'cons))
-    (symbol
-     (find-class 'symbol))
-    (fixnum
-     (find-class 'fixnum))
+    (string
+     (find-class 'string))
     (vector
      (find-class 'vector))
     (compiled-function
      (find-class 'function))
-;;;    (hash-table
-;;;     (find-class 'hash-table))
-;;;    (package
-;;;     (find-class 'package))
     (structure-object
      (find-class (structure-object-name object)))
     (character
@@ -601,6 +591,14 @@
      (find-class 'basic-restart))
     (run-time-context
      (find-class 'run-time-context))
+    (null
+     (find-class 'null))
+    (cons
+     (find-class 'cons))
+    (symbol
+     (find-class 'symbol))
+    (fixnum
+     (find-class 'fixnum))
     (tag6
      (error "Don't know the class of ~Z with other-type #x~X."
 	    object (with-inline-assembly (:returns :untagged-fixnum-ecx)




From ffjeld at common-lisp.net  Mon Mar 29 01:57:49 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Mar 2004 20:57:49 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp 
Message-ID: <E1B7m29-0003xh-00@common-lisp.net>

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

Modified Files:
	symbols.lisp 
Log Message:
Re-named create-symbol to %create-symbol, and avoided it checking the
name being a string (useful during GC migration).

Date: Sun Mar 28 20:57:48 2004
Author: ffjeld

Index: movitz/losp/muerte/symbols.lisp
diff -u movitz/losp/muerte/symbols.lisp:1.5 movitz/losp/muerte/symbols.lisp:1.6
--- movitz/losp/muerte/symbols.lisp:1.5	Sun Mar 28 12:33:46 2004
+++ movitz/losp/muerte/symbols.lisp	Sun Mar 28 20:57:48 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 23:55:41 2001
 ;;;;                
-;;;; $Id: symbols.lisp,v 1.5 2004/03/28 17:33:46 ffjeld Exp $
+;;;; $Id: symbols.lisp,v 1.6 2004/03/29 01:57:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -137,7 +137,7 @@
      (not (eq (movitz-accessor symbol movitz-symbol function-value)
 	      (load-global-constant movitz::unbound-function))))))
 
-(defun create-symbol (name &optional (package nil)
+(defun %create-symbol (name &optional (package nil)
 				     (plist nil)
 				     (value (load-global-constant unbound-value))
 				     (function (load-global-constant movitz::unbound-function))
@@ -146,16 +146,17 @@
     (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other)))))
   (let ((symbol (%word-offset (malloc-clumps 3) 1)))
     (setf-movitz-accessor (symbol movitz-symbol package) package)
+    (setf-movitz-accessor (symbol movitz-symbol name) name)
     (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name))
     (setf (symbol-flags symbol) flags
 	  (symbol-plist symbol) plist
 	  (symbol-function symbol) function
-	  (symbol-name symbol) name
 	  (symbol-value symbol) value)
     symbol))
 
 (defun make-symbol (name)
-  (create-symbol name))
+  (check-type name string "a symbol name")
+  (%create-symbol name))
 
 (defun copy-symbol (symbol &optional copy-properties) 
   "copy-symbol returns a fresh, uninterned symbol, the name of which
@@ -163,13 +164,13 @@
   symbol."
   (if (or (eq nil symbol)
 	  (not copy-properties))
-      (create-symbol (symbol-name symbol))
-    (create-symbol (symbol-name symbol)
-		   nil
-		   (symbol-plist symbol)
-		   (%unbounded-symbol-value symbol)
-		   (%unbounded-symbol-function symbol)
-		   (symbol-flags symbol))))
+      (%create-symbol (symbol-name symbol))
+    (%create-symbol (symbol-name symbol)
+		    nil
+		    (symbol-plist symbol)
+		    (%unbounded-symbol-value symbol)
+		    (%unbounded-symbol-function symbol)
+		    (symbol-flags symbol))))
 
 (defun symbol-flags (symbol)
   (etypecase symbol




From ffjeld at common-lisp.net  Mon Mar 29 14:30:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:30:22 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1B7xmQ-0003fQ-00@common-lisp.net>

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

Added Files:
	scavenge.lisp 
Log Message:
Utility functions for scavenging heap memory and stack memory for
pointer references.

Date: Mon Mar 29 09:30:22 2004
Author: ffjeld





From ffjeld at common-lisp.net  Mon Mar 29 14:32:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:32:13 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B7xoD-0005on-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Allocate (some) specialized arrays in terms of malloc-data-clumps
rather than the old (deprecated) inline-malloc.

Date: Mon Mar 29 09:32:12 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.12 movitz/losp/muerte/arrays.lisp:1.13
--- movitz/losp/muerte/arrays.lisp:1.12	Sun Mar 28 11:20:44 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Mar 29 09:32:12 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.12 2004/03/28 16:20:44 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.13 2004/03/29 14:32:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -505,45 +505,46 @@
      (setf fill-pointer (if (integerp fill-pointer) fill-pointer dimensions))
      (cond
       ((equal element-type 'character)
-       (let ((a (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) dimensions)
-			       :other-tag :vector
-			       :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
-								:character))))
-	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
+       (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8))))
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
 		       0 :unsigned-byte16)
 	   0)
-	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 		       0 :unsigned-byte16)
 	   dimensions)
-	 (setf (fill-pointer a) fill-pointer)
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
+		       0 :unsigned-byte16)
+	   #.(movitz:vector-type-tag :character))
+	 (check-type array string)
+	 (setf (fill-pointer array) fill-pointer)
 	 (cond
 	  (initial-element
 	   (check-type initial-element character)
 	   (dotimes (i dimensions)
-	     (setf (char%unsafe a i) initial-element)))
+	     (setf (char array i) initial-element)))
 	  (initial-contents
 	   (dotimes (i dimensions)
-	     (setf (char a i) (elt initial-contents i)))))
-	 a))
+	     (setf (char array i) (elt initial-contents i)))))
+	 array))
       ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
-       (let ((a (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) dimensions)
-			       :other-tag :vector
-			       :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
-								:u8))))
-	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
+       (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8))))
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
 		       0 :unsigned-byte16)
 	   0)
-	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 		       0 :unsigned-byte16)
 	   dimensions)
-	 (setf (fill-pointer a) fill-pointer)
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
+		       0 :unsigned-byte16)
+	   #.(movitz:vector-type-tag :u8))
+	 (setf (fill-pointer array) fill-pointer)
 	 (cond
 	  (initial-element
 	   (dotimes (i dimensions)
-	     (setf (aref a i) initial-element)))
+	     (setf (aref array i) initial-element)))
 	  (initial-contents
-	   (replace a initial-contents)))
-	 a))
+	   (replace array initial-contents)))
+	 array))
       ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
        (let ((a (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) (* 4 dimensions))
 			       :other-tag :vector




From ffjeld at common-lisp.net  Mon Mar 29 14:32:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:32:40 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <E1B7xoe-0006FW-00@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Minor edits.

Date: Mon Mar 29 09:32:40 2004
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.7 movitz/losp/muerte/basic-functions.lisp:1.8
--- movitz/losp/muerte/basic-functions.lisp:1.7	Thu Mar 25 20:49:06 2004
+++ movitz/losp/muerte/basic-functions.lisp	Mon Mar 29 09:32:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.7 2004/03/26 01:49:06 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.8 2004/03/29 14:32:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -331,10 +331,10 @@
   (getf (load-global-constant global-properties) property))
 
 (define-compiler-macro object-location (object)
+  "The location is the object's address divided by fixnum-factor."
   `(with-inline-assembly (:returns :register)
      (:compile-form (:result-mode :register) ,object)
      (:andl ,(* -2 movitz::+movitz-fixnum-factor+) (:result-register))))
-
   
 (defun object-location (object)
   "The location is the object's address divided by fixnum-factor."
@@ -355,4 +355,6 @@
 
 (defun %word-offset (word offset)
   (%word-offset word offset))
+
+
 




From ffjeld at common-lisp.net  Mon Mar 29 14:33:02 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:33:02 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp 
Message-ID: <E1B7xp0-0006OL-00@common-lisp.net>

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

Modified Files:
	common-lisp.lisp 
Log Message:
Include muerte/scavenge.

Date: Mon Mar 29 09:33:02 2004
Author: ffjeld

Index: movitz/losp/muerte/common-lisp.lisp
diff -u movitz/losp/muerte/common-lisp.lisp:1.2 movitz/losp/muerte/common-lisp.lisp:1.3
--- movitz/losp/muerte/common-lisp.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/common-lisp.lisp	Mon Mar 29 09:33:01 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:41:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: common-lisp.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: common-lisp.lisp,v 1.3 2004/03/29 14:33:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,6 +47,7 @@
 (require :muerte/restarts)
 (require :muerte/conditions)
 (require :muerte/read)
+(require :muerte/scavenge)
 (require :muerte/simple-streams)
 
 (require :muerte/io-port)




From ffjeld at common-lisp.net  Mon Mar 29 14:33:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:33:29 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1B7xpR-0006pF-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Some new functions required by GC functionality.

Date: Mon Mar 29 09:33:29 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.4 movitz/losp/muerte/inspect.lisp:1.5
--- movitz/losp/muerte/inspect.lisp:1.4	Fri Mar 26 09:05:20 2004
+++ movitz/losp/muerte/inspect.lisp	Mon Mar 29 09:33:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.4 2004/03/26 14:05:20 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.5 2004/03/29 14:33:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -168,6 +168,24 @@
        (when (member :catch types)
 	 (format t "~&catch:   ~Z: ~S" tag tag))))))
 
+(defun shallow-copy (old)
+  "Allocate a new object that is similar to the old one."
+  (etypecase old
+    (cons
+     (cons (car old) (cdr old)))
+    (std-instance
+     (allocate-std-instance (std-instance-class old)
+			    (std-instance-slots old)))
+    (symbol
+     (copy-symbol old t))
+    (vector
+     (make-array (array-dimension old 0)
+		 :element-type (array-element-type old)
+		 :initial-contents old
+		 :fill-pointer (fill-pointer old)))
+    (function
+     (copy-funobj old))
+    ))
 
 (defun malloc-words (words)
   (malloc-clumps (1+ (truncate (1+ words) 2))))
@@ -182,3 +200,60 @@
       (setf (memref x -6 (* i 2) :lisp) nil
 	    (memref x -2 (* i 2) :lisp) nil))
     x))
+
+(defun malloc-data-clumps (clumps)
+  "Allocate clumps for non-pointer data (i.e. doesn't require initialization)."
+  (malloc-clumps clumps))
+
+(defun location-in-object-p (object location)
+  "Is location inside object?"
+  (let ((object-location (object-location object)))
+    (etypecase object
+      ((or number null character)
+       nil)
+      (cons
+       (<= object-location
+	   location
+	   (+ object-location 1)))
+      (symbol
+       (<= object-location
+	   location
+	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-symbol))))
+      (run-time-context
+       (<= object-location
+	   location
+	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-constant-block))))
+      (std-instance
+       (<= object-location
+	   location
+	   (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-std-instance))))
+      (function
+       (<= object-location
+	   location
+	   (+ -1 object-location
+	      #.(movitz::movitz-type-word-size :movitz-funobj)
+	      (funobj-num-constants object))))
+      ((or vector-u8 string)
+       (<= object-location
+	   location
+	   (+ -1 object-location
+	      #.(movitz::movitz-type-word-size :movitz-vector)
+	      (* 2 (truncate (+ (array-dimension object 0) 7) 8)))))
+      (vector-u16
+       (<= object-location
+	   location
+	   (+ -1 object-location
+	      #.(movitz::movitz-type-word-size :movitz-vector)
+	      (* 2 (truncate (+ (array-dimension object 0) 3) 4)))))
+      ((or vector-u32 simple-vector)
+       (<= object-location
+	   location
+	   (+ -1 object-location
+	      #.(movitz::movitz-type-word-size :movitz-vector)
+	      (* 2 (truncate (+ (array-dimension object 0) 1) 2)))))
+      (structure-object
+       (<= object-location
+	   location
+	   (+ -1 object-location
+	      #.(movitz::movitz-type-word-size :movitz-struct)
+	      (* 2 (truncate (+ (structure-object-length object) 1) 2))))))))




From ffjeld at common-lisp.net  Mon Mar 29 14:34:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:34:20 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <E1B7xqG-0001Ha-00@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Add a compile-time assertion to the typep compiler-macro, ensuring
consitency for the pointer type.

Date: Mon Mar 29 09:34:20 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.4 movitz/losp/muerte/typep.lisp:1.5
--- movitz/losp/muerte/typep.lisp:1.4	Wed Mar 24 06:24:52 2004
+++ movitz/losp/muerte/typep.lisp	Mon Mar 29 09:34:20 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.4 2004/03/24 11:24:52 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.5 2004/03/29 14:34:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -188,6 +188,8 @@
 		(tag5 (make-tag-typep :null))
 		(tag6 (make-tag-typep :other))
 		(pointer
+		 (assert (equal (mapcar 'movitz::tag '(:cons :other :symbol))
+				'(1 6 7)))
 		 `(with-inline-assembly-case ()
 		    (do-case (t :boolean-zf=0 :labels (done))
 		      (:compile-form (:result-mode :eax) ,object)




From ffjeld at common-lisp.net  Mon Mar 29 14:35:17 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:35:17 -0500
Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp 
Message-ID: <E1B7xrB-0003fG-00@common-lisp.net>

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

Modified Files:
	storage-types.lisp 
Log Message:
The wide-tag :infant-object should _not_ have the same low-tag as cons
or null.

Date: Mon Mar 29 09:35:17 2004
Author: ffjeld

Index: movitz/storage-types.lisp
diff -u movitz/storage-types.lisp:1.14 movitz/storage-types.lisp:1.15
--- movitz/storage-types.lisp:1.14	Fri Mar 26 08:53:06 2004
+++ movitz/storage-types.lisp	Mon Mar 29 09:35:17 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.14 2004/03/26 13:53:06 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.15 2004/03/29 14:35:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -72,8 +72,8 @@
   :funobj #x3a
   :std-instance #x40
   :run-time-context #x50
-  :infant-object #x65
   :illegal #x13
+  :infant-object #x23
 
   ;; :simple-vector #x20
   ;; :character-vector 




From ffjeld at common-lisp.net  Mon Mar 29 14:35:46 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:35:46 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1B7xre-0004TA-00@common-lisp.net>

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

Added Files:
	los0-gc.lisp 
Log Message:
Implementation of a simple GC architecture, used by los0.

Date: Mon Mar 29 09:35:45 2004
Author: ffjeld





From ffjeld at common-lisp.net  Mon Mar 29 14:36:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:36:15 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1B7xs7-0005hZ-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Include los-gc, and install it when booting up.

Date: Mon Mar 29 09:36:15 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.7 movitz/losp/los0.lisp:1.8
--- movitz/losp/los0.lisp:1.7	Thu Mar 25 20:53:53 2004
+++ movitz/losp/los0.lisp	Mon Mar 29 09:36:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.7 2004/03/26 01:53:53 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.8 2004/03/29 14:36:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -39,7 +39,9 @@
 	muerte.mop
 	muerte.debug
 	#+ignore muerte.x86-pc.serial))
-	
+
+(require :los0-gc)
+
 (in-package muerte.init)
 
 (declaim (special muerte::*multiboot-data*))
@@ -838,12 +840,16 @@
     (incf extended-memsize (io-port #x71 :unsigned-byte8))
     (format t "Extended memory: ~D KB" extended-memsize))
 
+;;;  (loop for i from  #x40600 below #x80000
+;;;      do (setf (memref i 0 0 :unsigned-byte32) #xababe13))
+  
+  (install-los0-consing)
+  
   (let ((*repl-readline-context* (make-readline-context :history-size 16))
 	(*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
 	#+ignore (*error-no-condition-for-debugger* t)
 	(*debugger-function* #'los0-debugger)
 	(*package* nil))
-
     (with-simple-restart (continue "Abort LOS0 boot-up initialization.")
       (setf *cpu-features*
 	(find-cpu-features))
@@ -944,5 +950,5 @@
 	   (#\esc (break "Under the bridge."))
 	   (#\e (error "this is an error!"))))))))
 
-    
+
 (genesis)




From ffjeld at common-lisp.net  Mon Mar 29 14:36:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:36:43 -0500
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1B7xsZ-0005wj-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Some new symbols in the muerte package.

Date: Mon Mar 29 09:36:43 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.10 movitz/packages.lisp:1.11
--- movitz/packages.lisp:1.10	Wed Mar 24 13:39:47 2004
+++ movitz/packages.lisp	Mon Mar 29 09:36:43 2004
@@ -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.10 2004/03/24 18:39:47 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.11 2004/03/29 14:36:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1120,12 +1120,23 @@
 	   #:package-object-internal-symbols
 	   #:package-object-external-symbols
 
+	   #:map-heap-words
+	   #:map-stack-words
+	   #:malloc-clumps
+	   #:malloc-cons-pointer
+	   #:malloc-buffer-start
+
+	   #:%word-offset
+	   #:%run-time-context-slot
+	   #:shallow-copy
+	   
 	   vector-element-type
 	   vector-element-size
 	   with-subvector-accessor
 	   svref%unsafe
 	   bvref-u16
 	   object-location
+	   location-in-object-p
 	   inline-malloc
 	   define-compile-time-variable
 	   define-primitive-function




From ffjeld at common-lisp.net  Mon Mar 29 14:53:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:53:14 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp 
Message-ID: <E1B7y8Y-0004b5-00@common-lisp.net>

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

Modified Files:
	defstruct.lisp 
Log Message:
Added standard function copy-structure.

Date: Mon Mar 29 09:53:14 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.4 movitz/losp/muerte/defstruct.lisp:1.5
--- movitz/losp/muerte/defstruct.lisp:1.4	Fri Mar 26 08:57:12 2004
+++ movitz/losp/muerte/defstruct.lisp	Mon Mar 29 09:53:13 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.4 2004/03/26 13:57:12 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.5 2004/03/29 14:53:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,9 +19,22 @@
 
 (in-package muerte)
 
-(defun structure-object-length (obj)
-  (check-type obj structure-object)
-  (movitz-accessor-u16 obj movitz-struct length))
+(defun structure-object-length (object)
+  (check-type object structure-object)
+  (movitz-accessor-u16 object movitz-struct length))
+
+(defun copy-structure (object)
+  (check-type object structure-object)
+  (let* ((length (structure-object-length object))
+	 (copy (malloc-words length)))
+    (setf (memref copy -6 0 :lisp)
+      (memref object -6 0 :lisp))
+    (setf (memref copy -6 1 :unsigned-byte32)
+      (memref object -6 1 :unsigned-byte32))
+    (dotimes (i length)
+      (setf (structure-ref copy i)
+	(structure-ref object i)))
+    copy))
 
 (defun struct-predicate-prototype (obj)
   "Prototype function for predicates of user-defined struct.




From ffjeld at common-lisp.net  Mon Mar 29 14:56:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 09:56:26 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/equalp.lisp 
Message-ID: <E1B7yBe-0005Q3-00@common-lisp.net>

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

Modified Files:
	equalp.lisp 
Log Message:
Make equalp behave for structure-objects.

Date: Mon Mar 29 09:56:26 2004
Author: ffjeld

Index: movitz/losp/muerte/equalp.lisp
diff -u movitz/losp/muerte/equalp.lisp:1.2 movitz/losp/muerte/equalp.lisp:1.3
--- movitz/losp/muerte/equalp.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/equalp.lisp	Mon Mar 29 09:56:26 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 13 17:09:08 2001
 ;;;;                
-;;;; $Id: equalp.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: equalp.lisp,v 1.3 2004/03/29 14:56:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -57,4 +57,10 @@
 		     ((= i length) t)
 		   (unless (equalp (aref x i) (aref y i))
 		     (return nil)))))))
+    (structure-object
+     (and (eq (class-of x) (class-of y))
+	  (dotimes (i (structure-object-length x) t)
+	    (unless (equalp (structure-ref x i)
+			    (structure-ref y i))
+	      (return nil)))))
     (t (equal x y))))




From ffjeld at common-lisp.net  Mon Mar 29 15:26:26 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 10:26:26 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <E1B7yeg-0002xk-00@common-lisp.net>

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

Modified Files:
	inspect.lisp 
Log Message:
Teach shallow-copy about structure-objects.

Date: Mon Mar 29 10:26:26 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.5 movitz/losp/muerte/inspect.lisp:1.6
--- movitz/losp/muerte/inspect.lisp:1.5	Mon Mar 29 09:33:29 2004
+++ movitz/losp/muerte/inspect.lisp	Mon Mar 29 10:26:25 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.5 2004/03/29 14:33:29 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.6 2004/03/29 15:26:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -185,7 +185,8 @@
 		 :fill-pointer (fill-pointer old)))
     (function
      (copy-funobj old))
-    ))
+    (structure-object
+     (copy-structure old))))
 
 (defun malloc-words (words)
   (malloc-clumps (1+ (truncate (1+ words) 2))))




From ffjeld at common-lisp.net  Mon Mar 29 15:26:39 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 10:26:39 -0500
Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog 
Message-ID: <E1B7yet-000336-00@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***
Date: Mon Mar 29 10:26:39 2004
Author: ffjeld

Index: movitz/doc/ChangeLog
diff -u movitz/doc/ChangeLog:1.2 movitz/doc/ChangeLog:1.3
--- movitz/doc/ChangeLog:1.2	Mon Jan 19 06:23:43 2004
+++ movitz/doc/ChangeLog	Mon Mar 29 10:26:39 2004
@@ -1,3 +1,9 @@
+2004-03-29  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
+
+	* Added basic GC functionality. The Movitz platform is now I
+	believe viable for at least some real-world applications!  Also,
+	there have been many bug-fixes that I've forgotten to record here.
+
 2004-01-19  Frode Vatvedt Fjeld  <frodef at cs.uit.no>
 
 	* Fixed the bootloader slightly so it should now work with VMWare.




From ffjeld at common-lisp.net  Mon Mar 29 19:16:19 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 14:16:19 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <E1B82F9-00072e-00@common-lisp.net>

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

Modified Files:
	repl.lisp 
Log Message:
Don't print the results of toplevel-commands.

Date: Mon Mar 29 14:16:19 2004
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.7 movitz/losp/lib/repl.lisp:1.8
--- movitz/losp/lib/repl.lisp:1.7	Fri Mar 26 08:54:45 2004
+++ movitz/losp/lib/repl.lisp	Mon Mar 29 14:16:19 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 19 14:58:12 2003
 ;;;;                
-;;;; $Id: repl.lisp,v 1.7 2004/03/26 13:54:45 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.8 2004/03/29 19:16:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -52,34 +52,36 @@
 		      (invoke-restart 'muerte::next-line
 				      (muerte.readline:contextual-readline *repl-readline-context*)))))
 		(simple-read-from-string buffer-string t t))
-	    (multiple-value-call
-		(lambda (form previous-package &rest results)
-		  (declare (dynamic-extent results))
-		  (unless (packagep *package*)
-		    (warn "Resetting *package*")
-		    (setf *package* previous-package))
-		  (unless (boundp '*)
-		    (warn "* was unbound!")
-		    (setf * nil))
-		  (apply #'format t *repl-print-format* results)
-		  (psetq +++ ++ ++ + + form)
-		  (psetq *** ** ** * * (car results))
-		  (psetq /// // // / / (if *repl-consless*
-					   nil
-					 (copy-list results)))
-		  (values-list results))
-	      form previous-package
+	    (flet ((process-expresion (form previous-package printp &rest results)
+		     (declare (dynamic-extent results))
+		     (unless (packagep *package*)
+		       (warn "Resetting *package*")
+		       (setf *package* previous-package))
+		     (unless (boundp '*)
+		       (warn "* was unbound!")
+		       (setf * nil))
+		     (when printp
+		       (apply #'format t *repl-print-format* results))
+		     (psetq +++ ++ ++ + + form)
+		     (psetq *** ** ** * * (car results))
+		     (psetq /// // // / / (if *repl-consless*
+					      nil
+					    (copy-list results)))
+		     (values-list results)))
 	      (if (not (keywordp form))
-		  (eval form)
-		(apply 'muerte.toplevel:invoke-toplevel-command
-		       form
-		       (loop for arg = (multiple-value-bind (arg x)
-					   (simple-read-from-string buffer-string nil '#0=#:eof
-								    :start buffer-pointer)
-					 (setq buffer-pointer x)
-					 arg)
-			   until (eq arg '#0#)
-			   collect arg)))))))
+		  (multiple-value-call #'process-expresion
+		    form previous-package t (eval form))
+		(multiple-value-call #'process-expresion
+		  form previous-package nil
+		  (apply 'muerte.toplevel:invoke-toplevel-command
+			 form
+			 (loop for arg = (multiple-value-bind (arg x)
+					     (simple-read-from-string buffer-string nil '#0=#:eof
+								      :start buffer-pointer)
+					   (setq buffer-pointer x)
+					   arg)
+			     until (eq arg '#0#)
+			     collect arg))))))))
     (muerte.readline::readline-break (c)
       (declare (ignore c))
       (values))))




From ffjeld at common-lisp.net  Mon Mar 29 19:19:51 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 29 Mar 2004 14:19:51 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B82IZ-0004tU-00@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Properly allocate vectors specialized to (unsigned-byte 32).

Date: Mon Mar 29 14:19:51 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.13 movitz/losp/muerte/arrays.lisp:1.14
--- movitz/losp/muerte/arrays.lisp:1.13	Mon Mar 29 09:32:12 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Mar 29 14:19:51 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.13 2004/03/29 14:32:12 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.14 2004/03/29 19:19:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -546,30 +546,25 @@
 	   (replace array initial-contents)))
 	 array))
       ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
-       (let ((a (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) (* 4 dimensions))
-			       :other-tag :vector
-			       :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
-								:u32))))
-	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
+       (let ((array (malloc-words dimensions)))
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
 		       0 :unsigned-byte16)
 	   0)
-	 (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
 		       0 :unsigned-byte16)
 	   dimensions)
-	 (setf (fill-pointer a) fill-pointer)
+	 (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
+		       0 :unsigned-byte16)
+	   #.(movitz:vector-type-tag :u32))	 
+	 (setf (fill-pointer array) fill-pointer)
 	 (cond
 	  (initial-element
 	   (dotimes (i dimensions)
-	     (setf (aref a i) initial-element)))
+	     (setf (aref array i) initial-element)))
 	  (initial-contents
-	   (replace a initial-contents)))
-	 a))
-      (t (let ((array (malloc-words dimensions)
-		      #+ignore
-		      (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) (* 4 dimensions))
-				     :other-tag :vector
-				     :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type
-								      :any-t))))
+	   (replace array initial-contents)))
+	 array))
+      (t (let ((array (malloc-words dimensions)))
 	   (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
 			 0 :unsigned-byte16)
 	     0)




From ffjeld at common-lisp.net  Tue Mar 30 08:04:01 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:04:01 -0500
Subject: [movitz-cvs] CVS update: public_html/movitz.html 
Message-ID: <E1B8EE5-00043p-00@common-lisp.net>

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

Modified Files:
	movitz.html 
Log Message:
Added info about the new GC stuff.

Date: Tue Mar 30 03:04:00 2004
Author: ffjeld

Index: public_html/movitz.html
diff -u public_html/movitz.html:1.1 public_html/movitz.html:1.2
--- public_html/movitz.html:1.1	Tue Jan 13 08:31:59 2004
+++ public_html/movitz.html	Tue Mar 30 03:04:00 2004
@@ -10,7 +10,7 @@
  Author:        Frode Vatvedt Fjeld <frodef at acm.org>
  Created at:    Wed Nov  5 09:55:54 2003
                 
- $Id: movitz.html,v 1.1 2004/01/13 13:31:59 ffjeld Exp $
+ $Id: movitz.html,v 1.2 2004/03/30 08:04:00 ffjeld Exp $
                 
 -->
 
@@ -20,7 +20,7 @@
 </head>
 <body>
 <h1>Movitz: A Common Lisp OS development platform</h1>
-<tt>$Id: movitz.html,v 1.1 2004/01/13 13:31:59 ffjeld Exp $</tt>
+<tt>$Id: movitz.html,v 1.2 2004/03/30 08:04:00 ffjeld Exp $</tt>
 
 <h2><a href="files/">Files</a></h2>
 <p> The latest <a href="files/los0.img"> los0 kernel image</a> and its
@@ -141,17 +141,36 @@
 
 <h3>Garbage Collection</h3>
 
-There is no garbage collection scheme implemented yet. Whether a fully
-operational GC <em>can</em> be part of Muerte, or whether it requires
-extensive support from the particular MoKA run-time, remains to be
-seen.
-
-I expect that it turns out that some middle ground must be found: The
-basic mechanisms and hooks needed to perform GC will be provided by
-Muerte, and the MoKA uses this to provide full GC service (if it will
-provide GC at all). In this spirit, I hope to add something like a
-simple stop-and-copy GC to los0 soon.
+There is now preliminary support for GC in Muerte. This support is two
+things. Firstly, the object layouts, stack discipline, etc. are such
+that the system as such is amenable to scanning for GC
+purposes. Secondly, there are two functions in Muerte that are
+expectedly very useful for implementing many kinds of GC:
+<ul>
+
+<li> <tt>map-heap-words</tt> maps a function over every potential
+pointer in a specified memory region. This can be used both to
+implement GC as such (if the function migrates objects according to
+some GC scheme), and as a help for GC debugging (if the function
+merely checks some invariant or prints information). </li> <li>
+<tt>map-stack-words</tt> works similarly for a control stack. A stack
+is wrapped as a vector specialized to <tt>(unsigned-byte 32)</tt> in
+memory, so it will not recognized as pointers by
+e.g. <tt>map-heap-words</tt>. Hence, this function must be used
+explicitly in order to capture all pointers in the system.</li>
+</ul>
 
+The los0 image currently uses these two functions to implement a
+rather simple Cheney-style stop-and-copy GC architecture. In short,
+two 256 KB buffers are set up, and the memory allocation primitives
+are changed to allocate from one of these buffers designated
+"newspace". When newspace goes full, the roles of oldspace and
+newspace are switched, and the (newly demoted) oldspace is
+evacuated. This evacuation is performed rather naively, namely by
+scanning the entire heap, which tends to be somewhere between one and
+two megabytes in los0. Note that under this simple scheme there is no
+way for objects to be promoted from the two 256 KB buffers, so you
+cannot have more than this amount of live, dynamically allocated data.
 
 <h2>About OS design in Common Lisp</h2>
 




From ffjeld at common-lisp.net  Tue Mar 30 08:07:43 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:07:43 -0500
Subject: [movitz-cvs] CVS update: public_html/index.html 
Message-ID: <E1B8EHf-0002wD-00@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
Added a "Recent news" section.

Date: Tue Mar 30 03:07:42 2004
Author: ffjeld

Index: public_html/index.html
diff -u public_html/index.html:1.13 public_html/index.html:1.14
--- public_html/index.html:1.13	Tue Feb 10 06:42:30 2004
+++ public_html/index.html	Tue Mar 30 03:07:42 2004
@@ -13,6 +13,14 @@
   <h1>Movitz: a Common Lisp x86 development platform</h1>
  </div>
 
+ <h3>Recent news</h3>
+
+ <p> <i>March 30. 2004</i> There is now GC support in Muerte, and an
+ almost functional GC architecture included in the los0 image.
+
+ <p> For more news, see the <a
+ href="files/ChangeLog"><tt>ChageLog</tt></a>.
+
  <h3>Introduction</h3>
 
  <p> The Movitz system aspires to be an implementation of ANSI Common




From ffjeld at common-lisp.net  Tue Mar 30 08:09:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:09:21 -0500
Subject: [movitz-cvs] CVS update: public_html/index.html 
Message-ID: <E1B8EJF-0008H3-00@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
Typo fixes.

Date: Tue Mar 30 03:09:21 2004
Author: ffjeld

Index: public_html/index.html
diff -u public_html/index.html:1.14 public_html/index.html:1.15
--- public_html/index.html:1.14	Tue Mar 30 03:07:42 2004
+++ public_html/index.html	Tue Mar 30 03:09:20 2004
@@ -15,11 +15,11 @@
 
  <h3>Recent news</h3>
 
- <p> <i>March 30. 2004</i> There is now GC support in Muerte, and an
+ <p> <i>March 30, 2004:</i> There is now GC support in Muerte, and an
  almost functional GC architecture included in the los0 image.
 
  <p> For more news, see the <a
- href="files/ChangeLog"><tt>ChageLog</tt></a>.
+ href="files/ChangeLog"><tt>ChangeLog</tt></a>.
 
  <h3>Introduction</h3>
 




From ffjeld at common-lisp.net  Tue Mar 30 08:21:20 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:21:20 -0500
Subject: [movitz-cvs] CVS update: public_html/movitz.html 
Message-ID: <E1B8EUq-00042U-00@common-lisp.net>

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

Modified Files:
	movitz.html 
Log Message:
Some re-wording.

Date: Tue Mar 30 03:21:19 2004
Author: ffjeld

Index: public_html/movitz.html
diff -u public_html/movitz.html:1.2 public_html/movitz.html:1.3
--- public_html/movitz.html:1.2	Tue Mar 30 03:04:00 2004
+++ public_html/movitz.html	Tue Mar 30 03:21:18 2004
@@ -10,7 +10,7 @@
  Author:        Frode Vatvedt Fjeld <frodef at acm.org>
  Created at:    Wed Nov  5 09:55:54 2003
                 
- $Id: movitz.html,v 1.2 2004/03/30 08:04:00 ffjeld Exp $
+ $Id: movitz.html,v 1.3 2004/03/30 08:21:18 ffjeld Exp $
                 
 -->
 
@@ -20,7 +20,7 @@
 </head>
 <body>
 <h1>Movitz: A Common Lisp OS development platform</h1>
-<tt>$Id: movitz.html,v 1.2 2004/03/30 08:04:00 ffjeld Exp $</tt>
+<tt>$Id: movitz.html,v 1.3 2004/03/30 08:21:18 ffjeld Exp $</tt>
 
 <h2><a href="files/">Files</a></h2>
 <p> The latest <a href="files/los0.img"> los0 kernel image</a> and its
@@ -139,38 +139,45 @@
 required to interface any hardware without resorting to inline
 assembly is either in place or can easily be added.
 
-<h3>Garbage Collection</h3>
+<h3>Garbage Collection</h3> <a name="GC">
 
 There is now preliminary support for GC in Muerte. This support is two
 things. Firstly, the object layouts, stack discipline, etc. are such
 that the system as such is amenable to scanning for GC
 purposes. Secondly, there are two functions in Muerte that are
-expectedly very useful for implementing many kinds of GC:
+expectedly useful for implementing GC architectures:
 <ul>
 
 <li> <tt>map-heap-words</tt> maps a function over every potential
-pointer in a specified memory region. This can be used both to
-implement GC as such (if the function migrates objects according to
-some GC scheme), and as a help for GC debugging (if the function
-merely checks some invariant or prints information). </li> <li>
-<tt>map-stack-words</tt> works similarly for a control stack. A stack
-is wrapped as a vector specialized to <tt>(unsigned-byte 32)</tt> in
-memory, so it will not recognized as pointers by
+pointer in a specified memory region, denoted by start and end memory
+locations. This can be used both to implement GC as such (if the
+function migrates objects according to some GC scheme), and as a help
+for GC debugging (if the function merely checks some invariant or
+prints information). </li>
+
+<li> <tt>map-stack-words</tt> works similarly for a control stack. A
+stack is wrapped as a vector specialized to <tt>(unsigned-byte
+32)</tt> in memory, so it will not recognized as pointers by
 e.g. <tt>map-heap-words</tt>. Hence, this function must be used
-explicitly in order to capture all pointers in the system.</li>
+explicitly over each live control stack in order to capture all
+pointers in the system.</li>
+
 </ul>
 
 The los0 image currently uses these two functions to implement a
 rather simple Cheney-style stop-and-copy GC architecture. In short,
 two 256 KB buffers are set up, and the memory allocation primitives
-are changed to allocate from one of these buffers designated
+are changed to allocate from one of these buffers designated as
 "newspace". When newspace goes full, the roles of oldspace and
-newspace are switched, and the (newly demoted) oldspace is
-evacuated. This evacuation is performed rather naively, namely by
-scanning the entire heap, which tends to be somewhere between one and
-two megabytes in los0. Note that under this simple scheme there is no
-way for objects to be promoted from the two 256 KB buffers, so you
-cannot have more than this amount of live, dynamically allocated data.
+newspace are switched, and the live objects in the (newly become)
+oldspace are evacuated into the (newly become) newspace. This
+evacuation is performed rather naively, namely by scanning the entire
+heap, which tends to be somewhere between one and two megabytes in
+los0. Note that under this simple scheme there is no way for objects
+to be promoted from the two 256 KB buffers, so you cannot have more
+than this amount of live, dynamically allocated data. Note that there
+are still several rough edges remaining this GC implementation,
+e.g. it will not behave across e.g. any kind of interrupt.
 
 <h2>About OS design in Common Lisp</h2>
 




From ffjeld at common-lisp.net  Tue Mar 30 08:22:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:22:10 -0500
Subject: [movitz-cvs] CVS update: public_html/index.html 
Message-ID: <E1B8EVe-0004yZ-00@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
Add link to GC info in movitz.html.

Date: Tue Mar 30 03:22:10 2004
Author: ffjeld

Index: public_html/index.html
diff -u public_html/index.html:1.15 public_html/index.html:1.16
--- public_html/index.html:1.15	Tue Mar 30 03:09:20 2004
+++ public_html/index.html	Tue Mar 30 03:22:10 2004
@@ -16,7 +16,8 @@
  <h3>Recent news</h3>
 
  <p> <i>March 30, 2004:</i> There is now GC support in Muerte, and an
- almost functional GC architecture included in the los0 image.
+ almost functional GC architecture included in the los0 image. Some
+ info is also added <a href="movitz.html#GC">here</a>.
 
  <p> For more news, see the <a
  href="files/ChangeLog"><tt>ChangeLog</tt></a>.




From ffjeld at common-lisp.net  Tue Mar 30 08:27:57 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:27:57 -0500
Subject: [movitz-cvs] CVS update: public_html/movitz.html 
Message-ID: <E1B8EbF-00059A-00@common-lisp.net>

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

Modified Files:
	movitz.html 
Log Message:
Added a bit more about map-stack-words.

Date: Tue Mar 30 03:27:57 2004
Author: ffjeld

Index: public_html/movitz.html
diff -u public_html/movitz.html:1.3 public_html/movitz.html:1.4
--- public_html/movitz.html:1.3	Tue Mar 30 03:21:18 2004
+++ public_html/movitz.html	Tue Mar 30 03:27:57 2004
@@ -10,7 +10,7 @@
  Author:        Frode Vatvedt Fjeld <frodef at acm.org>
  Created at:    Wed Nov  5 09:55:54 2003
                 
- $Id: movitz.html,v 1.3 2004/03/30 08:21:18 ffjeld Exp $
+ $Id: movitz.html,v 1.4 2004/03/30 08:27:57 ffjeld Exp $
                 
 -->
 
@@ -20,7 +20,7 @@
 </head>
 <body>
 <h1>Movitz: A Common Lisp OS development platform</h1>
-<tt>$Id: movitz.html,v 1.3 2004/03/30 08:21:18 ffjeld Exp $</tt>
+<tt>$Id: movitz.html,v 1.4 2004/03/30 08:27:57 ffjeld Exp $</tt>
 
 <h2><a href="files/">Files</a></h2>
 <p> The latest <a href="files/los0.img"> los0 kernel image</a> and its
@@ -160,7 +160,9 @@
 32)</tt> in memory, so it will not recognized as pointers by
 e.g. <tt>map-heap-words</tt>. Hence, this function must be used
 explicitly over each live control stack in order to capture all
-pointers in the system.</li>
+pointers in the system. Another reason why stacks are special, is that
+they contain untagged pointers to code-vectors, and this requires
+special treatment.  </li>
 
 </ul>
 




From ffjeld at common-lisp.net  Tue Mar 30 08:31:10 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:31:10 -0500
Subject: [movitz-cvs] CVS update: public_html/movitz.html 
Message-ID: <E1B8EeM-0004y8-00@common-lisp.net>

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

Modified Files:
	movitz.html 
Log Message:
..and a bit more.

Date: Tue Mar 30 03:31:10 2004
Author: ffjeld

Index: public_html/movitz.html
diff -u public_html/movitz.html:1.4 public_html/movitz.html:1.5
--- public_html/movitz.html:1.4	Tue Mar 30 03:27:57 2004
+++ public_html/movitz.html	Tue Mar 30 03:31:10 2004
@@ -10,7 +10,7 @@
  Author:        Frode Vatvedt Fjeld <frodef at acm.org>
  Created at:    Wed Nov  5 09:55:54 2003
                 
- $Id: movitz.html,v 1.4 2004/03/30 08:27:57 ffjeld Exp $
+ $Id: movitz.html,v 1.5 2004/03/30 08:31:10 ffjeld Exp $
                 
 -->
 
@@ -20,7 +20,7 @@
 </head>
 <body>
 <h1>Movitz: A Common Lisp OS development platform</h1>
-<tt>$Id: movitz.html,v 1.4 2004/03/30 08:27:57 ffjeld Exp $</tt>
+<tt>$Id: movitz.html,v 1.5 2004/03/30 08:31:10 ffjeld Exp $</tt>
 
 <h2><a href="files/">Files</a></h2>
 <p> The latest <a href="files/los0.img"> los0 kernel image</a> and its
@@ -177,9 +177,10 @@
 heap, which tends to be somewhere between one and two megabytes in
 los0. Note that under this simple scheme there is no way for objects
 to be promoted from the two 256 KB buffers, so you cannot have more
-than this amount of live, dynamically allocated data. Note that there
-are still several rough edges remaining this GC implementation,
-e.g. it will not behave across e.g. any kind of interrupt.
+than this amount of live, dynamically allocated data. You may trigger
+the GC process explicitly with <tt>(init::stop-and-copy)</tt>. Note
+that there are still several rough edges remaining this GC
+implementation, e.g. it will not behave across any kind of interrupt.
 
 <h2>About OS design in Common Lisp</h2>
 




From ffjeld at common-lisp.net  Tue Mar 30 08:35:32 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:35:32 -0500
Subject: [movitz-cvs] CVS update: public_html/movitz.html 
Message-ID: <E1B8Eia-0003Ob-00@common-lisp.net>

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

Modified Files:
	movitz.html 
Log Message:
dumdidum.

Date: Tue Mar 30 03:35:32 2004
Author: ffjeld

Index: public_html/movitz.html
diff -u public_html/movitz.html:1.5 public_html/movitz.html:1.6
--- public_html/movitz.html:1.5	Tue Mar 30 03:31:10 2004
+++ public_html/movitz.html	Tue Mar 30 03:35:32 2004
@@ -10,7 +10,7 @@
  Author:        Frode Vatvedt Fjeld <frodef at acm.org>
  Created at:    Wed Nov  5 09:55:54 2003
                 
- $Id: movitz.html,v 1.5 2004/03/30 08:31:10 ffjeld Exp $
+ $Id: movitz.html,v 1.6 2004/03/30 08:35:32 ffjeld Exp $
                 
 -->
 
@@ -20,7 +20,7 @@
 </head>
 <body>
 <h1>Movitz: A Common Lisp OS development platform</h1>
-<tt>$Id: movitz.html,v 1.5 2004/03/30 08:31:10 ffjeld Exp $</tt>
+<tt>$Id: movitz.html,v 1.6 2004/03/30 08:35:32 ffjeld Exp $</tt>
 
 <h2><a href="files/">Files</a></h2>
 <p> The latest <a href="files/los0.img"> los0 kernel image</a> and its
@@ -178,9 +178,9 @@
 los0. Note that under this simple scheme there is no way for objects
 to be promoted from the two 256 KB buffers, so you cannot have more
 than this amount of live, dynamically allocated data. You may trigger
-the GC process explicitly with <tt>(init::stop-and-copy)</tt>. Note
-that there are still several rough edges remaining this GC
-implementation, e.g. it will not behave across any kind of interrupt.
+the GC process explicitly with <tt>(stop-and-copy)</tt>. Note that
+there are still several rough edges remaining this GC implementation,
+e.g. it will not behave across any kind of interrupt.
 
 <h2>About OS design in Common Lisp</h2>
 




From ffjeld at common-lisp.net  Tue Mar 30 08:50:13 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 03:50:13 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1B8Ewn-0003cu-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
In map-heap-words, only write back the new word if the function
changes it. Seems like an obvious way to reduce pressure on the memory
subsystem, and increased speed by about 5% on my test HW.

Date: Tue Mar 30 03:50:12 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.1 movitz/losp/muerte/scavenge.lisp:1.2
--- movitz/losp/muerte/scavenge.lisp:1.1	Mon Mar 29 09:30:22 2004
+++ movitz/losp/muerte/scavenge.lisp	Tue Mar 30 03:50:12 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.1 2004/03/29 14:30:22 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.2 2004/03/30 08:50:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -87,7 +87,8 @@
 	 ((typep x 'pointer)
 	  (let ((new (funcall function x)))
 	    (check-type new pointer)
-	    (setf (memref i 0 0 :lisp) new)))))))
+	    (unless (eq x new)
+	      (setf (memref i 0 0 :lisp) new))))))))
   (values))
 
 (defun map-stack-words (function start-stack-frame)




From ffjeld at common-lisp.net  Tue Mar 30 09:12:35 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 04:12:35 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1B8FIR-0001wG-00@common-lisp.net>

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

Modified Files:
	run-time-context.lisp 
Log Message:
Write %run-time-context-slot in terms of %word-offset.

Date: Tue Mar 30 04:12:35 2004
Author: ffjeld

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.2 movitz/losp/muerte/run-time-context.lisp:1.3
--- movitz/losp/muerte/run-time-context.lisp:1.2	Thu Mar 18 04:23:01 2004
+++ movitz/losp/muerte/run-time-context.lisp	Tue Mar 30 04:12:35 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.2 2004/03/18 09:23:01 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.3 2004/03/30 09:12:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -56,7 +56,7 @@
       (word
        (memref context -6 (third slot) :lisp))
       (code-vector-word
-       (memref context -6 (third slot) :lisp-code-vector))
+       (%word-offset (memref context -6 (third slot) :lisp) -2))
       (lu32
        (memref context -6 (third slot) :unsigned-byte32)))))
 




From ffjeld at common-lisp.net  Tue Mar 30 09:36:50 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 04:36:50 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1B8Ffu-0006an-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Remove the rather bogus :lisp-code-vector type.

Date: Tue Mar 30 04:36:50 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.4 movitz/losp/muerte/memref.lisp:1.5
--- movitz/losp/muerte/memref.lisp:1.4	Sun Mar 28 11:19:20 2004
+++ movitz/losp/muerte/memref.lisp	Tue Mar 30 04:36:50 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.4 2004/03/28 16:19:20 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.5 2004/03/30 09:36:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -151,32 +151,26 @@
 			(:popl :ecx)	; pop object
 			(:sarl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale offset+index
 			(:movb (:ebx :ecx ,(offset-by 1)) :ah)))))
-		((:lisp :lisp-code-vector)
-		 (let ((fix-when-code-vector
-			(when (eq type :lisp-code-vector)
-			  `((:subl ,movitz::+code-vector-word-offset+ :eax)))))
-		   (cond
-		    ((and (eq 0 index) (eq 0 offset))
-		     `(with-inline-assembly (:returns :eax)
-			(:compile-form (:result-mode :eax) ,object)
-			(:movl (:eax ,(offset-by 4)) :eax)
-			, at fix-when-code-vector))
-		    ((eq 0 offset)
-		     `(with-inline-assembly (:returns :eax)
-			(:compile-two-forms (:eax :ecx) ,object ,index)
+		(:lisp
+		 (cond
+		  ((and (eq 0 index) (eq 0 offset))
+		   `(with-inline-assembly (:returns :register)
+		      (:compile-form (:result-mode :register) ,object)
+		      (:movl ((:result-register) ,(offset-by 4)) (:result-register))))
+		  ((eq 0 offset)
+		   `(with-inline-assembly (:returns :eax)
+		      (:compile-two-forms (:eax :ecx) ,object ,index)
+		      ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
+			  `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx))
+		      (:movl (:eax :ecx ,(offset-by 4)) :eax)))
+		  (t `(with-inline-assembly (:returns :eax)
+			(:compile-form (:result-mode :push) ,object)
+			(:compile-two-forms (:untagged-fixnum-eax :ecx) ,offset ,index)
 			,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
 			    `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx))
-			(:movl (:eax :ecx ,(offset-by 4)) :eax)
-			, at fix-when-code-vector))
-		    (t `(with-inline-assembly (:returns :eax)
-			  (:compile-form (:result-mode :push) ,object)
-			  (:compile-two-forms (:untagged-fixnum-eax :ecx) ,offset ,index)
-			  ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
-			      `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx))
-			  (:addl :ecx :eax)
-			  (:popl :ebx)	; pop object
-			  (:movl (:eax :ebx ,(offset-by 4)) :eax)
-			  , at fix-when-code-vector)))))
+			(:addl :ecx :eax)
+			(:popl :ebx)	; pop object
+			(:movl (:eax :ebx ,(offset-by 4)) :eax)))))
 		(t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil))
 		   form)))))))))
 
@@ -187,7 +181,6 @@
     (:unsigned-byte32   (memref object offset index :unsigned-byte32))
     (:character         (memref object offset index :character))
     (:lisp              (memref object offset index :lisp))
-    (:lisp-code-vector  (memref object offset index :lisp-code-vector))
     (:signed-byte30+2   (memref object offset index :signed-byte30+2))
     (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))
 




From ffjeld at common-lisp.net  Tue Mar 30 19:23:41 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 14:23:41 -0500
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1B8Opp-0007LF-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Have the :untagged-fixnum-ecx mode accept (signed-byte 30) values.

Date: Tue Mar 30 14:23:40 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.37 movitz/compiler.lisp:1.38
--- movitz/compiler.lisp:1.37	Sun Mar 28 10:09:27 2004
+++ movitz/compiler.lisp	Tue Mar 30 14:23:40 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.37 2004/03/28 15:09:27 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.38 2004/03/30 19:23:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3432,7 +3432,7 @@
 		 (make-immediate-move value :eax)))
 	      (:untagged-fixnum-ecx
 	       (let ((value (movitz-fixnum-value object)))
-		 (check-type value (unsigned-byte 16))
+		 (check-type value (signed-byte 30))
 		 (make-immediate-move value :ecx)))
 	      (:push
 	       `((:pushl ,x)))




From ffjeld at common-lisp.net  Tue Mar 30 19:36:15 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 14:36:15 -0500
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1B8P1z-0001nV-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Fix the block operator's compiler not to return mode :ignore, rather :nothing.

Date: Tue Mar 30 14:36:15 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.12 movitz/special-operators-cl.lisp:1.13
--- movitz/special-operators-cl.lisp:1.12	Wed Mar 24 13:36:41 2004
+++ movitz/special-operators-cl.lisp	Tue Mar 30 14:36:15 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.12 2004/03/24 18:36:41 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.13 2004/03/30 19:36:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -724,6 +724,7 @@
 				(t :eax)))
 	   (block-returns-mode (case block-result-mode
 				 (:function :multiple-values)
+				 (:ignore :nothing)
 				 (t block-result-mode)))
 	   (block-env (make-instance 'lexical-exit-point-env
 			:uplink env




From ffjeld at common-lisp.net  Tue Mar 30 21:32:12 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 16:32:12 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <E1B8QqC-0001tg-00@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Add a declaration of the *print-circle* variable. Not that write
implements it.

Date: Tue Mar 30 16:32:12 2004
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.3 movitz/losp/muerte/print.lisp:1.4
--- movitz/losp/muerte/print.lisp:1.3	Mon Mar 22 09:38:13 2004
+++ movitz/losp/muerte/print.lisp	Tue Mar 30 16:32:12 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Sep  3 11:48:19 2001
 ;;;;                
-;;;; $Id: print.lisp,v 1.3 2004/03/22 14:38:13 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.4 2004/03/30 21:32:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -31,6 +31,7 @@
 (defvar *print-length* 8)
 (defvar *print-level* 3)
 (defvar *print-pretty* t)
+(defvar *print-circle* nil)
 
 (defvar *standard-output* #'muerte.x86-pc::textmode-console)
 (defvar *standard-input* #'muerte.x86-pc::textmode-console)




From ffjeld at common-lisp.net  Tue Mar 30 21:33:54 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 30 Mar 2004 16:33:54 -0500
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <E1B8Qrq-00033w-00@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
For non-lexical go, add a bounds check for the calcuclated
stack-pointer before assuming it.

Date: Tue Mar 30 16:33:54 2004
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.13 movitz/special-operators-cl.lisp:1.14
--- movitz/special-operators-cl.lisp:1.13	Tue Mar 30 14:36:15 2004
+++ movitz/special-operators-cl.lisp	Tue Mar 30 16:33:54 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.13 2004/03/30 19:36:15 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.14 2004/03/30 21:33:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -704,6 +704,7 @@
 			  `((:xorl :ebx :ebx)
 			    (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag))))
 			    (:jnc '(:sub-program () (:int 108)))
+			    (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
 			    (:movl :eax :esp)
 			    (:movl (:esp) :ebp)
 			    (:movl (:ebp -4) :esi)




From ffjeld at common-lisp.net  Wed Mar 31 12:17:21 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 07:17:21 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <E1B8een-0004i8-00@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Added two-arguments implementations for find and count-if.

Date: Wed Mar 31 07:17:19 2004
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.5 movitz/losp/muerte/sequences.lisp:1.6
--- movitz/losp/muerte/sequences.lisp:1.5	Sun Feb 29 14:14:59 2004
+++ movitz/losp/muerte/sequences.lisp	Wed Mar 31 07:17:14 2004
@@ -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.5 2004/02/29 19:14:59 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.6 2004/03/31 12:17:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -775,35 +775,50 @@
       sequence-1)))
 
 (defun find (item sequence &key from-end (test 'eql) (start 0) end (key 'identity))
-  (with-funcallable (test)
-    (with-funcallable (key)
+  (numargs-case
+   (2 (item sequence)
       (sequence-dispatch sequence
 	(vector
-	 (setf end (or end (length sequence)))
-	 (with-subvector-accessor (sequence-ref sequence start end)
-	   (if (not from-end)
-	       (do ((i start (1+ i)))
-		   ((>= i end) nil)
-		 (when (test item (key (aref sequence i)))
-		   (return (sequence-ref i))))
-	     (do ((i (1- end) (1- i)))
-		 ((< i start) nil)
-	       (when (test item (key (sequence-ref i)))
-		 (return (sequence-ref i)))))))
+	 (with-subvector-accessor (sequence-ref sequence)
+	   (dotimes (i (length sequence))
+	     (when (eql item (sequence-ref i))
+	       (return item)))))
 	(list
-	 (if end
-	     (do ((p (nthcdr start sequence) (cdr p))
-		  (i start (1+ i)))
-		 ((or (>= i end) (endp p)) nil)
-	       (when (test item (key (car p)))
-		 (return (or (and from-end
-				  (find item (cdr p) :from-end t :test test :key key :end (- end i 1)))
-			     (car p)))))
-	   (do ((p (nthcdr start sequence) (cdr p)))
-	       ((endp p) nil)
-	     (when (test item (key (car p)))
-	       (return (or (and from-end (find item (cdr p) :from-end t :test test :key key))
-			   (car p)))))))))))
+	 (dolist (x sequence)
+	   (when (eql item x)
+	     (return x))))))
+   (t (item sequence &key from-end (test 'eql) (start 0) end (key 'identity))
+      (with-funcallable (test)
+	(with-funcallable (key)
+	  (sequence-dispatch sequence
+	    (vector
+	     (setf end (or end (length sequence)))
+	     (with-subvector-accessor (sequence-ref sequence start end)
+	       (if (not from-end)
+		   (do ((i start (1+ i)))
+		       ((>= i end) nil)
+		     (when (test item (key (aref sequence i)))
+		       (return (sequence-ref i))))
+		 (do ((i (1- end) (1- i)))
+		     ((< i start) nil)
+		   (when (test item (key (sequence-ref i)))
+		     (return (sequence-ref i)))))))
+	    (list
+	     (if end
+		 (do ((p (nthcdr start sequence) (cdr p))
+		      (i start (1+ i)))
+		     ((or (>= i end) (endp p)) nil)
+		   (when (test item (key (car p)))
+		     (return (or (and from-end
+				      (find item (cdr p)
+					    :from-end t :test test
+					    :key key :end (- end i 1)))
+				 (car p)))))
+	       (do ((p (nthcdr start sequence) (cdr p)))
+		   ((endp p) nil)
+		 (when (test item (key (car p)))
+		   (return (or (and from-end (find item (cdr p) :from-end t :test test :key key))
+			       (car p)))))))))))))
   
 
 (defun find-if (predicate sequence &key from-end (start 0) end (key 'identity))
@@ -897,24 +912,42 @@
 		 (incf n))))))))))
 
 (defun count-if (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end)
-  (with-funcallable (predicate)
-    (with-funcallable (key)
-      (sequence-dispatch sequence
-	(list
-	 (if (not end)
-	     (do ((n 0)
-		  (p (nthcdr start sequence) (cdr p)))
-		 ((endp p) n)
-	       (when (predicate (key (car p)))
-		 (incf n)))
-	   (do ((n 0)
-		(i start (1+ i))
-		(p (nthcdr start sequence) (cdr p)))
-	       ((or (endp p) (>= i end)) n)
-	     (when (predicate (key (car p)))
-	       (incf n)))))
-	(vector
-	 (error "vector count-if not implemented."))))))
+  (numargs-case
+   (2 (predicate sequence)
+      (with-funcallable (predicate)
+	(sequence-dispatch sequence
+	  (list
+	   (let ((count 0))
+	     (dolist (x sequence)
+	       (when (predicate x)
+		 (incf count)))
+	     count))
+	  (vector
+	   (with-subvector-accessor (sequence-ref sequence)
+	     (let ((count 0))
+	       (dotimes (i (length sequence))
+		 (when (predicate (sequence-ref i))
+		   (incf count)))
+	       count))))))
+   (t (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end)
+      (with-funcallable (predicate)
+	(with-funcallable (key)
+	  (sequence-dispatch sequence
+	    (list
+	     (if (not end)
+		 (do ((n 0)
+		      (p (nthcdr start sequence) (cdr p)))
+		     ((endp p) n)
+		   (when (predicate (key (car p)))
+		     (incf n)))
+	       (do ((n 0)
+		    (i start (1+ i))
+		    (p (nthcdr start sequence) (cdr p)))
+		   ((or (endp p) (>= i end)) n)
+		 (when (predicate (key (car p)))
+		   (incf n)))))
+	    (vector
+	     (error "vector count-if not implemented."))))))))
 
 
 (macrolet ((every-some-body ()




From ffjeld at common-lisp.net  Wed Mar 31 15:55:31 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 10:55:31 -0500
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <E1B8i3v-00042p-00@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Added variable *compiler-allow-untagged-word-bits* (see docstring).

Date: Wed Mar 31 10:55:31 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.38 movitz/compiler.lisp:1.39
--- movitz/compiler.lisp:1.38	Tue Mar 30 14:23:40 2004
+++ movitz/compiler.lisp	Wed Mar 31 10:55:31 2004
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.38 2004/03/30 19:23:40 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.39 2004/03/31 15:55:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -43,6 +43,12 @@
 (defvar *compiler-global-segment-prefix* nil
   "Use these assembly-instruction prefixes when accessing the global
 run-time context.")
+
+(defvar *compiler-allow-untagged-word-bits* 0
+  "Allow (temporary) untagged values of this bit-size to exist, because
+the system ensures one way or another that there can be no pointers below
+this size.")
+
 
 (defvar *compiler-compile-eval-whens* t
   "When encountering (eval-when (:compile-toplevel) <code>),




From ffjeld at common-lisp.net  Wed Mar 31 16:31:44 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:31:44 -0500
Subject: [movitz-cvs] CVS update: movitz/eval.lisp 
Message-ID: <E1B8icy-0007It-00@common-lisp.net>

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

Modified Files:
	eval.lisp 
Log Message:
Have movitz-constantp and movitz-eval understand +, -, and *.

Date: Wed Mar 31 11:31:44 2004
Author: ffjeld

Index: movitz/eval.lisp
diff -u movitz/eval.lisp:1.3 movitz/eval.lisp:1.4
--- movitz/eval.lisp:1.3	Thu Mar 25 20:43:46 2004
+++ movitz/eval.lisp	Wed Mar 31 11:31:44 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  2 17:45:05 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: eval.lisp,v 1.3 2004/03/26 01:43:46 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.4 2004/03/31 16:31:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -66,8 +66,13 @@
       (symbol (or (movitz-env-get form 'constantp nil environment)
 		  (typep (movitz-binding form environment) 'constant-object-binding)))
       (cons (case (car form)
-	      ((muerte.cl::quote) t)
-	      (muerte.cl::not (movitz-constantp (second form))))))))
+	      ((muerte.cl:quote) t)
+	      ((muerte.cl:not)
+	       (movitz-constantp (second form)))
+	      ((muerte.cl:+ muerte.cl:- muerte.cl:*)
+	       (every (lambda (sub-form)
+			(movitz-constantp sub-form environment))
+		      (cdr form))))))))
 
 
 (defun isconst (x)
@@ -139,4 +144,9 @@
     (eval-self-evaluating (second form) env top-level-p))
    (muerte.cl::not
     (not (eval-form (second form) env nil)))
+   ((muerte.cl:+ muerte.cl:- muerte.cl:*)
+    (apply (translate-program (car form) :muerte.cl :cl)
+	   (mapcar (lambda (sub-form)
+		     (movitz-eval sub-form env nil))
+		   (cdr form))))
    (t (error "Don't know how to compile constant compound form ~A" form))))




From ffjeld at common-lisp.net  Wed Mar 31 16:32:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:32:22 -0500
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <E1B8ida-0007aC-00@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Added symbol.

Date: Wed Mar 31 11:32:22 2004
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.11 movitz/packages.lisp:1.12
--- movitz/packages.lisp:1.11	Mon Mar 29 09:36:43 2004
+++ movitz/packages.lisp	Wed Mar 31 11:32:22 2004
@@ -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.11 2004/03/29 14:36:43 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.12 2004/03/31 16:32:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1322,6 +1322,7 @@
 	   #:*compiler-global-segment-prefix*
 	   #:*compiler-compile-eval-whens*
 	   #:*compiler-compile-macro-expanders*
+	   #:*compiler-allow-untagged-word-bits*
 	   )
   (:import-from muerte
 		#:translate-program




From ffjeld at common-lisp.net  Wed Mar 31 16:33:25 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:33:25 -0500
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <E1B8ieb-0000fM-00@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Minor edits.

Date: Wed Mar 31 11:33:25 2004
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.16 movitz/special-operators.lisp:1.17
--- movitz/special-operators.lisp:1.16	Sun Mar 28 11:20:05 2004
+++ movitz/special-operators.lisp	Wed Mar 31 11:33:25 2004
@@ -8,7 +8,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 24 16:22:59 2000
 ;;;;                
-;;;; $Id: special-operators.lisp,v 1.16 2004/03/28 16:20:05 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.17 2004/03/31 16:33:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -377,7 +377,7 @@
 					       :muerte.cl :cl))
 	    (cl-macro-body (translate-program macro-body :muerte.cl :cl)))
 	(when (member name (image-called-functions *image*) :key #'first)
-	  #+ignore (warn "Macro ~S defined after being called as function (in ~S)."
+	  #+ignore (warn "Macro ~S defined after being called as function (first in ~S)."
 			 name
 			 (cdr (find name (image-called-functions *image*) :key #'first))))
 	(multiple-value-bind (cl-body declarations doc-string)
@@ -427,7 +427,7 @@
 		(env-formal (or envvar (gensym)))
 		(expansion-var (gensym)))
 	    (when (member operator-name (image-called-functions *image*) :key #'first)
-	      (warn "Compiler-macro ~S defined after being called as function (in ~S)"
+	      (warn "Compiler-macro ~S defined after being called as function (first in ~S)"
 		    operator-name
 		    (cdr (find operator-name (image-called-functions *image*) :key #'first))))
 	    (let ((expander
@@ -572,7 +572,7 @@
 			   (destructuring-bind (var)
 			       (cdr expr)
 			     (let ((binding (movitz-binding var env)))
-			       (check-type binding lexical-binding)
+			       (check-type binding binding)
 			       (list binding)))))
 		       (let ((code (assembly-macroexpand inline-asm amenv)))
 			 #+ignore
@@ -686,7 +686,7 @@
 			       `((:cmpl :edi ,(single-value-register not-returns))))
 		 :returns :boolean-zf=1)) ; TRUE iff result equal to :edi/NIL.
 	      (otherwise
-	       (warn "unable to deal inteligently with inlined-NOT not-returns: ~S for ~S from ~S"
+	       (warn "unable to deal intelligently with inlined-NOT not-returns: ~S for ~S from ~S"
 		     not-returns not-result-mode (not-values :producer))
 	       (let ((label (make-symbol "not-label")))
 		 (compiler-values (not-values)
@@ -711,9 +711,9 @@
 	as sub-form-result-mode = buried-result-modes
 	then (or (cdr sub-form-result-mode)
 		 sub-form-result-mode)
-	as current-result-mode = (if (endp (cdr sub-form))
-				     ;; all but the last form have
-				     ;; result-mode as declared
+	as current-result-mode = (if (endp (cdr sub-form)) all but the
+				     ;; last form have result-mode as
+				     ;; declared
 				     result-mode
 				   (car sub-form-result-mode))
 	as last-form-p = (endp (cdr sub-form))




From ffjeld at common-lisp.net  Wed Mar 31 16:34:48 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:34:48 -0500
Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp 
Message-ID: <E1B8ifw-00043V-00@common-lisp.net>

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

Modified Files:
	stream-image.lisp 
Log Message:
Be slightly more clever about guessing a nil-word for stream-images.

Date: Wed Mar 31 11:34:48 2004
Author: ffjeld

Index: movitz/stream-image.lisp
diff -u movitz/stream-image.lisp:1.3 movitz/stream-image.lisp:1.4
--- movitz/stream-image.lisp:1.3	Mon Feb  9 19:23:39 2004
+++ movitz/stream-image.lisp	Wed Mar 31 11:34:47 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Aug 27 14:46:50 2001
 ;;;;                
-;;;; $Id: stream-image.lisp,v 1.3 2004/02/10 00:23:39 ffjeld Exp $
+;;;; $Id: stream-image.lisp,v 1.4 2004/03/31 16:34:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -31,7 +31,11 @@
     :reader image-start-address)
    (nil-word
     :initarg :nil-word
-    :initform #x65
+    :initform (if (boundp '*image*)
+		  (image-nil-word *image*)
+		(progn
+		  (format *query-io* "~&Please enter the stream-images NIL value: ")
+		  (read *query-io*)))
     :reader image-nil-word)))
 
 (defmethod image-register32 ((image stream-image) register-name)




From ffjeld at common-lisp.net  Wed Mar 31 16:36:29 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:36:29 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <E1B8ihZ-00075n-00@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
The scavenging mapper function now also passes the referring location
as an argument to the mapped function.

Date: Wed Mar 31 11:36:29 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.1 movitz/losp/los0-gc.lisp:1.2
--- movitz/losp/los0-gc.lisp:1.1	Mon Mar 29 09:35:45 2004
+++ movitz/losp/los0-gc.lisp	Wed Mar 31 11:36:29 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.1 2004/03/29 14:35:45 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.2 2004/03/31 16:36:29 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -139,18 +139,25 @@
 	  (+ (object-location space)
 	     (array-dimension space 0)))))
 
-(defun report-nursery (x)
+(defun report-nursery (x location)
   "Write a message if x is inside newspace."
   (when (object-in-space-p (%run-time-context-slot 'nursery-space) x)
-    (format t "~&~Z: ~S: ~S" x (type-of x) x))
+    (format t "~&~Z: ~S: ~S from ~S" x (type-of x) x location))
   x)
 
-(defun report-inactive-space (x)
+(defun report-inactive-space (x location)
   "Check that x is not pointing into (what is presumably) oldspace."
   (when (object-in-space-p (space-other (%run-time-context-slot 'nursery-space)) x)
-    (break "~Z: ~S: ~S" x (type-of x) x))
+    (break "~Z: ~S: ~S from ~S" x (type-of x) x location))
   x)
 
+(defun location-finder (find-location)
+  (lambda (x location)
+    (when (location-in-object-p x find-location)
+      (break "The location ~S is in the object at ~Z referenced from location ~S."
+	     find-location x location))
+    x))
+
 (defun stop-and-copy ()
   (let* ((space0 (%run-time-context-slot 'nursery-space))
 	 (space1 (space-other space0)))
@@ -164,9 +171,11 @@
 	  (values space1 space0))
       ;; Ensure newspace is activated.
       (setf (%run-time-context-slot 'nursery-space) newspace)
+      ;; (assert (< #x200 (- (length newspace) (space-fresh-pointer newspace))))
       ;; Evacuate-oldspace is to be mapped over every potential pointer.
-      (flet ((evacuate-oldspace (x)
+      (flet ((evacuate-oldspace (x location)
 	       "If x is in oldspace, migrate it to newspace."
+	       (declare (ignore location))
 	       (if (not (object-in-space-p oldspace x))
 		   x
 		 (let ((forwarded-x (memref (object-location x) 0 1 :lisp)))




From ffjeld at common-lisp.net  Wed Mar 31 16:36:34 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:36:34 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <E1B8ihe-00078q-00@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
The scavenging mapper function now also passes the referring location
as an argument to the mapped function.

Date: Wed Mar 31 11:36:34 2004
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.2 movitz/losp/muerte/scavenge.lisp:1.3
--- movitz/losp/muerte/scavenge.lisp:1.2	Tue Mar 30 03:50:12 2004
+++ movitz/losp/muerte/scavenge.lisp	Wed Mar 31 11:36:34 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.2 2004/03/30 08:50:12 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.3 2004/03/31 16:36:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -31,7 +31,6 @@
 (defun map-heap-words (function start-location end-location)
   "Map function over each potential pointer word between
 start-location and end-location."
-  (check-type start-location fixnum)
   (macrolet ((scavenge-typep (x primary)
 	       (let ((code (movitz:tag primary)))
 		 `(with-inline-assembly (:returns :boolean-zf=1)
@@ -44,51 +43,50 @@
 		 `(with-inline-assembly (:returns :boolean-zf=1)
 		    (:compile-form (:result-mode :eax) ,x)
 		    (:cmpw ,code :ax)))))
-    (do ((i start-location (1+ i)))
-	((>= i end-location))
-      (let ((*i* i)
-	    (x (memref i 0 0 :lisp)))
-	(declare (special *i*))
+    (do ((scan start-location (1+ scan)))
+	((>= scan end-location))
+      (let (;; (*i* i)
+	    (x (memref scan 0 0 :lisp)))
+	;; (declare (special *i*))
 	(cond
 	 ((typep x '(or null fixnum character)))
 	 ((scavenge-typep x :illegal)
-	  (error "Illegal word ~Z at ~S." x i))
+	  (error "Illegal word ~Z at ~S." x scan))
 	 ((scavenge-typep x :funobj)
 	  ;; Process code-vector pointer specially..
-	  (let ((code-vector (%word-offset (memref i 0 -1 :lisp) -2))
-		(num-jumpers (ldb (byte 14 0) (memref i 0 6 :lisp))))
+	  (let ((code-vector (%word-offset (memref scan 0 -1 :lisp) -2))
+		(num-jumpers (ldb (byte 14 0) (memref scan 0 6 :lisp))))
 	    (check-type code-vector vector-u8)
-	    (map-heap-words function (+ i 4) (+ i 6)) ; scan funobj's lambda-list and name fields
-	    (let ((new-code-vector (funcall function code-vector)))
+	    (map-heap-words function (+ scan 4) (+ scan 6)) ; scan funobj's lambda-list and name fields
+	    (let ((new-code-vector (funcall function code-vector scan)))
 	      (check-type new-code-vector vector-u8)
 	      (unless (eq code-vector new-code-vector)
 		(error "Code-vector migration is not implemented.")
-		(setf (memref i 0 -1 :lisp) (%word-offset new-code-vector 2))
+		(setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2))
 		;; Do more stuff here to update code-vectors and jumpers
 		))
-	    (incf i (+ 6 num-jumpers)))) ; Don't scan the jumpers.
+	    (incf scan (+ 6 num-jumpers)))) ; Don't scan the jumpers.
 	 ((scavenge-typep x :infant-object)
-	  (error "Scanning an infant object ~Z at ~S." x i))
+	  (error "Scanning an infant object ~Z at ~S." x scan))
 	 ((or (scavenge-wide-typep x :vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :u8))
 	      (scavenge-wide-typep x :vector
 				   #.(bt:enum-value 'movitz:movitz-vector-element-type :character)))
-	  (let ((len (memref i -2 0 :unsigned-byte16)))
-	    (incf i (* 2 (truncate (+ 7 len) 8)))))
+	  (let ((len (memref scan -2 0 :unsigned-byte16)))
+	    (incf scan (* 2 (truncate (+ 7 len) 8)))))
 	 ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
-	  (let ((len (memref i -2 0 :unsigned-byte16)))
-	    (incf i (* 2 (truncate (+ 3 len) 4)))))
+	  (let ((len (memref scan -2 0 :unsigned-byte16)))
+	    (incf scan (* 2 (truncate (+ 3 len) 4)))))
 	 ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
-	  (let ((len (memref i -2 0 :unsigned-byte16)))
-	    (incf i (* 2 (truncate (+ 1 len) 2)))))
+	  (let ((len (memref scan -2 0 :unsigned-byte16)))
+	    (incf scan (* 2 (truncate (+ 1 len) 2)))))
 	 ((eq x (fixnum-word 3))
-	  (incf i)
-	  (incf i (memref i 0 0 :lisp)))
+	  (incf scan)
+	  (incf scan (memref scan 0 0 :lisp)))
 	 ((typep x 'pointer)
-	  (let ((new (funcall function x)))
-	    (check-type new pointer)
-	    (unless (eq x new)
-	      (setf (memref i 0 0 :lisp) new))))))))
+	  (let ((new (funcall function x scan)))
+	    (unless (eq new x)
+	      (setf (memref scan 0 0 :lisp) new))))))))
   (values))
 
 (defun map-stack-words (function start-stack-frame)




From ffjeld at common-lisp.net  Wed Mar 31 16:37:14 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:37:14 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <E1B8iiI-0007lY-00@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Improved :decimal top-level command.

Date: Wed Mar 31 11:37:13 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.8 movitz/losp/los0.lisp:1.9
--- movitz/losp/los0.lisp:1.8	Mon Mar 29 09:36:15 2004
+++ movitz/losp/los0.lisp	Wed Mar 31 11:37:13 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.8 2004/03/29 14:36:15 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.9 2004/03/31 16:37:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -680,25 +680,21 @@
 (define-toplevel-command :decimal (&optional x-list)
   (flet ((do-print (x)
 	   (typecase x
-	     #+ignore
-	     (float
-	      (format t "~&~W ~~ ~,3F" x x))
 	     (number
 	      (case *print-base*
 		(16 (format t "~&~W = ~D" x x))
 		(10 (format t "~&~W = #x~X" x x))
 		(t (format t "~&~W = ~D. = #x~X" x x x)))
-	      #+ignore
 	      (when (typep x 'ratio)
 		(format t " ~~ ~,3F" x)))
-	     (t (fresh-line)
-		(write x :radix nil :base (case *print-base* (10 16) (t 10)))))
+	     (pointer
+	      (format t "~&~Z = ~W" x x))
+	     (t (write x :radix nil :base (case *print-base* (10 16) (t 10)))))
 	   x))
     (if x-list
 	(do-print (eval x-list))
       (dolist (x cl:/ (values-list cl:/))
-	(do-print x))))
-  (values))
+	(do-print x)))))
 
 (define-toplevel-command :pop ()
   (when *debugger-dynamic-context*




From ffjeld at common-lisp.net  Wed Mar 31 16:38:22 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:38:22 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <E1B8ijO-0000gF-00@common-lisp.net>

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

Modified Files:
	repl.lisp 
Log Message:
In read-eval-print, output a fresh-line immediately before evaluating,
so the user can know he did in fact hit enter.

Date: Wed Mar 31 11:38:21 2004
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.8 movitz/losp/lib/repl.lisp:1.9
--- movitz/losp/lib/repl.lisp:1.8	Mon Mar 29 14:16:19 2004
+++ movitz/losp/lib/repl.lisp	Wed Mar 31 11:38:20 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 19 14:58:12 2003
 ;;;;                
-;;;; $Id: repl.lisp,v 1.8 2004/03/29 19:16:19 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.9 2004/03/31 16:38:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -52,6 +52,7 @@
 		      (invoke-restart 'muerte::next-line
 				      (muerte.readline:contextual-readline *repl-readline-context*)))))
 		(simple-read-from-string buffer-string t t))
+	    (fresh-line)		; Let the user know something happened.
 	    (flet ((process-expresion (form previous-package printp &rest results)
 		     (declare (dynamic-extent results))
 		     (unless (packagep *package*)




From ffjeld at common-lisp.net  Wed Mar 31 16:39:38 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:39:38 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <E1B8ikc-00043N-00@common-lisp.net>

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

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

Date: Wed Mar 31 11:39:38 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.14 movitz/losp/muerte/arrays.lisp:1.15
--- movitz/losp/muerte/arrays.lisp:1.14	Mon Mar 29 14:19:51 2004
+++ movitz/losp/muerte/arrays.lisp	Wed Mar 31 11:39:38 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.14 2004/03/29 19:19:51 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.15 2004/03/31 16:39:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -408,6 +408,7 @@
   (memref string 2 index :character))
 
 (defun (setf schar) (value string index)
+  (check-type string string)
   (setf (aref string index) value))
 
 (define-compiler-macro char%unsafe (string index)
@@ -448,7 +449,8 @@
   `(setf (memref ,vector 2 ,index :unsigned-byte32) ,value))
 
 (defun (setf u32ref%unsafe) (value vector index)
-  (setf (u32ref%unsafe vector index) value))
+  (setf (u32ref%unsafe vector index) value)
+  value)
 
 ;;; fast vector access
 




From ffjeld at common-lisp.net  Wed Mar 31 16:47:40 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:47:40 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp 
Message-ID: <E1B8isO-0002PA-00@common-lisp.net>

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

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

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

Index: movitz/losp/muerte/run-time-context.lisp
diff -u movitz/losp/muerte/run-time-context.lisp:1.3 movitz/losp/muerte/run-time-context.lisp:1.4
--- movitz/losp/muerte/run-time-context.lisp:1.3	Tue Mar 30 04:12:35 2004
+++ movitz/losp/muerte/run-time-context.lisp	Wed Mar 31 11:47:40 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 12 18:33:02 2003
 ;;;;                
-;;;; $Id: run-time-context.lisp,v 1.3 2004/03/30 09:12:35 ffjeld Exp $
+;;;; $Id: run-time-context.lisp,v 1.4 2004/03/31 16:47:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -98,10 +98,11 @@
   (let ((slot (find-run-time-context-slot context slot-name)))
     (ecase (second slot)
       (segment-descriptor
-       (let ((offset (+ -6 (* 4 (third slot)))))
-	 (+ (memref context offset 1 :unsigned-byte16)
-	    (ash (memref context offset 4 :unsigned-byte8) 16)
-	    (ash (memref context offset 7 :unsigned-byte8) 24)))))))
+       (let ((index8 (* 4 (third slot)))
+	     (index16 (* 2 (third slot))))
+	 (+ (memref context (+ -6 2) index16 :unsigned-byte16)
+	    (ash (memref context (+ -6 4) index8 :unsigned-byte8) 16)
+	    (ash (memref context (+ -6 7) index8 :unsigned-byte8) 24)))))))
 
 (defun (setf %run-time-context-segment-base) (value slot-name
 					     &optional (context (current-run-time-context)))
@@ -109,10 +110,11 @@
   (let ((slot (find-run-time-context-slot context slot-name)))
     (ecase (second slot)
       (segment-descriptor
-       (let ((offset (+ -6 (* 4 (third slot)))))
-	 (setf (memref context offset 1 :unsigned-byte16) (ldb (byte 16 0) value)
-	       (memref context offset 4 :unsigned-byte8) (ldb (byte 8 16) value)
-	       (memref context offset 7 :unsigned-byte8) (ldb (byte 6 24) value)))))
+       (let ((index8 (* 4 (third slot)))
+	     (index16 (* 2 (third slot))))
+	 (setf (memref context (+ -6 2) index16 :unsigned-byte16) (ldb (byte 16 0) value)
+	       (memref context (+ -6 4) index8 :unsigned-byte8) (ldb (byte 8 16) value)
+	       (memref context (+ -6 7) index8 :unsigned-byte8) (ldb (byte 6 24) value)))))
     value))
 
 (defun clone-run-time-context (&key (parent (current-run-time-context))




From ffjeld at common-lisp.net  Wed Mar 31 16:49:23 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 11:49:23 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1B8iu3-0007TV-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Clevered up (setf memref) quite a bit.

Date: Wed Mar 31 11:49:23 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.5 movitz/losp/muerte/memref.lisp:1.6
--- movitz/losp/muerte/memref.lisp:1.5	Tue Mar 30 04:36:50 2004
+++ movitz/losp/muerte/memref.lisp	Wed Mar 31 11:49:23 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.5 2004/03/30 09:36:50 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.6 2004/03/31 16:49:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -184,67 +184,252 @@
     (:signed-byte30+2   (memref object offset index :signed-byte30+2))
     (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))
 
-(define-compiler-macro (setf memref) (&whole form value object offset index type)
-  (if (not (movitz:movitz-constantp type))
+(define-compiler-macro (setf memref) (&whole form &environment env value object offset index type)
+  (if (not (movitz:movitz-constantp type env))
       form
     (case (movitz::eval-form type)
       (:character
-       `(with-inline-assembly (:returns :eax)
-	  (:compile-form (:result-mode :push) ,object)
-	  (:compile-form (:result-mode :push) ,offset)
-	  (:compile-two-forms (:ebx :eax) ,index ,value)
-	  (:popl :ecx)			; offset
-	  (:addl :ecx :ebx)		; index += offset
-	  (:sarl #.movitz::+movitz-fixnum-shift+ :ebx)
-	  (:popl :ecx)			; object
-	  (:movb :ah (:ebx :ecx))))
+       (cond
+	((and (movitz:movitz-constantp value env)
+	      (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 (let ((value (movitz:movitz-eval value env)))
+	   (check-type value movitz-character)
+	   `(progn
+	      (with-inline-assembly (:returns :nothing)
+		(:compile-form (:result-mode :ebx) ,object)
+		(:movb ,(movitz:movitz-intern value)
+		       (:ebx ,(+ (movitz:movitz-eval offset env)
+				 (* 1 (movitz:movitz-eval index env))))))
+	      ,value)))
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-two-forms (:eax :ebx) ,value ,object)
+	    (:movb :ah (:ebx ,(+ (movitz:movitz-eval offset env)
+				 (* 1 (movitz:movitz-eval index env)))))))
+	((movitz:movitz-constantp offset env)
+	 (let ((value-var (gensym "memref-value-")))
+	   `(let ((,value-var ,value)) 
+	      (with-inline-assembly (:returns :eax)
+		(:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,index)
+		(:load-lexical (:lexical-binding ,value-var) :eax)
+		(:movb :ah (:ebx :ecx ,(+ (movitz:movitz-eval offset env))))))))
+	(t (let ((object-var (gensym "memref-object-"))
+		 (offset-var (gensym "memref-offset-")))
+	     `(let ((,object-var ,object) (,offset-var ,offset))
+		(with-inline-assembly (:returns :nothing)
+		  (:compile-two-forms (:ecx :eax) ,index ,value)
+		  (:load-lexical (:lexical-binding ,offset-var) :ebx)
+		  (:addl :ebx :ecx)
+		  (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+		  (:load-lexical (:lexical-binding ,object-var) :ebx)
+		  (:movb :ah (:ebx :ecx))))))))
       (:unsigned-byte32
        (assert (= 4 movitz::+movitz-fixnum-factor+))
-       `(with-inline-assembly (:returns :untagged-fixnum-eax)
-	  (:compile-form (:result-mode :push) ,object)
-	  (:compile-form (:result-mode :push) ,offset)
-	  (:compile-two-forms (:ebx :eax) ,index ,value)
-	  (:popl :ecx)			; offset
-	  (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
-	  (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
-	  (:addl :ebx :ecx)		; index += offset
-	  (:popl :ebx)			; object
-	  (:movl :eax (:ebx :ecx))))
+       (cond
+	((and (movitz:movitz-constantp value env)
+	      (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 (let ((value (movitz:movitz-eval value env)))
+	   (check-type value (unsigned-byte 32))
+	   `(progn
+	      (with-inline-assembly (:returns :nothing)
+		(:compile-form (:result-mode :ebx) ,object)
+		(:movl ,value (:ebx ,(+ (movitz:movitz-eval offset env)
+					(* 2 (movitz:movitz-eval index env))))))
+	      ,value)))
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+	    (:compile-two-forms (:ecx :ebx) ,value ,object)
+	    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env)
+				  (* 4 (movitz:movitz-eval index env)))))))
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp value env))
+	 (let ((value (movitz:movitz-eval value env)))
+	   (check-type value (unsigned-byte 32))
+	   `(progn
+	      (with-inline-assembly (:returns :nothing)
+		(:compile-two-forms (:ecx :ebx) ,index ,object)
+		(:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env))))
+	      ,value)))
+	((movitz:movitz-constantp offset env)
+	 (let ((value-var (gensym "memref-value-")))
+	   `(let ((,value-var ,value))
+	      (with-inline-assembly (:returns :untagged-fixnum-ecx)
+		(:compile-two-forms (:ebx :eax) ,object ,index)
+		(:load-lexical (:lexical-binding ,value-var) :ecx)
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		(:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env)))))))
+	(t (warn "Compiling unsafely: ~A" form)
+	   `(with-inline-assembly (:returns :untagged-fixnum-eax)
+	      (:compile-form (:result-mode :push) ,object)
+	      (:compile-form (:result-mode :push) ,offset)
+	      (:compile-two-forms (:ebx :eax) ,index ,value)
+	      (:popl :ecx)		; offset
+	      (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
+	      (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+	      (:addl :ebx :ecx)		; index += offset
+	      (:popl :ebx)		; object
+	      (:movl :eax (:ebx :ecx))))))
       (:unsigned-byte16
-       `(with-inline-assembly (:returns :untagged-fixnum-eax)
-	  (:compile-form (:result-mode :push) ,object)
-	  (:compile-form (:result-mode :push) ,offset)
-	  (:compile-two-forms (:ebx :eax) ,index ,value)
-	  (:sarl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx)
-	  (:popl :ecx)			; offset
-	  (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
-	  (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
-	  (:addl :ebx :ecx)		; index += offset
-	  (:popl :ebx)			; object
-	  (:movw :ax (:ebx :ecx))))
+       (cond
+	((and (movitz:movitz-constantp value env)
+	      (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 (let ((value (movitz:movitz-eval value env)))
+	   (check-type value (unsigned-byte 16))
+	   `(progn
+	      (with-inline-assembly (:returns :nothing)
+		(:compile-form (:result-mode :ebx) ,object)
+		(:movw ,value (:ebx ,(+ (movitz:movitz-eval offset env)
+					(* 2 (movitz:movitz-eval index env))))))
+	      ,value)))
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+	    (:compile-two-forms (:ecx :ebx) ,value ,object)
+	    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env)
+				 (* 2 (movitz:movitz-eval index env)))))))
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp value env))
+	 (let ((value (movitz:movitz-eval value env)))
+	   (check-type value (unsigned-byte 16))
+	   `(progn
+	      (with-inline-assembly (:returns :nothing)
+		(:compile-two-forms (:ecx :ebx) ,index ,object)
+		(:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+		(:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env))))
+	      ,value)))
+	((movitz:movitz-constantp offset env)
+	 (let ((value-var (gensym "memref-value-")))
+	   (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+	       `(let ((,value-var ,value))
+		  (with-inline-assembly (:returns :untagged-fixnum-eax)
+		    (:compile-two-forms (:ebx :ecx) ,object ,index)
+		    (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax)
+		    (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+		    (:movw :ax (:ebx :ecx  ,(movitz:movitz-eval offset env)))))
+	     `(let ((,value-var ,value))
+		(with-inline-assembly (:returns :nothing)
+		  (:compile-two-forms (:ebx :ecx) ,object ,index)
+		  (:load-lexical (:lexical-binding ,value-var) :eax)
+		  (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+		  (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+		  (:movb :ah (:ebx :ecx  ,(movitz:movitz-eval offset env)))
+		  (:andl #xff0000 :eax)
+		  (:shrl 8 :eax)
+		  (:movb :ah (:ebx :ecx ,(1+ (movitz:movitz-eval offset env)))))
+		,value-var))))
+	(t (let ((value-var (gensym "memref-value-"))
+		 (object-var (gensym "memref-object-")))
+	     (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+		 `(let ((,value-var ,offset) (,object-var ,object))
+		    (with-inline-assembly (:returns :untagged-fixnum-eax)
+		      (:compile-two-forms (:ebx :ecx) ,offset ,index)
+		      (:load-lexical (:lexical-binding ,value-var) :eax)
+		      (:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax)
+		      (:leal (:ebx (:ecx 2)) :ecx)
+		      (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
+		      (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+		      (:load-lexical (:lexical-binding ,object-var) :ebx)
+		      (:movw :ax (:ebx :ecx))))
+	       `(let ((,value-var ,value) (,object-var ,object))
+		  (with-inline-assembly (:returns :nothing)
+		    (:compile-two-forms (:ebx :ecx) ,offset ,index)
+		    (:load-lexical (:lexical-binding ,value-var) :eax)
+		    (:leal (:ebx (:ecx 2)) :ecx)
+		    (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+		    (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+		    (:load-lexical (:lexical-binding ,object-var) :ebx)
+		    (:movb :ah (:ebx :ecx))
+		    (:andl #xff0000 :eax)
+		    (:shrl 8 :eax)
+		    (:movb :ah (:ebx :ecx 1)))
+		  ,value-var))))))
       (:unsigned-byte8
-       `(with-inline-assembly (:returns :untagged-fixnum-eax)
-	  (:compile-form (:result-mode :push) ,object)
-	  (:compile-form (:result-mode :push) ,offset)
-	  (:compile-two-forms (:ebx :eax) ,index ,value)
-	  (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
-	  (:popl :ecx)			; offset
-	  (:addl :ecx :ebx)		; index += offset
-	  (:sarl #.movitz::+movitz-fixnum-shift+ :ebx)
-	  (:popl :ecx)			; object
-	  (:movb :al (:ebx :ecx))))
+       (cond
+	((and (movitz:movitz-constantp value env)
+	      (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 (let ((value (movitz:movitz-eval value env)))
+	   (check-type value (unsigned-byte 8))
+	   `(progn
+	      (with-inline-assembly (:returns :nothing)
+		(:compile-form (:result-mode :ebx) ,object)
+		(:movb ,value (:ebx ,(+ (movitz:movitz-eval offset env)
+					(* 1 (movitz:movitz-eval index env))))))
+	      ,value)))
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+	    (:compile-two-forms (:ecx :ebx) ,value ,object)
+	    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+	    (:movb :cl (:ebx ,(+ (movitz:movitz-eval offset env)
+				 (* 1 (movitz:movitz-eval index env)))))))
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp value env))
+	 (let ((value (movitz:movitz-eval value env)))
+	   (check-type value (unsigned-byte 8))
+	   `(progn
+	      (with-inline-assembly (:returns :untagged-fixnum-ecx)
+		(:compile-two-forms (:eax :ecx) ,object ,index)
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		(:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env))))
+	      value)))
+	((movitz:movitz-constantp offset env)
+	 (let ((value-var (gensym "memref-value-")))
+	   `(let ((,value-var ,value))
+	      (with-inline-assembly (:returns :nothing)
+		(:compile-two-forms (:ebx :ecx) ,object ,index)
+		(:load-lexical (:lexical-binding ,value-var) :eax)
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		(:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) ; value into :AH
+		(:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env))))
+	      ,value-var)))
+	(t (let ((value-var (gensym "memref-value-"))
+		 (object-var (gensym "memref-object-")))
+	     `(let ((,value-var ,value) (,object-var ,object))
+		(with-inline-assembly (:returns :nothing)
+		  (:compile-two-forms (:ebx :ecx) ,offset ,index)
+		  (:load-lexical (:lexical-binding ,value-var) :eax)
+		  (:addl :ebx :ecx)
+		  (:load-lexical (:lexical-binding ,object-var) :ebx) ; value into :AH
+		  (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+		  (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+		  (:movb :ah (:ebx :ecx)))
+		,value-var)))))
       (:lisp
-       `(with-inline-assembly (:returns :eax)
-	  (:compile-form (:result-mode :push) ,object)
-	  (:compile-form (:result-mode :push) ,offset)
-	  (:compile-two-forms (:ebx :eax) ,index ,value)
-	  (:popl :ecx)			; offset
-	  (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
-	  ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
-	      `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx))
-	  (:addl :ecx :ebx)		; index += offset
-	  (:popl :ecx)			; value
-	  (:movl :eax (:ebx :ecx))))
+       (cond
+	((and (movitz:movitz-constantp offset env)
+	      (movitz:movitz-constantp index env))
+	 `(with-inline-assembly (:returns :eax)
+	    (:compile-two-forms (:eax :ebx) ,value ,object)
+	    (:movl :eax (:ebx ,(+ (movitz:movitz-eval offset env)
+				  (* 4 (movitz:movitz-eval index env)))))))
+	((movitz:movitz-constantp offset env)
+	 (let ((value-var (gensym "memref-value-")))
+	   `(let ((,value-var ,value))
+	      (with-inline-assembly (:returns :eax)
+		(:compile-two-forms (:ebx :ecx) ,object ,index)
+		(:load-lexical (:lexical-binding ,value-var) :eax)
+		,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2))
+		    `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx))
+		(:movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env)))))))
+	(t (let ((value-var (gensym "memref-value-"))
+		 (object-var (gensym "memref-object-")))
+	     `(let ((,value-var ,value) (,object-var ,object))
+		(with-inline-assembly (:returns :eax)
+		  (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index)
+		  (:load-lexical (:lexical-binding ,value-var) :eax)
+		  ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
+		      `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx))
+		  (:addl :ebx :ecx)	; index += offset
+		  (:load-lexical (:lexical-binding ,object-var) :ebx)
+		  (:movl :eax (:ebx :ecx))))))))
       (t ;; (warn "Can't handle inline MEMREF: ~S" form)
 	 form))))
 




From ffjeld at common-lisp.net  Wed Mar 31 18:33:52 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 13:33:52 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1B8kXA-0003kk-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Smarted up memref considerably.

Date: Wed Mar 31 13:33:52 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.6 movitz/losp/muerte/memref.lisp:1.7
--- movitz/losp/muerte/memref.lisp:1.6	Wed Mar 31 11:49:23 2004
+++ movitz/losp/muerte/memref.lisp	Wed Mar 31 13:33:52 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.6 2004/03/31 16:49:23 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.7 2004/03/31 18:33:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -30,13 +30,13 @@
 (define-compiler-macro memref (&whole form object offset index type &environment env)
 ;;;  (assert (typep offset '(integer 0 0)) (offset)
 ;;;    (error "memref offset not supported."))
-  (if (not (movitz:movitz-constantp type))
+  (if (not (movitz:movitz-constantp type env))
       form
     (labels ((extract-constant-delta (form)
 	     "Try to extract at compile-time an integer offset from form."
 	     (cond
 	      ((movitz:movitz-constantp form env)
-	       (let ((x (movitz::eval-form form env)))
+	       (let ((x (movitz:movitz-eval form env)))
 		 (check-type x integer)
 		 (values x 0)))
 	      ((not (consp form))
@@ -49,7 +49,7 @@
 			(2 (values 0 (second form)))
 			(t (loop with x = 0 and f = nil for sub-form in (cdr form)
 			       as sub-value = (when (movitz:movitz-constantp sub-form env)
-						(movitz::eval-form sub-form env))
+						(movitz:movitz-eval sub-form env))
 			       do (if (integerp sub-value)
 				      (incf x sub-value)
 				    (push sub-form f))
@@ -66,37 +66,46 @@
 	    (warn "o: ~S, co: ~S, i: ~S, ci: ~S"
 		  offset constant-offset
 		  index constant-index)
-	    (let ((type (movitz::eval-form type env)))
+	    (let ((type (movitz:movitz-eval type env)))
 	      (case type
 		(:unsigned-byte8
-		 `(with-inline-assembly (:returns :untagged-fixnum-eax)
-		    (:compile-form (:result-mode :push) ,object)
-		    (:compile-two-forms (:ecx :ebx) ,offset ,index)
-		    (:popl :eax)	; object
-		    (:addl :ecx :ebx)	; index += offset
-		    (:sarl #.movitz::+movitz-fixnum-shift+ :ebx)
-		    (:movzxb (:eax :ebx ,(offset-by 1)) :eax)))
+		 (cond
+		  ((and (eq 0 offset) (eq 0 index))
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		      (:compile-form (:result-mode :eax) ,object)
+		      (:movzxb (:eax ,(offset-by 1)) :ecx)))
+		  ((eq 0 offset)
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		      (:compile-two-forms (:eax :ecx) ,object ,index)
+		      (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
+		      (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)))
+		  (t (let ((object-var (gensym "memref-object-")))
+		       `(let ((,object-var ,object))
+			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			    (:load-lexical (:lexical-binding ,object-var) :eax)
+			    (:addl :ebx :ecx) ; index += offset
+			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+			    (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)))))))
 		(:unsigned-byte16
-		 `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-		    (:compile-form (:result-mode :push) ,object)
-		    (:compile-two-forms (:eax :ebx) ,offset ,index)
-		    (:sarl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx)
-		    (:sarl #.movitz::+movitz-fixnum-shift+ :eax)
-		    (:addl :eax :ebx)
-		    (:popl :eax)	; object
-		    (:movzxw (:eax :ebx ,(offset-by 2)) :ecx)))
-		(:unsigned-byte32
-		 (assert (= 2 movitz::+movitz-fixnum-shift+))
-		 (let ((overflow (gensym "overflow-")))
+		 (cond
+		  ((and (eq 0 offset) (eq 0 index))
 		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
-		      (:compile-form (:result-mode :push) ,object)
-		      (:compile-two-forms (:ecx :ebx) ,offset ,index)
-		      (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
-		      (:addl :ebx :ecx)
-		      (:popl :eax)	; object
-		      (:movl (:eax :ecx ,(offset-by 4)) :ecx)
-		      (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx)
-		      (:jg '(:sub-program (,overflow) (:int 4))))))
+		      (:compile-form (:result-mode :eax) ,object)
+		      (:movzxw (:eax ,(offset-by 2)) :ecx)))
+		  ((eq 0 offset)
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		      (:compile-two-forms (:eax :ecx) ,object ,index)
+		      (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+		      (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))
+		  (t (let ((object-var (gensym "memref-object-")))
+		       `(let ((,object-var ,object))
+			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			    (:leal (:ecx (:ebx 2)) :ecx)
+			    (:load-lexical (:lexical-binding ,object-var) :eax)
+			    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))))))
 		(:unsigned-byte29+3
 		 ;; Two values: the 29 upper bits as unsigned integer,
 		 ;; and secondly the lower 3 bits as unsigned.
@@ -133,7 +142,7 @@
 		    (:movl 2 :ecx)
 		    (:stc)))
 		(:character
-		 (when (eq 0 index) (warn "zero char index!"))
+		 (when (eq 0 index) (warn "memref zero char index!"))
 		 (cond
 		  ((eq 0 offset)
 		   `(with-inline-assembly (:returns :eax)
@@ -142,15 +151,41 @@
 		      (:movb #.(movitz:tag :character) :al)
 		      (:sarl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale index
 		      (:movb (:ecx :ebx ,(offset-by 1)) :ah)))
-		  (t `(with-inline-assembly (:returns :eax)
-			(:compile-form (:result-mode :push) ,object)
-			(:compile-two-forms (:ecx :ebx) ,offset ,index)
-			(:addl :ecx :ebx)
-			(:xorl :eax :eax)
-			(:movb #.(movitz:tag :character) :al)
-			(:popl :ecx)	; pop object
-			(:sarl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale offset+index
-			(:movb (:ebx :ecx ,(offset-by 1)) :ah)))))
+		  (t (let ((object-var (gensym "memref-object-")))
+		       `(let ((,object-var ,object))
+			  (with-inline-assembly (:returns :eax)
+			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			    (:addl :ebx :ecx)
+			    (:xorl :eax :eax)
+			    (:movb #.(movitz:tag :character) :al)
+			    (:load-lexical (:lexical-binding ,object-var) :ebx)
+			    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index
+			    (:movb (:ebx :ecx ,(offset-by 1)) :ah)))))))
+		(:unsigned-byte32
+		 (assert (= 4 movitz::+movitz-fixnum-factor+))
+		 (cond
+		  ((and (eq 0 offset) (eq 0 index))
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		      (:compile-form (:result-mode :eax) ,object)
+		      (:movl (:eax ,(offset-by 4)) :ecx)
+		      (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx)
+		      (:jg '(:sub-program () (:int 4)))))
+		  ((eq 0 offset)
+		   `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+		      (:compile-two-forms (:eax :ecx) ,object ,index)
+		      (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+		      (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx)
+		      (:jg '(:sub-program () (:int 4)))))
+		  (t (let ((object-var (gensym "memref-object-")))
+		       `(let ((,object-var ,object))
+			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+			    (:load-lexical (:lexical-binding ,object-var) :eax)
+			    (:addl :ebx :ecx)
+			    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+			    (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx)
+			    (:jg '(:sub-program () (:int 4)))))))))
 		(:lisp
 		 (cond
 		  ((and (eq 0 index) (eq 0 offset))
@@ -163,14 +198,17 @@
 		      ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
 			  `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx))
 		      (:movl (:eax :ecx ,(offset-by 4)) :eax)))
-		  (t `(with-inline-assembly (:returns :eax)
-			(:compile-form (:result-mode :push) ,object)
-			(:compile-two-forms (:untagged-fixnum-eax :ecx) ,offset ,index)
-			,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
-			    `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx))
-			(:addl :ecx :eax)
-			(:popl :ebx)	; pop object
-			(:movl (:eax :ebx ,(offset-by 4)) :eax)))))
+		  (t (assert (not (movitz:movitz-constantp offset env)))
+		     (assert (not (movitz:movitz-constantp index env)))
+		     (let ((object-var (gensym "memref-object-")))
+		       (assert (= 4 movitz:+movitz-fixnum-factor+))
+		       `(let ((,object-var ,object))
+			  (with-inline-assembly (:returns :eax)
+			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
+			    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+			    (:load-lexical (:lexical-binding ,object-var) :eax)
+			    (:addl :ebx :ecx)
+			    (:movl (:eax :ecx ,(offset-by 4)) :eax)))))))
 		(t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil))
 		   form)))))))))
 




From ffjeld at common-lisp.net  Wed Mar 31 21:35:28 2004
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 31 Mar 2004 16:35:28 -0500
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <E1B8nMu-0001Hm-00@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Minor edits. Removed the obsolete function memref2.

Date: Wed Mar 31 16:35:27 2004
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.7 movitz/losp/muerte/memref.lisp:1.8
--- movitz/losp/muerte/memref.lisp:1.7	Wed Mar 31 13:33:52 2004
+++ movitz/losp/muerte/memref.lisp	Wed Mar 31 16:35:27 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.7 2004/03/31 18:33:52 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.8 2004/03/31 21:35:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,18 +18,7 @@
 
 (in-package muerte)
 
-(defun memwrite2 (address value)
-  "Writes the 16-bit VALUE to memory ADDRESS."
-  (with-inline-assembly (:returns :nothing)
-    (:compile-form (:result-mode :eax) address)
-    (:compile-form (:result-mode :ebx) value)
-    (:sarl #.movitz::+movitz-fixnum-shift+ :eax)
-    (:sarl #.movitz::+movitz-fixnum-shift+ :ebx)
-    (:movw :bx (:eax))))
-
 (define-compiler-macro memref (&whole form object offset index type &environment env)
-;;;  (assert (typep offset '(integer 0 0)) (offset)
-;;;    (error "memref offset not supported."))
   (if (not (movitz:movitz-constantp type env))
       form
     (labels ((extract-constant-delta (form)
@@ -104,7 +93,7 @@
 			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
 			    (:leal (:ecx (:ebx 2)) :ecx)
 			    (:load-lexical (:lexical-binding ,object-var) :eax)
-			    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 			    (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)))))))
 		(:unsigned-byte29+3
 		 ;; Two values: the 29 upper bits as unsigned integer,
@@ -113,7 +102,7 @@
 		 `(with-inline-assembly (:returns :multiple-values)
 		    (:compile-form (:result-mode :push) ,object)
 		    (:compile-two-forms (:ecx :ebx) ,offset ,index)
-		    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+		    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 		    (:addl :ebx :ecx)
 		    (:popl :eax)	; object
 		    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
@@ -131,7 +120,7 @@
 		 `(with-inline-assembly (:returns :multiple-values)
 		    (:compile-form (:result-mode :push) ,object)
 		    (:compile-two-forms (:ecx :ebx) ,offset ,index)
-		    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+		    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 		    (:addl :ebx :ecx)
 		    (:popl :eax)	; object
 		    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
@@ -148,8 +137,8 @@
 		   `(with-inline-assembly (:returns :eax)
 		      (:compile-two-forms (:ecx :ebx) ,object ,index)
 		      (:xorl :eax :eax)
-		      (:movb #.(movitz:tag :character) :al)
-		      (:sarl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale index
+		      (:movb ,(movitz:tag :character) :al)
+		      (:sarl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale index
 		      (:movb (:ecx :ebx ,(offset-by 1)) :ah)))
 		  (t (let ((object-var (gensym "memref-object-")))
 		       `(let ((,object-var ,object))
@@ -157,9 +146,9 @@
 			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
 			    (:addl :ebx :ecx)
 			    (:xorl :eax :eax)
-			    (:movb #.(movitz:tag :character) :al)
+			    (:movb ,(movitz:tag :character) :al)
 			    (:load-lexical (:lexical-binding ,object-var) :ebx)
-			    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index
+			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index
 			    (:movb (:ebx :ecx ,(offset-by 1)) :ah)))))))
 		(:unsigned-byte32
 		 (assert (= 4 movitz::+movitz-fixnum-factor+))
@@ -180,7 +169,7 @@
 		       `(let ((,object-var ,object))
 			  (with-inline-assembly (:returns :untagged-fixnum-ecx)
 			    (:compile-two-forms (:ecx :ebx) ,offset ,index)
-			    (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+			    (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 			    (:load-lexical (:lexical-binding ,object-var) :eax)
 			    (:addl :ebx :ecx)
 			    (:movl (:eax :ecx ,(offset-by 4)) :ecx)
@@ -260,7 +249,7 @@
 		  (:compile-two-forms (:ecx :eax) ,index ,value)
 		  (:load-lexical (:lexical-binding ,offset-var) :ebx)
 		  (:addl :ebx :ecx)
-		  (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+		  (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 		  (:load-lexical (:lexical-binding ,object-var) :ebx)
 		  (:movb :ah (:ebx :ecx))))))))
       (:unsigned-byte32
@@ -307,8 +296,8 @@
 	      (:compile-form (:result-mode :push) ,offset)
 	      (:compile-two-forms (:ebx :eax) ,index ,value)
 	      (:popl :ecx)		; offset
-	      (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
-	      (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+	      (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
+	      (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
 	      (:addl :ebx :ecx)		; index += offset
 	      (:popl :ebx)		; object
 	      (:movl :eax (:ebx :ecx))))))
@@ -502,7 +491,7 @@
 	    (:shll 2 :ecx)
 	    (:addl :ecx :eax)
 	    (:addl :ebx :eax)
-	    (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
 	    (,prefixes :movl (:eax) :eax)))
 	(:unsigned-byte8
 	 `(with-inline-assembly (:returns :untagged-fixnum-eax)
@@ -514,7 +503,7 @@
 	    (:addl :ecx :ebx)		; add index
 	    (:addl :eax :ebx)		; add offset
 	    (:xorl :eax :eax)
-	    (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale down address
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale down address
 	    (,prefixes :movb (:ebx) :al)))
 	(:unsigned-byte32
 	 `(with-inline-assembly (:returns :eax)
@@ -528,7 +517,7 @@
 		    :al)
 	    (:jnz '(:sub-program (unaligned) (:int 63)))
 	    (:addl :ecx :eax)
-	    (:shrl #.movitz::+movitz-fixnum-shift+ :eax) ; scale down address
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale down address
 	    (,prefixes :movl (:eax) :ecx)
 	    (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx)
 	    (:jg '(:sub-program (overflow) (:int 4)))
@@ -541,7 +530,7 @@
 	   `(with-inline-assembly (:returns :untagged-fixnum-eax)
 	      (:compile-form (:result-mode :ebx) ,address)
 	      (:xorl :eax :eax)
-	      (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale down address
+	      (:shrl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale down address
 	      (,prefixes :movw (:ebx (:ecx 2)) :ax)))
 	  (t `(with-inline-assembly (:returns :untagged-fixnum-eax)
 		(:compile-form (:result-mode :push) ,address)
@@ -549,10 +538,10 @@
 		(:compile-form (:result-mode :ecx) ,index)
 		(:popl :eax)		; offset
 		(:popl :ebx)		; address
-		(:shrl #.movitz::+movitz-fixnum-shift+ :ecx) ; scale index
+		(:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index
 		(:addl :eax :ebx)	; add offset
 		(:xorl :eax :eax)
-		(:shrl #.movitz::+movitz-fixnum-shift+ :ebx) ; scale down address
+		(:shrl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale down address
 		(,prefixes :movw (:ebx (:ecx 2)) :ax)))))))))
 
 (defun memref-int (address offset index type &optional physicalp)
@@ -599,7 +588,7 @@
 	    (:popl :ebx)		; index
 	    (:popl :ecx)		; address
 	    (:addl :edx :ecx)
-	    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 	    (,prefixes :movl :eax (:ecx :ebx))))
 	(:unsigned-byte8
 	 `(with-inline-assembly (:returns :untagged-fixnum-eax)
@@ -610,10 +599,10 @@
 	    (:popl :edx)		; offset
 	    (:popl :ebx)		; index
 	    (:popl :ecx)		; address
-	    (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
 	    (:addl :ebx :ecx)
 	    (:addl :edx :ecx)
-	    (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 	    (,prefixes :movb :al (:ecx))))
 	(:unsigned-byte16
 	 (cond
@@ -623,11 +612,11 @@
 	      (:compile-form (:result-mode :push) ,index)
 	      (:compile-form (:result-mode :eax) ,value)
 	      (:popl :ebx)		; index
-	      (:shrl #.movitz::+movitz-fixnum-shift+ :eax) ; scale value
+	      (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale value
 	      (:popl :ecx)		; address
 	      (:shll 1 :ebx)		; scale index
 	      (:addl :ebx :ecx)
-	      (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) ; scale address
+	      (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale address
 	      (,prefixes :movw :ax (:ecx))))
 	  (t `(with-inline-assembly (:returns :untagged-fixnum-eax)
 		(:compile-form (:result-mode :push) ,address)
@@ -637,10 +626,10 @@
 		(:popl :edx)		; offset
 		(:popl :ebx)		; index
 		(:popl :ecx)		; address
-		(:shrl #.movitz::+movitz-fixnum-shift+ :eax) ; scale value
+		(:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale value
 		(:leal (:ecx (:ebx 2)) :ecx)
 		(:addl :edx :ecx)	;
-		(:shrl #.movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+address
+		(:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+address
 		(,prefixes :movw :ax (:ecx))))))))))
 
 (defun (setf memref-int) (value address offset index type &optional physicalp)
@@ -687,29 +676,6 @@
        (:jnz 'loop)
        done))))
 	     
-;;;       (:shrl 4 :ecx)
-;;;       (:jz 'quads-done)
-;;;
-;;;       quad-loop
-;;;       (:movl (:ebx) :edx)
-;;;       (:addl 4 :ebx)
-;;;       (:movl :edx (:eax))
-;;;       (:addl 4 :eax)
-;;;       (:decl :ecx)
-;;;       (:jnz 'quad-loop)
-;;;       
-;;;       quads-done
-;;;       (:compile-form (:result-mode ) count :ecx)
-;;;       (:shrl 2 :ecx)
-;;;       (:andl 3 :ecx)
-;;;       (:jz 'done)
-;;;       loop
-;;;       (:movb (:ebx :ecx) :dl)
-;;;       (:movb :dl (:eax :ecx))
-;;;       (:decl :ecx)
-;;;       (:jnz 'loop)
-;;;       done))))
-
 (define-compiler-macro %copy-words (destination source count &optional (start1 0) (start2 0)
 				    &environment env)
   (assert (= 4 movitz::+movitz-fixnum-factor+))