From ffjeld at common-lisp.net  Thu Aug 11 21:17:12 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Aug 2005 23:17:12 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <20050811211712.4F09988525@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
Fix pci-far-call to accept a value for DS, making it work with the
VMWare PCI BIOS.

Date: Thu Aug 11 23:17:11 2005
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.8 movitz/losp/x86-pc/pci.lisp:1.9
--- movitz/losp/x86-pc/pci.lisp:1.8	Tue Nov 30 15:16:57 2004
+++ movitz/losp/x86-pc/pci.lisp	Thu Aug 11 23:17:11 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2003-2004, 
+;;;;    Copyright (C) 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromsoe, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.8 2004/11/30 14:16:57 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.9 2005/08/11 21:17:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -53,7 +53,8 @@
 (defvar *bios32-base* nil)
 (defvar *pcibios-entry* nil)
 
-(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0))
+(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0)
+				  (ds (segment-register :gs)))
   "Make a 'far call' to cs:address with the provided values for eax and ebx.
 Returns the boolean status of CF, and the values of registers EAX, EBX, ECX, and EDX.
 The stack discipline is broken during this call, so we disable interrupts
@@ -71,6 +72,7 @@
       (:movl (:esp) :ebp)
       (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation))))
       (:pushl :edi)			; Save EDI so we can restore it later.
+      (:pushw :ds)			; Ditto for DS
       (:load-lexical (:lexical-binding cs) :untagged-fixnum-ecx)
       (:pushl :ecx)			; Code segment
       (:load-lexical (:lexical-binding address) :untagged-fixnum-ecx)
@@ -85,15 +87,19 @@
       (:pushl :ecx)			; push ESI
       (:load-lexical (:lexical-binding edi) :untagged-fixnum-ecx)
       (:pushl :ecx)			; push EDI
+      (:load-lexical (:lexical-binding ds) :untagged-fixnum-ecx)
+      (:movl :ecx :ebx)
       (:load-lexical (:lexical-binding ecx) :untagged-fixnum-ecx)
+      (:movw :bx :ds)
       (:popl :edi)
       (:popl :esi)
       (:popl :edx)
       (:popl :ebx)
       (:popl :eax)
-      (:call-segment (:esp))
+      ((:ss-override) :call-segment (:esp))
       (:leal (:esp 8) :esp)		; Skip cs:address
-      (:popl :edi)			; First of all, restore EDI!
+      (:popw :ds)			; First of all, restore DS..
+      (:popl :edi)			; .. and EDI.
       (:locally (:movl :edi (:edi (:edi-offset scratch2))))
       (:jnc 'cf=0)
       (:locally (:pushl (:edi (:edi-offset t-symbol))))



From ffjeld at common-lisp.net  Thu Aug 11 21:32:55 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Aug 2005 23:32:55 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <20050811213255.C701888525@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Some cleanup regarding the segment-descriptor-table.

Date: Thu Aug 11 23:32:55 2005
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.51 movitz/packages.lisp:1.52
--- movitz/packages.lisp:1.51	Sat Jun 11 01:05:38 2005
+++ movitz/packages.lisp	Thu Aug 11 23:32:55 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Nov 15 21:39:55 2003
 ;;;;                
-;;;; $Id: packages.lisp,v 1.51 2005/06/10 23:05:38 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.52 2005/08/11 21:32:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1264,6 +1264,9 @@
 	   #:segment-descriptor
 	   #:segment-descriptor-base-location
 	   #:segment-descriptor-limit
+	   #:segment-descriptor-type-s-dpl-p
+	   #:segment-descriptor-avl-x-db-g
+	   #:global-segment-descriptor-table
 	   #:control-register-lo12
 	   #:control-register-hi20
 	   #:ensure-data-vector



From ffjeld at common-lisp.net  Thu Aug 11 21:33:02 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Aug 2005 23:33:02 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050811213302.6B2F08852B@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
Some cleanup regarding the segment-descriptor-table.

Date: Thu Aug 11 23:33:01 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.10 movitz/losp/ll-testing.lisp:1.11
--- movitz/losp/ll-testing.lisp:1.10	Sat Jun 11 01:04:45 2005
+++ movitz/losp/ll-testing.lisp	Thu Aug 11 23:33:01 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.10 2005/06/10 23:04:45 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.11 2005/08/11 21:33:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -35,19 +35,6 @@
 ;;;		   (memref gdt-base 0 :index i :type :unsigned-byte32 :physicalp t))))
 ;;;	table))))
 
-
-
-
-(defun format-segment-table (table &key (start 0) (end (truncate (length table) 2)))
-  (loop for i from start below end
-      as selector = (* i 8)
-      do (format t "~&~3X: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%"
-		 selector
-		 (* 4 (segment-descriptor-base-location table selector))
-		 (segment-descriptor-limit table selector)
-		 (segment-descriptor-type-s-dpl-p table selector)
-		 (segment-descriptor-avl-x-db-g table selector)))
-  (values))
 
 
 (defmacro control-stack-fs (stack)



From ffjeld at common-lisp.net  Thu Aug 11 21:33:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Aug 2005 23:33:10 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050811213310.469B48852B@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
Some cleanup regarding the segment-descriptor-table.

Date: Thu Aug 11 23:33:09 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.46 movitz/losp/los0.lisp:1.47
--- movitz/losp/los0.lisp:1.46	Fri Jun 10 00:21:08 2005
+++ movitz/losp/los0.lisp	Thu Aug 11 23:33:08 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.46 2005/06/09 22:21:08 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.47 2005/08/11 21:33:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -29,9 +29,10 @@
 (require :lib/net/dhcp)
 (require :lib/repl)
 
-;; (require :ll-testing)
 (require :lib/threading)
 
+;; (require :lice-0.1/all)
+
 (defpackage muerte.init
   (:nicknames #:los0)
   (:use #:common-lisp
@@ -134,6 +135,7 @@
 		  (format t "error: ~S ~S" c x))))
       (error "This is an error. ~S" foo))))
 
+
 (defun fooo (v w)
   (tagbody
     (print (block blurgh
@@ -1317,9 +1319,24 @@
 
 (defvar *segment-descriptor-table*)
 
+(defun format-segment-table (table &key (start 0) (end (truncate (length table) 2)))
+  (loop for i from start below end
+      as selector = (* i 8)
+      do (format t "~&~3X: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%"
+		 selector
+		 (* 4 (segment-descriptor-base-location table selector))
+		 (segment-descriptor-limit table selector)
+		 (segment-descriptor-type-s-dpl-p table selector)
+		 (segment-descriptor-avl-x-db-g table selector)))
+  (values))
+
+(defun memdump (start length)
+  (loop for addr upfrom start repeat length
+      collect (memref-int addr :type :unsigned-byte8)))
 
 (defun genesis ()
   ;; (install-shallow-binding)
+  (setf *debugger-function* #'los0-debugger)
   (let ((extended-memsize 0))
     ;;  Find out how much extended memory we have 
     (setf (io-port #x70 :unsigned-byte8) #x18)
@@ -1330,15 +1347,14 @@
 
     (idt-init)
 
-;;;    (setf *segment-descriptor-table*	; Ensure we have a GDT with 16 entries, in static-space.
-;;;      (muerte::install-global-segment-table
-;;;       (muerte::dump-global-segment-table :entries 16)))
-    
+    (setf *segment-descriptor-table*	; Ensure we have a GDT with 16 entries, in static-space.
+      (setf (global-segment-descriptor-table)
+	(muerte::dump-global-segment-table :entries 16)))
+
     (install-los0-consing :kb-size 500)
     #+ignore
     (install-los0-consing :kb-size (max 50 (truncate (- extended-memsize 2048) 2))))
 
-  (setf *debugger-function* #'los0-debugger)
   (clos-bootstrap)
   (setf *package* (find-package "INIT"))
   ;; (install-shallow-binding)



From ffjeld at common-lisp.net  Thu Aug 11 21:34:27 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu, 11 Aug 2005 23:34:27 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp 
Message-ID: <20050811213427.881F38852B@common-lisp.net>

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

Modified Files:
	conditions.lisp 
Log Message:
If there's no debugger when one is needed (during signaling), print
a backtrace.

Date: Thu Aug 11 23:34:27 2005
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.16 movitz/losp/muerte/conditions.lisp:1.17
--- movitz/losp/muerte/conditions.lisp:1.16	Mon May 30 00:03:04 2005
+++ movitz/losp/muerte/conditions.lisp	Thu Aug 11 23:34:26 2005
@@ -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.16 2005/05/29 22:03:04 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.17 2005/08/11 21:34:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -280,6 +280,8 @@
     (setf *debugger-function* #'muerte.init::my-debugger))
   (cond
    ((not *debugger-function*)
+    (let ((*never-use-print-object* t))
+      (backtrace :spartan t))
     (format t "~&No debugger in *debugger-function*. Trying to continue or abort.")
     (invoke-restart (or (find-restart 'continue)
 			(find-restart 'abort)



From ffjeld at common-lisp.net  Fri Aug 12 06:34:37 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Aug 2005 08:34:37 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <20050812063437.F2CAF8853F@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
tweak.

Date: Fri Aug 12 08:34:37 2005
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.9 movitz/losp/x86-pc/pci.lisp:1.10
--- movitz/losp/x86-pc/pci.lisp:1.9	Thu Aug 11 23:17:11 2005
+++ movitz/losp/x86-pc/pci.lisp	Fri Aug 12 08:34:35 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.9 2005/08/11 21:17:11 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.10 2005/08/12 06:34:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -53,8 +53,8 @@
 (defvar *bios32-base* nil)
 (defvar *pcibios-entry* nil)
 
-(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0)
-				  (ds (segment-register :gs)))
+(defun pci-far-call (address &key (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0)
+				  (cs 8) (ds (segment-register :gs)))
   "Make a 'far call' to cs:address with the provided values for eax and ebx.
 Returns the boolean status of CF, and the values of registers EAX, EBX, ECX, and EDX.
 The stack discipline is broken during this call, so we disable interrupts



From ffjeld at common-lisp.net  Fri Aug 12 20:28:31 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Aug 2005 22:28:31 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <20050812202831.7858288540@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
A hack to get a hopefully good segment selector in DS for the
interrupt handler.

Date: Fri Aug 12 22:28:30 2005
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.46 movitz/losp/muerte/interrupt.lisp:1.47
--- movitz/losp/muerte/interrupt.lisp:1.46	Tue May 24 08:33:28 2005
+++ movitz/losp/muerte/interrupt.lisp	Fri Aug 12 22:28:30 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.46 2005/05/24 06:33:28 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.47 2005/08/12 20:28:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -116,6 +116,8 @@
 	    (:pushl :ecx)
 	    (:movcr :cr2 :ecx)
 	    (:locally (:pushl :ecx))
+	    (:movw #x20 :cx)
+	    (:movw :cx :ds)
 	    ,@(loop for reg in (sort (copy-list '(:eax :ebx :edx :esi))
 				     #'>
 				     :key #'dit-frame-index)



From ffjeld at common-lisp.net  Fri Aug 12 21:37:43 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 12 Aug 2005 23:37:43 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <20050812213743.C4FEF88547@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Fixed logand to deal with e.g. (logand #x-10 #x1234567345).

Date: Fri Aug 12 23:37:43 2005
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.106 movitz/losp/muerte/integers.lisp:1.107
--- movitz/losp/muerte/integers.lisp:1.106	Tue May 24 08:33:24 2005
+++ movitz/losp/muerte/integers.lisp	Fri Aug 12 23:37:42 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.106 2005/05/24 06:33:24 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.107 2005/08/12 21:37:42 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1559,6 +1559,16 @@
 		   (:compile-form (:result-mode :eax) x)
 		   (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx)
 		   (:andl :ecx :eax)))
+		((fixnum positive-bignum)
+		 (let ((result (copy-bignum y)))
+		   (with-inline-assembly (:returns :eax)
+		     (:compile-two-forms (:eax :untagged-fixnum-ecx) result x)
+		     (:andl :ecx (:eax (:offset movitz-bignum bigit0))))))
+		((positive-bignum fixnum)
+		 (let ((result (copy-bignum x)))
+		   (with-inline-assembly (:returns :eax)
+		     (:compile-two-forms (:eax :untagged-fixnum-ecx) result y)
+		     (:andl :ecx (:eax (:offset movitz-bignum bigit0))))))
 		((positive-bignum positive-bignum)
 		 (if (< (%bignum-bigits y) (%bignum-bigits x))
 		     (logand y x)



From ffjeld at common-lisp.net  Fri Aug 12 22:44:11 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Aug 2005 00:44:11 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp 
Message-ID: <20050812224411.8535F88548@common-lisp.net>

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

Modified Files:
	io-port.lisp 
Log Message:
Changed with-io-register-syntax to accept optional type argument.

Date: Sat Aug 13 00:44:10 2005
Author: ffjeld

Index: movitz/losp/muerte/io-port.lisp
diff -u movitz/losp/muerte/io-port.lisp:1.13 movitz/losp/muerte/io-port.lisp:1.14
--- movitz/losp/muerte/io-port.lisp:1.13	Wed Mar  2 18:15:43 2005
+++ movitz/losp/muerte/io-port.lisp	Sat Aug 13 00:44:10 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 21 22:14:08 2001
 ;;;;                
-;;;; $Id: io-port.lisp,v 1.13 2005/03/02 17:15:43 ffjeld Exp $
+;;;; $Id: io-port.lisp,v 1.14 2005/08/12 22:44:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -206,7 +206,8 @@
     `(let ((,io-var ,io-base-form))
        ;; (check-type ,io-var (unsigned-byte 16))
        (symbol-macrolet ((,name ,io-var))
-	 (macrolet ((,name (offset) `(io-register8 ,',io-var ,offset)))
+	 (macrolet ((,name (offset &optional (type :unsigned-byte8))
+		      `(io-port (+ ,',io-var ,offset) ,type)))
 	   , at body)))))
 
 (define-compiler-macro io-register8x2 (io-base offset-hi offset-lo)



From ffjeld at common-lisp.net  Fri Aug 12 22:50:23 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Aug 2005 00:50:23 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp 
Message-ID: <20050812225023.58CB888547@common-lisp.net>

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

Modified Files:
	io-port.lisp 
Log Message:
Added (io-port :unsigned-byte32).

Date: Sat Aug 13 00:50:23 2005
Author: ffjeld

Index: movitz/losp/muerte/io-port.lisp
diff -u movitz/losp/muerte/io-port.lisp:1.14 movitz/losp/muerte/io-port.lisp:1.15
--- movitz/losp/muerte/io-port.lisp:1.14	Sat Aug 13 00:44:10 2005
+++ movitz/losp/muerte/io-port.lisp	Sat Aug 13 00:50:22 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 21 22:14:08 2001
 ;;;;                
-;;;; $Id: io-port.lisp,v 1.14 2005/08/12 22:44:10 ffjeld Exp $
+;;;; $Id: io-port.lisp,v 1.15 2005/08/12 22:50:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -46,6 +46,16 @@
 	  (:shll ,movitz:+movitz-fixnum-shift+ :eax)
 	  (:movl :edi :edx)
 	  (:cld)))
+      (:unsigned-byte32
+       `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+	  (:compile-form (:result-mode :edx) ,port)
+	  (:std)
+	  (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+	  (:inl :dx :eax)
+	  (:movl :eax :ecx)
+	  (:movl :edi :eax)
+	  (:movl :edi :edx)
+	  (:cld)))
       (:character
        `(with-inline-assembly (:returns :eax)
 	  (:compile-form (:result-mode :edx) ,port)
@@ -64,6 +74,8 @@
      (io-port port :unsigned-byte8))
     (:unsigned-byte16
      (io-port port :unsigned-byte16))
+    (:unsigned-byte32
+     (io-port port :unsigned-byte32))
     (:character
      (io-port port :character))))
 



From ffjeld at common-lisp.net  Fri Aug 12 22:55:44 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Aug 2005 00:55:44 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp 
Message-ID: <20050812225544.72AD588548@common-lisp.net>

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

Modified Files:
	io-port.lisp 
Log Message:
Added (setf (io-port :unsigned-byte32)).

Date: Sat Aug 13 00:55:43 2005
Author: ffjeld

Index: movitz/losp/muerte/io-port.lisp
diff -u movitz/losp/muerte/io-port.lisp:1.15 movitz/losp/muerte/io-port.lisp:1.16
--- movitz/losp/muerte/io-port.lisp:1.15	Sat Aug 13 00:50:22 2005
+++ movitz/losp/muerte/io-port.lisp	Sat Aug 13 00:55:43 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 21 22:14:08 2001
 ;;;;                
-;;;; $Id: io-port.lisp,v 1.15 2005/08/12 22:50:22 ffjeld Exp $
+;;;; $Id: io-port.lisp,v 1.16 2005/08/12 22:55:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -169,6 +169,19 @@
 	      (:movl :edi :eax)
 	      (:cld))
 	    ,value-var))
+	(:unsigned-byte32
+	 `(let ((,value-var ,value)
+		(,port-var ,port))
+	    (with-inline-assembly (:returns :untagged-fixnum-ecx)
+	      (:load-lexical (:lexical-binding ,port-var) :edx)
+	      (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx)
+	      (:std)
+	      (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+	      (:movl :ecx :eax)
+	      (:outl :eax :dx)
+	      (:movl :edi :edx)
+	      (:movl :edi :eax)
+	      (:cld))))
 	(:character
 	 `(let ((,value-var ,value)
 		(,port-var ,port))
@@ -190,7 +203,9 @@
     (:unsigned-byte8
      (setf (io-port port :unsigned-byte8) value))
     (:unsigned-byte16
-     (setf (io-port port :unsigned-byte8) value))
+     (setf (io-port port :unsigned-byte16) value))
+    (:unsigned-byte32
+     (setf (io-port port :unsigned-byte32) value))
     (:character
      (setf (io-port port :character) value))))
 



From ffjeld at common-lisp.net  Sat Aug 13 20:24:07 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Aug 2005 22:24:07 +0200 (CEST)
Subject: [movitz-cvs] CVS update: ia-x86/codec.lisp 
Message-ID: <20050813202407.81D2E8854C@common-lisp.net>

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

Modified Files:
	codec.lisp 
Log Message:
Sign-extend the displacement part of an instruction when decoding it.

Date: Sat Aug 13 22:24:05 2005
Author: ffjeld

Index: ia-x86/codec.lisp
diff -u ia-x86/codec.lisp:1.6 ia-x86/codec.lisp:1.7
--- ia-x86/codec.lisp:1.6	Thu Sep  2 11:01:19 2004
+++ ia-x86/codec.lisp	Sat Aug 13 22:24:04 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2000, 2001, 2002, 2004,
+;;;;    Copyright (C) 2000, 2001, 2002, 2004-2005,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      codec.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu May  4 15:16:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: codec.lisp,v 1.6 2004/09/02 09:01:19 ffjeld Exp $
+;;;; $Id: codec.lisp,v 1.7 2005/08/13 20:24:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -701,11 +701,12 @@
     (incf byte-pos (template-instr-immediate-numo template))
     ;; displacement
     (setf (instr-symbolic-displacement is)
-      (complex (change-endian (ldb (byte (* 8 (template-instr-displacement-numo template)) 
-					 (* 8 byte-pos))
-				   datum)
-			      (template-instr-displacement-numo template))
-	       (template-instr-displacement-numo template)))
+      (sign-extend-complex
+       (complex (change-endian (ldb (byte (* 8 (template-instr-displacement-numo template)) 
+					  (* 8 byte-pos))
+				    datum)
+			       (template-instr-displacement-numo template))
+		(template-instr-displacement-numo template))))
     (incf byte-pos (template-instr-displacement-numo template))
     ;; SIB
     (when (template-instr-sib-p template)



From ffjeld at common-lisp.net  Sat Aug 13 20:31:52 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 13 Aug 2005 22:31:52 +0200 (CEST)
Subject: [movitz-cvs] CVS update: ia-x86/operands.lisp 
Message-ID: <20050813203152.3C4868854C@common-lisp.net>

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

Modified Files:
	operands.lisp 
Log Message:
Don't sign-extend already sign-extended displacement.

Date: Sat Aug 13 22:31:51 2005
Author: ffjeld

Index: ia-x86/operands.lisp
diff -u ia-x86/operands.lisp:1.5 ia-x86/operands.lisp:1.6
--- ia-x86/operands.lisp:1.5	Thu Sep  2 11:01:44 2004
+++ ia-x86/operands.lisp	Sat Aug 13 22:31:51 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 20012000, 2002-2004,
+;;;;    Copyright (C) 20012000, 2002-2005,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      operands.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Feb 16 14:02:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: operands.lisp,v 1.5 2004/09/02 09:01:44 ffjeld Exp $
+;;;; $Id: operands.lisp,v 1.6 2005/08/13 20:31:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -945,7 +945,7 @@
 	operand
       (setf register (decode-set (find-register-decode-set 'r/m32-01)
 				 r/m)
-	    offset (realpart (sign-extend-complex displacement)))))
+	    offset (realpart displacement))))
   (values operand))
 
 (defmethod operand-encode ((operand operand-indirect-register)
@@ -1687,7 +1687,7 @@
   (with-slots (offset)
       operand
     (setf offset
-      (realpart (sign-extend-complex (slot-value instr-symbolic 'displacement)))))
+      (realpart (slot-value instr-symbolic 'displacement))))
   (values operand))
 
 (defmethod operand-encode ((operand operand-rel-pointer)



From ffjeld at common-lisp.net  Sun Aug 14 11:35:53 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 13:35:53 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <20050814113553.0885388031@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed array-dimensions, added array-rank.

Date: Sun Aug 14 13:35:52 2005
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.53 movitz/losp/muerte/arrays.lisp:1.54
--- movitz/losp/muerte/arrays.lisp:1.53	Sat Jun 11 02:01:56 2005
+++ movitz/losp/muerte/arrays.lisp	Sun Aug 14 13:35:52 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.53 2005/06/11 00:01:56 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.54 2005/08/14 11:35:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -134,8 +134,17 @@
      (memref array (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
 
 (defun array-dimensions (array)
+  (let (r)
+    (dotimes (d (array-rank array))
+      (push (array-dimension array d) r))
+    (nreverse r)))
+
+(defun array-rank (array)
   (etypecase array
-    (vector 1)))
+    (indirect-vector
+     1)
+    ((simple-array * 1)
+     1)))
 
 (defun shrink-vector (vector new-size)
   (check-type vector vector)



From ffjeld at common-lisp.net  Sun Aug 14 12:04:07 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 14:04:07 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050814120407.A778B88032@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Fixed error message for etypecase.
Added non-compiled (typep x '(array ..)).
Tweaked coerce to be somewhat more general.

Date: Sun Aug 14 14:04:06 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.45 movitz/losp/muerte/typep.lisp:1.46
--- movitz/losp/muerte/typep.lisp:1.45	Fri Jun 10 00:19:10 2005
+++ movitz/losp/muerte/typep.lisp	Sun Aug 14 14:04:05 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.45 2005/06/09 22:19:10 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.46 2005/08/14 12:04:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -42,9 +42,7 @@
 	     (t (error "~S fell through an etypecase where the legal types were ~S."
 		       ,keyform
 		       ',(loop for c in clauses
-			     if (listp (car c))
-			     append (car c)
-			     else collect (car c))))))
+			     collect (car c))))))
 
 (define-compile-time-variable *simple-typespecs*
     ;; map symbol typespecs to typep-functions.
@@ -492,6 +490,17 @@
 	   ',fname))
        (defun ,fname ,lambda , at body))))
 
+(defun expand-type (type-specifier)
+  (typecase type-specifier
+    (symbol
+     (let ((typep-function (gethash type-specifier *derived-typespecs*)))
+       (when typep-function
+	 (funcall typep-function))))
+    (cons
+     (let ((typep-function (gethash (car type-specifier) *derived-typespecs*)))
+       (when typep-function
+	 (apply typep-function (cdr type-specifier)))))))
+
 (defun typep (object type-specifier)
   (block nil
     (typecase type-specifier
@@ -568,7 +577,26 @@
        (or (eq '* cdr) (typep (cdr x) cdr))))
 
 (deftype vector (&optional (element-type '*) (size '*))
-  `(simple-array ,element-type (,size)))
+  (if (eq size '*)
+      `(array ,element-type 1)
+    `(array ,element-type (,size))))
+
+(define-typep array (x &optional (element-type '*) (dimension-spec '*))
+  (and (typep x 'array)
+       (or (eq element-type '*)
+	   (do ((xet (array-element-type x))
+		(aet element-type (expand-type aet)))
+	       ((eq nil aet) nil)
+	     (when (equal xet aet) (return t))))
+       (or (eq dimension-spec '*)
+	   (if (integerp dimension-spec)
+	       (= dimension-spec (array-rank x))
+	     (and (= (length dimension-spec) (array-rank x))
+		  (every (lambda (xdim adim)
+			   (or (eq xdim '*) (= xdim adim)))
+			 dimension-spec
+			 (array-dimensions x)))))))
+      
 
 (define-simple-typep (atom atom) (x)
   (typep x 'atom))
@@ -669,14 +697,22 @@
 
 (defun coerce (object result-type)
   "=> result"
-  (cond
-   ((typep object result-type)
-    object)
-   ((and (eq result-type 'list)
-	 (typep object 'sequence))
-    (map 'list #'identity object))
-   ((and (typep object 'sequence)
-	 (member result-type '(vector array)))
-    (make-array (length object) :initial-contents object))
-   (t (error "Don't know how to coerce ~S to ~S." object result-type))))
+  (flet ((c (object result-type actual-type)
+	   (cond
+	    ((typep object result-type)
+	     object)
+	    ((member result-type '(list array vector))
+	     (map result-type #'identity object))
+	    ((and (consp result-type)
+		  (eq (car result-type) 'vector))
+	     (let* ((p (cdr result-type))
+		    (et (if p (pop p) t))
+		    (size (if p (pop p) nil)))
+	       (make-array (or size (length object))
+			   :initial-contents object
+			   :element-type et)))
+	    ((not (eq nil result-type))
+	     (c object (expand-type result-type) actual-type))
+	    (t (error "Don't know how to coerce ~S to ~S." object actual-type)))))
+    (c object result-type result-type)))
 



From ffjeld at common-lisp.net  Sun Aug 14 12:13:08 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 14:13:08 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/environment.lisp 
Message-ID: <20050814121308.1A70B88032@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
sync

Date: Sun Aug 14 14:13:07 2005
Author: ffjeld

Index: movitz/environment.lisp
diff -u movitz/environment.lisp:1.12 movitz/environment.lisp:1.13
--- movitz/environment.lisp:1.12	Tue Jan  4 12:35:25 2005
+++ movitz/environment.lisp	Sun Aug 14 14:13:07 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov  3 11:40:15 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: environment.lisp,v 1.12 2005/01/04 11:35:25 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.13 2005/08/14 12:13:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -292,12 +292,14 @@
 ;;;	(warn "..with body ~W" macro-function)
 	(let ((expansion (funcall macro-function form environment)))
 	  (cond
-;; 	    ((member (if (atom form) form (car form))
-;; 		     '(do) :test #'string=)
-;; 		     (warn "Expanded ~S to ~S" form expansion)
-;; 		     expansion)
+	   #+ignore ((member (if (atom form) form (car form))
+			     '(setf pcnet-reg) :test #'string=)
+		     (warn "Expanded ~S to ~S" form expansion)
+		     expansion)
 	   (t
-	    ;; (warn "Expanded macro named ~A." (if (atom form) form (car form)))
+	    #+ignore (warn "Expanded ~A:~%~S."
+			   (if (atom form) form (car form))
+			   expansion)
 	    expansion)))))
 
 (defun movitz-macroexpand-1 (form &optional env)



From ffjeld at common-lisp.net  Sun Aug 14 12:13:29 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 14:13:29 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp 
Message-ID: <20050814121329.0667388032@common-lisp.net>

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

Modified Files:
	ethernet.lisp 
Log Message:
Add a print-object method for ethernet devices.

Date: Sun Aug 14 14:13:27 2005
Author: ffjeld

Index: movitz/losp/lib/net/ethernet.lisp
diff -u movitz/losp/lib/net/ethernet.lisp:1.8 movitz/losp/lib/net/ethernet.lisp:1.9
--- movitz/losp/lib/net/ethernet.lisp:1.8	Sun May 22 00:37:21 2005
+++ movitz/losp/lib/net/ethernet.lisp	Sun Aug 14 14:13:27 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:25:31 2002
 ;;;;                
-;;;; $Id: ethernet.lisp,v 1.8 2005/05/21 22:37:21 ffjeld Exp $
+;;;; $Id: ethernet.lisp,v 1.9 2005/08/14 12:13:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -189,6 +189,12 @@
     :initarg :promiscuous-p
     :initform nil
     :accessor promiscuous-p)))
+
+(defmethod print-object ((x ethernet-device) s)
+  (print-unreadable-object (x s :type t :identity t)
+    (when (slot-boundp x 'mac-address)
+      (pprint-mac s (mac-address x)))))
+
 
 (defgeneric transmit (device packet &optional start end))
 (defgeneric receive (device &optional packet start))



From ffjeld at common-lisp.net  Sun Aug 14 12:13:53 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 14:13:53 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <20050814121353.AFB1388552@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Add #\_ as a 'safe' character.

Date: Sun Aug 14 14:13:51 2005
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.19 movitz/losp/muerte/print.lisp:1.20
--- movitz/losp/muerte/print.lisp:1.19	Wed May  4 10:00:39 2005
+++ movitz/losp/muerte/print.lisp	Sun Aug 14 14:13:51 2005
@@ -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.19 2005/05/04 08:00:39 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.20 2005/08/14 12:13:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -258,7 +258,7 @@
 				 (every (lambda (c)
 					  (or (upper-case-p c)
 					      (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\&
-							  #\/ #\< #\> #\=))
+							  #\/ #\< #\> #\= #\_))
 					      (digit-char-p c)))
 					name)
 				 (not (every (lambda (c)



From ffjeld at common-lisp.net  Sun Aug 14 12:15:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 14:15:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <20050814121506.9B84D88032@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
Added pci-device-address-maps.

Date: Sun Aug 14 14:15:05 2005
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.10 movitz/losp/x86-pc/pci.lisp:1.11
--- movitz/losp/x86-pc/pci.lisp:1.10	Fri Aug 12 08:34:35 2005
+++ movitz/losp/x86-pc/pci.lisp	Sun Aug 14 14:15:04 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.10 2005/08/12 06:34:35 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.11 2005/08/14 12:15:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -281,6 +281,30 @@
   (setf (pci-bios-config-space bus device function register #xb10b 8)
     value))
 
+
+(defmacro pci-config (register)
+  (cdr (or (assoc register
+		  '((:interrupt-line . #x3c)
+		    (:interrupt-pin . #x3d)
+		    (:base-addr . #x10)
+		    (:memspace . #x00)
+		    (:iospace . #x01)
+		    (:type . #x06)
+		    (:memspace64 . #x01)))
+	   (error "Unknown pci-config register: ~S" register))))
+
+(defun pci-device-address-maps (bus device function)
+  (loop for i upfrom (pci-config :base-addr) by 4 repeat 6
+      as base = (pci-bios-config-space-dword bus device function i)
+      unless (= 0 base) collect
+	(cond
+	 ((logbitp 0 base)
+	  (cons :io (logand base -4)))
+	 ((= 1 (ldb (byte 2 1) base))
+	  (cons :mem64 (logand base -16)))
+	 (t
+	  (cons :mem32 (logand base -16))))))
+	    
 (defun scan-pci-bus (bus)
   (loop for device from 0 to 31
       do (multiple-value-bind (vendor-id return-code)
@@ -298,5 +322,6 @@
 		       (ldb (byte 8 0) class-rev)
 		       status)
 	       (format *query-io* "    Class:~{ ~@[~A~]~}"
-		       (multiple-value-list (pci-class (ldb (byte 24 8) class-rev))))))))
-  (values))
\ No newline at end of file
+		       (multiple-value-list (pci-class (ldb (byte 24 8) class-rev))))
+	       (format *query-io* "~S" (pci-device-address-maps bus device 0))))))
+  (values))



From ffjeld at common-lisp.net  Sun Aug 14 12:26:11 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 14:26:11 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050814122611.1B26488031@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Fixed labels/flet confusion in coerce.

Date: Sun Aug 14 14:26:10 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.46 movitz/losp/muerte/typep.lisp:1.47
--- movitz/losp/muerte/typep.lisp:1.46	Sun Aug 14 14:04:05 2005
+++ movitz/losp/muerte/typep.lisp	Sun Aug 14 14:26:10 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.46 2005/08/14 12:04:05 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.47 2005/08/14 12:26:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -697,22 +697,23 @@
 
 (defun coerce (object result-type)
   "=> result"
-  (flet ((c (object result-type actual-type)
-	   (cond
-	    ((typep object result-type)
-	     object)
-	    ((member result-type '(list array vector))
-	     (map result-type #'identity object))
-	    ((and (consp result-type)
-		  (eq (car result-type) 'vector))
-	     (let* ((p (cdr result-type))
-		    (et (if p (pop p) t))
-		    (size (if p (pop p) nil)))
-	       (make-array (or size (length object))
-			   :initial-contents object
-			   :element-type et)))
-	    ((not (eq nil result-type))
-	     (c object (expand-type result-type) actual-type))
-	    (t (error "Don't know how to coerce ~S to ~S." object actual-type)))))
+  (labels
+      ((c (object result-type actual-type)
+	 (cond
+	  ((typep object result-type)
+	   object)
+	  ((member result-type '(list array vector))
+	   (map result-type #'identity object))
+	  ((and (consp result-type)
+		(eq (car result-type) 'vector))
+	   (let* ((p (cdr result-type))
+		  (et (if p (pop p) t))
+		  (size (if p (pop p) nil)))
+	     (make-array (or size (length object))
+			 :initial-contents object
+			 :element-type et)))
+	  ((not (eq nil result-type))
+	   (c object (expand-type result-type) actual-type))
+	  (t (error "Don't know how to coerce ~S to ~S." object actual-type)))))
     (c object result-type result-type)))
 



From ffjeld at common-lisp.net  Sun Aug 14 16:39:41 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 18:39:41 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <20050814163941.658FE88545@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Removed bogus macro that expanded if in terms of cond. This would
i.e. confuse some tree-walking stuff in loop's expander.

Date: Sun Aug 14 18:39:39 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.61 movitz/losp/muerte/basic-macros.lisp:1.62
--- movitz/losp/muerte/basic-macros.lisp:1.61	Wed May  4 00:15:38 2005
+++ movitz/losp/muerte/basic-macros.lisp	Sun Aug 14 18:39:39 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.61 2005/05/03 22:15:38 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.62 2005/08/14 16:39:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -106,9 +106,6 @@
 
 (define-compiler-macro cond (&body cond-body)
   (cons 'compiled-cond cond-body))
-
-(defmacro if (test-form then-form &optional else-form)
-  `(cond (,test-form ,then-form) (t ,else-form)))
 
 (define-compiler-macro if (test-form then-form &optional else-form &environment env)
   (when (and (movitz:movitz-constantp then-form env) (movitz:movitz-constantp else-form env))



From ffjeld at common-lisp.net  Sun Aug 14 18:50:13 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 20:50:13 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <20050814185013.A955B8854E@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
Fixed cut'n'paste-bug that caused specializing (setf
slot-value-using-class) not to work.

Date: Sun Aug 14 20:50:13 2005
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.33 movitz/losp/muerte/los-closette.lisp:1.34
--- movitz/losp/muerte/los-closette.lisp:1.33	Fri May  6 17:39:44 2005
+++ movitz/losp/muerte/los-closette.lisp	Sun Aug 14 20:50:12 2005
@@ -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.33 2005/05/06 15:39:44 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.34 2005/08/14 18:50:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1554,7 +1554,7 @@
 		   (or (not *standard-setf-slot-value-using-class*) ; still bootstrapping..
 		       (not (let ((value (car args))
 				  (object (cadr args)))
-			      (gf-nonstandard-specialized-p #'slot-value-using-class
+			      (gf-nonstandard-specialized-p #'(setf slot-value-using-class)
 							    (if (typep object 'funcallable-standard-class)
 								*standard-gf-setf-slot-value-using-class*
 							      *standard-setf-slot-value-using-class*)



From ffjeld at common-lisp.net  Sun Aug 14 18:52:40 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 20:52:40 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp 
Message-ID: <20050814185240.9E5DB8854E@common-lisp.net>

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

Modified Files:
	ethernet.lisp 
Log Message:
Add deftype mac-address as (vector (unsigned-byte 8) 6)

Date: Sun Aug 14 20:52:40 2005
Author: ffjeld

Index: movitz/losp/lib/net/ethernet.lisp
diff -u movitz/losp/lib/net/ethernet.lisp:1.9 movitz/losp/lib/net/ethernet.lisp:1.10
--- movitz/losp/lib/net/ethernet.lisp:1.9	Sun Aug 14 14:13:27 2005
+++ movitz/losp/lib/net/ethernet.lisp	Sun Aug 14 20:52:39 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:25:31 2002
 ;;;;                
-;;;; $Id: ethernet.lisp,v 1.9 2005/08/14 12:13:27 ffjeld Exp $
+;;;; $Id: ethernet.lisp,v 1.10 2005/08/14 18:52:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -170,6 +170,8 @@
 	(ether-type packet start) type)
   packet)
 
+(deftype mac-address ()
+  '(vector (unsigned-byte 8) 6))
 
 (defclass ethernet-device ()
   ((mac-address



From ffjeld at common-lisp.net  Sun Aug 14 18:52:54 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 14 Aug 2005 20:52:54 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050814185254.0DE5888032@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
*** empty log message ***
Date: Sun Aug 14 20:52:53 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.47 movitz/losp/muerte/typep.lisp:1.48
--- movitz/losp/muerte/typep.lisp:1.47	Sun Aug 14 14:26:10 2005
+++ movitz/losp/muerte/typep.lisp	Sun Aug 14 20:52:53 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.47 2005/08/14 12:26:10 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.48 2005/08/14 18:52:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -589,7 +589,7 @@
 	       ((eq nil aet) nil)
 	     (when (equal xet aet) (return t))))
        (or (eq dimension-spec '*)
-	   (if (integerp dimension-spec)
+	   (if (typep dimension-spec 'integer)
 	       (= dimension-spec (array-rank x))
 	     (and (= (length dimension-spec) (array-rank x))
 		  (every (lambda (xdim adim)



From ffjeld at common-lisp.net  Mon Aug 15 00:06:21 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 15 Aug 2005 02:06:21 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp 
Message-ID: <20050815000621.4191088547@common-lisp.net>

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

Modified Files:
	io-port.lisp 
Log Message:
Smarted up io-port compiler-macros a bit.

Date: Mon Aug 15 02:06:19 2005
Author: ffjeld

Index: movitz/losp/muerte/io-port.lisp
diff -u movitz/losp/muerte/io-port.lisp:1.16 movitz/losp/muerte/io-port.lisp:1.17
--- movitz/losp/muerte/io-port.lisp:1.16	Sat Aug 13 00:55:43 2005
+++ movitz/losp/muerte/io-port.lisp	Mon Aug 15 02:06:19 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 21 22:14:08 2001
 ;;;;                
-;;;; $Id: io-port.lisp,v 1.16 2005/08/12 22:55:43 ffjeld Exp $
+;;;; $Id: io-port.lisp,v 1.17 2005/08/15 00:06:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -27,27 +27,50 @@
       form
     (ecase (movitz:movitz-eval type env)
       (:unsigned-byte8
-       `(with-inline-assembly (:returns :eax)
-	  (:compile-form (:result-mode :edx) ,port)
-	  (:std)			; only EBX is now GC root
-	  (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
-	  (:xorl :eax :eax)
-	  (:inb :dx :al)
-	  (:shll ,movitz:+movitz-fixnum-shift+ :eax)
-	  (:movl :edi :edx)
-	  (:cld)))
+       `(with-inline-assembly-case (:type (unsigned-byte 8))
+	  (do-case (:untagged-fixnum-ecx :untagged-fixnum-ecx)
+	    (:compile-form (:result-mode :edx) ,port)
+	    (:std)			; only EBX is now GC root
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+	    (:xorl :eax :eax)
+	    (:inb :dx :al)
+	    (:movl :eax :ecx)
+	    (:movl :edi :eax)
+	    (:movl :edi :edx)
+	    (:cld))
+	  (do-case (t :eax)
+	    (:compile-form (:result-mode :edx) ,port)
+	    (:std)			; only EBX is now GC root
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+	    (:xorl :eax :eax)
+	    (:inb :dx :al)
+	    (:shll ,movitz:+movitz-fixnum-shift+ :eax)
+	    (:movl :edi :edx)
+	    (:cld))))
       (:unsigned-byte16
-       `(with-inline-assembly (:returns :eax)
-	  (:compile-form (:result-mode :edx) ,port)
-	  (:std)
-	  (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
-	  (:xorl :eax :eax)
-	  (:inw :dx :ax)
-	  (:shll ,movitz:+movitz-fixnum-shift+ :eax)
-	  (:movl :edi :edx)
-	  (:cld)))
+       `(with-inline-assembly-case (:type (unsigned-byte 16))
+	  (do-case (:untagged-fixnum-ecx :untagged-fixnum-ecx)
+	    (:compile-form (:result-mode :edx) ,port)
+	    (:std)
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+	    (:xorl :eax :eax)
+	    (:inw :dx :ax)
+	    (:movl :eax :ecx)
+	    (:movl :edi :eax)
+	    (:movl :edi :edx)
+	    (:cld))
+	  (do-case (t :eax)
+	    (:compile-form (:result-mode :edx) ,port)
+	    (:std)
+	    (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
+	    (:xorl :eax :eax)
+	    (:inw :dx :ax)
+	    (:shll ,movitz:+movitz-fixnum-shift+ :eax)
+	    (:movl :edi :edx)
+	    (:cld))))
       (:unsigned-byte32
-       `(with-inline-assembly (:returns :untagged-fixnum-ecx)
+       `(with-inline-assembly (:returns :untagged-fixnum-ecx
+					:type (unsigned-byte 32))
 	  (:compile-form (:result-mode :edx) ,port)
 	  (:std)
 	  (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
@@ -139,6 +162,61 @@
 		       `((:movl :edi :edx)))
 		   (:movl :edi :eax)
 		   (:cld)))))))))
+     ((and (movitz:movitz-constantp type env)
+	   (movitz:movitz-constantp value env))
+      (let ((value (movitz:movitz-eval value env)))
+	(ecase (movitz:movitz-eval type env)
+	  (:unsigned-byte8
+	   (check-type value (unsigned-byte 8))
+	   `(let ((,port-var ,port))
+	      (with-inline-assembly (:returns :nothing)
+		(:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
+		(:std)
+		(:movl :ecx :edx)
+		(:movb ,value :al)
+		(:outb :al :dx)
+		(:movl :edi :edx)
+		(:movl :edi :eax)
+		(:cld))
+	      ,value))
+	  (:unsigned-byte16
+	   (check-type value (unsigned-byte 16))
+	   `(let ((,port-var ,port))
+	      (with-inline-assembly (:returns :nothing)
+		(:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
+		(:std)
+		(:movl :ecx :edx)
+		(:movl ,value :eax)
+		(:outw :ax :dx)
+		(:movl :edi :edx)
+		(:movl :edi :eax)
+		(:cld))
+	      ,value))
+	  (:unsigned-byte32
+	   `(let ((,port-var ,port))
+	      (with-inline-assembly (:returns :nothing)
+		(:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
+		(:std)
+		(:movl :ecx :edx)
+		(:movl ,value :eax)
+		(:outl :eax :dx)
+		(:movl :edi :edx)
+		(:movl :edi :eax)
+		(:cld))
+	      ,value))
+	  (:character
+	   `(let ((,port-var ,port))
+	      (check-type value character)
+	      (with-inline-assembly (:returns :nothing)
+		(:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
+		(:std)
+		(:movl :ecx :edx)
+		(:movb ,(char-code value) :al)
+		(:outb :al :dx)
+		(:movl :edi :edx)
+		(:movl :edi :eax)
+		(:cld))
+	      ,value)))))
      ((movitz:movitz-constantp type env)
       (ecase (movitz:movitz-eval type env)
 	(:unsigned-byte8
@@ -160,10 +238,10 @@
 		(,port-var ,port))
 	    (with-inline-assembly (:returns :nothing)
 	      (:load-lexical (:lexical-binding ,port-var) :edx)
-	      (:load-lexical (:lexical-binding ,value-var) :eax)
+	      (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx)
 	      (:std)
 	      (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
-	      (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
+	      (:movl :ecx :eax)
 	      (:outw :ax :dx)
 	      (:movl :edi :edx)
 	      (:movl :edi :eax)



From ffjeld at common-lisp.net  Mon Aug 15 21:44:28 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 15 Aug 2005 23:44:28 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050815214428.C2A1088546@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Smarted up make-load-lexical and make-store-lexical somewhat regarding
recognizing constant values.

Date: Mon Aug 15 23:44:24 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.148 movitz/compiler.lisp:1.149
--- movitz/compiler.lisp:1.148	Thu Jul 21 19:28:46 2005
+++ movitz/compiler.lisp	Mon Aug 15 23:44:23 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.148 2005/07/21 17:28:46 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.149 2005/08/15 21:44:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3446,62 +3446,86 @@
 		   (first (set-difference '(:eax :ebx :edx)
 					  protect-registers))
 		   (error "Unable to chose a temporary register.")))
-	     (install-for-single-value (lexb lexb-location result-mode indirect-p)
-	       (cond
-		((and (eq result-mode :untagged-fixnum-ecx)
-		      (integerp lexb-location))
-		 (assert (not indirect-p))
-		 (assert (not (member :eax protect-registers)))
-		 (append (install-for-single-value lexb lexb-location :eax nil)
-			 `((,*compiler-global-segment-prefix*
-			    :call (:edi ,(global-constant-offset 'unbox-u32))))))
-		((integerp lexb-location)
-		 (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
-				  ,(single-value-register result-mode)))
-			 (when indirect-p
-			   `((:movl (-1 ,(single-value-register result-mode))
-				    ,(single-value-register result-mode))))))
-		(t (ecase (operator lexb-location)
-		     (:push
-		      (assert (member result-mode '(:eax :ebx :ecx :edx)))
-		      (assert (not indirect-p))
-		      `((:popl ,result-mode)))
-		     (:eax
-		      (assert (not indirect-p))
-		      (ecase result-mode
-			((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode)))
-			((:eax :single-value) nil)
-			(:untagged-fixnum-ecx
-			 `((,*compiler-global-segment-prefix*
-			    :call (:edi ,(global-constant-offset 'unbox-u32)))))))
-		     ((:ebx :ecx :edx)
-		      (assert (not indirect-p))
-		      (unless (eq result-mode lexb-location)
+	     (install-for-single-value (lexb lexb-location result-mode indirect-p
+					&optional binding-type)
+	       (let ((decoded-type (when binding-type
+				     (apply #'encoded-type-decode binding-type))))
+		 (cond
+		  ((and (eq result-mode :untagged-fixnum-ecx)
+			(integerp lexb-location))
+		   (cond
+;;;		    ((and binding-type
+;;;			  (not (movitz-subtypep decoded-type '(unsigned-byte 32))))
+;;;		     (error "Can't load a value of type ~S as ~S."
+;;;			    :untagged-fixnum-ecx))
+		    ((and binding-type
+			  (type-specifier-singleton decoded-type))
+		     (warn "Immloadlex: ~S"
+			   (type-specifier-singleton decoded-type))
+		     (make-immediate-move (movitz-immediate-value
+					   (car (type-specifier-singleton decoded-type)))
+					  :ecx))
+		    (t
+		     (assert (not indirect-p))
+		     (assert (not (member :eax protect-registers)))
+		     (append (install-for-single-value lexb lexb-location :eax nil)
+			     `((,*compiler-global-segment-prefix*
+				:call (:edi ,(global-constant-offset 'unbox-u32))))))))
+		  ((integerp lexb-location)
+		   (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
+				    ,(single-value-register result-mode)))
+			   (when indirect-p
+			     `((:movl (-1 ,(single-value-register result-mode))
+				      ,(single-value-register result-mode))))))
+		  ((eq lexb-location result-mode)
+		   ())
+		  (t (when (and (eq result-mode :untagged-fixnum-ecx)
+				binding-type
+				(type-specifier-singleton decoded-type))
+		       (break "xxx Immloadlex: ~S ~S"
+			     (operator lexb-location)
+			     (type-specifier-singleton decoded-type)))
+		     (ecase (operator lexb-location)
+		       (:push
+			(assert (member result-mode '(:eax :ebx :ecx :edx)))
+			(assert (not indirect-p))
+			`((:popl ,result-mode)))
+		       (:eax
+			(assert (not indirect-p))
 			(ecase result-mode
-			  ((:eax :single-value) `((:movl ,lexb-location :eax)))
-			  ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode)))
+			  ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode)))
+			  ((:eax :single-value) nil)
 			  (:untagged-fixnum-ecx
-			   `((:movl ,lexb-location :ecx)
-			     (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))))
-		     (:argument-stack
-		      (assert (<= 2 (function-argument-argnum lexb)) ()
-			"lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
-		      (cond
-		       ((eq result-mode :untagged-fixnum-ecx)
+			   `((,*compiler-global-segment-prefix*
+			      :call (:edi ,(global-constant-offset 'unbox-u32)))))))
+		       ((:ebx :ecx :edx)
 			(assert (not indirect-p))
-			`((:movl (:ebp ,(argument-stack-offset lexb)) :ecx)
-			  (:sarl ,+movitz-fixnum-shift+ :ecx)))
-		       (t (append `((:movl (:ebp ,(argument-stack-offset lexb))
-					   ,(single-value-register result-mode)))
-				  (when indirect-p
-				    `((:movl (-1 ,(single-value-register result-mode))
-					     ,(single-value-register result-mode))))))))
-		     (:untagged-fixnum-ecx
-		      (ecase result-mode
-			((:eax :ebx :ecx :edx)
-			 `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode)))
-			(:untagged-fixnum-ecx
-			 nil))))))))
+			(unless (eq result-mode lexb-location)
+			  (ecase result-mode
+			    ((:eax :single-value) `((:movl ,lexb-location :eax)))
+			    ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode)))
+			    (:untagged-fixnum-ecx
+			     `((:movl ,lexb-location :ecx)
+			       (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))))
+		       (:argument-stack
+			(assert (<= 2 (function-argument-argnum lexb)) ()
+			  "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
+			(cond
+			 ((eq result-mode :untagged-fixnum-ecx)
+			  (assert (not indirect-p))
+			  `((:movl (:ebp ,(argument-stack-offset lexb)) :ecx)
+			    (:sarl ,+movitz-fixnum-shift+ :ecx)))
+			 (t (append `((:movl (:ebp ,(argument-stack-offset lexb))
+					     ,(single-value-register result-mode)))
+				    (when indirect-p
+				      `((:movl (-1 ,(single-value-register result-mode))
+					       ,(single-value-register result-mode))))))))
+		       (:untagged-fixnum-ecx
+			(ecase result-mode
+			  ((:eax :ebx :ecx :edx)
+			   `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode)))
+			  (:untagged-fixnum-ecx
+			   nil)))))))))
       (etypecase binding
 	(forwarding-binding
 	 (assert (not (binding-lended-p binding)) (binding)
@@ -3545,7 +3569,8 @@
 			      ,tmp-register)
 		       (:movl (,tmp-register -1) ,tmp-register))))))))))
 	(located-binding
-	 (let ((binding-location (new-binding-location binding frame-map)))
+	 (let ((binding-type (binding-store-type binding))
+	       (binding-location (new-binding-location binding frame-map)))
 	   (cond
 	    ((and (binding-lended-p binding)
 		  (not shared-reference-p))
@@ -3607,7 +3632,8 @@
 		       `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
 			 (:je ',(operands result-mode)))))))
 		 (:untagged-fixnum-ecx
-		  (install-for-single-value binding binding-location :untagged-fixnum-ecx nil))
+		  (install-for-single-value binding binding-location :untagged-fixnum-ecx nil
+					    binding-type))
 		 (:lexical-binding
 		  (let* ((destination result-mode)
 			 (dest-location (new-binding-location destination frame-map :default nil)))
@@ -3639,16 +3665,9 @@
 		    (not (binding-lended-p binding))))
       (binding)
     "funny binding: ~W" binding)
-  (if (typep source 'constant-object-binding)
+  (if (and nil (typep source 'constant-object-binding))
       (make-load-constant (constant-object source) binding funobj frame-map)
-    (let ((protect-registers (cons source protect-registers))
-	  #+ignore (source (if (not (typep source 'constant-object-binding))
-			       source
-			     (etypecase (constant-object source)
-			       (movitz-null
-				:edi)
-			       (movitz-immediate-object
-				(movitz-immediate-value (constant-object source)))))))
+    (let ((protect-registers (cons source protect-registers)))
       (cond
        ((eq :untagged-fixnum-ecx source)
 	(if (eq :untagged-fixnum-ecx
@@ -3690,28 +3709,72 @@
 	       `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
 		 (:movl ,source (,tmp-reg -1))))))))
        (t (let ((location (new-binding-location binding frame-map)))
-	    (if (integerp location)
-		`((:movl ,source (:ebp ,(stack-frame-offset location))))
-	      (ecase (operator location)
-		((:push)
-		 `((:pushl ,source)))
-		((:eax :ebx :ecx :edx)
-		 (unless (eq source location)
-		   `((:movl ,source ,location))))
-		(:argument-stack
-		 (assert (<= 2 (function-argument-argnum binding)) ()
-		   "store-lexical argnum can't be ~A." (function-argument-argnum binding))
-		 `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
-		(:untagged-fixnum-ecx
-		 (cond
-		  ((eq source :untagged-fixnum-ecx)
-		   nil)
-		  ((eq source :eax)
-		   `((,*compiler-global-segment-prefix*
-		      :call (:edi ,(global-constant-offset 'unbox-u32)))))
-		  (t `((:movl ,source :eax)
-		       (,*compiler-global-segment-prefix*
-			:call (:edi ,(global-constant-offset 'unbox-u32)))))))))))))))
+	    (cond
+	     ((member source '(:eax :ebx :ecx :edx :edi :esp))
+	      (if (integerp location)
+		  `((:movl ,source (:ebp ,(stack-frame-offset location))))
+		(ecase (operator location)
+		  ((:push)
+		   `((:pushl ,source)))
+		  ((:eax :ebx :ecx :edx)
+		   (unless (eq source location)
+		     `((:movl ,source ,location))))
+		  (:argument-stack
+		   (assert (<= 2 (function-argument-argnum binding)) ()
+		     "store-lexical argnum can't be ~A." (function-argument-argnum binding))
+		   `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
+		  (:untagged-fixnum-ecx
+		   (assert (not (eq source :edi)))
+		   (cond
+		    ((eq source :untagged-fixnum-ecx)
+		     nil)
+		    ((eq source :eax)
+		     `((,*compiler-global-segment-prefix*
+			:call (:edi ,(global-constant-offset 'unbox-u32)))))
+		    (t `((:movl ,source :eax)
+			 (,*compiler-global-segment-prefix*
+			  :call (:edi ,(global-constant-offset 'unbox-u32))))))))))
+	     ((not (bindingp source))
+	      (error "Unknown source for store-lexical: ~S" source))
+	     ((binding-singleton source)
+	      (assert (not shared-reference-p))
+	      (let ((value (car (binding-singleton source))))
+		(etypecase value
+		  (movitz-fixnum
+		   (let ((immediate (movitz-immediate-value value)))
+		     (if (integerp location)
+			 (let ((tmp (chose-free-register protect-registers)))
+			   (append (make-immediate-move immediate tmp)
+				   `((:movl ,tmp (:ebp ,(stack-frame-offset location))))))
+		       #+ignore (if (= 0 immediate)
+				      (let ((tmp (chose-free-register protect-registers)))
+					`((:xorl ,tmp ,tmp)
+					  (:movl ,tmp (:ebp ,(stack-frame-offset location)))))
+				    `((:movl ,immediate (:ebp ,(stack-frame-offset location)))))
+		       (ecase (operator location)
+			 ((:argument-stack)
+			  `((:movl ,immediate (:ebp ,(argument-stack-offset binding)))))
+			 ((:eax :ebx :edx)
+			  (make-immediate-move immediate location))
+			 ((:untagged-fixnum-ecx)
+			  (make-immediate-move (movitz-fixnum-value value) :ecx))))))
+		  (movitz-heap-object
+		   (etypecase location
+		     ((member :eax :ebx :edx)
+		      (make-load-constant value location funobj frame-map))
+		     (integer
+		      (let ((tmp (chose-free-register protect-registers)))
+			(append (make-load-constant value tmp funobj frame-map)
+				(make-store-lexical binding tmp shared-reference-p
+						    funobj frame-map
+						    :protect-registers protect-registers))))
+		     ((eql :untagged-fixnum-ecx)
+		      (check-type value movitz-bignum)
+		      (let ((immediate (movitz-bignum-value value)))
+			(check-type immediate (unsigned-byte 32))
+			(make-immediate-move immediate :ecx)))
+		     )))))	       
+	     (t (error "Generalized lexb source for store-lexical not implemented: ~S" source)))))))))
 
 (defun finalize-code (code funobj frame-map)
   ;; (print-code 'to-be-finalized code)
@@ -3980,7 +4043,7 @@
 		       (make-store-lexical result-mode :eax nil funobj frame-map)))
 	      (:untagged-fixnum-ecx
 	       (let ((value (movitz-fixnum-value object)))
-		 (check-type value (signed-byte 30))
+		 (check-type value (unsigned-byte 32))
 		 (make-immediate-move value :ecx)))
 	      (:push
 	       `((:pushl ,x)))
@@ -6179,16 +6242,6 @@
 			   (borrowed-binding-target binding)))
 	      (error "Can't install non-local binding ~W." binding)))))))
 
-(defun binding-type-specifier (binding)
-  (break "nix binding-type-specifier: ~S" binding)
-  (etypecase binding
-    (forwarding-binding
-     (binding-type-specifier (forwarding-binding-target binding)))
-    (constant-object-binding
-     `(eql ,(constant-object binding)))
-    (binding
-     `(binding-type ,binding))))
-
 (defun binding-store-subtypep (binding type-specifier)
   "Is type-specifier a supertype of all values ever stored to binding?
    (Assuming analyze-bindings has put this information into binding-store-type.)"
@@ -6197,6 +6250,11 @@
     (multiple-value-call #'encoded-subtypep
       (values-list (binding-store-type binding))
       (type-specifier-encode type-specifier))))
+
+(defun binding-singleton (binding)
+  (let ((btype (binding-store-type binding)))
+    (when btype
+      (type-specifier-singleton (apply #'encoded-type-decode btype)))))
 
 ;;;;;;;
 ;;;;;;; Extended-code handlers



From ffjeld at common-lisp.net  Sat Aug 20 20:23:35 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:23:35 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <20050820202335.A46268854C@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
Minor tweaks to macro expanders.

Date: Sat Aug 20 22:23:35 2005
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.9 movitz/losp/muerte/arithmetic-macros.lisp:1.10
--- movitz/losp/muerte/arithmetic-macros.lisp:1.9	Tue Nov 23 17:00:20 2004
+++ movitz/losp/muerte/arithmetic-macros.lisp	Sat Aug 20 22:23:34 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2003-2004, 
+;;;;    Copyright (C) 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.9 2004/11/23 16:00:20 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.10 2005/08/20 20:23:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -41,27 +41,32 @@
      (:testb 1 :cl)))
 
 (define-compiler-macro + (&whole form &rest operands &environment env)
-  (case (length operands)
-    (0 0)
-    (1 (first operands))
-    (2 `(let ((x ,(first operands))
-	      (y ,(second operands)))
-	  (++%2op x y)))
-    (t (multiple-value-bind (constant-term non-constants)
-	   (loop for operand in operands
-	       if (movitz:movitz-constantp operand env)
-	       sum (movitz:movitz-eval operand env) into constant-term
-	       else collect operand into non-constant-operands
-	       finally (return (values constant-term non-constant-operands)))
-	 (cond
-	  ((null non-constants)
-	   constant-term)
-	  ((and (= 0 constant-term)
-		(not (cdr non-constants)))
-	   (car non-constants))
-	  ((= 0 constant-term)
-	   `(+ (+ ,(first non-constants) ,(second non-constants)) ,@(cddr non-constants)))
-	  (t `(+ (+ ,constant-term ,(first non-constants)) ,@(cdr non-constants))))))))
+  (flet ((term (x) (if (and nil (symbolp x))
+		       (gensym (format nil "term-~A-" x))
+		     (gensym "term-"))))
+    (case (length operands)
+      (0 0)
+      (1 (first operands))
+      (2 (let ((term1 (term (first operands)))
+	       (term2 (term (second operands))))
+	   `(let ((,term1 ,(first operands))
+		  (,term2 ,(second operands)))
+	      (++%2op ,term1 ,term2))))
+      (t (multiple-value-bind (constant-term non-constants)
+	     (loop for operand in operands
+		 if (movitz:movitz-constantp operand env)
+		 sum (movitz:movitz-eval operand env) into constant-term
+		 else collect operand into non-constant-operands
+		 finally (return (values constant-term non-constant-operands)))
+	   (cond
+	    ((null non-constants)
+	     constant-term)
+	    ((and (= 0 constant-term)
+		  (not (cdr non-constants)))
+	     (car non-constants))
+	    ((= 0 constant-term)
+	     `(+ (+ ,(first non-constants) ,(second non-constants)) ,@(cddr non-constants)))
+	    (t `(+ (+ ,constant-term ,(first non-constants)) ,@(cdr non-constants)))))))))
 
 (define-compiler-macro 1+ (number)
   `(+ 1 ,number))
@@ -256,7 +261,7 @@
 	     (case f1
 	       (0 `(progn ,factor2 0))
 	       (1 factor2)
-	       (2 `(let ((x ,factor2)) (+ x x)))
+	       (2 `(let ((x2 ,factor2)) (+ x2 x2)))
 	       (t `(no-macro-call * ,factor1 ,factor2)))))
 	  (t `(no-macro-call * ,factor1 ,factor2)))))
     (t `(* (* ,(first operands) ,(second operands)) ,@(cddr operands)))))



From ffjeld at common-lisp.net  Sat Aug 20 20:24:13 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:24:13 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <20050820202413.E5129884CB@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Removed superfluous array type expander.

Date: Sat Aug 20 22:24:12 2005
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.54 movitz/losp/muerte/arrays.lisp:1.55
--- movitz/losp/muerte/arrays.lisp:1.54	Sun Aug 14 13:35:52 2005
+++ movitz/losp/muerte/arrays.lisp	Sat Aug 20 22:24:11 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.54 2005/08/14 11:35:52 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.55 2005/08/20 20:24:11 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1076,28 +1076,6 @@
 (defun bvref-u16 (vector offset index)
   "View <vector> as an sequence of octets, access the big-endian 16-bit word at position <index> + <offset>."
   (bvref-u16 vector offset index))
-
-(define-typep array (x &optional (element-type '*) (dimension-spec '*))
-  (and (typep x 'array)
-       (or (eq element-type '*)
-	   (eq element-type t)
-	   (equalp (array-element-type x)
-		   (upgraded-array-element-type element-type)))
-       (or (eq dimension-spec '*)
-	   (and (integerp dimension-spec)
-		(= dimension-spec (array-dimensions x)))
-	   (and (listp dimension-spec)
-		(do ((array-rank (array-dimensions x))
-		     (d 0 (1+ d))
-		     (q dimension-spec))
-		    ((null q) (= d array-rank))
-		  (let ((dim (pop q)))
-		    (cond
-		     ((>= d array-rank)
-		      (return nil))
-		     ((eq dim '*))
-		     ((= dim (array-dimension x d)))
-		     (t (return nil)))))))))
 
 (defun ensure-data-vector (vector start length)
   (let ((end (typecase vector



From ffjeld at common-lisp.net  Sat Aug 20 20:25:09 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:25:09 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <20050820202509.D056988031@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Added macro check-the, which combindes 'the' and 'check-type'.

Date: Sat Aug 20 22:25:09 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.62 movitz/losp/muerte/basic-macros.lisp:1.63
--- movitz/losp/muerte/basic-macros.lisp:1.62	Sun Aug 14 18:39:39 2005
+++ movitz/losp/muerte/basic-macros.lisp	Sat Aug 20 22:25:09 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.62 2005/08/14 16:39:39 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.63 2005/08/20 20:25:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1193,6 +1193,11 @@
 
 (define-compiler-macro sti ()
   `(with-inline-assembly (:returns :nothing) (:sti)))
+
+
+(defmacro check-the (type form)
+  (let ((x (gensym "check-the-")))
+    `(the ,type (let ((,x ,form)) (check-type ,x ,type) ,x))))
 
 (require :muerte/setf)
 



From ffjeld at common-lisp.net  Sat Aug 20 20:25:42 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:25:42 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <20050820202542.69FC58854C@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
Add an optional (8-bit) fill parameter to %make-bignum.

Date: Sat Aug 20 22:25:41 2005
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.15 movitz/losp/muerte/bignums.lisp:1.16
--- movitz/losp/muerte/bignums.lisp:1.15	Mon Feb 14 08:13:42 2005
+++ movitz/losp/muerte/bignums.lisp	Sat Aug 20 22:25:41 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.15 2005/02/14 07:13:42 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.16 2005/08/20 20:25:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -66,18 +66,29 @@
   (check-type old bignum)
   (%shallow-copy-object old (1+ (%bignum-bigits old))))
 
-(defun %make-bignum (bigits)
-  (assert (plusp bigits))
-  (macrolet
-      ((do-it ()
-	 `(let ((words (1+ bigits)))
-	    (with-non-pointer-allocation-assembly (words :fixed-size-p t
-							 :object-register :eax)
-	      (:load-lexical (:lexical-binding bigits) :ecx)
-	      (:shll 16 :ecx)
-	      (:orl ,(movitz:tag :bignum 0) :ecx)
-	      (:movl :ecx (:eax (:offset movitz-bignum type)))))))
-    (do-it)))
+(defun %make-bignum (bigits &optional fill)
+  (numargs-case
+   (1 (bigits)
+      (check-type bigits (unsigned-byte 14))
+      (macrolet
+	  ((do-it ()
+	     `(let ((words (1+ bigits)))
+		(with-non-pointer-allocation-assembly (words :fixed-size-p t
+							     :object-register :eax)
+		  (:load-lexical (:lexical-binding bigits) :ecx)
+		  (:shll 16 :ecx)
+		  (:orl ,(movitz:tag :bignum 0) :ecx)
+		  (:movl :ecx (:eax (:offset movitz-bignum type)))))))
+	(do-it)))
+   (t (bigits &optional fill)
+      (let ((bignum (%make-bignum bigits)))
+	(when fill
+	  (check-type fill (unsigned-byte 8))
+	  (dotimes (i (* 4 bigits))
+	    (setf (memref bignum (movitz-type-slot-offset 'movitz-bignum 'bigit0)
+			  :index i :type :unsigned-byte8)
+	      fill)))
+	bignum))))
 
 (defun print-bignum (x)
   (check-type x bignum)



From ffjeld at common-lisp.net  Sat Aug 20 20:27:20 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:27:20 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp 
Message-ID: <20050820202720.1215B88542@common-lisp.net>

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

Modified Files:
	io-port.lisp 
Log Message:
Use check-the in with-io-register-syntax.

Date: Sat Aug 20 22:27:19 2005
Author: ffjeld

Index: movitz/losp/muerte/io-port.lisp
diff -u movitz/losp/muerte/io-port.lisp:1.17 movitz/losp/muerte/io-port.lisp:1.18
--- movitz/losp/muerte/io-port.lisp:1.17	Mon Aug 15 02:06:19 2005
+++ movitz/losp/muerte/io-port.lisp	Sat Aug 20 22:27:19 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Mar 21 22:14:08 2001
 ;;;;                
-;;;; $Id: io-port.lisp,v 1.17 2005/08/15 00:06:19 ffjeld Exp $
+;;;; $Id: io-port.lisp,v 1.18 2005/08/20 20:27:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -308,8 +308,7 @@
   "Syntax for easy access to IO registers. <name> is installed as a local macro
 that reads from <io-base-form> plus some offset."
   (let ((io-var (gensym "io-base-")))
-    `(let ((,io-var ,io-base-form))
-       ;; (check-type ,io-var (unsigned-byte 16))
+    `(let ((,io-var (check-the (unsigned-byte 16) ,io-base-form)))
        (symbol-macrolet ((,name ,io-var))
 	 (macrolet ((,name (offset &optional (type :unsigned-byte8))
 		      `(io-port (+ ,',io-var ,offset) ,type)))



From ffjeld at common-lisp.net  Sat Aug 20 20:28:32 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:28:32 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050820202832.9C24F8854E@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Fixed array type-expander.

Date: Sat Aug 20 22:28:32 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.48 movitz/losp/muerte/typep.lisp:1.49
--- movitz/losp/muerte/typep.lisp:1.48	Sun Aug 14 20:52:53 2005
+++ movitz/losp/muerte/typep.lisp	Sat Aug 20 22:28:31 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.48 2005/08/14 18:52:53 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.49 2005/08/20 20:28:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -590,10 +590,10 @@
 	     (when (equal xet aet) (return t))))
        (or (eq dimension-spec '*)
 	   (if (typep dimension-spec 'integer)
-	       (= dimension-spec (array-rank x))
-	     (and (= (length dimension-spec) (array-rank x))
+	       (eql dimension-spec (array-rank x))
+	     (and (eql (length dimension-spec) (array-rank x))
 		  (every (lambda (xdim adim)
-			   (or (eq xdim '*) (= xdim adim)))
+			   (or (eq xdim '*) (eql xdim adim)))
 			 dimension-spec
 			 (array-dimensions x)))))))
       



From ffjeld at common-lisp.net  Sat Aug 20 20:30:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:30:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler-protocol.lisp 
Message-ID: <20050820203006.2D7C18854E@common-lisp.net>

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

Modified Files:
	compiler-protocol.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:30:04 2005
Author: ffjeld

Index: movitz/compiler-protocol.lisp
diff -u movitz/compiler-protocol.lisp:1.3 movitz/compiler-protocol.lisp:1.4
--- movitz/compiler-protocol.lisp:1.3	Thu Feb 12 18:51:02 2004
+++ movitz/compiler-protocol.lisp	Sat Aug 20 22:30:03 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 10 13:02:03 2001
 ;;;;                
-;;;; $Id: compiler-protocol.lisp,v 1.3 2004/02/12 17:51:02 ffjeld Exp $
+;;;; $Id: compiler-protocol.lisp,v 1.4 2005/08/20 20:30:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -159,26 +159,29 @@
 				 ((&funobj funobj-var) (copy-symbol 'funobj) funobj-p)
 				 ((&env env-var) (copy-symbol 'env) env-p)
 				 ((&top-level-p top-level-p-var) (copy-symbol 'top-level-p) top-level-p-p)
-				 ((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p))
+				 ((&result-mode result-mode-var) (copy-symbol 'result-mode) result-mode-p)
+				 ((&extent extent-var) (copy-symbol 'extent) extent-p))
 			   &body defun-body)
   (multiple-value-bind (body docstring)
       (if (and (cdr defun-body)
 	       (stringp (car defun-body)))
 	  (values (cdr defun-body) (list (car defun-body)))
 	(values defun-body nil))
-    `(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var)
+    `(defun ,name (,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var ,extent-var)
        , at docstring
        (declare (,(if all-p 'ignorable 'ignore)
 		    ,@(unless form-p (list form-var))
 		  ,@(unless funobj-p (list funobj-var))
 		  ,@(unless env-p (list env-var))
 		  ,@(unless top-level-p-p (list top-level-p-var))
-		  ,@(unless result-mode-p (list result-mode-var))))
+		  ,@(unless result-mode-p (list result-mode-var))
+		  ,@(unless extent-p (list extent-var))))
        (macrolet ((default-compiler-values-producer () '',name)
 		  ,@(when all-p
 		      `((,all-var (v) (ecase v (:form ',form-var) (:funobj ',funobj-var)
 					     (:env ',env-var) (:top-level-p ',top-level-p-var)
-					     (:result-mode ',result-mode-var))))))
+					     (:result-mode ',result-mode-var)
+					     (:extent ',extent-var))))))
 	 , at body))))
 
 (defmacro compiler-call (compiler-name &rest all-keys
@@ -186,6 +189,7 @@
 			      ((:form form-var) nil form-p)
 			      ((:funobj funobj-var) nil funobj-p)
 			      ((:env env-var) nil env-p)
+			      ((:extent extent-var) nil extent-p)
 			      ((:top-level-p top-level-p-var) nil top-level-p-p)
 			      ((:result-mode result-mode-var) :ignore result-mode-p))
   (assert (not (and defaults forward)) ()
@@ -208,7 +212,8 @@
 		   ,(if funobj-p funobj-var `(,defaults :funobj))
 		   inner-env
 		   ,(when top-level-p-p top-level-p-var) ; default to nil, no forwarding.
-		   ,(if result-mode-p result-mode-var `(,defaults :result-mode)))))
+		   ,(if result-mode-p result-mode-var `(,defaults :result-mode))
+		   ,(if extent-p extent-var `(,defaults :extent)))))
    (forward
     `(let* ((outer-env ,(if env-p env-var `(,forward :env)))
 	    (inner-env ,(if (not with-stack-used)
@@ -222,15 +227,17 @@
 		,(if funobj-p funobj-var `(,forward :funobj))
 		inner-env
 		,(if top-level-p-p top-level-p-var `(,forward :top-level-p))
-		,(if result-mode-p result-mode-var `(,forward :result-mode)))))
+		,(if result-mode-p result-mode-var `(,forward :result-mode))
+		,(if extent-p extent-var `(,forward :extent)))))
    ((not with-stack-used)
-    `(funcall ,compiler-name ,form-var ,funobj-var ,env-var ,top-level-p-var ,result-mode-var))
+    `(funcall ,compiler-name ,form-var ,funobj-var ,env-var
+	      ,top-level-p-var ,result-mode-var ,extent-var))
    (t (assert env-p () ":env is required when with-stack-used is given.")
       `(funcall ,compiler-name ,form-var ,funobj-var
 		(make-instance 'with-things-on-stack-env
 		  :uplink ,env-var :stack-used ,with-stack-used
 		  :funobj (movitz-environment-funobj ,env-var))
-		,top-level-p-var ,result-mode-var))))
+		,top-level-p-var ,result-mode-var ,extent-var))))
 
 (defmacro define-special-operator (name formals &body body)
   (let* ((movitz-name (intern (symbol-name (translate-program name :cl :muerte.cl))



From ffjeld at common-lisp.net  Sat Aug 20 20:30:15 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:30:15 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <20050820203015.B5B7A88551@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:30:14 2005
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.22 movitz/compiler-types.lisp:1.23
--- movitz/compiler-types.lisp:1.22	Mon Jan  3 12:52:33 2005
+++ movitz/compiler-types.lisp	Sat Aug 20 22:30:14 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 2003-2004, 
+;;;;    Copyright (C) 2001, 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.22 2005/01/03 11:52:33 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.23 2005/08/20 20:30:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -153,7 +153,7 @@
 			(<= max (+ (car sub-range) epsilon))))
 		(d (and min (cdr sub-range) ; subtrahend starts above sub-range?
 			(<= (+ (cdr sub-range) epsilon) min))))
-	    ;; (warn "abcd: ~S ~S ~S ~S" a b c d)
+	    #+ignore (warn "abcd: ~S ~S ~S ~S" a b c d)
 	    (cond
 	     ((and a b)
 	      ;; sub-range is eclipsed by the subtrahend.
@@ -173,8 +173,8 @@
 		(numscope-add-range new-numscope (+ max epsilon) (cdr sub-range) epsilon)))
 	     ((and (not d) b)		; (warn "right prune ~D with [~D-~D]" sub-range min max)
 	      (setf new-numscope
-		(numscope-add-range new-numscope (car sub-range) min epsilon)))
-	     (t (error "I am confused!")))))
+		(numscope-add-range new-numscope (car sub-range) (- min epsilon) epsilon)))
+	     (t (break "I am confused!")))))
 	new-numscope))))
 
 (defun numscope-complement (numscope &optional (epsilon 1))
@@ -277,34 +277,35 @@
 	      :initial-value (code first-type)))))
 
 (defun encoded-type-decode (code integer-range members include complement)
-  (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
-	(= mask (logand mask code)))
-      (not complement)
-    (let ((sub-specs include))
-      (loop for x in *tb-bitmap* as bit upfrom 0
-	  do (when (logbitp bit code)
-	       (push x sub-specs)))
-      (when (not (null members))
-	(push (cons 'member members) sub-specs))
-      (when (numscope-allp integer-range)
-	(pushnew 'integer sub-specs))
-      (when (and (not (member 'integer sub-specs))
-		 integer-range)
-	(dolist (sub-range integer-range)
-	  (push (list 'integer
-		      (or (car sub-range) '*)
-		      (or (cdr sub-range) '*))
-		sub-specs)))
-      (cond
-       ((null sub-specs)
-	(if complement t nil))
-       ((not (cdr sub-specs))
-	(if (not complement)
-	    (car sub-specs)
-	  (list 'not (car sub-specs))))
-       (t (if (not complement)
-	      (cons 'or sub-specs)
-	    (list 'not (cons 'or sub-specs))))))))
+  (cond
+   ((let ((mask (1- (ash 1 (position :tail *tb-bitmap*)))))
+      (= mask (logand mask code)))
+    (not complement))
+   (t (let ((sub-specs include))
+	(loop for x in *tb-bitmap* as bit upfrom 0
+	    do (when (logbitp bit code)
+		 (push x sub-specs)))
+	(when (not (null members))
+	  (push (cons 'member members) sub-specs))
+	(when (numscope-allp integer-range)
+	  (pushnew 'integer sub-specs))
+	(when (and (not (member 'integer sub-specs))
+		   integer-range)
+	  (dolist (sub-range integer-range)
+	    (push (list 'integer
+			(or (car sub-range) '*)
+			(or (cdr sub-range) '*))
+		  sub-specs)))
+	(cond
+	 ((null sub-specs)
+	  (if complement t nil))
+	 ((not (cdr sub-specs))
+	  (if (not complement)
+	      (car sub-specs)
+	    (list 'not (car sub-specs))))
+	 (t (if (not complement)
+		(cons 'or sub-specs)
+	      (list 'not (cons 'or sub-specs)))))))))
 		  
 (defun type-values (codes &key integer-range members include complement)
   ;; Members: A list of objects explicitly included in type.
@@ -312,6 +313,8 @@
   (check-type include list)
   (check-type members list)
   (check-type integer-range list)
+  (when (eq 'and (car include))
+    (break "foo"))
   (let ((new-intscope integer-range)
 	(new-members ()))
     (dolist (member members)		; move integer members into integer-range
@@ -392,6 +395,19 @@
 			   (not (encoded-typep t nil x code0 integer-range0 members0 include0 nil)))
 			 members1)
 	      nil nil))
+     ((and (or integer-range0 integer-range1)
+	   (encoded-emptyp code0 nil members0 nil complement0)
+	   (encoded-emptyp code1 nil members1 nil complement1)
+	   (flet ((integer-super-p (x)
+		    (member x '(rational real number t))))
+	     (and (every #'integer-super-p include0)
+		  (every #'integer-super-p include1))))
+      (type-values () :integer-range (numscope-intersection integer-range0
+							    integer-range1)))
+     ((and (= code0 code1) (equal integer-range0 integer-range1)
+	   (equal members0 members1) (equal include0 include1)
+	   (eq complement0 complement1))
+      (values code0 integer-range0 members0 include0 complement0))
      ((and include0 (null include1))
       ;; (and (or a b c) d) => (or (and a d) (and b d) (and c d))
       (values (logand code0 code1)
@@ -413,19 +429,19 @@
 		      include1)
 	      nil))
      (t ;; (warn "and with two includes: ~S ~S" include0 include1)
-	(type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0
-							     include0 complement0)
-				       ,(encoded-type-decode code1 integer-range1 members1
-							     include1 complement1))))))
+	(type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0
+							      include0 complement0)
+					,(encoded-type-decode code1 integer-range1 members1
+							      include1 complement1)))))))
    ((and complement0 complement1)
     (multiple-value-bind (code integer-range members include complement)
 	(encoded-types-or code0 integer-range0 members0 include0 (not complement0)
 			  code1 integer-range1 members1 include1 (not complement1))
       (values code integer-range members include (not complement))))
-   (t (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0
-							   include0 complement0)
-				     ,(encoded-type-decode code1 integer-range1 members1
-							   include1 complement1))))))
+   (t (type-values () :include `((and ,(encoded-type-decode code0 integer-range0 members0
+							    include0 complement0)
+				      ,(encoded-type-decode code1 integer-range1 members1
+							    include1 complement1)))))))
 
 (defun encoded-types-or (code0 integer-range0 members0 include0 complement0
 			 code1 integer-range1 members1 include1 complement1)
@@ -659,7 +675,8 @@
   (cond
    ((or complement include (not (= 0 code)))
     nil)
-   ((= 1 (length members))
+   ((and (= 1 (length members))
+	 (= 0 code) (null intscope) (null include) (not complement))
     members)
    ((and (= 1 (length intscope))
 	 (caar intscope)
@@ -680,7 +697,7 @@
   "Return the integer type that can result from adding a member of type0 to a member of type1."
   ;; (declare (ignore members0 members1))
   (cond
-   ((or include0 include1 members0 members1)
+   ((or include0 include1 members0 members1 (/= 0 code0) (/= 0 code1))
     ;; We can't know..
     'number)
    ((or complement0 complement1)



From ffjeld at common-lisp.net  Sat Aug 20 20:30:46 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:30:46 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050820203046.E04558854E@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:30:44 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.149 movitz/compiler.lisp:1.150
--- movitz/compiler.lisp:1.149	Mon Aug 15 23:44:23 2005
+++ movitz/compiler.lisp	Sat Aug 20 22:30:40 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.149 2005/08/15 21:44:23 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.150 2005/08/20 20:30:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -473,7 +473,7 @@
 		 (assert (or (typep type 'binding)
 			     (eql 1 (type-specifier-num-values type))) ()
 		   "store-lexical with multiple-valued type: ~S for ~S" type binding)
-		 ;; (warn "store ~S type ~S, thunk ~S" binding type thunk)
+		 #+ignore (warn "store ~S type ~S, thunk ~S" binding type thunk)
 		 (let ((analysis (or (gethash binding binding-usage)
 				     (setf (gethash binding binding-usage)
 				       (make-type-analysis-with-declaration binding)))))
@@ -492,14 +492,14 @@
 			    (values-list (type-analysis-encoded-type analysis))
 			    (type-specifier-encode type))))))))
 	       (analyze-code (code)
+		 #+ignore (print-code 'analyze code)
 		 (dolist (instruction code)
 		   (when (listp instruction)
 		     (multiple-value-bind (store-binding store-type thunk thunk-args)
 			 (find-written-binding-and-type instruction)
 		       (when store-binding
-			 #+ignore
-			 (warn "store: ~S binding ~S type ~S thunk ~S"
-			       instruction store-binding store-type thunk)
+			 #+ignore (warn "store: ~S binding ~S type ~S thunk ~S"
+					instruction store-binding store-type thunk)
 			 (analyze-store store-binding store-type thunk thunk-args)))
 		     (analyze-code (instruction-sub-program instruction)))))
 	       (analyze-funobj (funobj)
@@ -617,6 +617,8 @@
 		 ;; Binding is local to this funobj
 		 (typecase binding
 		   (forwarding-binding
+		    (process-binding funobj (forwarding-binding-target binding) usages)
+		    #+ignore
 		    (setf (forwarding-binding-target binding)
 		      (process-binding funobj (forwarding-binding-target binding) usages)))
 		   (function-binding
@@ -2377,7 +2379,14 @@
     :accessor binding-env)
    (declarations
     :initarg :declarations
-    :accessor binding-declarations)))
+    :accessor binding-declarations)
+   (extent-env
+    :accessor binding-extent-env
+    :initform nil)))
+
+(defmethod (setf binding-env) :after (env (binding binding))
+  (unless (binding-extent-env binding)
+    (setf (binding-extent-env binding) env)))
 
 (defmethod print-object ((object binding) stream)
   (print-unreadable-object (object stream :type t :identity t)
@@ -2387,12 +2396,13 @@
 		   (binding-name object))
 	      (when (and (binding-target object)
 			 (not (eq object (binding-target object))))
-		(binding-name (binding-target object)))
+		(binding-name (forwarding-binding-target object)))
 	      (when (and #+ignore (slot-exists-p object 'store-type)
 			 #+ignore (slot-boundp object 'store-type)
 			 (binding-store-type object))
-		(apply #'encoded-type-decode
-		       (binding-store-type object)))))))
+		(or (apply #'encoded-type-decode
+			   (binding-store-type object))
+		    'empty))))))
 
 (defclass constant-object-binding (binding)
   ((object
@@ -2653,11 +2663,11 @@
 	      '((:int 100))
 	      :test #'equalp)))
   
-(defun sub-environment-p (env1 env2)
-  (cond
-   ((eq env1 env2) t)
-   ((null env1) nil)
-   (t (sub-environment-p (movitz-environment-uplink env1) env2))))
+#+ignore (defun sub-environment-p (env1 env2)
+	   (cond
+	    ((eq env1 env2) t)
+	    ((null env1) nil)
+	    (t (sub-environment-p (movitz-environment-uplink env1) env2))))
 
 (defun find-code-constants-and-jumpers (code &key include-programs)
   "Return code's constants (a plist of constants and their usage-counts) and jumper-sets."
@@ -3006,7 +3016,7 @@
    sub-environments found in CODE. A frame-map which is an assoc from
    bindings to stack-frame locations."
   ;; Then assign them to locations in the stack-frame.
-  ;; (warn "assigning code:~%~{~&    ~A~}" code)
+  #+ignore (warn "assigning code:~%~{~&    ~A~}" code)
   (check-type function-env function-env)
   (assert (= initial-stack-frame-position
 	     (1+ (frame-map-size frame-map))))
@@ -3022,10 +3032,42 @@
 	     (error "SEFEW: ~S" function-env))
 	    ;; The floor of this env is the roof of its extent-uplink.
 	    (t (assign-env-bindings (movitz-environment-extent-uplink env)))))
+	 ;; PROMOTE FORW-BINDINGS TO UPPER ENV!!
 	 (assign-env-bindings (env)
 	   (or (getf env-roof-map env nil)
 	       (let* ((stack-frame-position (env-floor env))
 		      (bindings-to-locate
+		       (loop for binding being the hash-keys of var-counts
+			   when (eq env (binding-extent-env binding))
+			   unless (let ((variable (binding-name binding)))
+				    (cond
+				     ((not (typep binding 'lexical-binding)))
+				     ((typep binding 'lambda-binding))
+				     ((typep binding 'constant-object-binding))
+				     ((typep binding 'forwarding-binding)
+				      ;; Immediately "assign" to target.
+				      (when (plusp (or (car (gethash binding var-counts)) 0))
+					(setf (new-binding-location binding frame-map)
+					  (forwarding-binding-target binding)))
+				      t)
+				     ((typep binding 'borrowed-binding))
+				     ((typep binding 'funobj-binding))
+				     ((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 ,(function-argument-argnum binding)))))
+				     ((unless (or (movitz-env-get variable 'ignore nil
+								  (binding-env binding) nil)
+						  (movitz-env-get variable 'ignorable nil
+								  (binding-env binding) nil)
+						  (typep binding 'hidden-rest-function-argument)
+						  (third (gethash binding var-counts)))
+					(warn "Unused variable: ~S"
+					      (binding-name binding))))
+				     ((not (plusp (or (car (gethash binding var-counts)) 0))))))
+			   collect binding)
+		       #+ignore
 		       (loop for (variable . binding) in (movitz-environment-bindings env)
 			   unless (cond
 				   ((not (typep binding 'lexical-binding)))
@@ -3087,6 +3129,22 @@
 							     (cdr init-pc))
 						15)
 					    count)))))))))
+		 #+ignore (labels ((dox (env upper)
+				     (if (or (not env)
+					     (not (sub-env-p env function-env)))
+					 0
+				       (let ((level (dox (funcall upper env) upper)))
+					 (format t "~%~v{ ~}~S" level t env)
+					 (+ level 4)))))
+			    (warn "At ~S binding ~S:~{ ~S~}: Extent: ~A~%Bind: ~A" 
+				  stack-frame-position
+				  env bindings-to-locate
+				  (with-output-to-string (*standard-output*)
+				    (dox env #'movitz-environment-extent-uplink))
+				  (with-output-to-string (*standard-output*)
+				    (when bindings-to-locate
+				      (dox (binding-env (first bindings-to-locate))
+					   #'movitz-environment-uplink)))))
 		 ;; First, make several passes while trying to locate bindings
 		 ;; into registers.
 		 (loop repeat 100 with try-again = t and did-assign = t
@@ -3181,6 +3239,8 @@
 			(setf (new-binding-location binding frame-map)
 			  `(:argument-stack ,(function-argument-argnum binding))))
 		       (located-binding
+			#+ignore (warn "Assigning ~S at ~S"
+				       binding stack-frame-position)
 			(setf (new-binding-location binding frame-map)
 			  (post-incf stack-frame-position))))))
 		 (setf (getf env-roof-map env)
@@ -3190,7 +3250,7 @@
 		   ;; do (warn "bind: ~S: ~S" binding (eq function-env (find-function-env env funobj)))
 	  when (sub-env-p env function-env)
 	  do (assign-env-bindings (binding-env binding)))
-      ;; (warn "Frame-map:~{ ~A~}"  frame-map)
+      #+ignore (warn "Frame-map:~{ ~A~}"  frame-map)
       frame-map)))
 
 
@@ -3269,7 +3329,7 @@
   "Resolve a binding in terms of forwarding."
   (etypecase binding
     (forwarding-binding
-     (forwarding-binding-target binding))
+     (binding-target (forwarding-binding-target binding)))
     (binding
      binding)))
 
@@ -3460,8 +3520,8 @@
 ;;;			    :untagged-fixnum-ecx))
 		    ((and binding-type
 			  (type-specifier-singleton decoded-type))
-		     (warn "Immloadlex: ~S"
-			   (type-specifier-singleton decoded-type))
+		     #+ignore (warn "Immloadlex: ~S"
+				    (type-specifier-singleton decoded-type))
 		     (make-immediate-move (movitz-immediate-value
 					   (car (type-specifier-singleton decoded-type)))
 					  :ecx))
@@ -3571,6 +3631,7 @@
 	(located-binding
 	 (let ((binding-type (binding-store-type binding))
 	       (binding-location (new-binding-location binding frame-map)))
+	   #+ignore (warn "~S type: ~S" binding binding-type)
 	   (cond
 	    ((and (binding-lended-p binding)
 		  (not shared-reference-p))
@@ -5349,13 +5410,32 @@
 	  :result-mode :eax
 	  :forward form-info)))))
   
-(define-compiler compile-form-unprotected (&all all &form form &result-mode result-mode)
+(define-compiler compile-form-unprotected (&all downstream &form form &result-mode result-mode
+						&extent extent)
   "3.1.2.1 Form Evaluation. May not honor RESULT-MODE.
 That is, RESULT-MODE is taken to be a suggestion, not an imperative."
-  (typecase form
-    (symbol (compiler-call #'compile-symbol :forward all))
-    (cons   (compiler-call #'compile-cons :forward all))
-    (t      (compiler-call #'compile-self-evaluating :forward all))))
+  (compiler-values-bind (&all upstream)
+      (typecase form
+	(symbol (compiler-call #'compile-symbol :forward downstream))
+	(cons   (compiler-call #'compile-cons :forward downstream))
+	(t      (compiler-call #'compile-self-evaluating :forward downstream)))
+    (when (typep (upstream :final-form) 'lexical-binding)
+      (labels ((fix-extent (binding)
+		 (cond
+		  ((sub-env-p extent (binding-extent-env binding))
+		   #+ignore (warn "Binding ~S OK in ~S wrt. ~S."
+				  binding
+				  (binding-extent-env binding)
+				  (downstream :env)))
+		  (t #+ignore (break "Binding ~S escapes from ~S to ~S"
+				     binding (binding-extent-env binding)
+				     extent)
+		      (setf (binding-extent-env binding) extent)))
+		 (when (typep binding 'forwarding-binding)
+		   (fix-extent (forwarding-binding-target binding)))))
+	(when extent
+	  (fix-extent (upstream :final-form)))))
+    (compiler-values (upstream))))
 
 (defun lambda-form-p (form)
   (and (listp form)
@@ -6092,17 +6172,20 @@
       (:jne ',push-values-loop)
       ,push-values-done)))
 
+(defun stack-add (x y)
+  (if (and (integerp x) (integerp y))
+      (+ x y)
+    t))
+
+(define-modify-macro stack-incf (&optional (delta 1)) stack-add)
+
 (defun stack-delta (inner-env outer-env)
   "Calculate the amount of stack-space used (in 32-bit stack slots) at the time
 of <inner-env> since <outer-env>,
 the number of intervening dynamic-slots (special bindings, unwind-protects, and catch-tags),
 and a list of any intervening unwind-protect environment-slots."
   (labels 
-      ((stack-distance-add (x y)
-	 (if (and (integerp x) (integerp y))
-	     (+ x y)
-	   t))
-       (find-stack-delta (env stack-distance num-dynamic-slots unwind-protects)
+      ((find-stack-delta (env stack-distance num-dynamic-slots unwind-protects)
 	 #+ignore (warn "find-stack-delta: ~S dist ~S, slots ~S" env
 			(stack-used env) (num-dynamic-slots env))
 	 (cond
@@ -6116,8 +6199,8 @@
 	  ((null env)
 	   (values nil 0 nil))
 	  (t (find-stack-delta (movitz-environment-uplink env)
-			       (stack-distance-add stack-distance (stack-used env))
-			       (stack-distance-add num-dynamic-slots (num-dynamic-slots env))
+			       (stack-add stack-distance (stack-used env))
+			       (stack-add num-dynamic-slots (num-dynamic-slots env))
 			       (if (typep env 'unwind-protect-env)
 				   (cons env unwind-protects)
 				 unwind-protects))))))
@@ -6334,6 +6417,8 @@
        ((not (typep init-with-register 'binding))
 	(assert init-with-type)
 	(values binding init-with-type)	)
+       ((and init-with-type (not (bindingp init-with-type)))
+	(values binding init-with-type))
        (t (values binding t
 		  (lambda (x) x)
 		  (list init-with-register)))))
@@ -6701,12 +6786,18 @@
 	(warn "Add for lend0: ~S" destination))
       (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
 	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
-;;;	(warn "add: ~A" instruction)
+	#+ignore
+	(warn "add: ~A for ~A" instruction result-type)
 	#+ignore
 	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
 	      destination result-type
 	      term0 loc0
 	      term1 loc1)
+	#+ignore
+	(when (eql loc0 loc1)
+	  (warn "add for:~%~A/~A in ~S~&~A/~A in ~S."
+		term0 loc0 (binding-extent-env (binding-target term0))
+		term1 loc1 (binding-extent-env (binding-target term1))))
 	(cond
 	 ((type-specifier-singleton result-type)
 	  ;; (break "constant add: ~S" instruction)
@@ -6744,7 +6835,7 @@
 	 ((and (movitz-subtypep type0 'fixnum)
 	       (movitz-subtypep type1 'fixnum)
 	       (movitz-subtypep result-type 'fixnum))
-	  ;; (warn "ADDX: ~S" instruction)
+	  #+ignore (warn "ADDX: ~S" instruction)
 	  (cond
 	   ((and (type-specifier-singleton type0)
 		 (eq loc1 destination-location))
@@ -6752,10 +6843,14 @@
 	     ((member destination-location '(:eax :ebx :ecx :edx))
 	      `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
 		       ,destination)))
-	     (t (assert (integerp loc1))
-		(break "check that this is correct..")
-		`((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
-			 (:ebp ,(stack-frame-offset loc1)))))))
+	     ((integerp loc1)
+	      ;; (break "check that this is correct..")
+	      `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+		       (:ebp ,(stack-frame-offset loc1)))))
+	     ((eq :argument-stack (operator loc1))
+	      `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+		       (:ebp ,(argument-stack-offset (binding-target term1))))))
+	     (t (error "Don't know how to add this for loc1 ~S" loc1))))
 	   ((and (type-specifier-singleton type0)
 		 (eq term1 destination)
 		 (integerp destination-location))
@@ -6768,41 +6863,44 @@
 	    (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
 			     ,loc1))
 		    (make-store-lexical destination loc1 nil funobj frame-map)))
-	   (t #+ignore (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A"
-			     destination-location
-			     destination
-			     loc0 term0
-			     loc1 term1
-			     (type-specifier-singleton type0)
-			     (eq loc1 destination))
+	   ((and (integerp loc0) (integerp loc1)
+		 (member destination-location '(:eax :ebx :ecx :edx)))
+	    (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+		      (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location))))
+	   (t (warn "ADD: ~A/~S = ~A/~S + ~A/~S"
+		    destination-location
+		    destination
+		    loc0 term0
+		    loc1 term1)
+	      #+ignore (warn "map: ~A" frame-map)
 ;;; 	    (warn "ADDI: ~S" instruction)
-	    (append (cond
-		     ((type-specifier-singleton type0)
-		      (append (make-load-lexical term1 :eax funobj nil frame-map)
-			      (make-load-constant (car (type-specifier-singleton type0))
-						  :ebx funobj frame-map)))
-		     ((type-specifier-singleton type1)
-		      (append (make-load-lexical term0 :eax funobj nil frame-map)
-			      (make-load-constant (car (type-specifier-singleton type1))
-						  :ebx funobj frame-map)))
-		     ((and (eq :eax loc0) (eq :ebx loc1))
-		      nil)
-		     ((and (eq :ebx loc0) (eq :eax loc1))
-		      nil)		; terms order isn't important
-		     ((eq :eax loc1)
-		      (append
-		       (make-load-lexical term0 :ebx funobj nil frame-map)))
-		     (t (append
-			 (make-load-lexical term0 :eax funobj nil frame-map)
-			 (make-load-lexical term1 :ebx funobj nil frame-map))))
-		    `((:movl (:edi ,(global-constant-offset '+)) :esi))
-		    (make-compiled-funcall-by-esi 2)
-		    (etypecase destination
-		      (symbol
-		       (unless (eq destination :eax)
-			 `((:movl :eax ,destination))))
-		      (binding
-		       (make-store-lexical destination :eax nil funobj frame-map)))))))
+	      (append (cond
+		       ((type-specifier-singleton type0)
+			(append (make-load-lexical term1 :eax funobj nil frame-map)
+				(make-load-constant (car (type-specifier-singleton type0))
+						    :ebx funobj frame-map)))
+		       ((type-specifier-singleton type1)
+			(append (make-load-lexical term0 :eax funobj nil frame-map)
+				(make-load-constant (car (type-specifier-singleton type1))
+						    :ebx funobj frame-map)))
+		       ((and (eq :eax loc0) (eq :ebx loc1))
+			nil)
+		       ((and (eq :ebx loc0) (eq :eax loc1))
+			nil)		; terms order isn't important
+		       ((eq :eax loc1)
+			(append
+			 (make-load-lexical term0 :ebx funobj nil frame-map)))
+		       (t (append
+			   (make-load-lexical term0 :eax funobj nil frame-map)
+			   (make-load-lexical term1 :ebx funobj nil frame-map))))
+		      `((:movl (:edi ,(global-constant-offset '+)) :esi))
+		      (make-compiled-funcall-by-esi 2)
+		      (etypecase destination
+			(symbol
+			 (unless (eq destination :eax)
+			   `((:movl :eax ,destination))))
+			(binding
+			 (make-store-lexical destination :eax nil funobj frame-map)))))))
 	 (t (append (cond
 		     ((type-specifier-singleton type0)
 		      (append (make-load-lexical term1 :eax funobj nil frame-map)
@@ -6848,12 +6946,13 @@
 	(rotatef x y)
 	(rotatef x-type y-type)
 	(rotatef x-singleton y-singleton))
-      (let (;; (x-loc (new-binding-location (binding-target x) frame-map :default nil))
+      (let (#+ignore (x-loc (new-binding-location (binding-target x) frame-map :default nil))
 	    (y-loc (new-binding-location (binding-target y) frame-map :default nil)))
 	#+ignore
-	(warn "eql ~S/~S ~S/~S"
-	      x x-loc
-	      y y-loc)
+	(warn "eql ~S/~S xx~Xxx ~S/~S: ~S"
+	      x x-loc (binding-target y)
+	      y y-loc
+	      instruction)
 	(flet ((make-branch ()
 		 (ecase (operator return-mode)
 		   (:boolean-branch-on-false



From ffjeld at common-lisp.net  Sat Aug 20 20:31:01 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:31:01 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/environment.lisp 
Message-ID: <20050820203101.5AD2A8854E@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:30:57 2005
Author: ffjeld

Index: movitz/environment.lisp
diff -u movitz/environment.lisp:1.13 movitz/environment.lisp:1.14
--- movitz/environment.lisp:1.13	Sun Aug 14 14:13:07 2005
+++ movitz/environment.lisp	Sat Aug 20 22:30:54 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov  3 11:40:15 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: environment.lisp,v 1.13 2005/08/14 12:13:07 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.14 2005/08/20 20:30:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -225,7 +225,7 @@
       (find-function-env (movitz-environment-uplink env) funobj)))
 
 (defun sub-env-p (sub-env env)
-  "Check if sub-env is a sub-environment of env."
+  "Check if sub-env is a sub-environment (or eq) of env."
   (cond
    ((not sub-env)
     nil)



From ffjeld at common-lisp.net  Sat Aug 20 20:31:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:31:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050820203106.5097588551@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:31:05 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.101 movitz/image.lisp:1.102
--- movitz/image.lisp:1.101	Sun May 22 00:38:39 2005
+++ movitz/image.lisp	Sat Aug 20 22:31:05 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.101 2005/05/21 22:38:39 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.102 2005/08/20 20:31:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -957,60 +957,61 @@
 	      (format t "~&;; Image file size: ~D octets.~%" image-end)
 	      ;; Write simple stage1 bootblock into sector 0..
 	      (format t "~&;; Dump count: ~D." (incf (dump-count *image*)))
-	      (set-file-position stream 0)
 	      (flet ((global-slot-position (slot-name)
 		       (+ 512
 			  (image-nil-word *image*)
 			  (image-ds-segment-base *image*)
 			  (global-constant-offset slot-name)
 			  (- load-address))))
-		(let ((bootblock (make-bootblock kernel-size
-						 load-address
-						 init-code-address)))
-		  (setf (image-bootblock *image*) bootblock)
-		  (write-sequence bootblock stream)
-		  (let* ((stack-vector-address (+ (image-nil-word *image*)
-						  (global-constant-offset 'stack-vector)
-						  (image-ds-segment-base *image*)))
-			 (stack-vector-position (- (+ stack-vector-address 512)
-						   load-address)))
-		    (declare (ignore stack-vector-position))
-		    #+ignore(warn "stack-v-pos: ~S => ~S" 
-				  stack-vector-position
-				  stack-vector-word)
-		    (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector)
-		    (write-binary 'word stream stack-vector-word)
-		    (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom)
-		    (write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion
-						  (- stack-vector-word (tag :other))))
-		    (set-file-position stream (global-slot-position 'stack-top) 'stack-top)
-		    (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other))
-						  (* 4 (movitz-vector-num-elements stack-vector)))))
-		  (if (not multiboot-p)
-		      (format t "~&;; No multiboot header.")
-		    ;; Update multiboot header, symbolic and in the file..
-		    (let* ((mb (image-multiboot-header *image*))
-			   (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))
-		      (when (> (+ mb-file-position (sizeof mb)) 8192)
-			(warn "Multiboot header at position ~D is above the 8KB mark, ~
+		(with-simple-restart (continue "Don't write a floppy bootloader.")
+		  (let ((bootblock (make-bootblock kernel-size
+						   load-address
+						   init-code-address)))
+		    (setf (image-bootblock *image*) bootblock)
+		    (set-file-position stream 0)
+		    (write-sequence bootblock stream)))
+		(let* ((stack-vector-address (+ (image-nil-word *image*)
+						(global-constant-offset 'stack-vector)
+						(image-ds-segment-base *image*)))
+		       (stack-vector-position (- (+ stack-vector-address 512)
+						 load-address)))
+		  (declare (ignore stack-vector-position))
+		  #+ignore(warn "stack-v-pos: ~S => ~S" 
+				stack-vector-position
+				stack-vector-word)
+		  (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector)
+		  (write-binary 'word stream stack-vector-word)
+		  (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom)
+		  (write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion
+						(- stack-vector-word (tag :other))))
+		  (set-file-position stream (global-slot-position 'stack-top) 'stack-top)
+		  (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other))
+						(* 4 (movitz-vector-num-elements stack-vector)))))
+		(if (not multiboot-p)
+		    (format t "~&;; No multiboot header.")
+		  ;; Update multiboot header, symbolic and in the file..
+		  (let* ((mb (image-multiboot-header *image*))
+			 (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))
+		    (when (> (+ mb-file-position (sizeof mb)) 8192)
+		      (warn "Multiboot header at position ~D is above the 8KB mark, ~
 this image will not be Multiboot compatible."
-			      (+ mb-file-position (sizeof mb))))
-		      (set-file-position stream mb-file-position 'multiboot-header)
-		      ;; (format t "~&;; Multiboot load-address: #x~X." load-address)
-		      (setf (header-address mb) mb-address
-			    (load-address mb) load-address
-			    (load-end-address mb) (+ load-address kernel-size)
-			    (bss-end-address mb) (+ load-address kernel-size)
-			    (entry-address mb) init-code-address)
-		      (write-binary-record mb stream)))))))))))
+			    (+ mb-file-position (sizeof mb))))
+		    (set-file-position stream mb-file-position 'multiboot-header)
+		    ;; (format t "~&;; Multiboot load-address: #x~X." load-address)
+		    (setf (header-address mb) mb-address
+			  (load-address mb) load-address
+			  (load-end-address mb) (+ load-address kernel-size)
+			  (bss-end-address mb) (+ load-address kernel-size)
+			  (entry-address mb) init-code-address)
+		    (write-binary-record mb stream))))))))))
   (values))
 
 (defun dump-image-core (image stream)



From ffjeld at common-lisp.net  Sat Aug 20 20:31:16 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:31:16 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <20050820203116.8E4948854E@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:31:15 2005
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.46 movitz/special-operators-cl.lisp:1.47
--- movitz/special-operators-cl.lisp:1.46	Sun Feb 27 03:28:33 2005
+++ movitz/special-operators-cl.lisp	Sat Aug 20 22:31:15 2005
@@ -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.46 2005/02/27 02:28:33 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.47 2005/08/20 20:31:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -61,10 +61,12 @@
 	       (local-env (make-local-movitz-environment env funobj
 							 :type 'let-env
 							 :declarations declarations))
-	       (init-env (make-instance 'with-things-on-stack-env
+	       (init-env #+ignore env
+			 (make-instance 'movitz-environment
 			   :uplink env
 			   :funobj funobj
 			   :extent-uplink local-env))
+	       (stack-used 0)
 	       (binding-var-codes
 		(loop for (var init-form) in let-vars
 		    if (movitz-env-get var 'special nil local-env)
@@ -75,21 +77,21 @@
 			    (append (if (= 0 (num-specials local-env)) ; first special? .. binding tail
 					`((:locally (:pushl (:edi (:edi-offset dynamic-env)))))
 				      `((:pushl :esp)))
-				    (prog1 nil (incf (stack-used init-env)))
 				    (compiler-call #'compile-form ; binding value
+				      :with-stack-used (incf stack-used)
 				      :env init-env
 				      :defaults all
 				      :form init-form
 				      :modify-accumulate let-modifies
 				      :result-mode :push)
 				    `((:pushl :edi)) ; scratch
-				    (prog1 nil (incf (stack-used init-env) 2))
 				    (compiler-call #'compile-self-evaluating ; binding name
+				      :with-stack-used (incf stack-used 2)
 				      :env init-env
 				      :defaults all
 				      :form var
 				      :result-mode :push)
-				    (prog1 nil (incf (stack-used init-env))))
+				    (prog1 nil (incf stack-used)))
 			    nil t)
 		    and do (movitz-env-add-binding local-env (make-instance 'dynamic-binding
 							       :name var))
@@ -103,10 +105,11 @@
 						  &final-form final-form)
 			       (compiler-call #'compile-form-to-register
 				 :env init-env
+				 :extent local-env
 				 :defaults all
 				 :form init-form
 				 :modify-accumulate let-modifies)
-;;;			     ;; (warn "prod: ~S, type: ~S" prod type)
+;;;			     (warn "var ~S, type: ~S" var type)
 ;;;			     (warn "var ~S init: ~S.." var init-form)
 ;;;			     (print-code 'init
 ;;;					 (compiler-call #'compile-form
@@ -163,6 +166,7 @@
 		    (check-type dest-binding lexical-binding)
 		    (compiler-call #'compile-form
 		      :forward all
+		      :extent local-env
 		      :result-mode dest-binding
 		      :form (second (first binding-var-codes)))))
 		 #+ignore
@@ -178,156 +182,178 @@
 		    (break "Yuhu: tmp ~S" tmp-binding)
 		    
 		    ))
-		 (t (let ((code (append
-				 (loop
-				     for ((var init-form init-code functional-p type init-register
-					       final-form)
-					  . rest-codes)
-				     on binding-var-codes
-				     as binding = (movitz-binding var local-env nil)
-						  ;;  for bb in binding-var-codes
-						  ;; do (warn "bind: ~S" bb)
-				     do (assert type)
-					(assert (not (binding-lended-p binding)))
-				     appending
-				       (cond
-					((and (typep binding 'located-binding)
-					      (not (binding-lended-p binding))
-;;;					      (= 1 (length init-code))
-;;;					      (eq :load-lexical (first (first init-code)))
-					      (typep final-form 'lexical-binding)
-					      (let ((target-binding final-form))
-						(and (typep target-binding 'lexical-binding)
-						     (eq (binding-funobj binding)
-							 (binding-funobj target-binding))
-						     (or (and (not (code-uses-binding-p body-code
-											binding
-											:load nil
-											:store t))
-							      (not (code-uses-binding-p body-code
-											target-binding
-											:load nil
-											:store t)))
-							 ;; This is the best we can do now to determine
-							 ;; if target-binding is ever used again.
-							 (and (eq result-mode :function)
-							      (not (code-uses-binding-p body-code
+		 (t (let ((code
+			   (append
+			    (loop
+				for ((var init-form init-code functional-p type init-register
+					  final-form)
+				     . rest-codes)
+				on binding-var-codes
+				as binding = (movitz-binding var local-env nil)
+					     ;;  for bb in binding-var-codes
+					     ;; do (warn "bind: ~S" bb)
+				do (assert type)
+				   (assert (not (binding-lended-p binding)))
+				appending
+				  (cond
+				   ((and (typep binding 'located-binding)
+					 (not (binding-lended-p binding))
+					 (typep final-form 'lexical-binding)
+					 (let ((target-binding final-form))
+					   (and (typep target-binding 'lexical-binding)
+						(eq (binding-funobj binding)
+						    (binding-funobj target-binding))
+						#+ignore
+						(sub-env-p (binding-env binding)
+							   (binding-env target-binding))
+						(or (and (not (code-uses-binding-p body-code
+										   binding
+										   :load nil
+										   :store t))
+							 (not (code-uses-binding-p body-code
+										   target-binding
+										   :load nil
+										   :store t)))
+						    (and (= 1 (length body-code))
+							 (eq :add (caar body-code)))
+						    (and (>= 1 (length body-code))
+							 (warn "short let body: ~S" body-code))
+						    ;; This is the best we can do now to determine
+						    ;; if target-binding is ever used again.
+						    (and (eq result-mode :function)
+							 (not (code-uses-binding-p body-code
+										   target-binding
+										   :load t
+										   :store t))
+							 (notany (lambda (code)
+								   (code-uses-binding-p (third code)
 											target-binding
 											:load t
 											:store t))
-							      (notany (lambda (code)
-									(code-uses-binding-p (third code)
-											     target-binding
-											     :load t
-											     :store t))
-								      rest-codes))))))
-					 ;; replace read-only binding with the outer binding
-					 #+ignore (warn "replace ~S in ~S with outer ~S"
-							binding (binding-funobj binding)
-							(second (first init-code)))
-					 (compiler-values-bind (&code new-init-code &final-form target)
-					     (compiler-call #'compile-form-unprotected
-					       :form init-form
-					       :result-mode :ignore
-					       :env init-env
-					       :defaults all)
-					   (check-type target lexical-binding)
-					   (change-class binding 'forwarding-binding 
-							 :target-binding target)
-					   (append new-init-code
-						   `((:init-lexvar ,binding
-								   :init-with-register ,target
-								   :init-with-type ,target)))))
-					((and (typep binding 'located-binding)
-					      (type-specifier-singleton type)
-					      (not (code-uses-binding-p body-code binding
-									:load nil :store t)))
-					 ;; replace read-only lexical binding with
-					 ;; side-effect-free form
-					 #+ignore (warn "Constant binding: ~S => ~S => ~S"
-							(binding-name binding)
-							init-form
-							(car (type-specifier-singleton type)))
-					 (change-class binding 'constant-object-binding
-						       :object (car (type-specifier-singleton type)))
-					 (if functional-p
-					     nil ; only inject code if it's got side-effects.
-					   (compiler-call #'compile-form-unprotected
-					     :env init-env
-					     :defaults all
-					     :form init-form
-					     :result-mode :ignore
-					     :modify-accumulate let-modifies)))
-					((typep binding 'lexical-binding)
-					 (let ((init (type-specifier-singleton
-						      (type-specifier-primary type))))
-					   (cond
-					    ((and init (eq *movitz-nil* (car init)))
-					     (append (if functional-p
-							 nil
-						       (compiler-call #'compile-form-unprotected
-							 :env init-env
-							 :defaults all
-							 :form init-form
-							 :result-mode :ignore
-							 :modify-accumulate let-modifies))
-						     `((:init-lexvar ,binding
-								     :init-with-register :edi
-								     :init-with-type null))))
-					    ((and (typep final-form 'lexical-binding)
-						  (eq (binding-funobj final-form)
-						      funobj))
-					     (append (if functional-p
-							 nil
-						       (compiler-call #'compile-form-unprotected
-							 :env init-env
-							 :defaults all
-							 :form init-form
-							 :result-mode :ignore
-							 :modify-accumulate let-modifies))
-						     `((:init-lexvar ,binding
-								     :init-with-register ,final-form
-								     ;; :init-with-type ,final-form
-								     ))))
-					    ((typep final-form 'constant-object-binding)
-					     #+ignore
-					     (warn "type: ~S or ~S" final-form 
-						   (type-specifier-primary type))
-					     (append (if functional-p
-							 nil
-						       (compiler-call #'compile-form-unprotected
-							 :env init-env
-							 :defaults all
-							 :form init-form
-							 :result-mode :ignore
-							 :modify-accumulate let-modifies))
-						     `((:init-lexvar
-							,binding
-							:init-with-register ,final-form
-							:init-with-type ,(type-specifier-primary type)
-							))))
-					    (t ;; (warn "for ~S ~S ~S" binding init-register final-form)
-					       (append init-code
-						       `((:init-lexvar
-							  ,binding
-							  :init-with-register ,init-register
-							  :init-with-type ,(type-specifier-primary type))))))))
-					(t init-code)))
-				 (when (plusp (num-specials local-env))
-				   `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
-									     'dynamic-variable-install))))
-				     (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
-				 body-code
-				 (when (and (plusp (num-specials local-env))
-					    (not (eq :non-local-exit body-returns)))
-				   #+ignore
-				   (warn "let spec ret: ~S, want: ~S ~S"
-					 body-returns result-mode let-var-specs)
-				   `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx)
-				     (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
-									     'dynamic-variable-uninstall))))
-				     (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
-				     (:leal (:esp ,(* 16 (num-specials local-env))) :esp))))))
+								 rest-codes))))))
+				    ;; replace read-only binding with the outer binding
+				    (compiler-values-bind (&code new-init-code &final-form target
+							   &type type)
+					(compiler-call #'compile-form-unprotected
+					  :extent local-env
+					  :form init-form
+					  :result-mode :ignore
+					  :env init-env
+					  :defaults all)
+				      (check-type target lexical-binding)
+				      (change-class binding 'forwarding-binding 
+						    :target-binding target)
+				      (let ((btype (if (multiple-value-call #'encoded-allp
+							 (type-specifier-encode
+							  (type-specifier-primary type)))
+						       target
+						     (type-specifier-primary type))))
+					#+ignore (warn "forwarding ~S -[~S]> ~S"
+						       binding btype target)
+					(append new-init-code
+						`((:init-lexvar
+						   ,binding
+						   :init-with-register ,target
+						   :init-with-type ,btype))))))
+				   ((and (typep binding 'located-binding)
+					 (type-specifier-singleton type)
+					 (not (code-uses-binding-p body-code binding
+								   :load nil :store t)))
+				    ;; replace read-only lexical binding with
+				    ;; side-effect-free form
+				    #+ignore (warn "Constant binding: ~S => ~S => ~S"
+						   (binding-name binding)
+						   init-form
+						   (car (type-specifier-singleton type)))
+				    (change-class binding 'constant-object-binding
+						  :object (car (type-specifier-singleton type)))
+				    (if functional-p
+					nil ; only inject code if it's got side-effects.
+				      (compiler-call #'compile-form-unprotected
+					:extent local-env
+					:env init-env
+					:defaults all
+					:form init-form
+					:result-mode :ignore
+					:modify-accumulate let-modifies)))
+				   ((typep binding 'lexical-binding)
+				    (let ((init (type-specifier-singleton
+						 (type-specifier-primary type))))
+				      (cond
+				       ((and init (eq *movitz-nil* (car init)))
+					(append (if functional-p
+						    nil
+						  (compiler-call #'compile-form-unprotected
+						    :extent local-env
+						    :env init-env
+						    :defaults all
+						    :form init-form
+						    :result-mode :ignore
+						    :modify-accumulate let-modifies))
+						`((:init-lexvar ,binding
+								:init-with-register :edi
+								:init-with-type null))))
+				       ((and (typep final-form 'lexical-binding)
+					     (eq (binding-funobj final-form)
+						 funobj))
+					(compiler-values-bind (&code new-init-code
+							       &type new-type
+							       &final-form new-binding)
+					    (compiler-call #'compile-form-unprotected
+					      :extent local-env
+					      :env init-env
+					      :defaults all
+					      :form init-form
+					      :result-mode :ignore
+					      :modify-accumulate let-modifies)
+					  (append (if functional-p
+						      nil
+						    new-init-code)
+						  (let ((ptype (type-specifier-primary new-type)))
+						    `((:init-lexvar ,binding
+								    :init-with-register ,new-binding
+								    :init-with-type ,ptype
+								    ))))))
+				       ((typep final-form 'constant-object-binding)
+					#+ignore
+					(warn "type: ~S or ~S" final-form 
+					      (type-specifier-primary type))
+					(append (if functional-p
+						    nil
+						  (compiler-call #'compile-form-unprotected
+						    :extent local-env
+						    :env init-env
+						    :defaults all
+						    :form init-form
+						    :result-mode :ignore
+						    :modify-accumulate let-modifies))
+						`((:init-lexvar
+						   ,binding
+						   :init-with-register ,final-form
+						   :init-with-type ,(type-specifier-primary type)
+						   ))))
+				       (t ;; (warn "for ~S ~S ~S" binding init-register final-form)
+					(append init-code
+						`((:init-lexvar
+						   ,binding
+						   :init-with-register ,init-register
+						   :init-with-type ,(type-specifier-primary type))))))))
+				   (t init-code)))
+			    (when (plusp (num-specials local-env))
+			      `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
+									'dynamic-variable-install))))
+				(:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
+			    body-code
+			    (when (and (plusp (num-specials local-env))
+				       (not (eq :non-local-exit body-returns)))
+			      #+ignore
+			      (warn "let spec ret: ~S, want: ~S ~S"
+				    body-returns result-mode let-var-specs)
+			      `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx)
+				(:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context
+									'dynamic-variable-uninstall))))
+				(:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+				(:leal (:esp ,(* 16 (num-specials local-env))) :esp))))))
 		      (compiler-values (body-values)
 			:returns body-returns
 			:producer (default-compiler-values-producer)



From ffjeld at common-lisp.net  Sat Aug 20 20:31:26 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 20 Aug 2005 22:31:26 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <20050820203126.10ABA88552@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Re-worked several aspects of binding/environments: assignment,
type-inference, etc.

Date: Sat Aug 20 22:31:25 2005
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.52 movitz/special-operators.lisp:1.53
--- movitz/special-operators.lisp:1.52	Thu May  5 17:16:33 2005
+++ movitz/special-operators.lisp	Sat Aug 20 22:31:25 2005
@@ -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.52 2005/05/05 15:16:33 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.53 2005/08/20 20:31:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1015,6 +1015,7 @@
 		       ((:lexical-binding) result-mode))))
 	(compiler-values ()
 	  :returns returns
+	  :type 'number
 	  :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))))
 
 (define-special-operator muerte::include (&form form)



From ffjeld at common-lisp.net  Sun Aug 21 12:11:49 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 14:11:49 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050821121149.03F1588032@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Added movitz-disassemble-method, and use it in movitz-mode.el.

Date: Sun Aug 21 14:11:48 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.102 movitz/image.lisp:1.103
--- movitz/image.lisp:1.102	Sat Aug 20 22:31:05 2005
+++ movitz/image.lisp	Sun Aug 21 14:11:41 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.102 2005/08/20 20:31:05 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.103 2005/08/21 12:11:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1299,6 +1299,26 @@
     (assert funobj (module)
       "No load funobj found for module ~S." module)
     (movitz-disassemble-funobj funobj :name module)))
+
+(defun movitz-disassemble-method (name lambda-list &optional qualifiers)
+  (let* ((gf (or (movitz-env-named-function name)
+		 (error "No function named ~S." name)))
+	 (specializing-lambda-list
+	  (subseq lambda-list 0
+		  (position-if (lambda (x)
+				 (and (symbolp x)
+				      (char= #\& (char (string x) 0))))
+			       lambda-list)))
+	 (specializers (mapcar #'muerte::find-specializer
+			       (mapcar (lambda (x)
+					 (if (consp x)
+					     (second x)
+					   'muerte.cl::t))
+				       specializing-lambda-list)))
+	 (method (muerte::movitz-find-method gf qualifiers specializers))
+	 (funobj (muerte::movitz-slot-value method 'muerte::function))
+	 (*print-base* 16))
+    (movitz-disassemble-funobj funobj)))
 
 (defparameter *recursive-disassemble-remember-funobjs* nil)
 



From ffjeld at common-lisp.net  Sun Aug 21 12:12:14 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 14:12:14 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el 
Message-ID: <20050821121214.BABF488032@common-lisp.net>

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

Modified Files:
	movitz-mode.el 
Log Message:
Added movitz-disassemble-method, and use it in movitz-mode.el.

Date: Sun Aug 21 14:12:01 2005
Author: ffjeld

Index: movitz/movitz-mode.el
diff -u movitz/movitz-mode.el:1.9 movitz/movitz-mode.el:1.10
--- movitz/movitz-mode.el:1.9	Sat Apr 30 23:19:42 2005
+++ movitz/movitz-mode.el	Sun Aug 21 14:11:51 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Sep 27 18:12:17 2001
 ;;;;                
-;;;; $Id: movitz-mode.el,v 1.9 2005/04/30 21:19:42 ffjeld Exp $
+;;;; $Id: movitz-mode.el,v 1.10 2005/08/21 12:11:51 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -107,9 +107,10 @@
    (dont-run-bochs-p
     (message "Dumping Movitz image...done. Bootblock ID: %d. Running qemu.."
 	     (fi:eval-in-lisp "movitz::*bootblock-build*"))
-    (call-process "/bin/sh" nil 0 nil "-c"
-		  (format "DISPLAY=\"%s\" cd ~/clnet/movitz && qemu -fda los0-image -boot a"
-			  display-shortcut)))
+;;     (call-process "/bin/sh" nil 0 nil "-c"
+;; 		  (format "DISPLAY=\"%s\" cd ~/clnet/movitz && qemu -fda los0-image -boot a"
+;; 			  display-shortcut))
+    )
    (t (message "Dumping Movitz image...done. Bootblock ID: %d. Running bochs on \"%s\"..."
 	       (fi:eval-in-lisp "movitz::*bootblock-build*")
 	       display-shortcut)
@@ -212,25 +213,13 @@
      ((string= "method" defun-type)
       (message "Movitz disassembling %s %s %s..." defun-type defun-name lambda-list)
       (fi:eval-in-lisp
-       "(cl:let* ((method-name (cl:let ((cl:*package* (cl:find-package :%s)))
+       "(cl:let* ((gf-name (cl:let ((cl:*package* (cl:find-package :%s)))
                                   (cl:read-from-string \"%s\")))
-                  (gf (movitz::movitz-env-named-function method-name))
                   (qualifiers (cl:read-from-string \"%s\"))
                   (lambda-list (cl:let ((cl:*package* (cl:find-package :%s)))
                                  (cl:read-from-string \"%s\")))
-                  (specializing-lambda-list
-                     (cl:subseq lambda-list 0
-                                (cl:position-if (cl:lambda (x)
-                                                  (cl:and (cl:symbolp x)
-                                                       (cl:char= #\\& (cl:char (cl:string x) 0))))
-                                                lambda-list)))
-                  (specializers (cl:mapcar #'muerte::find-specializer
-                                  (cl:mapcar (cl:lambda (x) (cl:if (cl:consp x) (cl:second x) 'muerte.cl:t))
-                                             specializing-lambda-list)))
-                  (method (muerte::movitz-find-method gf qualifiers specializers))
-                  (funobj (muerte::movitz-slot-value method 'muerte::function))
                   (cl:*print-base* 16))
-         (movitz::movitz-disassemble-funobj funobj))"
+         (movitz::movitz-disassemble-method gf-name lambda-list qualifiers))"
        fi:package defun-name options fi:package lambda-list)
       (switch-to-buffer "*common-lisp*")
       (message "Movitz disassembling %s %s...done." defun-type defun-name))
@@ -312,6 +301,7 @@
   (put 'with-inline-assembly tag '(like prog))
   (put 'with-inline-assembly-case tag '(like prog))
   (put 'do-case tag '(like prog))
+  (put 'select tag '(like case))
   (put 'compiler-typecase tag '(like case)))
 
 



From ffjeld at common-lisp.net  Sun Aug 21 13:47:17 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 15:47:17 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/image.lisp 
Message-ID: <20050821134717.AF03788032@common-lisp.net>

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

Modified Files:
	image.lisp 
Log Message:
Have compile-time-variables be per-image (on the host side), by way of
defining them as symbol-macros that expand to getf on an *image* slot.

Date: Sun Aug 21 15:47:16 2005
Author: ffjeld

Index: movitz/image.lisp
diff -u movitz/image.lisp:1.103 movitz/image.lisp:1.104
--- movitz/image.lisp:1.103	Sun Aug 21 14:11:41 2005
+++ movitz/image.lisp	Sun Aug 21 15:47:16 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.103 2005/08/21 12:11:41 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.104 2005/08/21 13:47:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -923,9 +923,9 @@
 							:cl :muerte.cl))))
 		     (t (warn "not a symbol for plist: ~S has ~S" symbol plist)))))
 	  ;; pull in global properties
-	  (loop for var in (image-compile-time-variables *image*)
+	  (loop for (var value) on (image-compile-time-variables *image*) by #'cddr
 	      do (let ((mname (movitz-read var))
-		       (mvalue (movitz-read (symbol-value var))))
+		       (mvalue (movitz-read value)))
 		   (setf (movitz-symbol-value mname) mvalue)))
 	  (setf (movitz-symbol-value (movitz-read 'muerte::*packages*))
 	    (movitz-read (make-packages-hash))))



From ffjeld at common-lisp.net  Sun Aug 21 13:47:25 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 15:47:25 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <20050821134725.4F7568815C@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Have compile-time-variables be per-image (on the host side), by way of
defining them as symbol-macros that expand to getf on an *image* slot.

Date: Sun Aug 21 15:47:20 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.63 movitz/losp/muerte/basic-macros.lisp:1.64
--- movitz/losp/muerte/basic-macros.lisp:1.63	Sat Aug 20 22:25:09 2005
+++ movitz/losp/muerte/basic-macros.lisp	Sun Aug 21 15:47:20 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.63 2005/08/20 20:25:09 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.64 2005/08/21 13:47:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -156,11 +156,12 @@
   (let ((the-value (eval value)))
     `(progn
        (eval-when (:compile-toplevel)
-	 (defvar ,name)
-	 (unless (member ',name (movitz::image-compile-time-variables movitz::*image*))
-	   (setf ,name ',the-value)
-	   (push ',name (movitz::image-compile-time-variables movitz::*image*))))
-       (defvar ,name 'uninitialized-compile-time-variable))))
+	 (define-symbol-macro ,name
+	     (getf (movitz::image-compile-time-variables movitz::*image*)
+		   ',name))
+	 (setf ,name (or ,name ',the-value)))
+       (eval-when (:load-toplevel :excute)
+	 (defvar ,name 'uninitialized-compile-time-variable)))))
 
 (defmacro let* (var-list &body declarations-and-body)
   (multiple-value-bind (body declarations)



From ffjeld at common-lisp.net  Sun Aug 21 13:47:54 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 15:47:54 +0200 (CEST)
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/los-closette-compiler.lisp 
Message-ID: <20050821134754.3902D884CB@common-lisp.net>

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

Modified Files:
	los-closette-compiler.lisp 
Log Message:
Some minor code cleanups.

Date: Sun Aug 21 15:47:53 2005
Author: ffjeld

Index: movitz/losp/muerte/los-closette-compiler.lisp
diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.17 movitz/losp/muerte/los-closette-compiler.lisp:1.18
--- movitz/losp/muerte/los-closette-compiler.lisp:1.17	Thu May  5 17:17:35 2005
+++ movitz/losp/muerte/los-closette-compiler.lisp	Sun Aug 21 15:47:53 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 29 13:15:11 2002
 ;;;;                
-;;;; $Id: los-closette-compiler.lisp,v 1.17 2005/05/05 15:17:35 ffjeld Exp $
+;;;; $Id: los-closette-compiler.lisp,v 1.18 2005/08/21 13:47:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,8 +28,6 @@
 (define-compile-time-variable *the-position-of-standard-effective-slots* nil)
 (define-compile-time-variable *the-class-standard-class* nil)
 
-(defvar *the-effective-slot-positions* nil)
-
 (eval-when (:compile-toplevel)		; extends to EOF
 
   (defvar *classes-with-old-slot-definitions* nil)
@@ -521,18 +519,17 @@
 	val)))
   
   (defun (setf std-slot-value) (value instance slot-name)
-    (setq slot-name (translate-program slot-name :cl :muerte.cl))
-    (let* ((location (slot-location (movitz-class-of instance) slot-name))
+    (let* ((location (slot-location (movitz-class-of instance)
+				    (translate-program slot-name :cl :muerte.cl)))
 	   (slots (std-instance-slots instance)))
       (setf (svref slots location) (muerte::translate-program value :cl :muerte.cl))))
   
-  (defun movitz-slot-value (object slot-name)
-    (setq slot-name (translate-program slot-name :cl :muerte.cl))
-    (std-slot-value object slot-name))
+  (defun movitz-slot-vale (object slot-name)
+    (std-slot-value object (translate-program slot-name :cl :muerte.cl)))
 
   (defun (setf movitz-slot-value) (new-value object slot-name)
-    (setq slot-name (translate-program slot-name :cl :muerte.cl))
-    (setf (std-slot-value object slot-name) new-value))
+    (setf (std-slot-value object (translate-program slot-name :cl :muerte.cl))
+      new-value))
   
   (defun std-slot-exists-p (instance slot-name)
     (not (null (find slot-name (class-slots (movitz-class-of instance))
@@ -577,27 +574,6 @@
 			    :name name
 			    all-keys)))
 	  (setf (movitz-find-class name) class)))))
-;;;      (when old-class
-;;;	
-;;;      (let (
-;;;	(cond
-;;;	 (old-class
-;;;	  (setf (std-instance-class old-class) (std-instance-class new-class)
-;;;		(std-instance-slots old-class) (std-instance-slots new-class)
-;;;		(std-instance-class new-class) (movitz::movitz-read 'dead-class-instance!)
-;;;		(std-instance-slots new-class) (movitz::movitz-read 'dead-class-instance!)
-;;;		(class-precedence-list old-class) (std-compute-class-precedence-list old-class))
-;;;	  (let ((supers (class-direct-superclasses old-class)))
-;;;	    (dolist (superclass supers)
-;;;	      (setf (class-direct-subclasses superclass)
-;;;		(delete new-class (class-direct-subclasses superclass)))
-;;;	      (pushnew old-class (class-direct-subclasses superclass))))
-;;;	  old-class)
-;;;	 ((not old-class)
-;;;	  (setf (movitz-find-class name) new-class)
-;;;	  new-class)))))
-
-;;;
   
   (defun movitz-make-instance-funcallable (metaclass &rest all-keys &key name direct-superclasses direct-slots &allow-other-keys)
     (declare (ignore all-keys))
@@ -1134,7 +1110,7 @@
 	    (generic-function-lambda-list gf) lambda-list
 	    (generic-function-methods gf) ()
 	    (generic-function-method-class gf) method-class
-	    (generic-function-method-combination gf) (symbol-value '*the-standard-method-combination*))
+	    (generic-function-method-combination gf) *the-standard-method-combination*)
       (finalize-generic-function gf)
       gf))
 



From ffjeld at common-lisp.net  Sun Aug 21 15:27:20 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 17:27:20 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050821152720.5E343884CB@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Improved :add extended-code.

Date: Sun Aug 21 17:27:19 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.150 movitz/compiler.lisp:1.151
--- movitz/compiler.lisp:1.150	Sat Aug 20 22:30:40 2005
+++ movitz/compiler.lisp	Sun Aug 21 17:27:19 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.150 2005/08/20 20:30:40 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.151 2005/08/21 15:27:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3066,33 +3066,6 @@
 					(warn "Unused variable: ~S"
 					      (binding-name binding))))
 				     ((not (plusp (or (car (gethash binding var-counts)) 0))))))
-			   collect binding)
-		       #+ignore
-		       (loop for (variable . binding) in (movitz-environment-bindings env)
-			   unless (cond
-				   ((not (typep binding 'lexical-binding)))
-				   ((typep binding 'lambda-binding))
-				   ((typep binding 'constant-object-binding))
-				   ((typep binding 'forwarding-binding)
-				    ;; Immediately "assign" to target.
-				    (when (plusp (or (car (gethash binding var-counts)) 0))
-				      (setf (new-binding-location binding frame-map)
-					(forwarding-binding-target binding)))
-				    t)
-				   ((typep binding 'borrowed-binding))
-				   ((typep binding 'funobj-binding))
-				   ((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 ,(function-argument-argnum binding)))))
-				   ((unless (or (movitz-env-get variable 'ignore nil env nil)
-						(movitz-env-get variable 'ignorable nil env nil)
-						(typep binding 'hidden-rest-function-argument)
-						(third (gethash binding var-counts)))
-				      (warn "Unused variable: ~S"
-					    (binding-name binding))))
-				   ((not (plusp (or (car (gethash binding var-counts)) 0)))))
 			   collect binding))
 		      (bindings-fun-arg-sorted
 		       (when (eq env function-env)
@@ -3145,6 +3118,13 @@
 				    (when bindings-to-locate
 				      (dox (binding-env (first bindings-to-locate))
 					   #'movitz-environment-uplink)))))
+		 #+ignore
+		 (loop for binding in bindings-to-locate
+		     do (when (binding-store-type binding)
+			  (warn "~S => ~S" binding (binding-store-type binding)))
+			(when (typep (binding-store-type binding) 'lexical-binding)
+			  (warn "binding ~S == ~S"
+				binding (binding-store-type binding))))
 		 ;; First, make several passes while trying to locate bindings
 		 ;; into registers.
 		 (loop repeat 100 with try-again = t and did-assign = t
@@ -6835,72 +6815,111 @@
 	 ((and (movitz-subtypep type0 'fixnum)
 	       (movitz-subtypep type1 'fixnum)
 	       (movitz-subtypep result-type 'fixnum))
-	  #+ignore (warn "ADDX: ~S" instruction)
-	  (cond
-	   ((and (type-specifier-singleton type0)
-		 (eq loc1 destination-location))
+	  (let ((constant0 (let ((x (type-specifier-singleton type0)))
+			     (when x (movitz-immediate-value (car x)))))
+		(constant1 (let ((x (type-specifier-singleton type1)))
+			     (when x (movitz-immediate-value (car x))))))
+	    (assert (not (and constant0 (zerop constant0))))
+	    (assert (not (and constant1 (zerop constant1))))
 	    (cond
-	     ((member destination-location '(:eax :ebx :ecx :edx))
-	      `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
-		       ,destination)))
-	     ((integerp loc1)
-	      ;; (break "check that this is correct..")
-	      `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
-		       (:ebp ,(stack-frame-offset loc1)))))
-	     ((eq :argument-stack (operator loc1))
-	      `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
-		       (:ebp ,(argument-stack-offset (binding-target term1))))))
-	     (t (error "Don't know how to add this for loc1 ~S" loc1))))
-	   ((and (type-specifier-singleton type0)
-		 (eq term1 destination)
-		 (integerp destination-location))
-	    (break "untested")
-	    `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
-		     (:ebp ,(stack-frame-offset destination-location)))))
-	   ((and (type-specifier-singleton type0)
-		 (symbolp loc1)
-		 (integerp destination-location))
-	    (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
-			     ,loc1))
-		    (make-store-lexical destination loc1 nil funobj frame-map)))
-	   ((and (integerp loc0) (integerp loc1)
-		 (member destination-location '(:eax :ebx :ecx :edx)))
-	    (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
-		      (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location))))
-	   (t (warn "ADD: ~A/~S = ~A/~S + ~A/~S"
-		    destination-location
-		    destination
-		    loc0 term0
-		    loc1 term1)
-	      #+ignore (warn "map: ~A" frame-map)
+	     ((and constant0
+		   (equal loc1 destination-location))
+	      (cond
+	       ((member destination-location '(:eax :ebx :ecx :edx))
+		`((:addl ,constant0 ,destination-location)))
+	       ((integerp loc1)
+		`((:addl ,constant0 (:ebp ,(stack-frame-offset loc1)))))
+	       ((eq :argument-stack (operator loc1))
+		`((:addl ,constant0
+			 (:ebp ,(argument-stack-offset (binding-target term1))))))
+	       (t (error "Don't know how to add this for loc1 ~S" loc1))))
+	     ((and constant0
+		   (integerp destination-location)
+		   (eql term1 destination-location))
+	      (break "untested")
+	      `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
+	     ((and constant0
+		   (integerp destination-location)
+		   (member loc1 '(:eax :ebx :ecx :edx)))
+	      (break "check this!")
+	      `((:addl ,constant0 ,loc1)
+		(:movl ,loc1 (:ebp ,(stack-frame-offset destination-location)))))
+	     ((and (integerp loc0)
+		   (integerp loc1)
+		   (member destination-location '(:eax :ebx :ecx :edx)))
+	      (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+			(:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location))))
+	     ((and (integerp destination-location)
+		   (eql loc0 destination-location)
+		   constant1)
+	      `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location)))))
+	     ((and (integerp destination-location)
+		   (eql loc1 destination-location)
+		   constant0)
+	      `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
+	     ((and (member destination-location '(:eax :ebx :ecx :edx))
+		   (eq loc0 :untagged-fixnum-ecx)
+		   constant1)
+	      `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1)
+		       ,destination-location)))
+	     ((and (member destination-location '(:eax :ebx :ecx :edx))
+		   (integerp loc1)
+		   constant0)
+	      `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location)
+		(:addl ,constant0 ,destination-location)))
+	     ((and (member destination-location '(:eax :ebx :ecx :edx))
+		   (integerp loc0)
+		   constant1)
+	      `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+		(:addl ,constant1 ,destination-location)))
+	     ((and (member destination-location '(:eax :ebx :ecx :edx))
+		   (integerp loc0)
+		   (member loc1 '(:eax :ebx :ecx :edx))
+		   (not (eq destination-location loc1)))
+	      `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+		(:addl ,loc1 ,destination-location)))
+	     ((and (member destination-location '(:eax :ebx :ecx :edx))
+		   constant0
+		   (member loc1 '(:eax :ebx :ecx :edx)))
+	      `((:leal (,loc1 ,constant0) ,destination-location)))
+	     ((and (member destination-location '(:eax :ebx :ecx :edx))
+		   constant1
+		   (member loc0 '(:eax :ebx :ecx :edx)))
+	      `((:leal (,loc0 ,constant1) ,destination-location)))
+	     (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
+		      destination-location
+		      destination
+		      loc0 term0
+		      loc1 term1)
+		#+ignore (warn "map: ~A" frame-map)
 ;;; 	    (warn "ADDI: ~S" instruction)
-	      (append (cond
-		       ((type-specifier-singleton type0)
-			(append (make-load-lexical term1 :eax funobj nil frame-map)
-				(make-load-constant (car (type-specifier-singleton type0))
-						    :ebx funobj frame-map)))
-		       ((type-specifier-singleton type1)
-			(append (make-load-lexical term0 :eax funobj nil frame-map)
-				(make-load-constant (car (type-specifier-singleton type1))
-						    :ebx funobj frame-map)))
-		       ((and (eq :eax loc0) (eq :ebx loc1))
-			nil)
-		       ((and (eq :ebx loc0) (eq :eax loc1))
-			nil)		; terms order isn't important
-		       ((eq :eax loc1)
-			(append
-			 (make-load-lexical term0 :ebx funobj nil frame-map)))
-		       (t (append
-			   (make-load-lexical term0 :eax funobj nil frame-map)
-			   (make-load-lexical term1 :ebx funobj nil frame-map))))
-		      `((:movl (:edi ,(global-constant-offset '+)) :esi))
-		      (make-compiled-funcall-by-esi 2)
-		      (etypecase destination
-			(symbol
-			 (unless (eq destination :eax)
-			   `((:movl :eax ,destination))))
-			(binding
-			 (make-store-lexical destination :eax nil funobj frame-map)))))))
+		(append (cond
+			 ((type-specifier-singleton type0)
+			  (append (make-load-lexical term1 :eax funobj nil frame-map)
+				  (make-load-constant (car (type-specifier-singleton type0))
+						      :ebx funobj frame-map)))
+			 ((type-specifier-singleton type1)
+			  (append (make-load-lexical term0 :eax funobj nil frame-map)
+				  (make-load-constant (car (type-specifier-singleton type1))
+						      :ebx funobj frame-map)))
+			 ((and (eq :eax loc0) (eq :ebx loc1))
+			  nil)
+			 ((and (eq :ebx loc0) (eq :eax loc1))
+			  nil)		; terms order isn't important
+			 ((eq :eax loc1)
+			  (append
+			   (make-load-lexical term0 :ebx funobj nil frame-map)))
+			 (t (append
+			     (make-load-lexical term0 :eax funobj nil frame-map)
+			     (make-load-lexical term1 :ebx funobj nil frame-map))))
+			`((:movl (:edi ,(global-constant-offset '+)) :esi))
+			(make-compiled-funcall-by-esi 2)
+			(etypecase destination
+			  (symbol
+			   (unless (eq destination :eax)
+			     `((:movl :eax ,destination))))
+			  (binding
+			   (make-store-lexical destination :eax nil funobj frame-map))))))))
 	 (t (append (cond
 		     ((type-specifier-singleton type0)
 		      (append (make-load-lexical term1 :eax funobj nil frame-map)



From ffjeld at common-lisp.net  Sun Aug 21 17:51:35 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 19:51:35 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <20050821175135.86D0D884CB@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
Fixed bug in lookup of deftypes at compile-time.

Date: Sun Aug 21 19:51:34 2005
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.23 movitz/compiler-types.lisp:1.24
--- movitz/compiler-types.lisp:1.23	Sat Aug 20 22:30:14 2005
+++ movitz/compiler-types.lisp	Sun Aug 21 19:51:34 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.23 2005/08/20 20:30:14 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.24 2005/08/21 17:51:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -499,9 +499,8 @@
 	 (type-values 'cons :members '(nil)))
 	(sequence
 	 (type-values '(vector cons) :members '(nil)))
-	(t (let ((deriver (and (boundp 'muerte::*compiler-derived-typespecs*)
-			       (gethash type-specifier
-					(symbol-value 'muerte::*compiler-derived-typespecs*)))))
+	(t (let ((deriver (and (boundp '*image*)
+			       (gethash type-specifier muerte::*compiler-derived-typespecs*))))
 	     (if deriver
 		 (type-specifier-encode (funcall deriver))
 	       (type-values () :include (list type-specifier)))))))
@@ -563,10 +562,10 @@
 	     (type-values () :include (list type-specifier)))))
 	((array vector binding-type)
 	 (type-values () :include (list type-specifier)))
-	(t (let ((deriver (and (boundp 'muerte::*compiler-derived-typespecs*)
-			       (gethash (intern (symbol-name (car type-specifier))
-						:muerte.cl)
-					(symbol-value 'muerte::*compiler-derived-typespecs*)))))
+	(t (let ((deriver (and (boundp '*image*)
+			       (gethash (translate-program (car type-specifier)
+							   :cl :muerte.cl)
+					muerte::*compiler-derived-typespecs*))))
 	     (assert deriver (type-specifier)
 	       "Unknown type ~S." type-specifier)
 	     (type-specifier-encode (apply deriver (cdr type-specifier))))))))))



From ffjeld at common-lisp.net  Sun Aug 21 17:51:54 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 19:51:54 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050821175154.1EDCA884CB@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
sync

Date: Sun Aug 21 19:51:53 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.151 movitz/compiler.lisp:1.152
--- movitz/compiler.lisp:1.151	Sun Aug 21 17:27:19 2005
+++ movitz/compiler.lisp	Sun Aug 21 19:51:53 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.151 2005/08/21 15:27:19 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.152 2005/08/21 17:51:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -6920,6 +6920,12 @@
 			     `((:movl :eax ,destination))))
 			  (binding
 			   (make-store-lexical destination :eax nil funobj frame-map))))))))
+	 ((and (movitz-subtypep result-type '(unsigned-byte 32))
+	       (warn "Unknown u32 ADD: ~A/~S = ~A/~S + ~A/~S"
+		      destination-location
+		      destination
+		      loc0 term0
+		      loc1 term1)))
 	 (t (append (cond
 		     ((type-specifier-singleton type0)
 		      (append (make-load-lexical term1 :eax funobj nil frame-map)



From ffjeld at common-lisp.net  Sun Aug 21 17:55:54 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 19:55:54 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp 
Message-ID: <20050821175554.E42988852B@common-lisp.net>

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

Modified Files:
	los-closette.lisp 
Log Message:
sync

Date: Sun Aug 21 19:55:54 2005
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.34 movitz/losp/muerte/los-closette.lisp:1.35
--- movitz/losp/muerte/los-closette.lisp:1.34	Sun Aug 14 20:50:12 2005
+++ movitz/losp/muerte/los-closette.lisp	Sun Aug 21 19:55:54 2005
@@ -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.34 2005/08/14 18:50:12 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.35 2005/08/21 17:55:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1310,11 +1310,13 @@
 	(and (slot-missing class object slot-name 'slot-boundp) t)
       (slot-boundp-using-class class object slot))))
 
-(defmethod slot-boundp-using-class ((class standard-class) object (slot standard-effective-slot-definition))
+(defmethod slot-boundp-using-class
+    ((class standard-class) object (slot standard-effective-slot-definition))
   (not (eq (load-global-constant new-unbound-value)
 	   (standard-instance-access object (slot-definition-location slot)))))
   
-(defmethod slot-boundp-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition))
+(defmethod slot-boundp-using-class
+    ((class funcallable-standard-class) object (slot standard-effective-slot-definition))
   (not (eq (load-global-constant new-unbound-value)
 	   (svref (std-gf-instance-slots object) (slot-definition-location slot)))))
 
@@ -1329,12 +1331,14 @@
 	       object)
       (slot-makunbound-using-class class object slot))))
 
-(defmethod slot-makunbound-using-class ((class standard-class) object (slot standard-effective-slot-definition))
+(defmethod slot-makunbound-using-class
+    ((class standard-class) object (slot standard-effective-slot-definition))
   (setf (standard-instance-access object (slot-definition-location slot))
     (load-global-constant new-unbound-value))
   object)
   
-(defmethod slot-makunbound-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition))
+(defmethod slot-makunbound-using-class
+    ((class funcallable-standard-class) object (slot standard-effective-slot-definition))
   (setf (svref (std-gf-instance-slots object) (slot-definition-location slot))
     (load-global-constant new-unbound-value))
   object)



From ffjeld at common-lisp.net  Sun Aug 21 17:56:41 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 19:56:41 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp 
Message-ID: <20050821175641.594688802E@common-lisp.net>

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

Modified Files:
	hash-tables.lisp 
Log Message:
Have the index type take a 'step' parameters.

Date: Sun Aug 21 19:56:41 2005
Author: ffjeld

Index: movitz/losp/muerte/hash-tables.lisp
diff -u movitz/losp/muerte/hash-tables.lisp:1.8 movitz/losp/muerte/hash-tables.lisp:1.9
--- movitz/losp/muerte/hash-tables.lisp:1.8	Thu Jun 16 12:00:51 2005
+++ movitz/losp/muerte/hash-tables.lisp	Sun Aug 21 19:56:40 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Feb 19 19:09:05 2001
 ;;;;                
-;;;; $Id: hash-tables.lisp,v 1.8 2005/06/16 10:00:51 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.9 2005/08/21 17:56:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -120,7 +120,7 @@
 	 (bucket-length (length bucket))
 	 (start-i2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length))
 	 (i2 start-i2))
-    (declare (type index i2))
+    (declare (type (index 2) i2))
     (do () (nil)
       (let ((k (svref%unsafe bucket i2)))
 	(cond



From ffjeld at common-lisp.net  Sun Aug 21 17:56:45 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 19:56:45 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <20050821175645.599FF88030@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Have the index type take a 'step' parameters.

Date: Sun Aug 21 19:56:44 2005
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.21 movitz/losp/muerte/sequences.lisp:1.22
--- movitz/losp/muerte/sequences.lisp:1.21	Fri Jun 10 00:19:05 2005
+++ movitz/losp/muerte/sequences.lisp	Sun Aug 21 19:56:44 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.21 2005/06/09 22:19:05 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.22 2005/08/21 17:56:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,8 +19,8 @@
   
 (in-package muerte)
 
-(deftype index ()
-  '(integer 0 #x1ffffffe))
+(deftype index (&optional (step 1))
+  `(integer 0 ,(- #x1fffffff step)))
 
 (defun sequencep (x)
   (or (typep x 'vector)



From ffjeld at common-lisp.net  Sun Aug 21 17:59:16 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 19:59:16 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <20050821175916.DF93288030@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Move (deftype index) from sequences.lisp to typep.lisp.

Date: Sun Aug 21 19:59:16 2005
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.22 movitz/losp/muerte/sequences.lisp:1.23
--- movitz/losp/muerte/sequences.lisp:1.22	Sun Aug 21 19:56:44 2005
+++ movitz/losp/muerte/sequences.lisp	Sun Aug 21 19:59:16 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.22 2005/08/21 17:56:44 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.23 2005/08/21 17:59:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,9 +18,6 @@
 (provide :muerte/sequences)
   
 (in-package muerte)
-
-(deftype index (&optional (step 1))
-  `(integer 0 ,(- #x1fffffff step)))
 
 (defun sequencep (x)
   (or (typep x 'vector)



From ffjeld at common-lisp.net  Sun Aug 21 17:59:19 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 19:59:19 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050821175919.33AF288542@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Move (deftype index) from sequences.lisp to typep.lisp.

Date: Sun Aug 21 19:59:19 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.49 movitz/losp/muerte/typep.lisp:1.50
--- movitz/losp/muerte/typep.lisp:1.49	Sat Aug 20 22:28:31 2005
+++ movitz/losp/muerte/typep.lisp	Sun Aug 21 19:59:18 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.49 2005/08/20 20:28:31 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.50 2005/08/21 17:59:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -691,6 +691,9 @@
 
 (deftype bit ()
   '(integer 0 1))
+
+(deftype index (&optional (step 1))
+  `(integer 0 ,(- #x1fffffff step)))
 
 (defun type-of (x)
   (class-name (class-of x)))



From ffjeld at common-lisp.net  Sun Aug 21 19:00:18 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 21 Aug 2005 21:00:18 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp 
Message-ID: <20050821190018.A51E5884C2@common-lisp.net>

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

Modified Files:
	lists.lisp 
Log Message:
Applied the index type declaration here and there.

Date: Sun Aug 21 21:00:17 2005
Author: ffjeld

Index: movitz/losp/muerte/lists.lisp
diff -u movitz/losp/muerte/lists.lisp:1.11 movitz/losp/muerte/lists.lisp:1.12
--- movitz/losp/muerte/lists.lisp:1.11	Sun Jun 12 23:27:07 2005
+++ movitz/losp/muerte/lists.lisp	Sun Aug 21 21:00:16 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.11 2005/06/12 21:27:07 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.12 2005/08/21 19:00:16 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -94,6 +94,7 @@
        (fast x (cddr fast))		;Fast pointer: leaps by 2.
        (slow x (cdr slow)))		;Slow pointer: leaps by 1.
       (nil)
+    (declare (type (index 2) n))
     ;; If fast pointer hits the end, return the count.
     (when (endp fast) (return n))
     (when (endp (cdr fast)) (return (+ n 1)))
@@ -127,10 +128,11 @@
        (r list)
        (i 0 (+ i 1)))
       ((atom l) r)
+    (declare (index i))
     (if (>= i n) (pop r))))
 
 (defun nthcdr (n list)
-  (do ()
+  (do ((n (check-the fixnum n)))
       ((or (null list) (not (plusp n))) list)
     (decf n)
     (setf list (cdr list))))



From ffjeld at common-lisp.net  Sun Aug 21 22:06:56 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Aug 2005 00:06:56 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050821220656.26AA0884C2@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Improved the add compiler.

Date: Mon Aug 22 00:06:53 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.152 movitz/compiler.lisp:1.153
--- movitz/compiler.lisp:1.152	Sun Aug 21 19:51:53 2005
+++ movitz/compiler.lisp	Mon Aug 22 00:06:48 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.152 2005/08/21 17:51:53 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.153 2005/08/21 22:06:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3611,7 +3611,10 @@
 	(located-binding
 	 (let ((binding-type (binding-store-type binding))
 	       (binding-location (new-binding-location binding frame-map)))
-	   #+ignore (warn "~S type: ~S" binding binding-type)
+	   #+ignore (warn "~S type: ~S ~:[~;lended~]"
+			  binding
+			  binding-type 
+			  (binding-lended-p binding))
 	   (cond
 	    ((and (binding-lended-p binding)
 		  (not shared-reference-p))
@@ -6757,13 +6760,15 @@
 ;;;      (warn "dest: ~S ~S"
 ;;;	    (apply #'encoded-type-decode (binding-store-type destination))
 ;;;	    result-type)	    
-      (when (binding-lended-p term0)
-	(warn "Add for lend0: ~S" term0))
-      (when (binding-lended-p term1)
-	(warn "Add for lend0: ~S" term1))
-      (when (and (bindingp destination)
-		 (binding-lended-p destination))
-	(warn "Add for lend0: ~S" destination))
+;;;      (when (binding-lended-p term0)
+;;;	(warn "Add from lend0: ~S" term0))
+;;;      (when (binding-lended-p term1)
+;;;	(warn "Add from lend1: ~S" term1))
+;;;      (when (and (bindingp destination)
+;;;		 (binding-lended-p destination))
+;;;	(warn "Add for lended dest: ~S" destination))
+;;;      (when (typep destination 'borrowed-binding)
+;;;	(warn "Add for borrowed ~S" destination))
       (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
 	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
 	#+ignore
@@ -6774,185 +6779,208 @@
 	      term0 loc0
 	      term1 loc1)
 	#+ignore
-	(when (eql loc0 loc1)
-	  (warn "add for:~%~A/~A in ~S~&~A/~A in ~S."
+	(when (eql destination-location 9)
+	  (warn "add for: ~S/~S~%= ~A/~A in ~S~&~A/~A in ~S."
+		destination destination-location
 		term0 loc0 (binding-extent-env (binding-target term0))
-		term1 loc1 (binding-extent-env (binding-target term1))))
-	(cond
-	 ((type-specifier-singleton result-type)
-	  ;; (break "constant add: ~S" instruction)
-	  (make-load-constant (car (type-specifier-singleton result-type))
-			      destination funobj frame-map))
-	 ((movitz-subtypep type0 '(integer 0 0))
-	  (cond
-	   ((eql destination loc1)
-	    #+ignore (break "NOP add: ~S" instruction)
-	    nil)
-	   ((and (member destination-location '(:eax :ebx :ecx :edx))
-		 (member loc1 '(:eax :ebx :ecx :edx)))
-	    `((:movl ,loc1 ,destination-location)))
-	   ((integerp loc1)
-	    (make-load-lexical term1 destination-location funobj nil frame-map))
-	   #+ignore
-	   ((integerp destination-location)
-	    (make-store-lexical destination-location loc1 nil funobj frame-map))
-	   (t (break "Unknown X zero-add: ~S" instruction))))
-	 ((movitz-subtypep type1 '(integer 0 0))
-	  ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
+		term1 loc1 (binding-extent-env (binding-target term1)))
+	  (print-code 'load-term1 (make-load-lexical term1 :eax funobj nil frame-map))
+	  (print-code 'load-dest (make-load-lexical destination :eax funobj nil frame-map)))
+	(flet ((make-default-add ()
+		 (when (movitz-subtypep result-type '(unsigned-byte 32))
+		   (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S"
+			 destination-location
+			 destination
+			 loc0 term0
+			 loc1 term1))
+		 (append (cond
+			  ((type-specifier-singleton type0)
+			   (append (make-load-lexical term1 :eax funobj nil frame-map)
+				   (make-load-constant (car (type-specifier-singleton type0))
+						       :ebx funobj frame-map)))
+			  ((type-specifier-singleton type1)
+			   (append (make-load-lexical term0 :eax funobj nil frame-map)
+				   (make-load-constant (car (type-specifier-singleton type1))
+						       :ebx funobj frame-map)))
+			  ((and (eq :eax loc0) (eq :ebx loc1))
+			   nil)
+			  ((and (eq :ebx loc0) (eq :eax loc1))
+			   nil)		; terms order isn't important
+			  ((eq :eax loc1)
+			   (append
+			    (make-load-lexical term0 :ebx funobj nil frame-map)))
+			  (t (append
+			      (make-load-lexical term0 :eax funobj nil frame-map)
+			      (make-load-lexical term1 :ebx funobj nil frame-map))))
+			 `((:movl (:edi ,(global-constant-offset '+)) :esi))
+			 (make-compiled-funcall-by-esi 2)
+			 (etypecase destination
+			   (symbol
+			    (unless (eq destination :eax)
+			      `((:movl :eax ,destination))))
+			   (binding
+			    (make-store-lexical destination :eax nil funobj frame-map))))))
 	  (cond
-	   ((eql destination loc0)
-	    #+ignore (break "NOP add: ~S" instruction)
-	    nil)
-	   ((and (member destination-location '(:eax :ebx :ecx :edx))
-		 (member loc0 '(:eax :ebx :ecx :edx)))
-	    `((:movl ,loc0 ,destination-location)))
-	   ((integerp loc0)
-	    (make-load-lexical term0 destination-location funobj nil frame-map))
-	   #+ignore
-	   ((integerp destination-location)
-	    (make-store-lexical destination-location loc0 nil funobj frame-map))
-	   (t (break "Unknown Y zero-add: ~S" instruction))))
-	 ((and (movitz-subtypep type0 'fixnum)
-	       (movitz-subtypep type1 'fixnum)
-	       (movitz-subtypep result-type 'fixnum))
-	  (let ((constant0 (let ((x (type-specifier-singleton type0)))
-			     (when x (movitz-immediate-value (car x)))))
-		(constant1 (let ((x (type-specifier-singleton type1)))
-			     (when x (movitz-immediate-value (car x))))))
-	    (assert (not (and constant0 (zerop constant0))))
-	    (assert (not (and constant1 (zerop constant1))))
+	   ((type-specifier-singleton result-type)
+	    ;; (break "constant add: ~S" instruction)
+	    (make-load-constant (car (type-specifier-singleton result-type))
+				destination funobj frame-map))
+	   ((movitz-subtypep type0 '(integer 0 0))
 	    (cond
-	     ((and constant0
-		   (equal loc1 destination-location))
-	      (cond
-	       ((member destination-location '(:eax :ebx :ecx :edx))
-		`((:addl ,constant0 ,destination-location)))
-	       ((integerp loc1)
-		`((:addl ,constant0 (:ebp ,(stack-frame-offset loc1)))))
-	       ((eq :argument-stack (operator loc1))
-		`((:addl ,constant0
-			 (:ebp ,(argument-stack-offset (binding-target term1))))))
-	       (t (error "Don't know how to add this for loc1 ~S" loc1))))
-	     ((and constant0
-		   (integerp destination-location)
-		   (eql term1 destination-location))
-	      (break "untested")
-	      `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
-	     ((and constant0
-		   (integerp destination-location)
-		   (member loc1 '(:eax :ebx :ecx :edx)))
-	      (break "check this!")
-	      `((:addl ,constant0 ,loc1)
-		(:movl ,loc1 (:ebp ,(stack-frame-offset destination-location)))))
-	     ((and (integerp loc0)
-		   (integerp loc1)
-		   (member destination-location '(:eax :ebx :ecx :edx)))
-	      (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
-			(:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location))))
-	     ((and (integerp destination-location)
-		   (eql loc0 destination-location)
-		   constant1)
-	      `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location)))))
-	     ((and (integerp destination-location)
-		   (eql loc1 destination-location)
-		   constant0)
-	      `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
-	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   (eq loc0 :untagged-fixnum-ecx)
-		   constant1)
-	      `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1)
-		       ,destination-location)))
-	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   (integerp loc1)
-		   constant0)
-	      `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location)
-		(:addl ,constant0 ,destination-location)))
+	     ((eql destination loc1)
+	      #+ignore (break "NOP add: ~S" instruction)
+	      nil)
 	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   (integerp loc0)
-		   constant1)
-	      `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
-		(:addl ,constant1 ,destination-location)))
-	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   (integerp loc0)
-		   (member loc1 '(:eax :ebx :ecx :edx))
-		   (not (eq destination-location loc1)))
-	      `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
-		(:addl ,loc1 ,destination-location)))
-	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   constant0
 		   (member loc1 '(:eax :ebx :ecx :edx)))
-	      `((:leal (,loc1 ,constant0) ,destination-location)))
+	      `((:movl ,loc1 ,destination-location)))
+	     ((integerp loc1)
+	      (make-load-lexical term1 destination-location funobj nil frame-map))
+	     #+ignore
+	     ((integerp destination-location)
+	      (make-store-lexical destination-location loc1 nil funobj frame-map))
+	     (t (break "Unknown X zero-add: ~S" instruction))))
+	   ((movitz-subtypep type1 '(integer 0 0))
+	    ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
+	    (cond
+	     ((eql destination loc0)
+	      #+ignore (break "NOP add: ~S" instruction)
+	      nil)
 	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   constant1
 		   (member loc0 '(:eax :ebx :ecx :edx)))
-	      `((:leal (,loc0 ,constant1) ,destination-location)))
-	     (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
-		      destination-location
-		      destination
-		      loc0 term0
-		      loc1 term1)
-		#+ignore (warn "map: ~A" frame-map)
+	      `((:movl ,loc0 ,destination-location)))
+	     ((integerp loc0)
+	      (make-load-lexical term0 destination-location funobj nil frame-map))
+	     #+ignore
+	     ((integerp destination-location)
+	      (make-store-lexical destination-location loc0 nil funobj frame-map))
+	     (t (break "Unknown Y zero-add: ~S" instruction))))
+	   ((and (movitz-subtypep type0 'fixnum)
+		 (movitz-subtypep type1 'fixnum)
+		 (movitz-subtypep result-type 'fixnum))
+	    (let ((constant0 (let ((x (type-specifier-singleton type0)))
+			       (when x (movitz-immediate-value (car x)))))
+		  (constant1 (let ((x (type-specifier-singleton type1)))
+			       (when x (movitz-immediate-value (car x))))))
+	      (assert (not (and constant0 (zerop constant0))))
+	      (assert (not (and constant1 (zerop constant1))))
+	      (cond
+	       ((and (not (binding-lended-p (binding-target term0)))
+		     (not (binding-lended-p (binding-target term1)))
+		     (not (and (bindingp destination)
+			       (binding-lended-p (binding-target destination)))))
+		(cond
+		 ((and constant0
+		       (equal loc1 destination-location))
+		  (cond
+		   ((member destination-location '(:eax :ebx :ecx :edx))
+		    `((:addl ,constant0 ,destination-location)))
+		   ((integerp loc1)
+		    `((:addl ,constant0 (:ebp ,(stack-frame-offset loc1)))))
+		   ((eq :argument-stack (operator loc1))
+		    `((:addl ,constant0
+			     (:ebp ,(argument-stack-offset (binding-target term1))))))
+		   (t (error "Don't know how to add this for loc1 ~S" loc1))))
+		 ((and constant0
+		       (integerp destination-location)
+		       (eql term1 destination-location))
+		  (break "untested")
+		  `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
+		 ((and constant0
+		       (integerp destination-location)
+		       (member loc1 '(:eax :ebx :ecx :edx)))
+		  (break "check this!")
+		  `((:addl ,constant0 ,loc1)
+		    (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location)))))
+		 ((and (integerp loc0)
+		       (integerp loc1)
+		       (member destination-location '(:eax :ebx :ecx :edx)))
+		  (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+			    (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location))))
+		 ((and (integerp destination-location)
+		       (eql loc0 destination-location)
+		       constant1)
+		  `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location)))))
+		 ((and (integerp destination-location)
+		       (eql loc1 destination-location)
+		       constant0)
+		  `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       (eq loc0 :untagged-fixnum-ecx)
+		       constant1)
+		  `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1)
+			   ,destination-location)))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       (integerp loc1)
+		       constant0)
+		  `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location)
+		    (:addl ,constant0 ,destination-location)))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       (integerp loc0)
+		       constant1)
+		  `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+		    (:addl ,constant1 ,destination-location)))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       (integerp loc0)
+		       (member loc1 '(:eax :ebx :ecx :edx))
+		       (not (eq destination-location loc1)))
+		  `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+		    (:addl ,loc1 ,destination-location)))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       constant0
+		       (member loc1 '(:eax :ebx :ecx :edx)))
+		  `((:leal (,loc1 ,constant0) ,destination-location)))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       constant1
+		       (member loc0 '(:eax :ebx :ecx :edx)))
+		  `((:leal (,loc0 ,constant1) ,destination-location)))
+		 (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
+			  destination-location
+			  destination
+			  loc0 term0
+			  loc1 term1)
+		    #+ignore (warn "map: ~A" frame-map)
 ;;; 	    (warn "ADDI: ~S" instruction)
-		(append (cond
-			 ((type-specifier-singleton type0)
-			  (append (make-load-lexical term1 :eax funobj nil frame-map)
-				  (make-load-constant (car (type-specifier-singleton type0))
-						      :ebx funobj frame-map)))
-			 ((type-specifier-singleton type1)
-			  (append (make-load-lexical term0 :eax funobj nil frame-map)
-				  (make-load-constant (car (type-specifier-singleton type1))
-						      :ebx funobj frame-map)))
-			 ((and (eq :eax loc0) (eq :ebx loc1))
-			  nil)
-			 ((and (eq :ebx loc0) (eq :eax loc1))
-			  nil)		; terms order isn't important
-			 ((eq :eax loc1)
-			  (append
-			   (make-load-lexical term0 :ebx funobj nil frame-map)))
-			 (t (append
-			     (make-load-lexical term0 :eax funobj nil frame-map)
-			     (make-load-lexical term1 :ebx funobj nil frame-map))))
-			`((:movl (:edi ,(global-constant-offset '+)) :esi))
-			(make-compiled-funcall-by-esi 2)
-			(etypecase destination
-			  (symbol
-			   (unless (eq destination :eax)
-			     `((:movl :eax ,destination))))
-			  (binding
-			   (make-store-lexical destination :eax nil funobj frame-map))))))))
-	 ((and (movitz-subtypep result-type '(unsigned-byte 32))
-	       (warn "Unknown u32 ADD: ~A/~S = ~A/~S + ~A/~S"
-		      destination-location
-		      destination
-		      loc0 term0
-		      loc1 term1)))
-	 (t (append (cond
-		     ((type-specifier-singleton type0)
-		      (append (make-load-lexical term1 :eax funobj nil frame-map)
-			      (make-load-constant (car (type-specifier-singleton type0))
-						  :ebx funobj frame-map)))
-		     ((type-specifier-singleton type1)
-		      (append (make-load-lexical term0 :eax funobj nil frame-map)
-			      (make-load-constant (car (type-specifier-singleton type1))
-						  :ebx funobj frame-map)))
-		     ((and (eq :eax loc0) (eq :ebx loc1))
-		      nil)
-		     ((and (eq :ebx loc0) (eq :eax loc1))
-		      nil)		; terms order isn't important
-		     ((eq :eax loc1)
-		      (append
-		       (make-load-lexical term0 :ebx funobj nil frame-map)))
-		     (t (append
-			 (make-load-lexical term0 :eax funobj nil frame-map)
-			 (make-load-lexical term1 :ebx funobj nil frame-map))))
-		    `((:movl (:edi ,(global-constant-offset '+)) :esi))
-		    (make-compiled-funcall-by-esi 2)
-		    (etypecase destination
-		      (symbol
-		       (unless (eq destination :eax)
-			 `((:movl :eax ,destination))))
-		      (binding
-		       (make-store-lexical destination :eax nil funobj frame-map))))))))))
+		    (append (cond
+			     ((type-specifier-singleton type0)
+			      (append (make-load-lexical term1 :eax funobj nil frame-map)
+				      (make-load-constant (car (type-specifier-singleton type0))
+							  :ebx funobj frame-map)))
+			     ((type-specifier-singleton type1)
+			      (append (make-load-lexical term0 :eax funobj nil frame-map)
+				      (make-load-constant (car (type-specifier-singleton type1))
+							  :ebx funobj frame-map)))
+			     ((and (eq :eax loc0) (eq :ebx loc1))
+			      nil)
+			     ((and (eq :ebx loc0) (eq :eax loc1))
+			      nil)	; terms order isn't important
+			     ((eq :eax loc1)
+			      (append
+			       (make-load-lexical term0 :ebx funobj nil frame-map)))
+			     (t (append
+				 (make-load-lexical term0 :eax funobj nil frame-map)
+				 (make-load-lexical term1 :ebx funobj nil frame-map))))
+			    `((:movl (:edi ,(global-constant-offset '+)) :esi))
+			    (make-compiled-funcall-by-esi 2)
+			    (etypecase destination
+			      (symbol
+			       (unless (eq destination :eax)
+				 `((:movl :eax ,destination))))
+			      (binding
+			       (make-store-lexical destination :eax nil funobj frame-map)))))))
+	       ((and constant0
+		     (integerp destination-location)
+		     (eql loc1 destination-location)
+		     (binding-lended-p (binding-target destination)))
+		(assert (binding-lended-p (binding-target term1)))
+		(append (make-load-lexical destination :eax funobj t frame-map)
+			`((:addl ,constant0 (-1 :eax)))))
+	       ((warn "~S" (list (and (bindingp destination)
+				      (binding-lended-p (binding-target destination)))
+				 (binding-lended-p (binding-target term0))
+				 (binding-lended-p (binding-target term1)))))
+	       (t (warn "Unknown fixnum add: ~S" instruction)
+		  (make-default-add)))))
+	   (t (make-default-add))))))))
 
 ;;;;;;;
 



From ffjeld at common-lisp.net  Sun Aug 21 23:29:46 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Aug 2005 01:29:46 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp 
Message-ID: <20050821232946.16CDE88547@common-lisp.net>

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

Modified Files:
	compiler-types.lisp 
Log Message:
Fix for encoded-types-and: the clause for numbers was wrong.

Date: Mon Aug 22 01:29:45 2005
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.24 movitz/compiler-types.lisp:1.25
--- movitz/compiler-types.lisp:1.24	Sun Aug 21 19:51:34 2005
+++ movitz/compiler-types.lisp	Mon Aug 22 01:29:44 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.24 2005/08/21 17:51:34 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.25 2005/08/21 23:29:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -395,15 +395,18 @@
 			   (not (encoded-typep t nil x code0 integer-range0 members0 include0 nil)))
 			 members1)
 	      nil nil))
-     ((and (or integer-range0 integer-range1)
-	   (encoded-emptyp code0 nil members0 nil complement0)
+     ((and (encoded-emptyp code0 nil members0 include0 complement0)
 	   (encoded-emptyp code1 nil members1 nil complement1)
 	   (flet ((integer-super-p (x)
 		    (member x '(rational real number t))))
-	     (and (every #'integer-super-p include0)
-		  (every #'integer-super-p include1))))
-      (type-values () :integer-range (numscope-intersection integer-range0
-							    integer-range1)))
+	     (every #'integer-super-p include1)))
+      (type-values () :integer-range integer-range0))
+     ((and (encoded-emptyp code0 nil members0 nil complement0)
+	   (encoded-emptyp code1 nil members1 include1 complement1)
+	   (flet ((integer-super-p (x)
+		    (member x '(rational real number t))))
+	     (every #'integer-super-p include0)))
+      (type-values () :integer-range integer-range1))
      ((and (= code0 code1) (equal integer-range0 integer-range1)
 	   (equal members0 members1) (equal include0 include1)
 	   (eq complement0 complement1))



From ffjeld at common-lisp.net  Sun Aug 21 23:30:11 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Aug 2005 01:30:11 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050821233011.6767B88547@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
sync

Date: Mon Aug 22 01:30:05 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.153 movitz/compiler.lisp:1.154
--- movitz/compiler.lisp:1.153	Mon Aug 22 00:06:48 2005
+++ movitz/compiler.lisp	Mon Aug 22 01:30:04 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.153 2005/08/21 22:06:48 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.154 2005/08/21 23:30:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -6715,7 +6715,7 @@
 		(let ((x (multiple-value-call #'encoded-integer-types-add
 			   (type-specifier-encode type0)
 			   (type-specifier-encode type1))))
-		  ;; (warn "thunked: ~S ~S -> ~S" term0 term1 x)
+		  #+ignore (warn "thunked: ~S ~S -> ~S" term0 term1 x)
 		  x))
 	      (list term0 term1)
 	      ))))



From ffjeld at common-lisp.net  Mon Aug 22 17:03:01 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Mon, 22 Aug 2005 19:03:01 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <20050822170301.DBAA08802E@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Applied (declare (type index)) some more.

Date: Mon Aug 22 19:03:00 2005
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.23 movitz/losp/muerte/sequences.lisp:1.24
--- movitz/losp/muerte/sequences.lisp:1.23	Sun Aug 21 19:59:16 2005
+++ movitz/losp/muerte/sequences.lisp	Mon Aug 22 19:03:00 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.23 2005/08/21 17:59:16 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.24 2005/08/22 17:03:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -80,7 +80,8 @@
 (defun length%list (sequence)
   (do ((length 0 (1+ length))
        (x sequence (cdr x)))
-      ((null x) length)))
+      ((null x) length)
+    (declare (type index length))))
 
 (defun elt (sequence index)
   (sequence-dispatch sequence
@@ -146,7 +147,8 @@
 				(funcall-function result (key (pop list)))))
 		      ((or (null list)
 			   (= end counter))
-		       result)))
+		       result)
+		    (declare (index counter))))
 		 (vector
 		  (with-subvector-accessor (sequence-ref sequence start end)
 		    (do* ((index start)
@@ -155,7 +157,8 @@
 						      (key (sequence-ref (prog1 index (incf index)))))
 						    (key (sequence-ref (prog1 index (incf index)))))
 				  (funcall-function result (sequence-ref (prog1 index (incf index))))))
-			((= index end) result))))))))))))
+			((= index end) result)
+		      (declare (index index)))))))))))))
 
 (defun subseq (sequence start &optional end)
   (sequence-dispatch sequence
@@ -205,11 +208,13 @@
 	   (do ((end (length sequence))
 		(i 0 (1+ i)))
 	       ((>= i end))
+	     (declare (index i end))
 	     (when (eql (sequence-ref i) item)
 	       (return i)))))
 	(list
 	 (do ((i 0 (1+ i)))
 	     ((null sequence) nil)
+	   (declare (index i))
 	   (when (eql (pop sequence) item)
 	     (return i))))))
    (t (item sequence &key from-end (test #'eql) test-not (start 0) end  (key 'identity))
@@ -224,10 +229,12 @@
 		((not from-end)
 		 (do ((i start (1+ i)))
 		     ((>= i end))
+		   (declare (index i))
 		   (when (test (key (sequence-ref i)) item)
 		     (return i))))
 		(t (do ((i (1- end) (1- i)))
 		       ((< i start))
+		     (declare (index i))
 		     (when (test (key (sequence-ref i)) item)
 		       (return i)))))))
 	    (list
@@ -245,6 +252,7 @@
 	      (t (do ((p (nthcdr start sequence))
 		      (i start (1+ i)))
 		     ((or (null p) (>= i end)) nil)
+		   (declare (index i))
 		   (when (test (key (pop p)) item)
 		     (return (if (not from-end) i
 			       (let ((next-i (position item p :end (- end 1 i) :from-end t
@@ -261,12 +269,14 @@
 	     (do ((end (length sequence))
 		  (i 0 (1+ i)))
 		 ((>= i end))
+	       (declare (index i end))
 	       (when (predicate (sequence-ref i))
 		 (return i)))))
 	  (list
 	   (do ((p sequence)
 		(i 0 (1+ i)))
 	       ((null p))
+	     (declare (index i))
 	     (when (predicate (pop p))
 	       (return i)))))))
    (t (predicate sequence &key (start 0) end (key 'identity) from-end)
@@ -322,6 +332,7 @@
        (do ((i 0 (1+ i))
 	    (j (1- (length sequence)) (1- j)))
 	   ((<= j i))
+	 (declare (index i j))
 	 (let ((x (sequence-ref i)))
 	   (setf (sequence-ref i) (sequence-ref j)
 		 (sequence-ref j) x))))
@@ -356,19 +367,19 @@
 		  (do* ((i start1 (1+ i))
 			(j start2 (1+ j)))
 		      ((>= i end1) nil)
-		    (declare (type (unsigned-byte 16) i j start1 end1 start2 end2))
+		    (declare (index i j))
 		    (test-return i j)))
 		 ((< length1 length2)
 		  (do* ((i start1 (1+ i))
 			(j start2 (1+ j)))
 		      ((>= i end1) end1)
-		    (declare ((unsigned-byte 16) i j start1 end1 start2 end2))
+		    (declare (index i j))
 		    (test-return i j)))
 		 ((> length1 length2)
 		  (do* ((i start1 (1+ i))
 			(j start2 (1+ j)))
 		      ((>= j end2) i)
-		    (declare ((unsigned-byte 16) i j start1 end1 start2 end2))
+		    (declare (index i j))
 		    (test-return i j))))))))
 	 (list
 	  (let ((length1 (- end1 start1))
@@ -380,23 +391,27 @@
 	      (do ((i1 start1 (1+ i1))
 		   (p2 start-cons2 (cdr p2)))
 		  ((>= i1 end1) (if (null p2) nil i1))
+		(declare (index i1))
 		(unless (and p2 (eql (seq1-ref i1) (car p2)))
 		  (return i1))))
 	     ((< length1 (- end2 start2))
 	      (do ((i1 start1 (1+ i1))
 		   (p2 start-cons2 (cdr p2)))
 		  ((>= i1 end1) end1)
+		(declare (index i1))
 		(unless (eql (seq1-ref i1) (car p2))
 		  (return i1))))
 	     ((> length1 (- end2 start2))
 	      (do ((i1 start1 (1+ i1))
 		   (p2 start-cons2 (cdr p2)))
 		  ((null p2) end1)
+		(declare (index i1))
 		(unless (eql (seq1-ref i1) (car p2))
 		  (return i1))))
 	     (t (do ((i1 start1 (1+ i1))
 		     (p2 start-cons2 (cdr p2)))
 		    ((null p2) nil)
+		  (declare (index i1))
 		  (unless (eql (seq1-ref i1) (car p2))
 		    (return i1))))))))))
     (list
@@ -416,6 +431,7 @@
 		 (p2 start-cons2 (cdr p2))
 		 (i1 start1 (1+ i1)))
 		((null p1) (if (null p2) nil i1))
+	      (declare (index i1))
 	      (unless (and p2 (eql (car p1) (car p2)))
 		(return i1))))
 	   (t (do ((p1 start-cons1 (cdr p1))
@@ -424,6 +440,7 @@
 		   (i2 start2 (1+ i2)))
 		  ((if end1 (>= i1 end1) (null p1))
 		   (if (if end2 (>= i2 end2) (null p2)) nil i1))
+		(declare (index i1 i2))
 		(unless (and (or (not end2) (< i1 end2))
 			     (eql (car p1) (car p2)))
 		  (return i1)))))))))))
@@ -456,29 +473,29 @@
 	     (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
 	       (sequence-dispatch sequence-2
 		 (vector
-		  (unless end2 (setf end2 (length sequence-2)))
-		  (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
-		    (macrolet ((test-return (index1 index2)
-				 `(unless (test (key (sequence-1-ref ,index1))
-						(key (sequence-2-ref ,index2)))
-				    (return-from mismatch ,index1))))
-		      (let ((length1 (- end1 start1))
-			    (length2 (- end2 start2)))
-			(cond
-			 ((< length1 length2)
-			  (dotimes (i length1)
-			    (declare ((unsigned-byte 16) i start1 start2))
-			    (test-return (+ start1 i) (+ start2 i)))
-			  end1)
-			 ((> length1 length2)
-			  (dotimes (i length2)
-			    (declare ((unsigned-byte 16) i start1 start2))
-			    (test-return (+ start1 i) (+ start2 i)))
-			  (+ start1 length2))
-			 (t (dotimes (i length1)
-			      (declare ((unsigned-byte 16) i start1 start2))
+		  (let ((end2 (check-the index (or end2 (length sequence-2)))))
+		    (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
+		      (macrolet ((test-return (index1 index2)
+				   `(unless (test (key (sequence-1-ref ,index1))
+						  (key (sequence-2-ref ,index2)))
+				      (return-from mismatch ,index1))))
+			(let ((length1 (- end1 start1))
+			      (length2 (- end2 start2)))
+			  (cond
+			   ((< length1 length2)
+			    (dotimes (i length1)
+			      (declare (index i))
 			      (test-return (+ start1 i) (+ start2 i)))
-			    nil))))))
+			    end1)
+			   ((> length1 length2)
+			    (dotimes (i length2)
+			      (declare (index i))
+			      (test-return (+ start1 i) (+ start2 i)))
+			    (+ start1 length2))
+			   (t (dotimes (i length1)
+				(declare (index i))
+				(test-return (+ start1 i) (+ start2 i)))
+			      nil)))))))
 		 (list
 		  (let ((length1 (- end1 start1))
 			(start-cons2 (nthcdr start2 sequence-2)))
@@ -489,23 +506,27 @@
 		      (do ((i1 start1 (1+ i1))
 			   (p2 start-cons2 (cdr p2)))
 			  ((>= i1 end1) (if (null p2) nil i1))
+			(declare (index i1))
 			(unless (and p2 (test (key (sequence-1-ref i1)) (key (car p2))))
 			  (return-from mismatch i1))))
 		     ((< length1 (- end2 start2))
 		      (do ((i1 start1 (1+ i1))
 			   (p2 start-cons2 (cdr p2)))
 			  ((>= i1 end1) end1)
+			(declare (index i1))
 			(unless (test (key (sequence-1-ref i1)) (key (car p2)))
 			  (return-from mismatch i1))))
 		     ((> length1 (- end2 start2))
 		      (do ((i1 start1 (1+ i1))
 			   (p2 start-cons2 (cdr p2)))
 			  ((null p2) end1)
+			(declare (index i1))
 			(unless (test (key (sequence-1-ref i1)) (key (car p2)))
 			  (return-from mismatch i1))))
 		     (t (do ((i1 start1 (1+ i1))
 			     (p2 start-cons2 (cdr p2)))
 			    ((null p2) nil)
+			  (declare (index i1))
 			  (unless (test (key (sequence-1-ref i1)) (key (car p2)))
 			    (return-from mismatch i1))))))))))
 	    (list
@@ -526,6 +547,7 @@
 			 (p2 start-cons2 (cdr p2))
 			 (i1 start1 (1+ i1)))
 			((null p1) (if (null p2) nil i1))
+		      (declare (index i1))
 		      (unless (and p2 (test (key (car p1)) (key (car p2))))
 			(return i1))))
 		   (t (do ((p1 start-cons1 (cdr p1))
@@ -534,6 +556,7 @@
 			   (i2 start2 (1+ i2)))
 			  ((if end1 (>= i1 end1) (null p1))
 			   (if (if end2 (>= i2 end2) (null p2)) nil i1))
+			(declare (index i1 i2))
 			(unless p2
 			  (if end2
 			      (error "Illegal end2 bounding index.")



From ffjeld at common-lisp.net  Mon Aug 22 23:05:49 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Aug 2005 01:05:49 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050822230549.A13FB8802E@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
More improvements to add.

Date: Tue Aug 23 01:05:37 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.154 movitz/compiler.lisp:1.155
--- movitz/compiler.lisp:1.154	Mon Aug 22 01:30:04 2005
+++ movitz/compiler.lisp	Tue Aug 23 01:05:35 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.154 2005/08/21 23:30:04 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.155 2005/08/22 23:05:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -3464,7 +3464,7 @@
        (t (list base-register offset))))))
 
 (defun make-load-lexical (binding result-mode funobj shared-reference-p frame-map
-			  &key tmp-register protect-registers)
+			  &key tmp-register protect-registers override-binding-type)
   "When tmp-register is provided, use that for intermediate storage required when
 loading borrowed bindings."
   #+ignore
@@ -3494,10 +3494,6 @@
 		  ((and (eq result-mode :untagged-fixnum-ecx)
 			(integerp lexb-location))
 		   (cond
-;;;		    ((and binding-type
-;;;			  (not (movitz-subtypep decoded-type '(unsigned-byte 32))))
-;;;		     (error "Can't load a value of type ~S as ~S."
-;;;			    :untagged-fixnum-ecx))
 		    ((and binding-type
 			  (type-specifier-singleton decoded-type))
 		     #+ignore (warn "Immloadlex: ~S"
@@ -3505,6 +3501,12 @@
 		     (make-immediate-move (movitz-immediate-value
 					   (car (type-specifier-singleton decoded-type)))
 					  :ecx))
+		    ((and binding-type
+			  (movitz-subtypep decoded-type '(and fixnum (unsigned-byte 32))))
+		     (assert (not indirect-p))
+		     (append (install-for-single-value lexb lexb-location :ecx nil)
+			     `((:shrl ,+movitz-fixnum-shift+ :ecx))))
+		    #+ignore ((warn "utecx ~S bt: ~S" lexb decoded-type))
 		    (t
 		     (assert (not indirect-p))
 		     (assert (not (member :eax protect-registers)))
@@ -3571,7 +3573,8 @@
 	 (assert (not (binding-lended-p binding)) (binding)
 	   "Can't lend a forwarding-binding ~S." binding)
 	 (make-load-lexical (forwarding-binding-target binding)
-			    result-mode funobj shared-reference-p frame-map))
+			    result-mode funobj shared-reference-p frame-map
+			    :override-binding-type (binding-store-type binding)))
 	(constant-object-binding
 	 (assert (not (binding-lended-p binding)) (binding)
 	   "Can't lend a constant-reference-binding ~S." binding)
@@ -3609,7 +3612,8 @@
 			      ,tmp-register)
 		       (:movl (,tmp-register -1) ,tmp-register))))))))))
 	(located-binding
-	 (let ((binding-type (binding-store-type binding))
+	 (let ((binding-type (or override-binding-type
+				 (binding-store-type binding)))
 	       (binding-location (new-binding-location binding frame-map)))
 	   #+ignore (warn "~S type: ~S ~:[~;lended~]"
 			  binding
@@ -6820,47 +6824,47 @@
 			      `((:movl :eax ,destination))))
 			   (binding
 			    (make-store-lexical destination :eax nil funobj frame-map))))))
-	  (cond
-	   ((type-specifier-singleton result-type)
-	    ;; (break "constant add: ~S" instruction)
-	    (make-load-constant (car (type-specifier-singleton result-type))
-				destination funobj frame-map))
-	   ((movitz-subtypep type0 '(integer 0 0))
+	  (let ((constant0 (let ((x (type-specifier-singleton type0)))
+			     (when x (movitz-immediate-value (car x)))))
+		(constant1 (let ((x (type-specifier-singleton type1)))
+			     (when x (movitz-immediate-value (car x))))))
 	    (cond
-	     ((eql destination loc1)
-	      #+ignore (break "NOP add: ~S" instruction)
-	      nil)
-	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   (member loc1 '(:eax :ebx :ecx :edx)))
-	      `((:movl ,loc1 ,destination-location)))
-	     ((integerp loc1)
-	      (make-load-lexical term1 destination-location funobj nil frame-map))
-	     #+ignore
-	     ((integerp destination-location)
-	      (make-store-lexical destination-location loc1 nil funobj frame-map))
-	     (t (break "Unknown X zero-add: ~S" instruction))))
-	   ((movitz-subtypep type1 '(integer 0 0))
-	    ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
-	    (cond
-	     ((eql destination loc0)
-	      #+ignore (break "NOP add: ~S" instruction)
-	      nil)
-	     ((and (member destination-location '(:eax :ebx :ecx :edx))
-		   (member loc0 '(:eax :ebx :ecx :edx)))
-	      `((:movl ,loc0 ,destination-location)))
-	     ((integerp loc0)
-	      (make-load-lexical term0 destination-location funobj nil frame-map))
-	     #+ignore
-	     ((integerp destination-location)
-	      (make-store-lexical destination-location loc0 nil funobj frame-map))
-	     (t (break "Unknown Y zero-add: ~S" instruction))))
-	   ((and (movitz-subtypep type0 'fixnum)
-		 (movitz-subtypep type1 'fixnum)
-		 (movitz-subtypep result-type 'fixnum))
-	    (let ((constant0 (let ((x (type-specifier-singleton type0)))
-			       (when x (movitz-immediate-value (car x)))))
-		  (constant1 (let ((x (type-specifier-singleton type1)))
-			       (when x (movitz-immediate-value (car x))))))
+	     ((type-specifier-singleton result-type)
+	      ;; (break "constant add: ~S" instruction)
+	      (make-load-constant (car (type-specifier-singleton result-type))
+				  destination funobj frame-map))
+	     ((movitz-subtypep type0 '(integer 0 0))
+	      (cond
+	       ((eql destination loc1)
+		#+ignore (break "NOP add: ~S" instruction)
+		nil)
+	       ((and (member destination-location '(:eax :ebx :ecx :edx))
+		     (member loc1 '(:eax :ebx :ecx :edx)))
+		`((:movl ,loc1 ,destination-location)))
+	       ((integerp loc1)
+		(make-load-lexical term1 destination-location funobj nil frame-map))
+	       #+ignore
+	       ((integerp destination-location)
+		(make-store-lexical destination-location loc1 nil funobj frame-map))
+	       (t (break "Unknown X zero-add: ~S" instruction))))
+	     ((movitz-subtypep type1 '(integer 0 0))
+	      ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
+	      (cond
+	       ((eql destination loc0)
+		#+ignore (break "NOP add: ~S" instruction)
+		nil)
+	       ((and (member destination-location '(:eax :ebx :ecx :edx))
+		     (member loc0 '(:eax :ebx :ecx :edx)))
+		`((:movl ,loc0 ,destination-location)))
+	       ((integerp loc0)
+		(make-load-lexical term0 destination-location funobj nil frame-map))
+	       #+ignore
+	       ((integerp destination-location)
+		(make-store-lexical destination-location loc0 nil funobj frame-map))
+	       (t (break "Unknown Y zero-add: ~S" instruction))))
+	     ((and (movitz-subtypep type0 'fixnum)
+		   (movitz-subtypep type1 'fixnum)
+		   (movitz-subtypep result-type 'fixnum))
 	      (assert (not (and constant0 (zerop constant0))))
 	      (assert (not (and constant1 (zerop constant1))))
 	      (cond
@@ -6933,6 +6937,18 @@
 		       constant1
 		       (member loc0 '(:eax :ebx :ecx :edx)))
 		  `((:leal (,loc0 ,constant1) ,destination-location)))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       constant0
+		       (eq :argument-stack (operator loc1)))
+		  `((:movl (:ebp ,(argument-stack-offset (binding-target term1)))
+			   ,destination-location)
+		    (:addl ,constant0 ,destination-location)))
+		 ((and (member destination-location '(:eax :ebx :ecx :edx))
+		       constant1
+		       (eq :argument-stack (operator loc0)))
+		  `((:movl (:ebp ,(argument-stack-offset (binding-target term0)))
+			   ,destination-location)
+		    (:addl ,constant1 ,destination-location)))
 		 (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
 			  destination-location
 			  destination
@@ -6979,8 +6995,28 @@
 				 (binding-lended-p (binding-target term0))
 				 (binding-lended-p (binding-target term1)))))
 	       (t (warn "Unknown fixnum add: ~S" instruction)
-		  (make-default-add)))))
-	   (t (make-default-add))))))))
+		  (make-default-add))))
+	     #+ignore
+	     ((and (movitz-subtypep result-type '(unsigned-byte 32))
+		   (movitz-subtypep type0 'fixnum)
+		   (movitz-subtypep type1 'fixnum))
+	      (cond
+	       ((and (not (binding-lended-p (binding-target term0)))
+		     (not (binding-lended-p (binding-target term1)))
+		     (not (and (bindingp destination)
+			       (binding-lended-p (binding-target destination)))))
+		(cond
+		 ((and (not constant0)
+		       (not constant1)
+		       (member destination-location '(:eax :ebx :edx)))
+		  (print-code instruction
+			      (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map)
+				      `((,*compiler-local-segment-prefix*
+					 :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0))))
+				      )))
+		 (t (make-default-add))))
+	       (t (make-default-add))))
+	     (t (make-default-add)))))))))
 
 ;;;;;;;
 



From ffjeld at common-lisp.net  Tue Aug 23 16:09:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Aug 2005 18:09:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <20050823160906.989C5884C2@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
More index declarations.

Date: Tue Aug 23 18:09:03 2005
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.24 movitz/losp/muerte/sequences.lisp:1.25
--- movitz/losp/muerte/sequences.lisp:1.24	Mon Aug 22 19:03:00 2005
+++ movitz/losp/muerte/sequences.lisp	Tue Aug 23 18:09:02 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.24 2005/08/22 17:03:00 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.25 2005/08/23 16:09:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -121,44 +121,46 @@
 			  (result (funcall-function (sequence-ref (prog1 index (incf index)))
 						    (sequence-ref (prog1 index (incf index))))
 				  (funcall-function result (sequence-ref (prog1 index (incf index))))))
-			((= index end) result))))))))))
+			((= index end) result)
+		      (declare (index index)))))))))))
    (t (function sequence &key (key 'identity) from-end
 		(start 0) (end (length sequence))
 		(initial-value nil initial-value-p))
       (when from-end
 	(error "REDUCE from-end is not implemented."))
-      (with-funcallable (funcall-function function)
-	(with-funcallable (key)
-	  (case (- end start)
-	    (0 (if initial-value-p
-		   initial-value
-		 (funcall-function)))
-	    (1 (if initial-value-p
-		   (funcall-function initial-value (key (elt sequence start)))
-		 (key (elt sequence start))))
-	    (t (sequence-dispatch sequence
-		 (list
-		  (do* ((counter (1+ start) (1+ counter))
-			(list (nthcdr start sequence))
-			(result (funcall-function (if initial-value-p
-						      initial-value
-						    (key (pop list)))
-						  (key (pop list)))
-				(funcall-function result (key (pop list)))))
-		      ((or (null list)
-			   (= end counter))
-		       result)
-		    (declare (index counter))))
-		 (vector
-		  (with-subvector-accessor (sequence-ref sequence start end)
-		    (do* ((index start)
+      (let ((start (check-the index start)))
+	(with-funcallable (funcall-function function)
+	  (with-funcallable (key)
+	    (case (- end start)
+	      (0 (if initial-value-p
+		     initial-value
+		   (funcall-function)))
+	      (1 (if initial-value-p
+		     (funcall-function initial-value (key (elt sequence start)))
+		   (key (elt sequence start))))
+	      (t (sequence-dispatch sequence
+		   (list
+		    (do* ((counter (1+ start) (1+ counter))
+			  (list (nthcdr start sequence))
 			  (result (funcall-function (if initial-value-p
 							initial-value
+						      (key (pop list)))
+						    (key (pop list)))
+				  (funcall-function result (key (pop list)))))
+			((or (null list)
+			     (= end counter))
+			 result)
+		      (declare (index counter))))
+		   (vector
+		    (with-subvector-accessor (sequence-ref sequence start end)
+		      (do* ((index start)
+			    (result (funcall-function (if initial-value-p
+							  initial-value
+							(key (sequence-ref (prog1 index (incf index)))))
 						      (key (sequence-ref (prog1 index (incf index)))))
-						    (key (sequence-ref (prog1 index (incf index)))))
-				  (funcall-function result (sequence-ref (prog1 index (incf index))))))
-			((= index end) result)
-		      (declare (index index)))))))))))))
+				    (funcall-function result (sequence-ref (prog1 index (incf index))))))
+			  ((= index end) result)
+			(declare (index index))))))))))))))
 
 (defun subseq (sequence start &optional end)
   (sequence-dispatch sequence
@@ -591,6 +593,7 @@
 	      (i 0 (1+ i))
 	      (p first-sequence (cdr p)))
 	     ((or (endp p) (>= i end)) result-sequence)
+	   (declare (index i))
 	   (setf (result-ref i) (map (car p))))))
       ((list vector)
        (with-subvector-accessor (first-ref first-sequence)
@@ -598,6 +601,7 @@
 	      (i 0 (1+ i))
 	      (p result-sequence (cdr p)))
 	     ((or (endp p) (>= i end)) result-sequence)
+	   (declare (index i))
 	   (setf (car p) (map (first-ref i)))))))))
 
 (defun map-for-nil (function first-sequence &rest more-sequences)
@@ -629,6 +633,7 @@
 		    (j 0 (1+ j)))
 		   ((or (>= i len1)
 			(>= j len2)))
+		 (declare (index i j))
 		 (mapf (first-sequence-ref i) (second-sequence-ref j))))))
 	  )))
    (t (function first-sequence &rest more-sequences)
@@ -665,6 +670,7 @@
 		   ((or (>= i len1)
 			(>= j len2))
 		    (nreverse result))
+		 (declare (index i j))
 		 (push (mapf (first-sequence-ref i) (second-sequence-ref j))
 		       result))))))
 	((list vector)
@@ -676,6 +682,7 @@
 		  (j 0 (1+ j)))
 		 ((or (endp p) (>= j len2))
 		  (nreverse result))
+	       (declare (index j))
 	       (push (mapf (car p) (second-sequence-ref j))
 		     result)))))
 	((vector list)
@@ -687,6 +694,7 @@
 		  (j 0 (1+ j)))
 		 ((or (endp p) (>= j len1))
 		  (nreverse result))
+	       (declare (index j))
 	       (push (mapf (first-sequence-ref j) (car p))
 		     result)))))))
    (t (function first-sequence &rest more-sequences)
@@ -703,10 +711,12 @@
 	    (vector
 	     (do ((i 0 (1+ i)))
 		 ((>= i (length result)) result)
+	       (declare (index i))
 	       (setf (char result i) (mapf (aref first-sequence i)))))
 	    (list
 	     (do ((i 0 (1+ i)))
 		 ((>= i (length result)) result)
+	       (declare (index i))
 	       (setf (char result i) (mapf (pop first-sequence)))))))))
    (t (function first-sequence &rest more-sequences)
       (declare (ignore function first-sequence more-sequences))
@@ -727,116 +737,127 @@
 
 (defun fill (sequence item &key (start 0) end)
   "=> sequence"
-  (etypecase sequence
-    (list
-     (do ((p (nthcdr start sequence) (cdr p))
-	  (i start (1+ i)))
-	 ((or (null p) (and end (>= i end))))
-       (setf (car p) item)))
-    ((simple-array (unsigned-byte 32) 1)
-     (let* ((length (array-dimension sequence 0))
-	    (end (or end length)))
-       (unless (<= 0 end length)
-	 (error 'index-out-of-range :index end :range length))
-       (do ((i start (1+ i)))
-	   ((>= i end))
-	 (declare (type index i))
-	 (setf (memref sequence (movitz-type-slot-offset 'movitz-basic-vector 'data)
-		       :index i
-		       :type :unsigned-byte32)
-	   item))))
-    (vector
-     (let ((end (or end (length sequence))))
-       (with-subvector-accessor (sequence-ref sequence start end)
+  (let ((start (check-the index start)))
+    (etypecase sequence
+      (list
+       (do ((p (nthcdr start sequence) (cdr p))
+	    (i start (1+ i)))
+	   ((or (null p) (and end (>= i end))))
+	 (declare (index i))
+	 (setf (car p) item)))
+      ((simple-array (unsigned-byte 32) 1)
+       (let* ((length (array-dimension sequence 0))
+	      (end (or end length)))
+	 (unless (<= 0 end length)
+	   (error 'index-out-of-range :index end :range length))
 	 (do ((i start (1+ i)))
 	     ((>= i end))
 	   (declare (index i))
-	   (setf (sequence-ref i) item))))))
+	   (setf (memref sequence (movitz-type-slot-offset 'movitz-basic-vector 'data)
+			 :index i
+			 :type :unsigned-byte32)
+	     item))))
+      (vector
+       (let ((end (or end (length sequence))))
+	 (with-subvector-accessor (sequence-ref sequence start end)
+	   (do ((i start (1+ i)))
+	       ((>= i end))
+	     (declare (index i))
+	     (setf (sequence-ref i) item)))))))
   sequence)
 
 (defun replace (sequence-1 sequence-2 &key (start1 0) end1 (start2 0) end2)
-  (cond
-   ((and (eq sequence-1 sequence-2)
-	 (<= start2 start1 (or end2 start1)))
-    (if (= start1 start2)
-	sequence-1			; no need to copy anything
-      ;; must copy in reverse direction
-      (sequence-dispatch sequence-1
-	(vector
-	 (let ((l (length sequence-1)))
-	   (setf end1 (or end1 l)
-		 end2 (or end2 l))
-	   (assert (<= 0 start2 end2 l)))
-	 (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
-	   (do* ((length (min (- end1 start1) (- end2 start2)))
-		 (i (+ start1 length -1) (1- i))
-		 (j (+ start2 length -1) (1- j)))
-	       ((< i start1) sequence-1)
-	     (declare (index i j length))
-	     (setf (sequence-1-ref i)
-	       (sequence-1-ref j)))))
-	(list
-	 (let* ((length (length sequence-1))
-		(reverse-list (nreverse sequence-1))
-		(size (min (- (or end1 length) start1) (- (or end2 length) start2))))
-	   (do ((p (nthcdr (- length start1 size) reverse-list) (cdr p))
-		(q (nthcdr (- length start2 size) reverse-list) (cdr q))
-		(i 0 (1+ i)))
-	       ((>= i size) (nreverse reverse-list))
-	     (setf (car p) (car q))))))))
-   ;; (not (eq sequence-1 sequence-2)) ..
-   (t (sequence-dispatch sequence-1
-	(vector
-	 (setf end1 (or end1 (length sequence-1)))
-	 (sequence-dispatch sequence-2
-	   (vector
-	    (setf end2 (or end2 (length sequence-2)))
-	    (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
-	      (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
-		(cond
-		 ((< (- end1 start1) (- end2 start2))
-		  (do ((i start1 (1+ i))
-		       (j start2 (1+ j)))
-		      ((>= i end1) sequence-1)
-		    (setf (sequence-1-ref i) (sequence-2-ref j))))
-		 (t (do ((i start1 (1+ i))
+  (let ((start1 (check-the index start1))
+	(start2 (check-the index start2)))
+    (cond
+     ((and (eq sequence-1 sequence-2)
+	   (<= start2 start1 (or end2 start1)))
+      (if (= start1 start2)
+	  sequence-1			; no need to copy anything
+	;; must copy in reverse direction
+	(sequence-dispatch sequence-1
+	  (vector
+	   (let ((l (length sequence-1)))
+	     (setf end1 (or end1 l)
+		   end2 (or end2 l))
+	     (assert (<= 0 start2 end2 l)))
+	   (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
+	     (do* ((length (min (- end1 start1) (- end2 start2)))
+		   (i (+ start1 length -1) (1- i))
+		   (j (+ start2 length -1) (1- j)))
+		 ((< i start1) sequence-1)
+	       (declare (index i j length))
+	       (setf (sequence-1-ref i)
+		 (sequence-1-ref j)))))
+	  (list
+	   (let* ((length (length sequence-1))
+		  (reverse-list (nreverse sequence-1))
+		  (size (min (- (or end1 length) start1) (- (or end2 length) start2))))
+	     (do ((p (nthcdr (- length start1 size) reverse-list) (cdr p))
+		  (q (nthcdr (- length start2 size) reverse-list) (cdr q))
+		  (i 0 (1+ i)))
+		 ((>= i size) (nreverse reverse-list))
+	       (delcare (index i))
+	       (setf (car p) (car q))))))))
+     ;; (not (eq sequence-1 sequence-2)) ..
+     (t (sequence-dispatch sequence-1
+	  (vector
+	   (setf end1 (or end1 (length sequence-1)))
+	   (sequence-dispatch sequence-2
+	     (vector
+	      (setf end2 (or end2 (length sequence-2)))
+	      (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
+		(with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
+		  (cond
+		   ((< (- end1 start1) (- end2 start2))
+		    (do ((i start1 (1+ i))
 			 (j start2 (1+ j)))
-			((>= j end2) sequence-1)
-		      (setf (sequence-1-ref i) (sequence-2-ref j))))))))
-	   (list
-	    (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
-	      (if (not end2)
+			((>= i end1) sequence-1)
+		      (decare (index i j))
+		      (setf (sequence-1-ref i) (sequence-2-ref j))))
+		   (t (do ((i start1 (1+ i))
+			   (j start2 (1+ j)))
+			  ((>= j end2) sequence-1)
+			(decare (index i j))
+			(setf (sequence-1-ref i) (sequence-2-ref j))))))))
+	     (list
+	      (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
+		(if (not end2)
+		    (do ((i start1 (1+ i))
+			 (p (nthcdr start2 sequence-2) (cdr p)))
+			((or (null p) (>= i end1)) sequence-1)
+		      (declare (index i))
+		      (setf (sequence-1-ref i) (car p)))
 		  (do ((i start1 (1+ i))
+		       (j start2 (1+ j))
 		       (p (nthcdr start2 sequence-2) (cdr p)))
-		      ((or (null p) (>= i end1)) sequence-1)
-		    (setf (sequence-1-ref i) (car p)))
-		(do ((i start1 (1+ i))
-		     (j start2 (1+ j))
-		     (p (nthcdr start2 sequence-2) (cdr p)))
-		    ((or (>= i end1) (endp p) (>= j end2)) sequence-1)
-		  (setf (sequence-1-ref i) (car p))))))))
-	(list
-	 (sequence-dispatch sequence-2
-	   (vector
-	    (setf end2 (or end2 (length sequence-2)))
-	    (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
-	      (do ((p (nthcdr start1 sequence-1) (cdr p))
-		   (i start1 (1+ i))
-		   (j start2 (1+ j)))
-		  ((or (endp p) (>= j end2) (and end1 (>= i end1)))
+		      ((or (>= i end1) (endp p) (>= j end2)) sequence-1)
+		    (declare (index i j))
+		    (setf (sequence-1-ref i) (car p))))))))
+	  (list
+	   (sequence-dispatch sequence-2
+	     (vector
+	      (setf end2 (or end2 (length sequence-2)))
+	      (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
+		(do ((p (nthcdr start1 sequence-1) (cdr p))
+		     (i start1 (1+ i))
+		     (j start2 (1+ j)))
+		    ((or (endp p) (>= j end2) (and end1 (>= i end1)))
+		     sequence-1)
+		  (declare (index i j))
+		  (setf (car p) (sequence-2-ref j)))))
+	     (list
+	      (do ((i start1 (1+ i))
+		   (j start2 (1+ j))
+		   (p (nthcdr start1 sequence-1) (cdr p))
+		   (q (nthcdr start2 sequence-2) (cdr q)))
+		  ((or (endp p) (endp q)
+		       (and end1 (>= i end1))
+		       (and end2 (>= j end2)))
 		   sequence-1)
-		(setf (car p) (sequence-2-ref j)))))
-	   (list
-	    (do ((i start1 (1+ i))
-		 (j start2 (1+ j))
-		 (p (nthcdr start1 sequence-1) (cdr p))
-		 (q (nthcdr start2 sequence-2) (cdr q)))
-		((or (endp p) (endp q)
-		     (and end1 (>= i end1))
-		     (and end2 (>= j end2)))
-		 sequence-1)
-	      (setf (car p) (car q)))))))
-      sequence-1)))
+		(declare (index i j))
+		(setf (car p) (car q)))))))
+	sequence-1))))
 
 (defun find (item sequence &key from-end (test 'eql) (start 0) end (key 'identity))
   (numargs-case
@@ -852,37 +873,41 @@
 	   (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)
+      (let ((start (check-the index start)))
+	(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)
+		       (declare (index i))
+		       (when (test item (key (aref sequence i)))
+			 (return (sequence-ref i))))
+		   (do ((i (1- end) (1- i)))
+		       ((< i start) nil)
+		     (declare (index i))
+		     (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)
+		     (declare (index i))
+		     (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 :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)))))))))))))
+		     (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))
@@ -895,6 +920,7 @@
 	     (with-subvector-accessor (sequence-ref sequence 0 end)
 	       (do ((i 0 (1+ i)))
 		   ((>= i end))
+		 (declare (index i))
 		 (let ((x (sequence-ref i)))
 		   (when (predicate x) (return x)))))))
 	  (list
@@ -903,38 +929,42 @@
 	     (let ((x (car p)))
 	       (when (predicate x) (return x))))))))
    (t (predicate sequence &key from-end (start 0) end (key 'identity))
-      (with-funcallable (predicate)
-	(with-funcallable (key)
-	  (sequence-dispatch sequence
-	    (vector
-	     (setf end (or end (length sequence)))
-	     (with-subvector-accessor (sequence-ref sequence start end)
-	       (cond
-		((not from-end)
-		 (do ((i start (1+ i)))
-		     ((>= i end))
-		   (when (predicate (key (sequence-ref i)))
-		     (return (sequence-ref i)))))
-		(t (do ((i (1- end) (1- i)))
-		       ((< i start))
+      (let ((start (check-the index start)))
+	(with-funcallable (predicate)
+	  (with-funcallable (key)
+	    (sequence-dispatch sequence
+	      (vector
+	       (setf end (or end (length sequence)))
+	       (with-subvector-accessor (sequence-ref sequence start end)
+		 (cond
+		  ((not from-end)
+		   (do ((i start (1+ i)))
+		       ((>= i end))
+		     (declare (index i))
 		     (when (predicate (key (sequence-ref i)))
-		       (return (sequence-ref i))))))))
-	    (list
-	     (cond
-	      (end
-	       (do ((p (nthcdr start sequence) (cdr p))
-		    (i start (1+ i)))
-		   ((or (>= i end) (endp p)) nil)
-		 (when (predicate (key (car p)))
-		   (return (or (and from-end
-				    (find-if predicate (cdr p) :end (- end i 1) :key key :from-end t))
-			       (car p))))))
-	      (t (do ((p (nthcdr start sequence) (cdr p)))
-		     ((endp p) nil)
+		       (return (sequence-ref i)))))
+		  (t (do ((i (1- end) (1- i)))
+			 ((< i start))
+		       (declare (index i))
+		       (when (predicate (key (sequence-ref i)))
+			 (return (sequence-ref i))))))))
+	      (list
+	       (cond
+		(end
+		 (do ((p (nthcdr start sequence) (cdr p))
+		      (i start (1+ i)))
+		     ((or (>= i end) (endp p)) nil)
+		   (declare (index i))
 		   (when (predicate (key (car p)))
 		     (return (or (and from-end
-				      (find-if predicate (cdr p) :key key :from-end t))
-				 (car p))))))))))))))
+				      (find-if predicate (cdr p) :end (- end i 1) :key key :from-end t))
+				 (car p))))))
+		(t (do ((p (nthcdr start sequence) (cdr p)))
+		       ((endp p) nil)
+		     (when (predicate (key (car p)))
+		       (return (or (and from-end
+					(find-if predicate (cdr p) :key key :from-end t))
+				   (car p)))))))))))))))
 
 (defun find-if-not (predicate sequence &rest key-args)
   (declare (dynamic-extent key-args))
@@ -942,38 +972,43 @@
   
 (defun count (item sequence &key (start 0) end (test 'eql) (key 'identity) test-not from-end)
   (declare (ignore test-not))
-  (with-funcallable (test)
-    (with-funcallable (key)
-      (sequence-dispatch sequence
-	(vector
-	 (setf end (or end (length sequence)))
-	 (with-subvector-accessor (sequence-ref sequence start end)
+  (let ((start (check-the index start)))
+    (with-funcallable (test)
+      (with-funcallable (key)
+	(sequence-dispatch sequence
+	  (vector
+	   (let ((end (check-the index (or end (length sequence)))))
+	     (with-subvector-accessor (sequence-ref sequence start end)
+	       (cond
+		((not from-end)
+		 (do ((i start (1+ i))
+		      (n 0))
+		     ((>= i end) n)
+		   (declare (index i n))
+		   (when (test item (key (sequence-ref i)))
+		     (incf n))))
+		(t (do ((i (1- end) (1- i))
+			(n 0))
+		       ((< i start) n)
+		     (declare (index i n))
+		     (when (test item (key (sequence-ref i)))
+		       (incf n))))))))
+	  (list
 	   (cond
-	    ((not from-end)
-	     (do ((i start (1+ i))
+	    ((not end)
+	     (do ((p (nthcdr start sequence) (cdr p))
 		  (n 0))
-		 ((>= i end) n)
-	       (when (test item (key (sequence-ref i)))
+		 ((endp p) n)
+	       (declare (index n))
+	       (when (test item (key (car p)))
 		 (incf n))))
-	    (t (do ((i (1- end) (1- i))
+	    (t (do ((p (nthcdr start sequence) (cdr p))
+		    (i start (1+ i))
 		    (n 0))
-		   ((< i start) n)
-		 (when (test item (key (sequence-ref i)))
-		   (incf n)))))))
-	(list
-	 (cond
-	  ((not end)
-	   (do ((p (nthcdr start sequence) (cdr p))
-		(n 0))
-	       ((endp p) n)
-	     (when (test item (key (car p)))
-	       (incf n))))
-	  (t (do ((p (nthcdr start sequence) (cdr p))
-		  (i start (1+ i))
-		  (n 0))
-		 ((or (endp p) (>= i end)) n)
-	       (when (test item (key (car p)))
-		 (incf n))))))))))
+		   ((or (endp p) (>= i end)) n)
+		 (declare (index i n))
+		 (when (test item (key (car p)))
+		   (incf n)))))))))))
 
 (defun count-if (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end)
   (numargs-case
@@ -982,6 +1017,7 @@
 	(sequence-dispatch sequence
 	  (list
 	   (let ((count 0))
+	     (declare (index count))
 	     (dolist (x sequence)
 	       (when (predicate x)
 		 (incf count)))
@@ -989,29 +1025,34 @@
 	  (vector
 	   (with-subvector-accessor (sequence-ref sequence)
 	     (let ((count 0))
+	       (declare (index count))
 	       (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."))))))))
+      (let ((start (check-the index start)))
+	(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)
+		     (declare (index n))
+		     (when (predicate (key (car p)))
+		       (incf n)))
+		 (let ((end (check-the index end)))
+		   (do ((n 0)
+			(i start (1+ i))
+			(p (nthcdr start sequence) (cdr p)))
+		       ((or (endp p) (>= i end)) n)
+		     (declare (index i n))
+		     (when (predicate (key (car p)))
+		       (incf n))))))
+	      (vector
+	       (error "vector count-if not implemented.")))))))))
 
 
 (macrolet ((every-some-body ()
@@ -1028,6 +1069,7 @@
 		     (do* ((l (length first-sequence))
 			   (i 0 (1+ i)))
 			 ((= l i) (default-value))
+		       (declare (index i l))
 		       (test-return (predicate (aref first-sequence i)))))))
 		 ((null (cdr more-sequences)) ; 2 sequences case
 		  (let ((second-sequence (first more-sequences)))
@@ -1041,6 +1083,7 @@
 		       (do ((end (min (length first-sequence) (length second-sequence)))
 			    (i 0 (1+ i)))
 			   ((>= i end) (default-value))
+			 (declare (index i))
 			 (test-return (predicate (aref first-sequence i)
 						 (aref second-sequence i)))))
 		      ((list vector)
@@ -1048,12 +1091,14 @@
 			    (i 0 (1+ i))
 			    (p first-sequence (cdr p)))
 			   ((or (endp p) (>= i end)) (default-value))
+			 (declare (index i))
 			 (test-return (predicate (car p) (aref second-sequence i)))))
 		      ((vector list)
 		       (do ((end (length first-sequence))
 			    (i 0 (1+ i))
 			    (p second-sequence (cdr p)))
 			   ((or (endp p) (>= i end)) (default-value))
+			 (declare (index i))
 			 (test-return (predicate (aref first-sequence i) (car p))))))))
 		 (t (flet ((next (p)
 			     (sequence-dispatch p
@@ -1080,6 +1125,7 @@
 				 (when (seqend p i)
 				   (return t))))
 			   (default-value))
+			(declare (index i))
 			(do ((x arg3+ (cdr x))
 			     (y p3+ (cdr y)))
 			    ((null x))
@@ -1120,6 +1166,7 @@
 		 (p0 list (cdr p0))
 		 (p1 (cdr list) (cdr p1)))
 		((or (endp p1) (and end (>= i end))) list)
+	      (declare (index i))
 	      (when (test item (key (car p1)))
 		(return
 		  ;; reiterate from <list> to <p1>, consing up a copy, with
@@ -1147,6 +1194,7 @@
 	   (p0 list (cdr p0))
 	   (p1 (cdr list) (cdr p1)))
 	  ((endp p1) list)
+	(declare (index i))
 	(when (eql item (car p1))
 	  (return
 	    ;; reiterate from <list> to <p1>, consing up a copy, with
@@ -1199,6 +1247,7 @@
 		 (p0 list (cdr p0))
 		 (p1 (cdr list) (cdr p1)))
 		((or (endp p1) (and end (>= i end))) list)
+	      (declare (index i))
 	      (when (test (key (car p1)))
 		(return
 		  ;; reiterate from <list> to <p1>, consing up a copy, with
@@ -1246,6 +1295,7 @@
 	(with-funcallable (key)
 	  (let ((i 0)			; for end checking
 		(c 0))			; for count checking
+	    (declare (index i c))
 	    (cond
 	     ((= 0 start)
 	      ;; delete from head..
@@ -1286,6 +1336,7 @@
 	(with-funcallable (key)
 	  (let ((i 0)			; for end checking
 		(c 0))			; for count checking
+	    (declare (index i c))
 	    (cond
 	     ((= 0 start)
 	      ;; delete from head..
@@ -1398,112 +1449,121 @@
 		  (complement test-not)
 		test)))
     (declare (dynamic-extent test))
-    (sequence-dispatch sequence-2
-      (vector
-       (unless end1
-	 (setf end1 (length sequence-1)))
-       (unless end2
-	 (setf end2 (length sequence-2)))
-       (do ((stop (- end2 (- end1 start1 1)))
-	    (i start2 (1+ i)))
-	   ((>= i stop) nil)
-	 (let ((mismatch-position (mismatch sequence-1 sequence-2
-					    :start1 start1 :end1 end1
-					    :start2 i :end2 end2
-					    :key key :test test)))
-	   (when (or (not mismatch-position)
-		     (= mismatch-position end1))
-	     (return (or (and from-end
-			      (search sequence-1 sequence-2
-				      :from-end t :test test :key key
-				      :start1 start1 :end1 end1
-				      :start2 (1+ i) :end2 end2))
-			 i))))))
-      (list
-       (unless end1
-	 (setf end1 (length sequence-1)))
-       (do ((stop (and end2 (- end2 start2 (- end1 start1 1))))
-	    (p (nthcdr start2 sequence-2) (cdr p))
-	    (i 0 (1+ i)))
-	   ((or (endp p) (and stop (>= i stop))) nil)
-	 (let ((mismatch-position (mismatch sequence-1 p
-					    :start1 start1 :end1 end1
-					    :key key :test test)))
-	   (when (or (not mismatch-position)
-		     (= mismatch-position end1))
-	     (return (+ start2 i
-			(or (and from-end
-				 (search sequence-1 p
-					 :start2 1 :end2 (and end2 (- end2 i start2))
-					 :from-end t :test test :key key
-					 :start1 start1 :end1 end1))
-			    0))))))))))
-
+    (let ((start1 (check-the index start1))
+	  (start2 (check-the index start2)))
+      (sequence-dispatch sequence-2
+	(vector
+	 (let ((end1 (check-the index (or end1 (length sequence-1))))
+	       (end2 (check-the index (or end2 (length sequence-2)))))
+	   (do ((stop (- end2 (- end1 start1 1)))
+		(i start2 (1+ i)))
+	       ((>= i stop) nil)
+	     (declare (index i))
+	     (let ((mismatch-position (mismatch sequence-1 sequence-2
+						:start1 start1 :end1 end1
+						:start2 i :end2 end2
+						:key key :test test)))
+	       (when (or (not mismatch-position)
+			 (= mismatch-position end1))
+		 (return (or (and from-end
+				  (search sequence-1 sequence-2
+					  :from-end t :test test :key key
+					  :start1 start1 :end1 end1
+					  :start2 (1+ i) :end2 end2))
+			     i)))))))
+	(list
+	 (let ((end1 (check-the index (or end1 (length sequence-1)))))
+	   (do ((stop (and end2 (- end2 start2 (- end1 start1 1))))
+		(p (nthcdr start2 sequence-2) (cdr p))
+		(i 0 (1+ i)))
+	       ((or (endp p) (and stop (>= i stop))) nil)
+	     (declare (index i))
+	     (let ((mismatch-position (mismatch sequence-1 p
+						:start1 start1 :end1 end1
+						:key key :test test)))
+	       (when (or (not mismatch-position)
+			 (= mismatch-position end1))
+		 (return (+ start2 i
+			    (or (and from-end
+				     (search sequence-1 p
+					     :start2 1 :end2 (and end2 (- end2 i start2))
+					     :from-end t :test test :key key
+					     :start1 start1 :end1 end1))
+				0))))))))))))
 
 (defun insertion-sort (vector predicate key start end)
   "Insertion-sort is used for stable-sort, and as a finalizer for
 quick-sort with cut-off greater than 1."
-  (with-funcallable (predicate)
-    (with-subvector-accessor (vector-ref vector start end)
-      (if (not key)
-	  (do ((i (1+ start) (1+ i)))
-	      ((>= i end))
-	    ;; insert vector[i] into [start...i-1]
-	    (let ((v (vector-ref i))
-		  (j (1- i)))
-	      (when (predicate v (vector-ref j))
-		(setf (vector-ref i) (vector-ref j))
-		(do* ((j+1 j (1- j+1))
-		      (j (1- j) (1- j)))
-		    ((or (< j start)
-			 (not (predicate v (vector-ref j))))
-		     (setf (vector-ref j+1) v))
-		  (setf (vector-ref j+1) (vector-ref j))))))
-	(with-funcallable (key)
-	  (do ((i (1+ start) (1+ i)))	; the same, only with a key-function..
-	      ((>= i end))
-	    ;; insert vector[i] into [start...i-1]
-	    (do* ((v (vector-ref i))
-		  (vk (key v))
-		  (j (1- i) (1- j))
-		  (j+1 i (1- j+1)))
-		((or (<= j+1 start)
-		     (not (predicate vk (key (vector-ref j)))))
-		 (setf (vector-ref j+1) v))
-	      (setf (vector-ref j+1) (vector-ref j))))))))
+  (let ((start (check-the index start))
+	(end (check-the index end)))
+    (with-funcallable (predicate)
+      (with-subvector-accessor (vector-ref vector start end)
+	(if (not key)
+	    (do ((i (1+ start) (1+ i)))
+		((>= i end))
+	      (declare (index i))
+	      ;; insert vector[i] into [start...i-1]
+	      (let ((v (vector-ref i))
+		    (j (1- i)))
+		(when (predicate v (vector-ref j))
+		  (setf (vector-ref i) (vector-ref j))
+		  (do* ((j+1 j (1- j+1))
+			(j (1- j) (1- j)))
+		      ((or (< j start)
+			   (not (predicate v (vector-ref j))))
+		       (setf (vector-ref j+1) v))
+		    (declare (index j j+1))
+		    (setf (vector-ref j+1) (vector-ref j))))))
+	  (with-funcallable (key)
+	    (do ((i (1+ start) (1+ i)))	; the same, only with a key-function..
+		((>= i end))
+	      (declare (index i))
+	      ;; insert vector[i] into [start...i-1]
+	      (do* ((v (vector-ref i))
+		    (vk (key v))
+		    (j (1- i) (1- j))
+		    (j+1 i (1- j+1)))
+		  ((or (<= j+1 start)
+		       (not (predicate vk (key (vector-ref j)))))
+		   (setf (vector-ref j+1) v))
+		(declare (index j j+1))
+		(setf (vector-ref j+1) (vector-ref j)))))))))
   vector)
 
 (defun quick-sort (vector predicate key start end cut-off)
-  (macrolet ((do-while (p &body body)
-	       `(do () ((not ,p)) , at body)))
-    (when (> (- end start) cut-off)
-      (with-subvector-accessor (vector-ref vector start end)
-	(with-funcallable (predicate)
-	  (with-funcallable (key)
-	    (prog* ((pivot (vector-ref start)) ; should do median-of-three here..
-		    (keyed-pivot (key pivot))
-		    (left (1+ start))
-		    (right (1- end))
-		    left-item right-item)
-	     partitioning-loop
-	      (do-while (not (predicate keyed-pivot (key (setf left-item (vector-ref left)))))
-		(incf left)
-		(when (>= left end)
-		  (setf right-item (vector-ref right))
-		  (go partitioning-complete)))
-	      (do-while (predicate keyed-pivot (key (setf right-item (vector-ref right))))
-		(decf right))
-	      (when (< left right)
-		(setf (vector-ref left) right-item
-		      (vector-ref right) left-item)
-		(incf left)
-		(decf right)
-		(go partitioning-loop))
-	     partitioning-complete
-	      (setf (vector-ref start) right-item ; (aref vector right)
-		    (vector-ref right) pivot)
-	      (quick-sort vector predicate key start right cut-off)
-	      (quick-sort vector predicate key (1+ right) end cut-off)))))))
+  (let ((start (check-the index start))
+	(end (check-the index end)))
+    (macrolet ((do-while (p &body body)
+		 `(do () ((not ,p)) , at body)))
+      (when (> (- end start) cut-off)
+	(with-subvector-accessor (vector-ref vector start end)
+	  (with-funcallable (predicate)
+	    (with-funcallable (key)
+	      (prog* ((pivot (vector-ref start)) ; should do median-of-three here..
+		      (keyed-pivot (key pivot))
+		      (left (1+ start))
+		      (right (1- end))
+		      left-item right-item)
+		(declare (index left right))
+	       partitioning-loop
+		(do-while (not (predicate keyed-pivot (key (setf left-item (vector-ref left)))))
+		  (incf left)
+		  (when (>= left end)
+		    (setf right-item (vector-ref right))
+		    (go partitioning-complete)))
+		(do-while (predicate keyed-pivot (key (setf right-item (vector-ref right))))
+		  (decf right))
+		(when (< left right)
+		  (setf (vector-ref left) right-item
+			(vector-ref right) left-item)
+		  (incf left)
+		  (decf right)
+		  (go partitioning-loop))
+	       partitioning-complete
+		(setf (vector-ref start) right-item ; (aref vector right)
+		      (vector-ref right) pivot)
+		(quick-sort vector predicate key start right cut-off)
+		(quick-sort vector predicate key (1+ right) end cut-off))))))))
   vector)
 
 (defun sort (sequence predicate &key (key 'identity))
@@ -1603,14 +1663,13 @@
 	list-1			    ; list-1 is one length n list to be merged
 	last			    ; last points to the last visited cell
 	(merge-lists-header (list :header)))
-    (declare (fixnum n))
+    (declare (index n))
     (do () (nil)
       ;; start collecting runs of n at the first element
       (setf unsorted (cdr head))
       ;; tack on the first merge of two n-runs to the head holder
       (setf last head)
       (let ((n-1 (1- n)))
-	(declare (fixnum n-1))
 	(do () (nil)
 	  (setf list-1 unsorted)
 	  (let ((temp (nthcdr n-1 list-1))
@@ -1634,7 +1693,7 @@
 		  ;; if there is only one run, then tack it on to the end
 		  (t (setf (cdr last) list-1)
 		     (return)))))
-	(setf n (ash n 1))		; (+ n n)
+	(setf n (+ n n))
 	;; If the inner loop only executed once, then there were only enough
 	;; elements for two runs given n, so all the elements have been merged
 	;; into one list.  This may waste one outer iteration to realize.
@@ -1670,6 +1729,7 @@
 			       (dolist (s sequences length)
 				 (incf length (length s))))))
 	   (i 0))
+      (declare (index i))
       (dolist (s sequences)
 	(replace r s :start1 i)
 	(incf i (length s)))



From ffjeld at common-lisp.net  Tue Aug 23 17:58:20 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Aug 2005 19:58:20 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <20050823175820.8F3A088547@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Fixed typo: delcare -> declare.

Date: Tue Aug 23 19:58:19 2005
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.25 movitz/losp/muerte/sequences.lisp:1.26
--- movitz/losp/muerte/sequences.lisp:1.25	Tue Aug 23 18:09:02 2005
+++ movitz/losp/muerte/sequences.lisp	Tue Aug 23 19:58:19 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.25 2005/08/23 16:09:02 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.26 2005/08/23 17:58:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -797,7 +797,7 @@
 		  (q (nthcdr (- length start2 size) reverse-list) (cdr q))
 		  (i 0 (1+ i)))
 		 ((>= i size) (nreverse reverse-list))
-	       (delcare (index i))
+	       (declare (index i))
 	       (setf (car p) (car q))))))))
      ;; (not (eq sequence-1 sequence-2)) ..
      (t (sequence-dispatch sequence-1



From ffjeld at common-lisp.net  Tue Aug 23 21:42:09 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Tue, 23 Aug 2005 23:42:09 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050823214209.523AD88547@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed a bug in analyze-bindings where declared types where not taken
into account in certain situations, preventing proper type inference.

Date: Tue Aug 23 23:42:08 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.155 movitz/compiler.lisp:1.156
--- movitz/compiler.lisp:1.155	Tue Aug 23 01:05:35 2005
+++ movitz/compiler.lisp	Tue Aug 23 23:42:07 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.155 2005/08/22 23:05:35 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.156 2005/08/23 21:42:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -455,11 +455,18 @@
 			  (binding-store-type binding)))
 		  ((typep binding 'function-argument)
 		   t)
+		  ((let ((analysis (gethash binding binding-usage)))
+		     (assert (and (and analysis
+				       (null (type-analysis-thunks analysis))))
+			 (binding)
+		       "Can't resolve unresolved binding ~S." binding)))
+		  (*compiler-trust-user-type-declarations-p*
+		   (let ((analysis (gethash binding binding-usage)))
+		     (multiple-value-call #'encoded-type-decode
+		       (apply #'encoded-types-and
+			      (append (type-analysis-declared-encoded-type analysis)
+				      (type-analysis-encoded-type analysis))))))
 		  (t (let ((analysis (gethash binding binding-usage)))
-		       (assert (and (and analysis
-					 (null (type-analysis-thunks analysis))))
-			   (binding)
-			 "Can't resolve unresolved binding ~S." binding)
 		       (apply #'encoded-type-decode
 			      (type-analysis-encoded-type analysis))))))
 	       (type-is-t (type-specifier)
@@ -523,8 +530,22 @@
 					 if (not (every #'binding-resolved-p thunk-args))
 					 collect (cons thunk thunk-args)
 					 else
-					 do (setf (type-analysis-encoded-type analysis)
-					      (multiple-value-list
+					 do #+ignore
+					 (warn "because ~S=>~S->~S completing ~S: ~S and ~S"
+					       thunk thunk-args
+					       (mapcar #'binding-resolve thunk-args)
+					       binding
+					       (type-analysis-declared-encoded-type analysis)
+					       (multiple-value-list
+						(multiple-value-call
+						    #'encoded-types-or
+						  (values-list
+						   (type-analysis-encoded-type analysis))
+						  (type-specifier-encode
+						   (apply thunk (mapcar #'binding-resolve
+									thunk-args))))))
+					 (setf (type-analysis-encoded-type analysis)
+					   (multiple-value-list
 					       (multiple-value-call
 						   #'encoded-types-and
 						 (values-list
@@ -5564,6 +5585,8 @@
     #+ignore (when (and (eq result-mode :function)
 			(eq operator (movitz-print (movitz-funobj-name funobj))))
 	       (warn "Tail-recursive call detected."))
+    (when (eq operator 'muerte.cl::declare)
+      (break "Compiling funcall to ~S" 'muerte.cl::declare))
     (pushnew (cons operator muerte.cl::*compile-file-pathname*)
 	     (image-called-functions *image*)
 	     :key #'first)
@@ -6406,6 +6429,10 @@
 	(values binding init-with-type)	)
        ((and init-with-type (not (bindingp init-with-type)))
 	(values binding init-with-type))
+       ((and init-with-type
+	     (bindingp init-with-type)
+	     (binding-store-type init-with-type))
+	(apply #'encoded-type-decode (binding-store-type init-with-type)))
        (t (values binding t
 		  (lambda (x) x)
 		  (list init-with-register)))))



From ffjeld at common-lisp.net  Wed Aug 24 07:19:38 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:19:38 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp 
Message-ID: <20050824071938.92DAB8852B@common-lisp.net>

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

Modified Files:
	hash-tables.lisp 
Log Message:
Added index declarations.

Date: Wed Aug 24 09:19:37 2005
Author: ffjeld

Index: movitz/losp/muerte/hash-tables.lisp
diff -u movitz/losp/muerte/hash-tables.lisp:1.9 movitz/losp/muerte/hash-tables.lisp:1.10
--- movitz/losp/muerte/hash-tables.lisp:1.9	Sun Aug 21 19:56:40 2005
+++ movitz/losp/muerte/hash-tables.lisp	Wed Aug 24 09:19:37 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Feb 19 19:09:05 2001
 ;;;;                
-;;;; $Id: hash-tables.lisp,v 1.9 2005/08/21 17:56:40 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.10 2005/08/24 07:19:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -51,17 +51,19 @@
 
 (defun hash-table-iterator (bucket index)
   (when index
-    (do ((length (array-dimension bucket 0)))
-	((>= index length) nil)
-      (unless (eq (svref%unsafe bucket index) '--no-hash-key--)
-	(return (+ index 2)))
-      (incf index 2))))
+    (let ((index (check-the (index 2) index)))
+      (do ((length (array-dimension bucket 0)))
+	  ((>= index length) nil)
+	(unless (eq (svref%unsafe bucket index) '--no-hash-key--)
+	  (return (+ index 2)))
+	(incf index 2)))))
 
 (defmacro with-hash-table-iterator ((name hash-table) &body declarations-and-body)
   (let ((bucket-var (gensym "bucket-var-"))
 	(bucket-index-var (gensym "bucket-index-var-")))
     `(let* ((,bucket-var (hash-table-bucket ,hash-table))
 	    (,bucket-index-var 0))
+       (declare (type (index 2) ,bucket-index-var))
        (macrolet ((,name ()
 		    `(when (setq ,',bucket-index-var
 			     (hash-table-iterator ,',bucket-var ,',bucket-index-var))
@@ -138,6 +140,7 @@
 	 (bucket-length (array-dimension bucket 0))
 	 (start-i2 (rem (ash (sxhash-eq key0) 1) bucket-length))
 	 (i2 start-i2))
+    (declare ((index 2) i2))
     (do () (nil)
       (let ((k (svref%unsafe bucket i2)))
 	(cond
@@ -156,6 +159,7 @@
 	 (start-i2 (rem (ash (logxor (sxhash-eq key0) (sxhash-eq key1)) 1)
 			bucket-length))
 	 (i2 start-i2))
+    (declare ((index 2) i2))
     (do () (nil)
       (let ((k (svref%unsafe bucket i2)))
 	(cond
@@ -174,6 +178,7 @@
 	(bucket-length (length bucket))
 	(index2 (rem (ash (funcall (hash-table-sxhash hash-table) key) 1) bucket-length)))
       (nil)
+    (declare ((index 2) index2))
     (let ((k (svref%unsafe bucket index2)))
       (cond
        ((eq k '--no-hash-key--)



From ffjeld at common-lisp.net  Wed Aug 24 07:27:48 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:27:48 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp 
Message-ID: <20050824072748.ABB3988547@common-lisp.net>

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

Modified Files:
	arrays.lisp 
Log Message:
Fixed fill-pointer declaration for vector-push.

Date: Wed Aug 24 09:27:48 2005
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.55 movitz/losp/muerte/arrays.lisp:1.56
--- movitz/losp/muerte/arrays.lisp:1.55	Sat Aug 20 22:24:11 2005
+++ movitz/losp/muerte/arrays.lisp	Wed Aug 24 09:27:47 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.55 2005/08/20 20:24:11 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.56 2005/08/24 07:27:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1010,7 +1010,7 @@
 (defun vector-push (new-element vector)
   (check-type vector vector)
   (let ((p (fill-pointer vector)))
-    (declare (type (unsigned-byte 16) p))
+    (declare (index p))
     (when (< p (array-dimension vector 0))
       (setf (aref vector p) new-element
 	    (fill-pointer vector) (1+ p))



From ffjeld at common-lisp.net  Wed Aug 24 07:28:36 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:28:36 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <20050824072836.9016C88547@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Print CPU cycles with ~:D.

Date: Wed Aug 24 09:28:21 2005
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.12 movitz/losp/muerte/environment.lisp:1.13
--- movitz/losp/muerte/environment.lisp:1.12	Wed Apr 20 08:53:20 2005
+++ movitz/losp/muerte/environment.lisp	Wed Aug 24 09:28:19 2005
@@ -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.12 2005/04/20 06:53:20 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.13 2005/08/24 07:28:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -140,7 +140,7 @@
 	   (clumps (and start-mem (- (malloc-cons-pointer) start-mem)))
 	   (delta-time (+ (ash (- end-time-hi start-time-hi) 29)
 			  (- end-time-lo start-time-lo skew))))
-      (format t "~&;; CPU cycles: ~D.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
+      (format t "~&;; CPU cycles: ~:D.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
 	      delta-time clumps clumps))))
 
 (defmacro time (form)



From ffjeld at common-lisp.net  Wed Aug 24 07:29:01 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:29:01 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp 
Message-ID: <20050824072901.52E72884C2@common-lisp.net>

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

Modified Files:
	sequences.lisp 
Log Message:
Fixed typo decare -> declare.

Date: Wed Aug 24 09:29:00 2005
Author: ffjeld

Index: movitz/losp/muerte/sequences.lisp
diff -u movitz/losp/muerte/sequences.lisp:1.26 movitz/losp/muerte/sequences.lisp:1.27
--- movitz/losp/muerte/sequences.lisp:1.26	Tue Aug 23 19:58:19 2005
+++ movitz/losp/muerte/sequences.lisp	Wed Aug 24 09:28:59 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 11 14:19:23 2001
 ;;;;                
-;;;; $Id: sequences.lisp,v 1.26 2005/08/23 17:58:19 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.27 2005/08/24 07:28:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -813,12 +813,12 @@
 		    (do ((i start1 (1+ i))
 			 (j start2 (1+ j)))
 			((>= i end1) sequence-1)
-		      (decare (index i j))
+		      (declare (index i j))
 		      (setf (sequence-1-ref i) (sequence-2-ref j))))
 		   (t (do ((i start1 (1+ i))
 			   (j start2 (1+ j)))
 			  ((>= j end2) sequence-1)
-			(decare (index i j))
+			(declare (index i j))
 			(setf (sequence-1-ref i) (sequence-2-ref j))))))))
 	     (list
 	      (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)



From ffjeld at common-lisp.net  Wed Aug 24 07:29:41 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:29:41 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp 
Message-ID: <20050824072941.9630188548@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Added some (declare index) to hash-table-iter-vars.

Date: Wed Aug 24 09:29:41 2005
Author: ffjeld

Index: movitz/losp/muerte/packages.lisp
diff -u movitz/losp/muerte/packages.lisp:1.10 movitz/losp/muerte/packages.lisp:1.11
--- movitz/losp/muerte/packages.lisp:1.10	Mon May 30 00:03:06 2005
+++ movitz/losp/muerte/packages.lisp	Wed Aug 24 09:29:40 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 30 15:19:43 2001
 ;;;;                
-;;;; $Id: packages.lisp,v 1.10 2005/05/29 22:03:06 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.11 2005/08/24 07:29:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -143,7 +143,8 @@
 		   (setf ,package-hash-var internals)
 		   (go ,loop-tag))))))))))
 
-(defmacro do-external-symbols ((var &optional (package *package*) result-form) &body declarations-and-body)
+(defmacro do-external-symbols
+    ((var &optional (package *package*) result-form) &body declarations-and-body)
   (let ((next-var (gensym))
 	(more-var (gensym))
 	(key-var (gensym)))
@@ -170,6 +171,7 @@
 			      (t (let ((x (pop ,use-list-var)))
 				   (and x (package-object-external-symbols x)))))))
 	 ((not ,hash-table-var) ,result-form)
+       (declare (index ,state-var))
        (with-hash-table-iterator (,next-var ,hash-table-var)
 	 (do () (nil)
 	   (multiple-value-bind (,more-var ,key-var ,var) (,next-var)
@@ -177,7 +179,6 @@
 	     (if ,more-var
 		 (let () , at declarations-and-body)
 	       (return))))))))
-
 
 (defun apropos (string &optional package)
   (flet ((apropos-symbol (symbol string)



From ffjeld at common-lisp.net  Wed Aug 24 07:30:15 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:30:15 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp 
Message-ID: <20050824073015.1292A8854D@common-lisp.net>

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

Modified Files:
	memref.lisp 
Log Message:
Added (require typep) so we can do some type-inferring.

Date: Wed Aug 24 09:30:14 2005
Author: ffjeld

Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.47 movitz/losp/muerte/memref.lisp:1.48
--- movitz/losp/muerte/memref.lisp:1.47	Tue May 24 08:33:35 2005
+++ movitz/losp/muerte/memref.lisp	Wed Aug 24 09:30:14 2005
@@ -10,10 +10,11 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar  6 21:25:49 2001
 ;;;;                
-;;;; $Id: memref.lisp,v 1.47 2005/05/24 06:33:35 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.48 2005/08/24 07:30:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
+(require :muerte/typep)
 (provide :muerte/memref)
 
 (in-package muerte)



From ffjeld at common-lisp.net  Wed Aug 24 07:30:47 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:30:47 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050824073047.750C28854D@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Working on add and type inference.

Date: Wed Aug 24 09:30:46 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.156 movitz/compiler.lisp:1.157
--- movitz/compiler.lisp:1.156	Tue Aug 23 23:42:07 2005
+++ movitz/compiler.lisp	Wed Aug 24 09:30:45 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.156 2005/08/23 21:42:07 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.157 2005/08/24 07:30:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -7023,26 +7023,75 @@
 				 (binding-lended-p (binding-target term1)))))
 	       (t (warn "Unknown fixnum add: ~S" instruction)
 		  (make-default-add))))
-	     #+ignore
 	     ((and (movitz-subtypep result-type '(unsigned-byte 32))
 		   (movitz-subtypep type0 'fixnum)
 		   (movitz-subtypep type1 'fixnum))
-	      (cond
-	       ((and (not (binding-lended-p (binding-target term0)))
-		     (not (binding-lended-p (binding-target term1)))
-		     (not (and (bindingp destination)
-			       (binding-lended-p (binding-target destination)))))
+	      (flet ((mkadd (src srcloc destreg)
+		       (if (integerp srcloc)
+			   `((:addl (:ebp ,(stack-frame-offset srcloc))
+				    ,destreg))
+			 (ecase (operator srcloc)
+			   ((:eax :ebx :ecx :edx)
+			    `((:addl ,srcloc ,destreg)))
+			   ((:argument-stack)
+			    `((:addl (:ebx ,(argument-stack-offset src))
+				     ,destreg)))
+			   ))))
 		(cond
 		 ((and (not constant0)
 		       (not constant1)
-		       (member destination-location '(:eax :ebx :edx)))
-		  (print-code instruction
-			      (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map)
-				      `((,*compiler-local-segment-prefix*
-					 :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0))))
-				      )))
-		 (t (make-default-add))))
-	       (t (make-default-add))))
+		       (not (binding-lended-p (binding-target term0)))
+		       (not (binding-lended-p (binding-target term1)))
+		       (not (and (bindingp destination)
+				 (binding-lended-p (binding-target destination)))))
+		  (cond
+;;;		   ((and (not (eq loc0 :untagged-fixnum-ecx))
+;;;			 (not (eq loc1 :untagged-fixnum-ecx))
+;;;			 (not (eq destination-location :untagged-fixnum-ecx)))
+;;;		    (let ((tmpreg (cond
+;;;				   ((member destination-location '(:eax :ebx :ecx :edx))
+;;;				    destination-location)
+;;;				   ((some (lambda (x) (and (not (eq x loc0)) (not (eq x loc1))))
+;;;					  '(:ecx :edx :eax :ebx)))
+;;;				   (t :ecx)))
+;;;			  (no-overflow (gensym "no-overflow-")))
+;;;		      (append (make-load-lexical term0 :eax funobj nil frame-map)
+;;;			      (mkadd term1 loc1 :eax)
+;;;			      `((:jnc ',no-overflow)
+;;;				(:movl :eax :ecx)
+;;;				(:rcrl 1 :ecx)
+;;;				(:shrl 1 :ecx)
+;;;				(,*compiler-local-segment-prefix*
+;;;				 :call (:edi ,(global-constant-offset 'box-u32-ecx)))
+;;;				,no-overflow))
+		   (t (make-default-add)
+		      #+ignore
+		      (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map)
+			      `((,*compiler-local-segment-prefix*
+				 :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0))))
+			      (make-load-lexical term1 :untagged-fixnum-ecx funobj nil frame-map)
+			      `((,*compiler-local-segment-prefix*
+				 :addl (:edi ,(global-constant-offset 'raw-scratch0)) :ecx))
+			      (if (integerp destination-location)
+				  `((,*compiler-local-segment-prefix*
+				     :call (:edi ,(global-constant-offset 'box-u32-ecx)))
+				    (:movl :eax (:ebp ,(stack-frame-offset destination-location))))
+				(ecase (operator destination-location)
+				  ((:untagged-fixnum-ecx)
+				   nil)
+				  ((:eax)
+				   `((,*compiler-local-segment-prefix*
+				      :call (:edi ,(global-constant-offset 'box-u32-ecx)))))
+				  ((:ebx :ecx :edx)
+				   `((,*compiler-local-segment-prefix*
+				      :call (:edi ,(global-constant-offset 'box-u32-ecx)))
+				     (:movl :eax ,destination-location)))
+				  ((:argument-stack)
+				   `((,*compiler-local-segment-prefix*
+				      :call (:edi ,(global-constant-offset 'box-u32-ecx)))
+				     (:movl :eax (:ebp ,(argument-stack-offset
+							 (binding-target destination))))))))))))
+		 (t (make-default-add)))))
 	     (t (make-default-add)))))))))
 
 ;;;;;;;



From ffjeld at common-lisp.net  Wed Aug 24 07:31:35 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:31:35 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp 
Message-ID: <20050824073135.345E48854A@common-lisp.net>

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
Rearranged some code to have movitz build cleanly.

Date: Wed Aug 24 09:31:34 2005
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.10 movitz/losp/muerte/arithmetic-macros.lisp:1.11
--- movitz/losp/muerte/arithmetic-macros.lisp:1.10	Sat Aug 20 22:23:34 2005
+++ movitz/losp/muerte/arithmetic-macros.lisp	Wed Aug 24 09:31:34 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.10 2005/08/20 20:23:34 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.11 2005/08/24 07:31:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,6 +20,8 @@
 
 (in-package muerte)
 
+;;;
+
 (defmacro number-double-dispatch ((x y) &rest clauses)
   `(let ((x ,x) (y ,y))
      (cond ,@(loop for ((x-type y-type) . then-body) in clauses
@@ -499,3 +501,115 @@
 (define-compiler-macro %ratio-denominator (x)
   `(memref ,x (movitz-type-slot-offset 'movitz-ratio 'denominator)))
 
+;;;
+
+(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name)
+  `(progn
+     ,(when condition
+	`(define-compiler-macro ,2op-name (n1 n2 &environment env)
+	   (cond
+	    ((and (movitz:movitz-constantp n1 env)
+		  (movitz:movitz-constantp n2 env))
+	     (list ',2op-name (movitz:movitz-eval n1 env) (movitz:movitz-eval n2 env)))
+	    ((movitz:movitz-constantp n1 env)
+	     (let ((n1 (movitz::movitz-eval n1 env)))
+	       (check-type n1 number)
+	       (if (typep n1 '(signed-byte 30))
+		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		      (:call-global-pf fast-compare-fixnum-real))
+		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		    (:call-global-pf fast-compare-two-reals)))))
+	    ((movitz:movitz-constantp n2 env)
+	     (let ((n2 (movitz:movitz-eval n2 env)))
+	       (check-type n2 number)
+	       (if (typep n2 '(signed-byte 30))
+		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		      (:call-global-pf fast-compare-real-fixnum))
+		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		    (:call-global-pf fast-compare-two-reals)))))
+	    (t `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		  (:call-global-pf fast-compare-two-reals))))))
+
+     (defun ,2op-name (n1 n2)
+       (,2op-name n1 n2))
+
+     (define-compiler-macro ,name (&whole form number &rest more-numbers)
+       (case (length more-numbers)
+	 (0 `(progn ,number t))
+	 (1 `(,',2op-name ,number ,(first more-numbers)))
+	 ,@(when 3op-name
+	     `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers)))))
+	 (t #+ignore (when (= 2 (length more-numbers))
+		       (warn "3op: ~S" form))
+	  `(and (,',2op-name ,number ,(first more-numbers))
+		  (,',name , at more-numbers)))))
+
+     ,(when defun-p
+	`(defun ,name (number &rest more-numbers)
+	   (declare (dynamic-extent more-numbers))
+	   (cond
+	    ((null more-numbers)
+	     (check-type number fixnum)
+	     t)
+	    ((not (cdr more-numbers))
+	     (,2op-name number (first more-numbers)))
+	    (t (and (,2op-name number (first more-numbers))
+		    (do ((p more-numbers (cdr p)))
+			((not (cdr p)) t)
+		      (unless (,2op-name (car p) (cadr p))
+			(return nil))))))))))
+
+(define-number-relational >= >=%2op :boolean-greater-equal)
+(define-number-relational > >%2op :boolean-greater)
+(define-number-relational < <%2op :boolean-less)
+(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op)
+
+;;; Types
+
+(define-typep integer (x &optional (min '*) (max '*))
+  (and (typep x 'integer)
+       (or (eq min '*) (<= min x))
+       (or (eq max '*) (<= x max))))
+
+(deftype unsigned-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    '(integer 0))
+   ((typep size '(integer 1 *))
+    ;; The funcall is a hack not to invoke compiler machinery
+    ;; that depends on the unsigned-byte type being defined.
+    (list 'integer 0 (funcall '- (ash 1 size) 1)))
+   (t (error "Illegal size for unsigned-byte."))))
+
+(deftype signed-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    'integer)
+   ((typep size '(integer 1 *))
+    (list 'integer
+	  (- (ash 1 (1- size)))
+	  (1- (ash 1 (1- size)))))
+   (t (error "Illegal size for signed-byte."))))
+
+(define-typep rational (x &optional (lower-limit '*) (upper-limit '*))
+  (and (typep x 'rational)
+       (or (eq lower-limit '*)
+	   (<= lower-limit x))
+       (or (eq upper-limit '*)
+	   (<= x upper-limit))))
+
+(deftype real (&optional (lower-limit '*) (upper-limit '*))
+  `(or (integer ,lower-limit ,upper-limit)
+       (rational ,lower-limit ,upper-limit)))
+  
+
+(define-simple-typep (bit bitp) (x)
+  (or (eq x 0) (eq x 1)))
+
+(deftype index (&optional (step 1))
+  `(integer 0 ,(- #x1fffffff step)))



From ffjeld at common-lisp.net  Wed Aug 24 07:31:42 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:31:42 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <20050824073142.F02F588540@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Rearranged some code to have movitz build cleanly.

Date: Wed Aug 24 09:31:40 2005
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.107 movitz/losp/muerte/integers.lisp:1.108
--- movitz/losp/muerte/integers.lisp:1.107	Fri Aug 12 23:37:42 2005
+++ movitz/losp/muerte/integers.lisp	Wed Aug 24 09:31:40 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.107 2005/08/12 21:37:42 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.108 2005/08/24 07:31:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -256,71 +256,6 @@
 ;;;
 
 
-(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name)
-  `(progn
-     ,(when condition
-	`(define-compiler-macro ,2op-name (n1 n2 &environment env)
-	   (cond
-	    ((and (movitz:movitz-constantp n1 env)
-		  (movitz:movitz-constantp n2 env))
-	     (list ',2op-name (movitz:movitz-eval n1 env) (movitz:movitz-eval n2 env)))
-	    ((movitz:movitz-constantp n1 env)
-	     (let ((n1 (movitz::movitz-eval n1 env)))
-	       (check-type n1 number)
-	       (if (typep n1 '(signed-byte 30))
-		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		      (:call-global-pf fast-compare-fixnum-real))
-		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		    (:call-global-pf fast-compare-two-reals)))))
-	    ((movitz:movitz-constantp n2 env)
-	     (let ((n2 (movitz:movitz-eval n2 env)))
-	       (check-type n2 number)
-	       (if (typep n2 '(signed-byte 30))
-		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		      (:call-global-pf fast-compare-real-fixnum))
-		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		    (:call-global-pf fast-compare-two-reals)))))
-	    (t `(with-inline-assembly (:returns ,,condition :side-effects nil)
-		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
-		  (:call-global-pf fast-compare-two-reals))))))
-
-     (defun ,2op-name (n1 n2)
-       (,2op-name n1 n2))
-
-     (define-compiler-macro ,name (&whole form number &rest more-numbers)
-       (case (length more-numbers)
-	 (0 `(progn ,number t))
-	 (1 `(,',2op-name ,number ,(first more-numbers)))
-	 ,@(when 3op-name
-	     `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers)))))
-	 (t #+ignore (when (= 2 (length more-numbers))
-		       (warn "3op: ~S" form))
-	  `(and (,',2op-name ,number ,(first more-numbers))
-		  (,',name , at more-numbers)))))
-
-     ,(when defun-p
-	`(defun ,name (number &rest more-numbers)
-	   (declare (dynamic-extent more-numbers))
-	   (cond
-	    ((null more-numbers)
-	     (check-type number fixnum)
-	     t)
-	    ((not (cdr more-numbers))
-	     (,2op-name number (first more-numbers)))
-	    (t (and (,2op-name number (first more-numbers))
-		    (do ((p more-numbers (cdr p)))
-			((not (cdr p)) t)
-		      (unless (,2op-name (car p) (cadr p))
-			(return nil))))))))))
-
-(define-number-relational >= >=%2op :boolean-greater-equal)
-(define-number-relational > >%2op :boolean-greater)
-(define-number-relational < <%2op :boolean-less)
-(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op)
 
 ;;; Unsigned
 
@@ -402,45 +337,6 @@
 (defun oddp (x)
   (compiler-macro-call oddp x))
 
-;;; Types
-
-(define-typep integer (x &optional (min '*) (max '*))
-  (and (typep x 'integer)
-       (or (eq min '*) (<= min x))
-       (or (eq max '*) (<= x max))))
-
-(deftype signed-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    'integer)
-   ((typep size '(integer 1 *))
-    (list 'integer
-	  (- (ash 1 (1- size)))
-	  (1- (ash 1 (1- size)))))
-   (t (error "Illegal size for signed-byte."))))
-
-(deftype unsigned-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    '(integer 0))
-   ((typep size '(integer 1 *))
-    (list 'integer 0 (1- (ash 1 size))))
-   (t (error "Illegal size for unsigned-byte."))))
-
-(define-typep rational (x &optional (lower-limit '*) (upper-limit '*))
-  (and (typep x 'rational)
-       (or (eq lower-limit '*)
-	   (<= lower-limit x))
-       (or (eq upper-limit '*)
-	   (<= x upper-limit))))
-
-(deftype real (&optional (lower-limit '*) (upper-limit '*))
-  `(or (integer ,lower-limit ,upper-limit)
-       (rational ,lower-limit ,upper-limit)))
-  
-
-(define-simple-typep (bit bitp) (x)
-  (or (eq x 0) (eq x 1)))
 
 ;;; 
 



From ffjeld at common-lisp.net  Wed Aug 24 07:31:51 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:31:51 +0200 (CEST)
Subject: [movitz-cvs] CVS update:
	movitz/losp/muerte/los-closette-compiler.lisp 
Message-ID: <20050824073151.1C8C08815C@common-lisp.net>

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

Modified Files:
	los-closette-compiler.lisp 
Log Message:
Rearranged some code to have movitz build cleanly.

Date: Wed Aug 24 09:31:48 2005
Author: ffjeld

Index: movitz/losp/muerte/los-closette-compiler.lisp
diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.18 movitz/losp/muerte/los-closette-compiler.lisp:1.19
--- movitz/losp/muerte/los-closette-compiler.lisp:1.18	Sun Aug 21 15:47:53 2005
+++ movitz/losp/muerte/los-closette-compiler.lisp	Wed Aug 24 09:31:47 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 29 13:15:11 2002
 ;;;;                
-;;;; $Id: los-closette-compiler.lisp,v 1.18 2005/08/21 13:47:53 ffjeld Exp $
+;;;; $Id: los-closette-compiler.lisp,v 1.19 2005/08/24 07:31:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -27,7 +27,8 @@
 (define-compile-time-variable *the-slots-of-standard-class* nil)
 (define-compile-time-variable *the-position-of-standard-effective-slots* nil)
 (define-compile-time-variable *the-class-standard-class* nil)
-
+(define-compile-time-variable *the-standard-method-combination* nil)
+    
 (eval-when (:compile-toplevel)		; extends to EOF
 
   (defvar *classes-with-old-slot-definitions* nil)
@@ -524,7 +525,7 @@
 	   (slots (std-instance-slots instance)))
       (setf (svref slots location) (muerte::translate-program value :cl :muerte.cl))))
   
-  (defun movitz-slot-vale (object slot-name)
+  (defun movitz-slot-value (object slot-name)
     (std-slot-value object (translate-program slot-name :cl :muerte.cl)))
 
   (defun (setf movitz-slot-value) (new-value object slot-name)



From ffjeld at common-lisp.net  Wed Aug 24 07:31:58 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:31:58 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp 
Message-ID: <20050824073158.53A9C8815C@common-lisp.net>

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

Modified Files:
	typep.lisp 
Log Message:
Rearranged some code to have movitz build cleanly.

Date: Wed Aug 24 09:31:57 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.50 movitz/losp/muerte/typep.lisp:1.51
--- movitz/losp/muerte/typep.lisp:1.50	Sun Aug 21 19:59:18 2005
+++ movitz/losp/muerte/typep.lisp	Wed Aug 24 09:31:57 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.50 2005/08/21 17:59:18 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.51 2005/08/24 07:31:57 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -691,9 +691,6 @@
 
 (deftype bit ()
   '(integer 0 1))
-
-(deftype index (&optional (step 1))
-  `(integer 0 ,(- #x1fffffff step)))
 
 (defun type-of (x)
   (class-name (class-of x)))



From ffjeld at common-lisp.net  Wed Aug 24 07:32:52 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:32:52 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/ll-testing.lisp 
Message-ID: <20050824073252.D699C8815C@common-lisp.net>

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

Modified Files:
	ll-testing.lisp 
Log Message:
sync

Date: Wed Aug 24 09:32:52 2005
Author: ffjeld

Index: movitz/losp/ll-testing.lisp
diff -u movitz/losp/ll-testing.lisp:1.11 movitz/losp/ll-testing.lisp:1.12
--- movitz/losp/ll-testing.lisp:1.11	Thu Aug 11 23:33:01 2005
+++ movitz/losp/ll-testing.lisp	Wed Aug 24 09:32:52 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Apr 14 08:18:43 2005
 ;;;;                
-;;;; $Id: ll-testing.lisp,v 1.11 2005/08/11 21:33:01 ffjeld Exp $
+;;;; $Id: ll-testing.lisp,v 1.12 2005/08/24 07:32:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -237,4 +237,6 @@
       (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ; reset eflags
       (:popfl)
       (:jmp (:esi (:offset movitz-funobj code-vector))))))
+
+
 



From ffjeld at common-lisp.net  Wed Aug 24 07:32:58 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:32:58 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050824073258.AA52C88554@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
sync

Date: Wed Aug 24 09:32:56 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.47 movitz/losp/los0.lisp:1.48
--- movitz/losp/los0.lisp:1.47	Thu Aug 11 23:33:08 2005
+++ movitz/losp/los0.lisp	Wed Aug 24 09:32:54 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.47 2005/08/11 21:33:08 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.48 2005/08/24 07:32:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1351,7 +1351,7 @@
       (setf (global-segment-descriptor-table)
 	(muerte::dump-global-segment-table :entries 16)))
 
-    (install-los0-consing :kb-size 500)
+    (install-los0-consing :kb-size (* 10 1024))
     #+ignore
     (install-los0-consing :kb-size (max 50 (truncate (- extended-memsize 2048) 2))))
 



From ffjeld at common-lisp.net  Wed Aug 24 07:33:04 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:33:04 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/all.lisp 
Message-ID: <20050824073304.421278815C@common-lisp.net>

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

Modified Files:
	all.lisp 
Log Message:
sync

Date: Wed Aug 24 09:33:03 2005
Author: ffjeld

Index: movitz/losp/x86-pc/all.lisp
diff -u movitz/losp/x86-pc/all.lisp:1.4 movitz/losp/x86-pc/all.lisp:1.5
--- movitz/losp/x86-pc/all.lisp:1.4	Fri Apr 23 17:04:12 2004
+++ movitz/losp/x86-pc/all.lisp	Wed Aug 24 09:33:02 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Sep 27 21:14:56 2001
 ;;;;                
-;;;; $Id: all.lisp,v 1.4 2004/04/23 15:04:12 ffjeld Exp $
+;;;; $Id: all.lisp,v 1.5 2005/08/24 07:33:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,7 +23,7 @@
 (require :x86-pc/pit8253)
 (require :x86-pc/interrupt)
 (require :x86-pc/cmos)
-(require :x86-pc/pci)
+(require :x86-pc/pci-device)
 ;; (require :x86-pc/serial)
 (require :x86-pc/textmode-console)
 (require :x86-pc/debugger)



From ffjeld at common-lisp.net  Wed Aug 24 07:33:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:33:10 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/am7990.lisp 
Message-ID: <20050824073310.BF40B8815C@common-lisp.net>

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

Added Files:
	am7990.lisp 
Log Message:
sync

Date: Wed Aug 24 09:33:09 2005
Author: ffjeld




From ffjeld at common-lisp.net  Wed Aug 24 07:33:15 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:33:15 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp 
Message-ID: <20050824073315.5E5158815C@common-lisp.net>

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

Modified Files:
	dp8390.lisp 
Log Message:
sync

Date: Wed Aug 24 09:33:14 2005
Author: ffjeld

Index: movitz/losp/x86-pc/dp8390.lisp
diff -u movitz/losp/x86-pc/dp8390.lisp:1.7 movitz/losp/x86-pc/dp8390.lisp:1.8
--- movitz/losp/x86-pc/dp8390.lisp:1.7	Wed May  5 10:24:29 2004
+++ movitz/losp/x86-pc/dp8390.lisp	Wed Aug 24 09:33:13 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001-2004, 
+;;;;    Copyright (C) 2001-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 18 12:21:36 2002
 ;;;;                
-;;;; $Id: dp8390.lisp,v 1.7 2004/05/05 08:24:29 ffjeld Exp $
+;;;; $Id: dp8390.lisp,v 1.8 2005/08/24 07:33:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -129,6 +129,14 @@
 	address))
     (setf (io-register8x2 dp8390 ($page0-write rbcr1) ($page0-write rbcr0)) size
 	  (dp8390 ($page0-write cr)) command))
+  nil)
+
+(defun foo (io-base command size address)
+  (let ((io-base (the (unsigned-byte #x10)
+		   (let ((check-the-io-base io-base))
+		     (check-type check-the-io-base (unsigned-byte #x10))
+		     check-the-io-base))))
+    (setf (io-port (+ io-base 0) :unsigned-byte8) #o40))
   nil)
 
 (defmacro with-dp8390-dma ((dp8390-var rdma-command size &optional address) &body body)



From ffjeld at common-lisp.net  Wed Aug 24 07:33:22 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Wed, 24 Aug 2005 09:33:22 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp 
Message-ID: <20050824073322.DD0F58815C@common-lisp.net>

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

Modified Files:
	pci.lisp 
Log Message:
sync

Date: Wed Aug 24 09:33:22 2005
Author: ffjeld

Index: movitz/losp/x86-pc/pci.lisp
diff -u movitz/losp/x86-pc/pci.lisp:1.11 movitz/losp/x86-pc/pci.lisp:1.12
--- movitz/losp/x86-pc/pci.lisp:1.11	Sun Aug 14 14:15:04 2005
+++ movitz/losp/x86-pc/pci.lisp	Wed Aug 24 09:33:21 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Dec 14 22:33:42 2003
 ;;;;                
-;;;; $Id: pci.lisp,v 1.11 2005/08/14 12:15:04 ffjeld Exp $
+;;;; $Id: pci.lisp,v 1.12 2005/08/24 07:33:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -294,16 +294,19 @@
 	   (error "Unknown pci-config register: ~S" register))))
 
 (defun pci-device-address-maps (bus device function)
-  (loop for i upfrom (pci-config :base-addr) by 4 repeat 6
+  (loop with io-keys = '(:io :io-2 :io-3 :io-4 :io-5 :io-6)
+      with mem-keys = '(:mem :mem-2 :mem-3 :mem-4 :mem-5 :mem-6)
+      with mem64-keys = '(:mem64 :mem64-2 :mem64-3 :mem64-4 :mem64-5 :mem64-6)
+      for i upfrom (pci-config :base-addr) by 4 repeat 6
       as base = (pci-bios-config-space-dword bus device function i)
-      unless (= 0 base) collect
+      unless (= 0 base) nconc
 	(cond
 	 ((logbitp 0 base)
-	  (cons :io (logand base -4)))
+	  (list (pop io-keys) (logand base -4)))
 	 ((= 1 (ldb (byte 2 1) base))
-	  (cons :mem64 (logand base -16)))
+	  (list (pop mem64-keys) (logand base -16)))
 	 (t
-	  (cons :mem32 (logand base -16))))))
+	  (list (pop mem-keys) (logand base -16))))))
 	    
 (defun scan-pci-bus (bus)
   (loop for device from 0 to 31
@@ -321,7 +324,58 @@
 		       (ldb (byte 24 8) class-rev)
 		       (ldb (byte 8 0) class-rev)
 		       status)
-	       (format *query-io* "    Class:~{ ~@[~A~]~}"
+	       (format *query-io* "    Class:~{~@[ ~A~]~}."
 		       (multiple-value-list (pci-class (ldb (byte 24 8) class-rev))))
-	       (format *query-io* "~S" (pci-device-address-maps bus device 0))))))
+	       (format *query-io* "~@[~{ ~A: #x~X~^,~}.~]"
+		       (pci-device-address-maps bus device 0))))))
   (values))
+
+(defmacro $pci-config (reg)
+  "PCI config header registers for all devices."
+  (or (case reg
+	(:pcir-devvendor #x00)
+	(:pcir-vendor #x00)
+	(:pcir-device #x02)
+	(:pcir-command #x04)
+	(:pcim-cmd-porten #x0001)
+	(:pcim-cmd-memen #x0002)
+	(:pcim-cmd-busmasteren #x0004)
+	(:pcim-cmd-mwricen #x0010)
+	(:pcim-cmd-perrespen #x0040)
+	(:pcim-cmd-serrespen #x0100)
+	(:pcir-status #x06)
+	(:pcim-status-cappresent #x0010)
+	(:pcim-status-66capable #x0020)
+	(:pcim-status-backtoback #x0080)
+	(:pcim-status-perrreport #x0100)
+	(:pcim-status-sel-fast #x0000)
+	(:pcim-status-sel-medimum #x0200)
+	(:pcim-status-sel-slow #x0400)
+	(:pcim-status-sel-mask #x0600)
+	(:pcim-status-stabort #x0800)
+	(:pcim-status-rtabort #x1000)
+	(:pcim-status-rmabort #x2000)
+	(:pcim-status-serr #x4000)
+	(:pcim-status-perr #x8000)
+	(:pcir-revid #x08)
+	(:pcir-progif #x09)
+	(:pcir-subclass #x0a)
+	(:pcir-class #x0b)
+	(:pcir-cachelnsz #x0c)
+	(:pcir-lattimer #x0d)
+	(:pcir-headertype #x0e)
+	(:pcim-mfdev #x80)
+	(:pcir-bist #x0f)
+
+	(:pcir-maps #x10)
+	(:pcir-cardbuscis #x28)
+	(:pcir-subvend-0 #x2c)
+	(:pcir-subdev-0 #x2e)
+	(:pcir-bios #x30)
+	(:pcim-bios-enable #x01)
+	(:pcir-cap-ptr #x34)
+	(:pcir-intline #x3c)
+	(:pcir-intpin #x3d)
+	(:pcir-mingnt #x3e)
+	(:pcir-maxlat #x3f))
+      (error "Unknown $pci-config register ~S." reg)))



From ffjeld at common-lisp.net  Fri Aug 26 19:38:20 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:38:20 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <20050826193820.9D1ED884C8@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:38:19 2005
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.51 movitz/losp/muerte/scavenge.lisp:1.52
--- movitz/losp/muerte/scavenge.lisp:1.51	Sat Jun 11 01:06:39 2005
+++ movitz/losp/muerte/scavenge.lisp	Fri Aug 26 21:38:19 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.51 2005/06/10 23:06:39 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.52 2005/08/26 19:38:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -55,6 +55,7 @@
 	 (*scan-last* nil)		; Last scanned object, for debugging.
 	 (scan start-location (1+ scan)))
 	((>= scan end-location))
+      (declare (fixnum scan))
       (with-simple-restart (continue-map-header-vals
 			    "Continue map-header-vals at location ~S." (1+ scan))
 	(let ((x (memref scan 0 :type :unsigned-byte16))



From ffjeld at common-lisp.net  Fri Aug 26 19:38:37 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:38:37 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp 
Message-ID: <20050826193837.64B12880AC@common-lisp.net>

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

Modified Files:
	read.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:38:36 2005
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.12 movitz/losp/muerte/read.lisp:1.13
--- movitz/losp/muerte/read.lisp:1.12	Fri Jun 10 20:35:01 2005
+++ movitz/losp/muerte/read.lisp	Fri Aug 26 21:38:35 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 17 21:50:42 2001
 ;;;;                
-;;;; $Id: read.lisp,v 1.12 2005/06/10 18:35:01 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.13 2005/08/26 19:38:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -84,7 +84,9 @@
       (return i))))
 
 (defun simple-read-token (string &key (start 0) (end (length string)))
-  (let ((colon-position (and (char= #\: (schar string start)) start))
+  (let ((start (check-the index start))
+	(end (check-the index end))
+	(colon-position (and (char= #\: (schar string start)) start))
 	(almost-integer nil))
     (multiple-value-bind (token-end token-integer token-denominator)
 	(do ((integer (or (digit-char-p (schar string start) *read-base*)
@@ -104,6 +106,7 @@
 			 integer))
 		     (when (and integer denominator (plusp denominator))
 		       denominator)))
+	  (declare (index i))
 	  (let ((c (schar string i)))
 	    (when (char= #\: c)
 	      (setf colon-position i))
@@ -130,6 +133,7 @@
 		 (and (< *read-base* 10)
 		      (do ((i start (1+ i)))
 			  ((>= i (1- token-end)) t)
+			(declare (index i))
 			(unless (digit-char-p (schar string i) 10)
 			  (return nil))))))
 	(let ((x (if (= *read-base* 10)
@@ -181,48 +185,51 @@
 
 (defun simple-read-delimited-list (delimiter string start end &key (tail-delimiter #\.) list)
   "=> list, new-position, new-string, new-end."
-  (multiple-value-bind (next-string next-start next-end)
-      (catch 'next-line
-	(restart-bind
-	    ((next-line (lambda (next-string &optional (next-start 0)
-						       (next-end (length next-string)))
-			  (throw 'next-line
-			    (values next-string next-start next-end)))))
-	  (do ((i start (1+ i)))
-	      ((>= i end)
-	       (error 'missing-delimiter
-		      :delimiter delimiter
-		      :start-position start))
-	    (let ((char (schar string i)))
-	      (cond
-	       ((char= delimiter char)
-		(return-from simple-read-delimited-list
-		  (values (nreverse list) (1+ i) string end)))
-	       ((eq tail-delimiter char)
-		(unless list
-		  (error "Nothing before ~C in list." tail-delimiter))
-		(multiple-value-bind (cdr-list cdr-end cdr-string cdr-string-end)
-		    (simple-read-delimited-list #\) string (1+ i) end
-						:tail-delimiter tail-delimiter)
-		  (unless (endp (cdr cdr-list))
-		    (error "Too many objects after ~C in list: ~S"
-			   tail-delimiter (cdr cdr-list)))
-		  (setf list (nreverse list)
-			(cdr (last list)) (car cdr-list))
+  (let ((start (check-the index start))
+	(end (check-the index end)))
+    (multiple-value-bind (next-string next-start next-end)
+	(catch 'next-line
+	  (restart-bind
+	      ((next-line (lambda (next-string &optional (next-start 0)
+							 (next-end (length next-string)))
+			    (throw 'next-line
+			      (values next-string next-start next-end)))))
+	    (do ((i start (1+ i)))
+		((>= i end)
+		 (error 'missing-delimiter
+			:delimiter delimiter
+			:start-position start))
+	      (declare (index i))
+	      (let ((char (schar string i)))
+		(cond
+		 ((char= delimiter char)
 		  (return-from simple-read-delimited-list
-		    (values list cdr-end cdr-string cdr-string-end))))
-	       ((char-whitespace-p char))
-	       (t (multiple-value-bind (element element-end next-string next-string-end)
-		      (simple-read-from-string string t t :start i :end end)
-		    (when next-string
-		      (assert next-string-end)
-		      (setf string next-string
-			    end next-string-end))
-		    (setf i (1- element-end))
-		    (push element list))))))))
-    (simple-read-delimited-list delimiter next-string next-start next-end
-				:tail-delimiter tail-delimiter
-				:list list)))
+		    (values (nreverse list) (1+ i) string end)))
+		 ((eq tail-delimiter char)
+		  (unless list
+		    (error "Nothing before ~C in list." tail-delimiter))
+		  (multiple-value-bind (cdr-list cdr-end cdr-string cdr-string-end)
+		      (simple-read-delimited-list #\) string (1+ i) end
+						  :tail-delimiter tail-delimiter)
+		    (unless (endp (cdr cdr-list))
+		      (error "Too many objects after ~C in list: ~S"
+			     tail-delimiter (cdr cdr-list)))
+		    (setf list (nreverse list)
+			  (cdr (last list)) (car cdr-list))
+		    (return-from simple-read-delimited-list
+		      (values list cdr-end cdr-string cdr-string-end))))
+		 ((char-whitespace-p char))
+		 (t (multiple-value-bind (element element-end next-string next-string-end)
+			(simple-read-from-string string t t :start i :end end)
+		      (when next-string
+			(assert next-string-end)
+			(setf string next-string
+			      end next-string-end))
+		      (setf i (1- element-end))
+		      (push element list))))))))
+      (simple-read-delimited-list delimiter next-string next-start next-end
+				  :tail-delimiter tail-delimiter
+				  :list list))))
 
 (defun position-with-escape (char string start end &optional (errorp t))
   (with-subvector-accessor (string-ref string start end)
@@ -231,6 +238,7 @@
 	((>= i end)
 	 (when errorp
 	   (error "Missing terminating character ~C." char)))
+      (declare (index i))
       (let ((c (string-ref i)))
 	(cond
 	 ((char= char c)
@@ -240,108 +248,114 @@
 	  (incf i)))))))
 
 (defun escaped-string-copy (string start end num-escapes)
-  (do* ((length (- end start num-escapes))
-	(new-string (make-string length))
-	(p 0 (1+ p))
-	(q start (1+ q)))
-      ((>= p length) new-string)
-    (when (char= (char string q) #\\)
-      (incf q))
-    (setf (char new-string p) (char string q))))
+  (let ((start (check-the index start))
+	(end (check-the index end)))
+    (do* ((length (- end start num-escapes))
+	  (new-string (make-string length))
+	  (p 0 (1+ p))
+	  (q start (1+ q)))
+	((>= p length) new-string)
+      (declare (index p q))
+      (when (char= (char string q) #\\)
+	(incf q))
+      (setf (char new-string p) (char string q)))))
   
 
 (defun simple-read-from-string (string &optional eof-error-p eof-value &key (start 0) (end (length string)))
   "=> object, new-position, new-string, new-end."
-  (do ((i start (1+ i)))
-      ((>= i end) (if eof-error-p
-		      (error "EOF")
-		    (values eof-value i)))
-    (case (schar string i)
-      ((#\space #\tab #\newline))
-      (#\( (return-from simple-read-from-string
-	     (simple-read-delimited-list #\) string (1+ i) end :tail-delimiter #\.)))
-      (#\) (warn "Ignoring extra ~C." (schar string i))
-	   (incf i))
-      (#\' (multiple-value-bind (quoted-form form-end)
-	       (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)
-	     (return-from simple-read-from-string
-	       (values (list 'quote quoted-form) form-end string end))))
-      (#\" (incf i)
-	   (multiple-value-bind (string-end num-escapes)
-	       (position-with-escape #\" string i end)
-	     (return-from simple-read-from-string
-	       (values (escaped-string-copy string i string-end num-escapes)
-		       (1+ string-end)
-		       string end))))
-      (#\| (incf i)
-	   (multiple-value-bind (symbol-end num-escapes)
-	       (position-with-escape #\| string i end)
-	     (return-from simple-read-from-string
-	       (values (if (= 0 num-escapes)
-			   (intern-string string *package* :start i :end symbol-end)
-			 (intern (escaped-string-copy string i symbol-end num-escapes)))
-		       (1+ symbol-end)
-		       string end))))
-      (#\# (assert (< (incf i) end) (string)
-	     "End of string after #: ~S." (substring string start end))
-	  (multiple-value-bind (parameter parameter-end)
-	      (parse-integer string :start i :end end :radix 10 :junk-allowed t)
-	    (setf i parameter-end)
-	    (return-from simple-read-from-string
-	      (ecase (char-downcase (char string i))
-		(#\b (simple-read-integer string (1+ i) end 2))
-		(#\o (simple-read-integer string (1+ i) end 8))
-		(#\x (simple-read-integer string (1+ i) end 16))
-		(#\r (check-type parameter (integer 2 36))
-		     (simple-read-integer string (1+ i) end parameter))
-		(#\' (multiple-value-bind (quoted-form form-end)
-			 (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)
-		       (values (list 'function quoted-form) form-end string end)))
-		(#\( (multiple-value-bind (contents-list form-end)
-			 (simple-read-delimited-list #\) string (1+ i) end)
-		       (values (replace (make-array (or parameter (length contents-list))
-						    :initial-element (car (last contents-list)))
-					contents-list)
-			       form-end
-			       string end)))
-		(#\* (let* ((token-end (find-token-end string :start (incf i) :end end))
-			    (bit-vector (make-array (or parameter (- token-end i))
-						    :element-type 'bit)))
-		       (do ((p i (1+ p))
-			    (q 0 (1+ q))
-			    (bit nil))
-			   ((>= q (length bit-vector)))
-			 (when (< p token-end)
-			   (setf bit (schar string p)))
-			 (case bit
-			   (#\0 (setf (aref bit-vector q) 0))
-			   (#\1 (setf (aref bit-vector q) 1))
-			   (t (error "Illegal bit-vector element: ~S" bit))))
-		       (values bit-vector
-			       token-end
-			       string end)))
-		(#\s (multiple-value-bind (struct-form form-end)
-			 (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)
-		       (check-type struct-form list)
-		       (let* ((struct-name (car struct-form))
-			      (struct-args (cdr struct-form)))
-			 (check-type struct-name symbol "A structure name.")
-			 (values (apply #'make-structure struct-name struct-args)
-				 form-end string end))))
-		(#\: (let* ((token-end (find-token-end string :start (incf i) :end end))
-			    (symbol-name (string-upcase string :start i :end token-end)))
-		       (values (make-symbol symbol-name)
-			       token-end string end)))
-		(#\\ (let* ((token-end (find-token-end string :start (incf i) :end end))
-			    (char (name-char string i token-end)))
-		       (cond
-			(char (values char token-end))
-			((>= 1 (- token-end i))
-			 (values (char string i) (1+ i) string end))
-			(t (error "Don't know this character: ~S"
-				  (substring string i token-end))))))))))
-      (t (return-from simple-read-from-string
-	   (simple-read-token string :start i :end end))))))
+  (let ((start (check-the index start))
+	(end (check-the index end)))
+    (do ((i start (1+ i)))
+	((>= i end) (if eof-error-p
+			(error "EOF")
+		      (values eof-value i)))
+      (declare (index i))
+      (case (schar string i)
+	((#\space #\tab #\newline))
+	(#\( (return-from simple-read-from-string
+	       (simple-read-delimited-list #\) string (1+ i) end :tail-delimiter #\.)))
+	(#\) (warn "Ignoring extra ~C." (schar string i))
+	     (incf i))
+	(#\' (multiple-value-bind (quoted-form form-end)
+		 (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)
+	       (return-from simple-read-from-string
+		 (values (list 'quote quoted-form) form-end string end))))
+	(#\" (incf i)
+	     (multiple-value-bind (string-end num-escapes)
+		 (position-with-escape #\" string i end)
+	       (return-from simple-read-from-string
+		 (values (escaped-string-copy string i string-end num-escapes)
+			 (1+ string-end)
+			 string end))))
+	(#\| (incf i)
+	     (multiple-value-bind (symbol-end num-escapes)
+		 (position-with-escape #\| string i end)
+	       (return-from simple-read-from-string
+		 (values (if (= 0 num-escapes)
+			     (intern-string string *package* :start i :end symbol-end)
+			   (intern (escaped-string-copy string i symbol-end num-escapes)))
+			 (1+ symbol-end)
+			 string end))))
+	(#\# (assert (< (incf i) end) (string)
+	       "End of string after #: ~S." (substring string start end))
+	    (multiple-value-bind (parameter parameter-end)
+		(parse-integer string :start i :end end :radix 10 :junk-allowed t)
+	      (setf i parameter-end)
+	      (return-from simple-read-from-string
+		(ecase (char-downcase (char string i))
+		  (#\b (simple-read-integer string (1+ i) end 2))
+		  (#\o (simple-read-integer string (1+ i) end 8))
+		  (#\x (simple-read-integer string (1+ i) end 16))
+		  (#\r (check-type parameter (integer 2 36))
+		       (simple-read-integer string (1+ i) end parameter))
+		  (#\' (multiple-value-bind (quoted-form form-end)
+			   (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)
+			 (values (list 'function quoted-form) form-end string end)))
+		  (#\( (multiple-value-bind (contents-list form-end)
+			   (simple-read-delimited-list #\) string (1+ i) end)
+			 (values (replace (make-array (or parameter (length contents-list))
+						      :initial-element (car (last contents-list)))
+					  contents-list)
+				 form-end
+				 string end)))
+		  (#\* (let* ((token-end (find-token-end string :start (incf i) :end end))
+			      (bit-vector (make-array (or parameter (- token-end i))
+						      :element-type 'bit)))
+			 (do ((p i (1+ p))
+			      (q 0 (1+ q))
+			      (bit nil))
+			     ((>= q (length bit-vector)))
+			   (when (< p token-end)
+			     (setf bit (schar string p)))
+			   (case bit
+			     (#\0 (setf (aref bit-vector q) 0))
+			     (#\1 (setf (aref bit-vector q) 1))
+			     (t (error "Illegal bit-vector element: ~S" bit))))
+			 (values bit-vector
+				 token-end
+				 string end)))
+		  (#\s (multiple-value-bind (struct-form form-end)
+			   (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end)
+			 (check-type struct-form list)
+			 (let* ((struct-name (car struct-form))
+				(struct-args (cdr struct-form)))
+			   (check-type struct-name symbol "A structure name.")
+			   (values (apply #'make-structure struct-name struct-args)
+				   form-end string end))))
+		  (#\: (let* ((token-end (find-token-end string :start (incf i) :end end))
+			      (symbol-name (string-upcase string :start i :end token-end)))
+			 (values (make-symbol symbol-name)
+				 token-end string end)))
+		  (#\\ (let* ((token-end (find-token-end string :start (incf i) :end end))
+			      (char (name-char string i token-end)))
+			 (cond
+			  (char (values char token-end))
+			  ((>= 1 (- token-end i))
+			   (values (char string i) (1+ i) string end))
+			  (t (error "Don't know this character: ~S"
+				    (substring string i token-end))))))))))
+	(t (return-from simple-read-from-string
+	     (simple-read-token string :start i :end end)))))))
 
 (defun read-from-string (&rest args)
   (declare (dynamic-extent args))



From ffjeld at common-lisp.net  Fri Aug 26 19:38:42 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:38:42 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp 
Message-ID: <20050826193842.CD52A880AC@common-lisp.net>

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

Modified Files:
	print.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:38:42 2005
Author: ffjeld

Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.20 movitz/losp/muerte/print.lisp:1.21
--- movitz/losp/muerte/print.lisp:1.20	Sun Aug 14 14:13:51 2005
+++ movitz/losp/muerte/print.lisp	Fri Aug 26 21:38:41 2005
@@ -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.20 2005/08/14 12:13:51 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.21 2005/08/26 19:38:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -95,6 +95,7 @@
 	(do ((i (+ pos 1 (if sign-char 1 0) (if comma-interval (truncate pos comma-interval) 0))
 		(1+ i)))
 	    ((>= i mincol))
+	  (declare (index i))
 	  (write-char padchar stream)))
       (when sign-char
 	(write-char sign-char stream)))
@@ -159,6 +160,7 @@
   (with-subvector-accessor (string-ref string start end)
     (do ((i start (1+ i)))
 	((>= i end))
+      (declare (index i))
       (write-char (string-ref i) stream)))
   #+ignore (stream-write-string (output-stream-designator stream) string start end))
 



From ffjeld at common-lisp.net  Fri Aug 26 19:38:52 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:38:52 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp 
Message-ID: <20050826193852.56A078802E@common-lisp.net>

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

Modified Files:
	hash-tables.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:38:51 2005
Author: ffjeld

Index: movitz/losp/muerte/hash-tables.lisp
diff -u movitz/losp/muerte/hash-tables.lisp:1.10 movitz/losp/muerte/hash-tables.lisp:1.11
--- movitz/losp/muerte/hash-tables.lisp:1.10	Wed Aug 24 09:19:37 2005
+++ movitz/losp/muerte/hash-tables.lisp	Fri Aug 26 21:38:50 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Feb 19 19:09:05 2001
 ;;;;                
-;;;; $Id: hash-tables.lisp,v 1.10 2005/08/24 07:19:37 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.11 2005/08/26 19:38:50 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -191,6 +191,7 @@
 		  (hash-table-count hash-table) 0)
 	    (do ((i 0 (+ i 2)))
 		((>= i bucket-length))
+	      (declare ((index 2) i))
 	      (let ((old-key (svref%unsafe bucket i)))
 		(unless (eq old-key '--no-hash-key--)
 		  (setf (gethash old-key hash-table)
@@ -206,7 +207,9 @@
 	(setf index2 0))))))
 
 (defun gethash-string (key-string start end hash-table &optional default (key 'identity))
-  (let ((bucket (hash-table-bucket hash-table)))
+  (let ((start (check-the index start))
+	(end (check-the index end))
+	(bucket (hash-table-bucket hash-table)))
     (with-subvector-accessor (key-string-ref key-string start end)
       (do* ((bucket-length (length bucket))
 	    (index2 (rem (* 2 (sxhash-subvector key-string start end 8))
@@ -222,6 +225,7 @@
 		   (do ((bs-index 0 (1+ bs-index))
 			(key-index start (1+ key-index)))
 		       ((>= key-index end) t)
+		     (declare (index bs-index key-index))
 		     (unless (and (< bs-index bs-length)
 				  (char= (funcall key (key-string-ref key-index))
 					 (schar bs bs-index)))
@@ -235,6 +239,7 @@
 		(rem (+ 2 index2) bucket-length))
 	(i 0 (+ i 2)))
       ((>= i bucket-length) nil)
+    (declare ((index 2) i index2))
     (let ((x (svref bucket index2)))
       (when (or (eq x '--no-hash-key--)
 		(funcall (hash-table-test hash-table) x key))
@@ -245,6 +250,7 @@
 	(do ((i (rem (+ index2 2) bucket-length)
 		(rem (+ i 2) bucket-length)))
 	    ((= i index2))
+	  (declare ((index 2) i))
 	  (let ((k (svref bucket i)))
 	    (when (eq x '--no-hash-key--)
 	      (return))
@@ -259,6 +265,7 @@
 	(bucket-length (length bucket))
 	(i 0 (+ i 2)))
       ((>= i bucket-length))
+    (declare ((index 2) i))
     (setf (svref bucket i) '--no-hash-key--))
   hash-table)
 



From ffjeld at common-lisp.net  Fri Aug 26 19:38:57 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:38:57 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/equalp.lisp 
Message-ID: <20050826193857.428CC8802E@common-lisp.net>

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

Modified Files:
	equalp.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:38:56 2005
Author: ffjeld

Index: movitz/losp/muerte/equalp.lisp
diff -u movitz/losp/muerte/equalp.lisp:1.6 movitz/losp/muerte/equalp.lisp:1.7
--- movitz/losp/muerte/equalp.lisp:1.6	Thu Jul 22 03:07:38 2004
+++ movitz/losp/muerte/equalp.lisp	Fri Aug 26 21:38:56 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2001, 2003-2004, 
+;;;;    Copyright (C) 2001, 2003-2005, 
 ;;;;    Department of Computer Science, University of Tromso, Norway.
 ;;;; 
 ;;;;    For distribution policy, see the accompanying file COPYING.
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 13 17:09:08 2001
 ;;;;                
-;;;; $Id: equalp.lisp,v 1.6 2004/07/22 01:07:38 ffjeld Exp $
+;;;; $Id: equalp.lisp,v 1.7 2005/08/26 19:38:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -55,6 +55,7 @@
 	    (and (= length (length y))
 		 (do ((i 0 (1+ i)))
 		     ((= i length) t)
+		   (declare (index i))
 		   (unless (equalp (aref x i) (aref y i))
 		     (return nil)))))))
     (structure-object



From ffjeld at common-lisp.net  Fri Aug 26 19:39:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:39:10 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp 
Message-ID: <20050826193910.8CA308802E@common-lisp.net>

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

Modified Files:
	format.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:39:07 2005
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.11 movitz/losp/muerte/format.lisp:1.12
--- movitz/losp/muerte/format.lisp:1.11	Fri Jun 10 20:35:28 2005
+++ movitz/losp/muerte/format.lisp	Fri Aug 26 21:39:06 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Mar 23 01:18:36 2002
 ;;;;                
-;;;; $Id: format.lisp,v 1.11 2005/06/10 18:35:28 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.12 2005/08/26 19:39:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -79,6 +79,7 @@
 	     (i 0 (1+ i)))
 	    ((or (and (not d) (plusp i) (zerop remainder))
 		 (> i last-i)))
+	  (declare (index i))
 	  (multiple-value-bind (next-digit next-remainder)
 	      (if (= i last-i)
 		  (round (* 10 remainder))



From ffjeld at common-lisp.net  Fri Aug 26 19:39:14 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:39:14 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <20050826193914.0716D880E6@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:39:14 2005
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.108 movitz/losp/muerte/integers.lisp:1.109
--- movitz/losp/muerte/integers.lisp:1.108	Wed Aug 24 09:31:40 2005
+++ movitz/losp/muerte/integers.lisp	Fri Aug 26 21:39:14 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.108 2005/08/24 07:31:40 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.109 2005/08/26 19:39:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -803,6 +803,7 @@
 		   (let ((result (%make-bignum (1+ (ceiling result-length 32)))))
 		     (let ((src-max-bigit (* 2 (%bignum-bigits integer))))
 		       (dotimes (i (* 2 (%bignum-bigits result)))
+			 (declare (index i))
 			 (let ((src (+ i long)))
 			   (setf (memref result -2 :index i :type :unsigned-byte16)
 			     (if (< src src-max-bigit)



From ffjeld at common-lisp.net  Fri Aug 26 19:39:21 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:39:21 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp 
Message-ID: <20050826193921.3FDA08855F@common-lisp.net>

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

Modified Files:
	basic-functions.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:39:20 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.19 movitz/losp/muerte/basic-functions.lisp:1.20
--- movitz/losp/muerte/basic-functions.lisp:1.19	Tue May 24 08:33:19 2005
+++ movitz/losp/muerte/basic-functions.lisp	Fri Aug 26 21:39:20 2005
@@ -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.19 2005/05/24 06:33:19 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.20 2005/08/26 19:39:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -389,42 +389,46 @@
   (ecase type
     (:unsigned-byte8
      (let ((vector (make-array length :element-type '(unsigned-byte 8))))
-       (let ((i index))
-	 (dotimes (j length)
+       (let ((i (check-the index index)))
+	 (declare (index i))
+	 (dotimes (j (check-the index length))
+	   (declare (index j))
 	   (setf (aref vector j)
 	     (memref object offset :index i :type :unsigned-byte8))
 	   (incf i)))
        vector))))
 
 (defun (setf memrange) (value object offset index length type)
-  (ecase type
-    (:unsigned-byte8
-     (etypecase value
-       ((unsigned-byte 8)
-	(do ((end (+ index length))
-	     (i index (1+ i)))
-	    ((>= i end))
-	  (setf (memref object offset :index i :type :unsigned-byte8) value)))
-       (vector
-	(do ((end (+ index length))
-	     (i index (1+ i))
-	     (j 0 (1+ j)))
-	    ((or (>= i end) (>= j (length value))))
-	  (setf (memref object offset :index i :type :unsigned-byte8)
-	    (aref value j))))))
-    (:character
-     (etypecase value
-       (character
-	(do ((end (+ index length))
-	     (i index (1+ i)))
-	    ((>= i end))
-	  (setf (memref object offset :index i :type :character) value)))
-       (string
-	(do ((end (+ index length))
-	     (i index (1+ i))
-	     (j 0 (1+ j)))
-	    ((or (>= i end) (>= j (length value))))
-	  (setf (memref object offset :index i :type :character)
-	    (char value j)))))))
+  (let* ((index (check-the index index))
+	 (end (check-the index (+ index length))))	
+    (ecase type
+      (:unsigned-byte8
+       (etypecase value
+	 ((unsigned-byte 8)
+	  (do ((i index (1+ i)))
+	      ((>= i end))
+	    (declare (index i))
+	    (setf (memref object offset :index i :type :unsigned-byte8) value)))
+	 (vector
+	  (do ((i index (1+ i))
+	       (j 0 (1+ j)))
+	      ((or (>= i end) (>= j (length value))))
+	    (declare (index i j))
+	    (setf (memref object offset :index i :type :unsigned-byte8)
+	      (aref value j))))))
+      (:character
+       (etypecase value
+	 (character
+	  (do ((i index (1+ i)))
+	      ((>= i end))
+	    (declare (index i))
+	    (setf (memref object offset :index i :type :character) value)))
+	 (string
+	  (do ((i index (1+ i))
+	       (j 0 (1+ j)))
+	      ((or (>= i end) (>= j (length value))))
+	    (declare (index i j))
+	    (setf (memref object offset :index i :type :character)
+	      (char value j))))))))
   value)
      



From ffjeld at common-lisp.net  Fri Aug 26 19:39:28 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:39:28 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp 
Message-ID: <20050826193928.DA736880E6@common-lisp.net>

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

Modified Files:
	more-macros.lisp 
Log Message:
Add some type declarations.

Date: Fri Aug 26 21:39:27 2005
Author: ffjeld

Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.28 movitz/losp/muerte/more-macros.lisp:1.29
--- movitz/losp/muerte/more-macros.lisp:1.28	Tue May 24 08:33:40 2005
+++ movitz/losp/muerte/more-macros.lisp	Fri Aug 26 21:39:26 2005
@@ -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.28 2005/05/24 06:33:40 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.29 2005/08/26 19:39:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -117,8 +117,8 @@
 	   , at declarations-and-body
 	   ,result-form))
        (t `(do ((,var 0 (1+ ,var)))
-	       ((>= ,var ,count-form) ,result-form)
-	     (declare (type (integer 0 ,count-form) ,var))
+	       ((>= ,var ,count) ,result-form)
+	     (declare (type (integer 0 ,count) ,var))
 	     , at declarations-and-body))))))
 
 (defmacro dotimes ((var count-form &optional result-form) &body declarations-and-body)



From ffjeld at common-lisp.net  Fri Aug 26 19:40:34 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:40:34 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp 
Message-ID: <20050826194034.3ED228853F@common-lisp.net>

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

Modified Files:
	interrupt.lisp 
Log Message:
Handle into exception after fixnum addition.

Date: Fri Aug 26 21:40:33 2005
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.47 movitz/losp/muerte/interrupt.lisp:1.48
--- movitz/losp/muerte/interrupt.lisp:1.47	Fri Aug 12 22:28:30 2005
+++ movitz/losp/muerte/interrupt.lisp	Fri Aug 26 21:40:32 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.47 2005/08/12 20:28:30 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.48 2005/08/26 19:40:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -276,9 +276,9 @@
 
 (defun interrupt-default-handler (vector dit-frame)
   (declare (without-check-stack-limit))
-  (macrolet ((dereference (fixnum-address &optional (type :lisp))
+  (macrolet ((dereference (location &optional (type :lisp))
 	       "Dereference the fixnum-address."
-	       `(memref ,fixnum-address 0 :type ,type)))
+	       `(memref ,location 0 :type ,type)))
     (let (($eip (+ dit-frame (dit-frame-index :eip)))
 	  ($eax (+ dit-frame (dit-frame-index :eax)))
 	  ($ebx (+ dit-frame (dit-frame-index :ebx)))
@@ -290,14 +290,24 @@
 	(case vector
 	  (0 (error 'division-by-zero))
 	  (3 (break "Break instruction at ~@Z." $eip))
-	  (4 (if (not (eq (load-global-constant new-unbound-value)
-			  (dereference $eax)))
-		 (error "Primitive overflow assertion failed.")
+	  (4 (cond
+	      ((eq (load-global-constant new-unbound-value)
+		   (dereference $eax))
 	       (let ((name (dereference $ebx)))
 		 (with-simple-restart (new-value "Set the value of ~S." name)
 		   (error 'unbound-variable :name name))
 		 (format *query-io* "~&Enter a value for ~S: " name)
-		 (setf (dereference $eax) (read *query-io*)))))
+		 (setf (dereference $eax) (read *query-io*))))
+	      ((typep (dereference $eax) 'fixnum)
+	       (let ((eax (dereference $eax)))
+		 (setf (dereference $eax)
+		   (if (plusp eax)
+		       (- most-negative-fixnum
+			  1 (- most-positive-fixnum eax))
+		     (+ most-positive-fixnum
+			1 (- eax most-negative-fixnum))))
+		 (warn "Overflow: ~S -> ~S" eax (dereference $eax))))
+	      (t (error "Primitive overflow assertion failed."))))
 	  (6 (error "Illegal instruction at ~@Z." $eip))
 	  (13  (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z"
 		     $eip



From ffjeld at common-lisp.net  Fri Aug 26 19:41:34 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:41:34 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050826194134.0E3B38853F@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Compile (add <fixnum> <fixnum>) to addl x y, into. So rely on the
interrupt handler to deal with overflows.

Date: Fri Aug 26 21:41:33 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.157 movitz/compiler.lisp:1.158
--- movitz/compiler.lisp:1.157	Wed Aug 24 09:30:45 2005
+++ movitz/compiler.lisp	Fri Aug 26 21:41:32 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.157 2005/08/24 07:30:45 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.158 2005/08/26 19:41:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2870,6 +2870,7 @@
   "Try to locate binding in a register. Return a register, or
    nil and :not-now, or :never.
    This function is factored out from assign-bindings."
+  (assert (not (typep binding 'forwarding-binding)))
   (let* ((count-init-pc (gethash binding var-counts))
 	 (count (car count-init-pc))
 	 (init-pc (second count-init-pc)))
@@ -2898,9 +2899,12 @@
 			 (when pos
 			   (return (values i (nth pos read-destinations) distance)))))))
 	  (declare (ignore load-instruction))
-	  ;; (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination)
 	  (multiple-value-bind (free-registers more-later-p)
 	      (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map))
+	    #+ignore
+	    (when (string= 'num-jumpers (binding-name binding))
+	      (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination)
+	      (warn "free: ~S, more: ~S" free-registers more-later-p))
 	    (let ((free-registers-no-ecx (remove :ecx free-registers)))
 	      (cond
 	       ((member binding-destination free-registers-no-ecx)
@@ -6804,7 +6808,7 @@
 	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
 	#+ignore
 	(warn "add: ~A for ~A" instruction result-type)
-	#+ignore
+
 	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
 	      destination result-type
 	      term0 loc0
@@ -6817,7 +6821,14 @@
 		term1 loc1 (binding-extent-env (binding-target term1)))
 	  (print-code 'load-term1 (make-load-lexical term1 :eax funobj nil frame-map))
 	  (print-code 'load-dest (make-load-lexical destination :eax funobj nil frame-map)))
-	(flet ((make-default-add ()
+	(flet ((make-store (source destination)
+		 (cond
+		  ((eq source destination)
+		   nil)
+		  ((member destination '(:eax :ebx :ecx :edx))
+		   `((:movl ,source ,destination)))
+		  (t (make-store-lexical destination source nil funobj frame-map))))
+	       (make-default-add ()
 		 (when (movitz-subtypep result-type '(unsigned-byte 32))
 		   (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S"
 			 destination-location
@@ -6852,9 +6863,11 @@
 			   (binding
 			    (make-store-lexical destination :eax nil funobj frame-map))))))
 	  (let ((constant0 (let ((x (type-specifier-singleton type0)))
-			     (when x (movitz-immediate-value (car x)))))
+			     (when (and x (typep (car x) 'movitz-fixnum))
+			       (movitz-immediate-value (car x)))))
 		(constant1 (let ((x (type-specifier-singleton type1)))
-			     (when x (movitz-immediate-value (car x))))))
+			     (when (and x (typep (car x) 'movitz-fixnum))
+			       (movitz-immediate-value (car x))))))
 	    (cond
 	     ((type-specifier-singleton result-type)
 	      ;; (break "constant add: ~S" instruction)
@@ -7023,20 +7036,27 @@
 				 (binding-lended-p (binding-target term1)))))
 	       (t (warn "Unknown fixnum add: ~S" instruction)
 		  (make-default-add))))
-	     ((and (movitz-subtypep result-type '(unsigned-byte 32))
-		   (movitz-subtypep type0 'fixnum)
+	     ((and (movitz-subtypep type0 'fixnum)
 		   (movitz-subtypep type1 'fixnum))
-	      (flet ((mkadd (src srcloc destreg)
-		       (if (integerp srcloc)
-			   `((:addl (:ebp ,(stack-frame-offset srcloc))
-				    ,destreg))
-			 (ecase (operator srcloc)
-			   ((:eax :ebx :ecx :edx)
-			    `((:addl ,srcloc ,destreg)))
-			   ((:argument-stack)
-			    `((:addl (:ebx ,(argument-stack-offset src))
-				     ,destreg)))
-			   ))))
+	      (flet ((mkadd-into (src destreg)
+		       (assert (eq destreg :eax) (destreg)
+			 "Movitz' INTO protocol says the overflowed value must be in EAX, ~
+but it's requested to be in ~S."
+			 destreg)
+		       (let ((srcloc (new-binding-location (binding-target src) frame-map)))
+			 (if (integerp srcloc)
+			     `((:addl (:ebp ,(stack-frame-offset srcloc))
+				      ,destreg)
+			       (:into))
+			   (ecase (operator srcloc)
+			     ((:eax :ebx :ecx :edx)
+			      `((:addl ,srcloc ,destreg)
+				(:into)))
+			     ((:argument-stack)
+			      `((:addl (:ebx ,(argument-stack-offset src))
+				       ,destreg)
+				(:into)))
+			     )))))
 		(cond
 		 ((and (not constant0)
 		       (not constant1)
@@ -7045,26 +7065,22 @@
 		       (not (and (bindingp destination)
 				 (binding-lended-p (binding-target destination)))))
 		  (cond
-;;;		   ((and (not (eq loc0 :untagged-fixnum-ecx))
-;;;			 (not (eq loc1 :untagged-fixnum-ecx))
-;;;			 (not (eq destination-location :untagged-fixnum-ecx)))
-;;;		    (let ((tmpreg (cond
-;;;				   ((member destination-location '(:eax :ebx :ecx :edx))
-;;;				    destination-location)
-;;;				   ((some (lambda (x) (and (not (eq x loc0)) (not (eq x loc1))))
-;;;					  '(:ecx :edx :eax :ebx)))
-;;;				   (t :ecx)))
-;;;			  (no-overflow (gensym "no-overflow-")))
-;;;		      (append (make-load-lexical term0 :eax funobj nil frame-map)
-;;;			      (mkadd term1 loc1 :eax)
-;;;			      `((:jnc ',no-overflow)
-;;;				(:movl :eax :ecx)
-;;;				(:rcrl 1 :ecx)
-;;;				(:shrl 1 :ecx)
-;;;				(,*compiler-local-segment-prefix*
-;;;				 :call (:edi ,(global-constant-offset 'box-u32-ecx)))
-;;;				,no-overflow))
-		   (t (make-default-add)
+		   ((and (not (eq loc0 :untagged-fixnum-ecx))
+			 (not (eq loc1 :untagged-fixnum-ecx))
+			 (not (eq destination-location :untagged-fixnum-ecx)))
+		    (append (cond
+			     ((and (eq loc0 :eax) (eq loc1 :eax))
+			      `((:addl :eax :eax)
+				(:into)))
+			     ((eq loc0 :eax)
+			      (mkadd-into term1 :eax))
+			     ((eq loc1 :eax)
+			      (mkadd-into term0 :eax))
+			     (t (append (make-load-lexical term0 :eax funobj nil frame-map
+							   :protect-registers (list loc1))
+					(mkadd-into term1 :eax))))
+			    (make-store :eax destination)))
+		  (t (make-default-add)
 		      #+ignore
 		      (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map)
 			      `((,*compiler-local-segment-prefix*



From ffjeld at common-lisp.net  Fri Aug 26 19:43:33 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 21:43:33 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050826194333.84C338853F@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Comment out debug message..

Date: Fri Aug 26 21:43:32 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.158 movitz/compiler.lisp:1.159
--- movitz/compiler.lisp:1.158	Fri Aug 26 21:41:32 2005
+++ movitz/compiler.lisp	Fri Aug 26 21:43:32 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.158 2005/08/26 19:41:32 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.159 2005/08/26 19:43:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -6808,7 +6808,7 @@
 	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
 	#+ignore
 	(warn "add: ~A for ~A" instruction result-type)
-
+	#+ignore
 	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
 	      destination result-type
 	      term0 loc0



From ffjeld at common-lisp.net  Fri Aug 26 21:40:42 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 23:40:42 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <20050826214042.1F0178853F@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Export muerte:check-the.

Date: Fri Aug 26 23:40:29 2005
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.52 movitz/packages.lisp:1.53
--- movitz/packages.lisp:1.52	Thu Aug 11 23:32:55 2005
+++ movitz/packages.lisp	Fri Aug 26 23:40:28 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Nov 15 21:39:55 2003
 ;;;;                
-;;;; $Id: packages.lisp,v 1.52 2005/08/11 21:32:55 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.53 2005/08/26 21:40:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1098,6 +1098,7 @@
 	   #:read-key
 	   #:fixnump
 	   #:newline
+	   #:check-the
 	   
 	   #:*print-safely*
 	   



From ffjeld at common-lisp.net  Fri Aug 26 21:42:09 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 23:42:09 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050826214209.DDD9C8853F@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Fixed bug in peephole optimizer that would erroneously regard some
stack-frame locations as unused.

Date: Fri Aug 26 23:42:08 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.159 movitz/compiler.lisp:1.160
--- movitz/compiler.lisp:1.159	Fri Aug 26 21:43:32 2005
+++ movitz/compiler.lisp	Fri Aug 26 23:42:08 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.159 2005/08/26 19:43:32 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.160 2005/08/26 21:42:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -567,6 +567,13 @@
 		       (when (and (not (null (type-analysis-thunks analysis)))
 				  (not (apply #'encoded-allp
 					      (type-analysis-declared-encoded-type analysis))))
+			 #+ignore
+			 (warn "Trusting ~S, was ~S, because ~S [~S]"
+			       binding
+			       (type-analysis-encoded-type analysis)
+			       (type-analysis-thunks analysis)
+			       (loop for (thunk . thunk-args) in (type-analysis-thunks analysis)
+				   collect (mapcar #'binding-resolved-p thunk-args)))
 			 (setf (type-analysis-encoded-type analysis)
 			   (type-analysis-declared-encoded-type analysis))
 			 (setf (type-analysis-thunks analysis) nil))) ; Ignore remaining thunks.
@@ -1742,6 +1749,8 @@
 	   (stack-frame-operand (twop-dst c op)))
 	 (read-stack-frame-p (c)
 	   (or (load-stack-frame-p c :movl)
+	       (load-stack-frame-p c :addl)
+	       (load-stack-frame-p c :subl)
 	       (load-stack-frame-p c :cmpl)
 	       (store-stack-frame-p c :cmpl)
 	       (and (consp c)
@@ -7044,6 +7053,7 @@
 but it's requested to be in ~S."
 			 destreg)
 		       (let ((srcloc (new-binding-location (binding-target src) frame-map)))
+			 (unless (eql srcloc loc1) (break))
 			 (if (integerp srcloc)
 			     `((:addl (:ebp ,(stack-frame-offset srcloc))
 				      ,destreg)



From ffjeld at common-lisp.net  Fri Aug 26 21:42:40 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Fri, 26 Aug 2005 23:42:40 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp 
Message-ID: <20050826214240.834698853F@common-lisp.net>

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

Modified Files:
	textmode.lisp 
Log Message:
Tweaked textmode-scroll-down.

Date: Fri Aug 26 23:42:40 2005
Author: ffjeld

Index: movitz/losp/x86-pc/textmode.lisp
diff -u movitz/losp/x86-pc/textmode.lisp:1.14 movitz/losp/x86-pc/textmode.lisp:1.15
--- movitz/losp/x86-pc/textmode.lisp:1.14	Wed Nov 24 17:24:36 2004
+++ movitz/losp/x86-pc/textmode.lisp	Fri Aug 26 23:42:39 2005
@@ -1,6 +1,6 @@
 ;;;;------------------------------------------------------------------
 ;;;; 
-;;;;    Copyright (C) 2000-2004,
+;;;;    Copyright (C) 2000-2005,
 ;;;;    Department of Computer Science, University of Tromso, Norway
 ;;;; 
 ;;;; Filename:      textmode.lisp
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  9 15:38:56 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: textmode.lisp,v 1.14 2004/11/24 16:24:36 ffjeld Exp $
+;;;; $Id: textmode.lisp,v 1.15 2005/08/26 21:42:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -100,6 +100,7 @@
 	 (move-vga-cursor (setf *cursor-x* (1+ x)) y))))
   nil)
 
+#+ignore
 (defun textmode-copy-line (destination source count)
   (check-type count (and (integer 0 511) (satisfies evenp)))
   (check-type source (unsigned-byte 20))
@@ -125,12 +126,36 @@
 (defun textmode-scroll-down ()
   (declare (special muerte.lib::*scroll-offset*))
   (incf muerte.lib::*scroll-offset*)
-  (loop with stride = (* 2 *screen-stride*)
-      for y below (1- *screen-height*)
-      as src from (+ *screen* stride) by stride
-      as dst from *screen* by stride
-      do (textmode-copy-line dst src *screen-width*)
-      finally (textmode-clear-line 0 (1- *screen-height*)))
+  (macrolet ((copy-line (destination source count)
+	       `(let ((destination ,destination)
+		      (source ,source)
+		      (count ,count))
+		  (with-inline-assembly (:returns :nothing)
+		    (:compile-form (:result-mode :edx) destination)
+		    (:compile-form (:result-mode :eax) source)
+		    (:compile-form (:result-mode :ebx) count)
+		    (:std)		; Only EBX is now (potential) GC root
+		    (:andl #x-8 :ebx)	; ..so make sure EBX is a fixnum
+		    (:shrl 2 :eax)
+		    (:shrl 2 :edx)
+		    (:shrl 1 :ebx)
+		    (:jz 'end-copy-loop)
+		   copy-loop
+		    (#.movitz:*compiler-physical-segment-prefix* :movl (:eax :ebx -4) :ecx)
+		    (#.movitz:*compiler-physical-segment-prefix* :movl :ecx (:edx :ebx -4))
+		    (:subl 4 :ebx)
+		    (:ja 'copy-loop)
+		   end-copy-loop
+		    (:cld)))))
+    (loop with screen = (check-the fixnum *screen*)
+	with stride = (* 2 *screen-stride*)
+	with width = (check-the fixnum *screen-width*)
+	with height = (1- (check-the fixnum *screen-height*))
+	repeat height
+	as src of-type fixnum from (+ screen stride) by stride
+	as dst of-type fixnum from screen by stride
+	do (copy-line dst src width)
+	finally (textmode-clear-line 0 height)))
   (signal 'newline))
 
 (defun textmode-clear-line (from-column line)



From ffjeld at common-lisp.net  Fri Aug 26 22:38:12 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 27 Aug 2005 00:38:12 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp 
Message-ID: <20050826223812.DEF6188168@common-lisp.net>

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

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

Date: Sat Aug 27 00:38:08 2005
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.55 movitz/losp/muerte/inspect.lisp:1.56
--- movitz/losp/muerte/inspect.lisp:1.55	Sat Jun 11 02:02:04 2005
+++ movitz/losp/muerte/inspect.lisp	Sat Aug 27 00:38:07 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.55 2005/06/11 00:02:04 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.56 2005/08/26 22:38:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -262,6 +262,9 @@
      (copy-funobj old))
     (structure-object
      (copy-structure old))
+    (ratio
+     (make-ratio (%ratio-numerator old)
+		 (%ratio-denominator old)))
     (run-time-context
      (%shallow-copy-object old (movitz-type-word-size 'movitz-run-time-context)))))
 



From ffjeld at common-lisp.net  Fri Aug 26 22:42:44 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 27 Aug 2005 00:42:44 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <20050826224244.B6C6A88545@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Be a bit more conservative about debugging.

Date: Sat Aug 27 00:42:43 2005
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.52 movitz/losp/muerte/scavenge.lisp:1.53
--- movitz/losp/muerte/scavenge.lisp:1.52	Fri Aug 26 21:38:19 2005
+++ movitz/losp/muerte/scavenge.lisp	Sat Aug 27 00:42:43 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.52 2005/08/26 19:38:19 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.53 2005/08/26 22:42:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -50,7 +50,9 @@
 	       (let ((code (dpb secondary
 				(byte 8 8)
 				(movitz:tag primary))))
-		 `(= ,code ,x))))
+		 `(= ,code ,x)))
+	     (record-scan (x)
+	       #+ignore `(setf *scan-last* ,x)))
     (do ((verbose *map-header-vals-verbose*)
 	 (*scan-last* nil)		; Last scanned object, for debugging.
 	 (scan start-location (1+ scan)))
@@ -79,12 +81,12 @@
 	    ;; Just skip the bigits
 	    (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14))
 		   (delta (logior bigits 1)))
-	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
+	      (record-scan (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan delta)))
 	   ((scavenge-typep x :defstruct)
 	    (assert (evenp scan) ()
 	      "Scanned struct-header ~S at odd location #x~X." x scan)
-	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other))))
+	    (record-scan (%word-offset scan #.(movitz:tag :other))))
 	   ((scavenge-typep x :run-time-context)
 	    (assert (evenp scan) ()
 	      "Scanned run-time-context-header ~S at odd location #x~X." 
@@ -102,7 +104,7 @@
 	    (assert (evenp scan) ()
 	      "Scanned funobj-header ~S at odd location #x~X." 
 	      (memref scan 0 :type :unsigned-byte32) scan)
-	    (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
+	    (record-scan (%word-offset scan #.(movitz:tag :other)))
 	    ;; Process code-vector pointers specially..
 	    (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector))
 		   (new-code-vector (map-instruction-pointer function scan old-code-vector)))
@@ -163,14 +165,14 @@
 	      "Scanned u8-vector-header ~S at odd location #x~X." x scan)
 	    (let ((len (memref scan 0 :index 1 :type :lisp)))
 	      (check-type len positive-fixnum)
-	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
+	      (record-scan (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan (1+ (* 2 (truncate (+ 7 len) 8))))))
 	   ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16))
 	    (assert (evenp scan) ()
 	      "Scanned u16-vector-header ~S at odd location #x~X." x scan)
 	    (let ((len (memref scan 0 :index 1)))
 	      (check-type len positive-fixnum)
-	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
+	      (record-scan (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan (1+ (* 2 (truncate (+ 3 len) 4))))))
 	   ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32))
 	    (assert (evenp scan) ()
@@ -178,7 +180,7 @@
 	    (let ((len (memref scan 4)))
 	      (assert (typep len 'positive-fixnum) ()
 		"Scanned basic-vector at ~S with illegal length ~S." scan len)
-	      (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
+	      (record-scan (%word-offset scan #.(movitz:tag :other)))
 	      (incf scan (1+ (logand (1+ len) -2)))))
 	   ((scavenge-typep x :basic-vector)
 	    (if (or (scavenge-wide-typep x :basic-vector
@@ -187,10 +189,10 @@
 		    (scavenge-wide-typep x :basic-vector
 					 #.(bt:enum-value 'movitz:movitz-vector-element-type
 							  :indirects)))
-		(setf *scan-last* (%word-offset scan #.(movitz:tag :other)))
+		(record-scan (%word-offset scan #.(movitz:tag :other)))
 	      (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan)))
 	   ((and (eq x 3) (eq x2 0))
-	    (setf *scan-last* scan)
+	    (record-scan scan)
 	    (incf scan)
 	    (let ((delta (memref scan 0)))
 	      (check-type delta positive-fixnum)



From ffjeld at common-lisp.net  Fri Aug 26 22:50:40 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sat, 27 Aug 2005 00:50:40 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/packages.lisp 
Message-ID: <20050826225040.2635C88545@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
Export muerte:index.

Date: Sat Aug 27 00:50:36 2005
Author: ffjeld

Index: movitz/packages.lisp
diff -u movitz/packages.lisp:1.53 movitz/packages.lisp:1.54
--- movitz/packages.lisp:1.53	Fri Aug 26 23:40:28 2005
+++ movitz/packages.lisp	Sat Aug 27 00:50:36 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Nov 15 21:39:55 2003
 ;;;;                
-;;;; $Id: packages.lisp,v 1.53 2005/08/26 21:40:28 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.54 2005/08/26 22:50:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1099,6 +1099,7 @@
 	   #:fixnump
 	   #:newline
 	   #:check-the
+	   #:index
 	   
 	   #:*print-safely*
 	   



From ffjeld at common-lisp.net  Sun Aug 28 20:53:15 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 22:53:15 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp 
Message-ID: <20050828205315.7A3C288032@common-lisp.net>

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

Modified Files:
	basic-macros.lisp 
Log Message:
Fixed bogus word-nibble.

Date: Sun Aug 28 22:53:14 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-macros.lisp
diff -u movitz/losp/muerte/basic-macros.lisp:1.64 movitz/losp/muerte/basic-macros.lisp:1.65
--- movitz/losp/muerte/basic-macros.lisp:1.64	Sun Aug 21 15:47:20 2005
+++ movitz/losp/muerte/basic-macros.lisp	Sun Aug 28 22:53:13 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.64 2005/08/21 13:47:20 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.65 2005/08/28 20:53:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1083,10 +1083,11 @@
 
 (defmacro word-nibble (word-form nibble)
   (check-type nibble (integer 0 7))
-  `(with-inline-assembly (:returns :untagged-fixnum-eax)
+  `(with-inline-assembly (:returns :untagged-fixnum-ecx)
      (:compile-form (:result-mode :eax) ,word-form)
-     (:shrl ,(* 4 nibble) :eax)
-     (:andl #xf :eax)))
+     (:movl :eax :ecx)
+     (:shrl ,(* 4 nibble) :ecx)
+     (:andl #xf :ecx)))
 
 (define-compiler-macro boundp (symbol)
   `(with-inline-assembly-case ()



From ffjeld at common-lisp.net  Sun Aug 28 20:56:01 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 22:56:01 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp 
Message-ID: <20050828205601.25A3988032@common-lisp.net>

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

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

Date: Sun Aug 28 22:56:00 2005
Author: ffjeld

Index: movitz/losp/x86-pc/dp8390.lisp
diff -u movitz/losp/x86-pc/dp8390.lisp:1.8 movitz/losp/x86-pc/dp8390.lisp:1.9
--- movitz/losp/x86-pc/dp8390.lisp:1.8	Wed Aug 24 09:33:13 2005
+++ movitz/losp/x86-pc/dp8390.lisp	Sun Aug 28 22:56:00 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 18 12:21:36 2002
 ;;;;                
-;;;; $Id: dp8390.lisp,v 1.8 2005/08/24 07:33:13 ffjeld Exp $
+;;;; $Id: dp8390.lisp,v 1.9 2005/08/28 20:56:00 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -129,14 +129,6 @@
 	address))
     (setf (io-register8x2 dp8390 ($page0-write rbcr1) ($page0-write rbcr0)) size
 	  (dp8390 ($page0-write cr)) command))
-  nil)
-
-(defun foo (io-base command size address)
-  (let ((io-base (the (unsigned-byte #x10)
-		   (let ((check-the-io-base io-base))
-		     (check-type check-the-io-base (unsigned-byte #x10))
-		     check-the-io-base))))
-    (setf (io-port (+ io-base 0) :unsigned-byte8) #o40))
   nil)
 
 (defmacro with-dp8390-dma ((dp8390-var rdma-command size &optional address) &body body)



From ffjeld at common-lisp.net  Sun Aug 28 21:03:28 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 23:03:28 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp 
Message-ID: <20050828210328.4130488032@common-lisp.net>

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

Modified Files:
	special-operators-cl.lisp 
Log Message:
Many fixes to the compiler. Basic change is that LET init-forms are
compiled with compile-form-unprotected, and that
compile-lexical-variable and compile-self-evaluating return binding
only as "returns", not in the form of "code".

Date: Sun Aug 28 23:03:27 2005
Author: ffjeld

Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.47 movitz/special-operators-cl.lisp:1.48
--- movitz/special-operators-cl.lisp:1.47	Sat Aug 20 22:31:15 2005
+++ movitz/special-operators-cl.lisp	Sun Aug 28 23:03:27 2005
@@ -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.47 2005/08/20 20:31:15 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.48 2005/08/28 21:03:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -85,11 +85,11 @@
 				      :modify-accumulate let-modifies
 				      :result-mode :push)
 				    `((:pushl :edi)) ; scratch
-				    (compiler-call #'compile-self-evaluating ; binding name
+				    (compiler-call #'compile-form ; binding name
 				      :with-stack-used (incf stack-used 2)
 				      :env init-env
 				      :defaults all
-				      :form var
+				      :form `(muerte.cl:quote ,var)
 				      :result-mode :push)
 				    (prog1 nil (incf stack-used)))
 			    nil t)
@@ -103,20 +103,26 @@
 			   (compiler-values-bind (&code init-code &functional-p functional-p
 						  &type type &returns init-register
 						  &final-form final-form)
-			       (compiler-call #'compile-form-to-register
+			       
+			       (compiler-call #'compile-form-unprotected
+				 :result-mode binding
+				 :env init-env
+				 :extent local-env
+				 :defaults all
+				 :form init-form)
+			     #+ignore
+			     (compiler-call #'compile-form-to-register
 				 :env init-env
 				 :extent local-env
 				 :defaults all
 				 :form init-form
 				 :modify-accumulate let-modifies)
+			     (when (eq binding init-register)
+			       (setf init-register nil))
 ;;;			     (warn "var ~S, type: ~S" var type)
 ;;;			     (warn "var ~S init: ~S.." var init-form)
-;;;			     (print-code 'init
-;;;					 (compiler-call #'compile-form
-;;;					   :env init-env
-;;;					   :defaults all
-;;;					   :form init-form
-;;;					   :result-mode binding))
+;;;			     (warn "bind: ~S reg: ~S" binding init-register)
+;;;			     (print-code 'init init-code)
 			     (list var
 				   init-form
 				   init-code
@@ -127,6 +133,7 @@
 				     init-type)
 				   (case init-register
 				     (:non-local-exit :edi)
+				     (:multiple-values :eax)
 				     (t init-register))
 				   final-form))))))
 	  (setf (stack-used local-env)
@@ -221,6 +228,9 @@
 						    ;; This is the best we can do now to determine
 						    ;; if target-binding is ever used again.
 						    (and (eq result-mode :function)
+							 (not (and (bindingp body-returns)
+								   (binding-eql target-binding
+										body-returns)))
 							 (not (code-uses-binding-p body-code
 										   target-binding
 										   :load t
@@ -261,10 +271,11 @@
 								   :load nil :store t)))
 				    ;; replace read-only lexical binding with
 				    ;; side-effect-free form
-				    #+ignore (warn "Constant binding: ~S => ~S => ~S"
-						   (binding-name binding)
-						   init-form
-						   (car (type-specifier-singleton type)))
+				    #+ignore
+				    (warn "Constant binding: ~S => ~S => ~S"
+					  (binding-name binding)
+					  init-form
+					  (car (type-specifier-singleton type)))
 				    (change-class binding 'constant-object-binding
 						  :object (car (type-specifier-singleton type)))
 				    (if functional-p
@@ -1404,7 +1415,9 @@
 		:returns :eax))))
 	 (t (compiler-call #'compile-form-unprotected
 	      :forward all
-	      :form `(muerte::compiled-cond (,test-form ,then-form) (t ,else-form)))))))))
+	      :form `(muerte::compiled-cond
+		      (,test-form ,then-form)
+		      (muerte.cl::t ,else-form)))))))))
 
 (define-special-operator the (&all all &form form)
   (destructuring-bind (value-type sub-form)



From ffjeld at common-lisp.net  Sun Aug 28 21:04:06 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 23:04:06 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp 
Message-ID: <20050828210406.08C5F88545@common-lisp.net>

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

Modified Files:
	special-operators.lisp 
Log Message:
Many fixes to the compiler. Basic change is that LET init-forms are
compiled with compile-form-unprotected, and that
compile-lexical-variable and compile-self-evaluating return binding
only as "returns", not in the form of "code".

Date: Sun Aug 28 23:03:55 2005
Author: ffjeld

Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.53 movitz/special-operators.lisp:1.54
--- movitz/special-operators.lisp:1.53	Sat Aug 20 22:31:25 2005
+++ movitz/special-operators.lisp	Sun Aug 28 23:03:53 2005
@@ -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.53 2005/08/20 20:31:25 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.54 2005/08/28 21:03:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -82,21 +82,19 @@
      ((not (null then-forms))
       (let ((skip-label (gensym (format nil "cond-skip-~D-" clause-num))))
 	(compiler-values-bind (&code test-code)
-	    (multiple-value-bind (test-result-mode)
-		(cond
-		 ((and last-clause-p
-		       (eq (operator result-mode)
-			   :boolean-branch-on-false))
-		  (cons :boolean-branch-on-false
-			(cdr result-mode)))
-		 (t (cons :boolean-branch-on-false
-			  skip-label)))
-	      (compiler-call #'compile-form
-		:result-mode test-result-mode
-		:modify-accumulate clause-modifies
-		:form test-form
-		:funobj funobj
-		:env env))
+	    (compiler-call #'compile-form
+	      :result-mode (cond
+			    ((and last-clause-p
+				  (eq (operator result-mode)
+				      :boolean-branch-on-false))
+			     (cons :boolean-branch-on-false
+				   (cdr result-mode)))
+			    (t (cons :boolean-branch-on-false
+				     skip-label)))
+	      :modify-accumulate clause-modifies
+	      :form test-form
+	      :funobj funobj
+	      :env env)
 	  (compiler-values-bind (&code then-code &returns then-returns)
 	      (compiler-call #'compile-form
 		:form (cons 'muerte.cl::progn then-forms)
@@ -134,8 +132,7 @@
 (define-special-operator compiled-cond
     (&form form &funobj funobj &env env &result-mode result-mode)
   (let ((clauses (cdr form)))
-    (let* ((cond-modifies nil)
-	   (cond-exit-label (gensym "cond-exit-"))
+    (let* ((cond-exit-label (gensym "cond-exit-"))
 	   (cond-result-mode (case (operator result-mode)
 			       (:values :multiple-values)
 			       ((:ignore :function :multiple-values :eax :ebx :ecx :edx
@@ -152,32 +149,28 @@
 				   '(:ignore
 				     :boolean-branch-on-true
 				     :boolean-branch-on-false))))
-      (loop for clause in clauses
+      (loop with last-clause-num = (1- (length clauses))
+	  for clause in clauses
 	  for clause-num upfrom 0
-	  with last-clause-num = (1- (length clauses))
-	  as (clause-code constantly-true-p clause-modifies) =
-	    (multiple-value-list (make-compiled-cond-clause clause
-							    clause-num
-							    (and only-control-p
-								 (= clause-num last-clause-num))
-							    cond-exit-label funobj env cond-result-mode))
+	  as (clause-code constantly-true-p) =
+	    (multiple-value-list
+	     (make-compiled-cond-clause clause
+					clause-num
+					(and only-control-p
+					     (= clause-num last-clause-num))
+					cond-exit-label funobj env cond-result-mode))
 	  append clause-code into cond-code
-	  do (setf cond-modifies
-	       (modifies-union cond-modifies clause-modifies))
 	  when constantly-true-p
 	  do (return (compiler-values ()
 		       :returns cond-returns
-		       :modifies cond-modifies
 		       :code (append cond-code
 				     (list cond-exit-label))))
 	  finally
 	    (return (compiler-values ()
 		      :returns cond-returns
-		      :modifies cond-modifies
 		      :code (append cond-code
 				    ;; no test succeeded => nil
 				    (unless only-control-p
-;;;				      (warn "doing default nil..")
 				      (compiler-call #'compile-form
 					:form nil
 					:funobj funobj



From ffjeld at common-lisp.net  Sun Aug 28 21:10:47 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 23:10:47 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <20050828211047.B4F4988032@common-lisp.net>

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

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

Date: Sun Aug 28 23:10:46 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.57 movitz/losp/los0-gc.lisp:1.58
--- movitz/losp/los0-gc.lisp:1.57	Sun Jun 12 22:32:44 2005
+++ movitz/losp/los0-gc.lisp	Sun Aug 28 23:10:46 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.57 2005/06/12 20:32:44 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.58 2005/08/28 21:10:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -396,8 +396,8 @@
 				(and (object-in-space-p newspace forwarded-x)
 				     forwarded-x)))
 			 (let ((forward-x (shallow-copy x)))
-			   (when (and (typep x 'muerte::pointer)
-				      *gc-consistency-check*)
+			   (when (and *gc-consistency-check*
+				      (typep x 'muerte::pointer))
 			     (let ((a *x*))
 			       (vector-push (%object-lispval x) a)
 			       (vector-push (memref (object-location x) 0 :type :unsigned-byte32) a)
@@ -411,21 +411,21 @@
 	(dolist (range muerte::%memory-map-roots%)
 	  (map-header-vals evacuator (car range) (cdr range))))
       ;; Scan newspace, Cheney style.
-      (loop with newspace-location = (+ 2 (object-location newspace))
-	  with scan-pointer = 2
-	  as fresh-pointer = (space-fresh-pointer newspace)
+      (loop with newspace-location of-type index = (+ 2 (object-location newspace))
+	  with scan-pointer of-type index = 2
+	  as fresh-pointer of-type index = (space-fresh-pointer newspace)
 	  while (< scan-pointer fresh-pointer)
 	  do (map-header-vals evacuator
 			      (+ newspace-location scan-pointer)
 			      (+ newspace-location (space-fresh-pointer newspace)))
 	     (setf scan-pointer fresh-pointer))
-      ;; Consistency check..
-      (map-stack-vector (lambda (x foo)
-			  (declare (ignore foo))
-			  x)
-			nil
-			(current-stack-frame))
       (when *gc-consistency-check*
+	;; Consistency check..
+	(map-stack-vector (lambda (x foo)
+			    (declare (ignore foo))
+			    x)
+			  nil
+			  (current-stack-frame))
 	(with-simple-restart (continue "Ignore failed GC consistency check.")
 	  (without-interrupts
 	    (let ((a *x*))
@@ -495,11 +495,12 @@
       (dolist (hook *gc-hooks*)
 	(funcall hook))
       (initialize-space oldspace)
-      (fill oldspace #x13 :start 2)
-      ;; (setf *gc-stack2* *gc-stack*)
-      (setf *gc-stack* (muerte::copy-current-control-stack))
-      #+ignore (setf (fill-pointer *xx*) (fill-pointer *x*))
-      #+ignore (replace *xx* *x*)))
+      (when *gc-consistency-check*
+	(fill oldspace #x13 :start 2)
+	;; (setf *gc-stack2* *gc-stack*)
+	(setf *gc-stack* (muerte::copy-current-control-stack))
+	#+ignore (setf (fill-pointer *xx*) (fill-pointer *x*))
+	#+ignore (replace *xx* *x*))))
   (values))
 
 (defun simple-stop-and-copy (newspace oldspace)



From ffjeld at common-lisp.net  Sun Aug 28 21:12:28 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 23:12:28 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp 
Message-ID: <20050828211228.165AD88032@common-lisp.net>

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

Modified Files:
	repl.lisp 
Log Message:
Use just readline if there is no *repl-readline-context*.

Date: Sun Aug 28 23:12:27 2005
Author: ffjeld

Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.15 movitz/losp/lib/repl.lisp:1.16
--- movitz/losp/lib/repl.lisp:1.15	Wed Mar  9 08:16:48 2005
+++ movitz/losp/lib/repl.lisp	Sun Aug 28 23:12:27 2005
@@ -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.15 2005/03/09 07:16:48 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.16 2005/08/28 21:12:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -52,7 +52,10 @@
       (funcall *repl-prompter*)))
   (handler-case
       (let ((previous-package *package*)
-	    (buffer-string (muerte.readline:contextual-readline *repl-readline-context*)))
+	    (buffer-string
+	     (if *repl-readline-context*
+		 (muerte.readline:contextual-readline *repl-readline-context*)
+	       (muerte.readline:readline (make-string 256) *terminal-io*))))
 	(when (plusp (length buffer-string))
 	  (terpri)
 	  (multiple-value-bind (form buffer-pointer)



From ffjeld at common-lisp.net  Sun Aug 28 21:13:08 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 23:13:08 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp 
Message-ID: <20050828211308.845FB88168@common-lisp.net>

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

Modified Files:
	scavenge.lisp 
Log Message:
Minor tweaks.

Date: Sun Aug 28 23:13:08 2005
Author: ffjeld

Index: movitz/losp/muerte/scavenge.lisp
diff -u movitz/losp/muerte/scavenge.lisp:1.53 movitz/losp/muerte/scavenge.lisp:1.54
--- movitz/losp/muerte/scavenge.lisp:1.53	Sat Aug 27 00:42:43 2005
+++ movitz/losp/muerte/scavenge.lisp	Sun Aug 28 23:13:07 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Mar 29 14:54:08 2004
 ;;;;                
-;;;; $Id: scavenge.lisp,v 1.53 2005/08/26 22:42:43 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.54 2005/08/28 21:13:07 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -52,6 +52,7 @@
 				(movitz:tag primary))))
 		 `(= ,code ,x)))
 	     (record-scan (x)
+	       (declare (ignorable x))
 	       #+ignore `(setf *scan-last* ,x)))
     (do ((verbose *map-header-vals-verbose*)
 	 (*scan-last* nil)		; Last scanned object, for debugging.
@@ -149,8 +150,7 @@
 		;; Jumpers
 		(let ((num-jumpers (memref scan 0 :type :unsigned-byte14))
 		      #+ignore (num-constants (memref scan 2 :type :unsigned-byte16)))
-		  (incf scan num-jumpers)
-		  #+ignore (warn "~D jumpers for ~S, ~S" num-jumpers *scan-last* scan))))))
+		  (incf scan num-jumpers))))))
 	   ((scavenge-typep x :infant-object)
 	    (assert (evenp scan) ()
 	      "Scanned infant ~S at odd location #x~X." x scan)
@@ -409,6 +409,7 @@
 					  debug-context)
   "Update the (raw) instruction-pointer at location,
 assuming the pointer refers to old-code-vector."
+  (declare (ignorable debug-context))
   ;; (check-type old-code-vector code-vector) ; Can't de-reference old objects..
   (let ((old-ip-location (memref location 0 :type :location)))
     (assert (location-in-code-vector-p%unsafe old-code-vector old-ip-location))



From ffjeld at common-lisp.net  Sun Aug 28 21:13:31 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 23:13:31 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp 
Message-ID: <20050828211331.2BFA088168@common-lisp.net>

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

Modified Files:
	los0.lisp 
Log Message:
sync.

Date: Sun Aug 28 23:13:30 2005
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.48 movitz/losp/los0.lisp:1.49
--- movitz/losp/los0.lisp:1.48	Wed Aug 24 09:32:54 2005
+++ movitz/losp/los0.lisp	Sun Aug 28 23:13:30 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.48 2005/08/24 07:32:54 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.49 2005/08/28 21:13:30 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -343,8 +343,6 @@
     (setf (sequence-1-ref i)
       'foo)))
 
-(defun plus (a b)
-  (+ b a))
 
 #+ignore
 (defun test-values ()
@@ -1104,8 +1102,8 @@
 			 (find-package "COMMON-LISP")
 			 (error "Unable to find any package!")))
 	  (*repl-prompt-context* #\d)
-	  (*repl-readline-context* (or *repl-readline-context*
-				       (make-readline-context :history-size 16))))
+	  #+ignore (*repl-readline-context* (or *repl-readline-context*
+						(make-readline-context :history-size 16))))
       (let ((*print-safely* t))
 	(invoke-toplevel-command :error))
       (loop
@@ -1334,6 +1332,10 @@
   (loop for addr upfrom start repeat length
       collect (memref-int addr :type :unsigned-byte8)))
 
+(defun plus (a b)
+  (+ (muerte::check-the fixnum a)
+     (muerte::check-the fixnum b)))
+
 (defun genesis ()
   ;; (install-shallow-binding)
   (setf *debugger-function* #'los0-debugger)
@@ -1355,7 +1357,8 @@
     #+ignore
     (install-los0-consing :kb-size (max 50 (truncate (- extended-memsize 2048) 2))))
 
-  (clos-bootstrap)
+  (let ((muerte::*error-no-condition-for-debugger* t))
+    (clos-bootstrap))
   (setf *package* (find-package "INIT"))
   ;; (install-shallow-binding)
   (let ((*repl-readline-context* (make-readline-context :history-size 16))
@@ -1416,7 +1419,9 @@
 
 (defun read (&optional input-stream eof-error-p eof-value recursive-p)
   (declare (ignore input-stream recursive-p))
-  (let ((string (muerte.readline:contextual-readline *repl-readline-context*)))
+  (let ((string (if *repl-readline-context*
+		    (muerte.readline:contextual-readline *repl-readline-context*)
+		  (muerte.readline:readline (make-string 256) *terminal-io*))))
     (simple-read-from-string string eof-error-p eof-value)))
 
 



From ffjeld at common-lisp.net  Wed Aug 31 22:31:03 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:31:03 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050831223103.8AB118853C@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Improved add compiler some more.

Date: Thu Sep  1 00:30:57 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.161 movitz/compiler.lisp:1.162
--- movitz/compiler.lisp:1.161	Sun Aug 28 23:03:41 2005
+++ movitz/compiler.lisp	Thu Sep  1 00:30:55 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.161 2005/08/28 21:03:41 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.162 2005/08/31 22:30:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2428,8 +2428,8 @@
 	      (when (and (binding-target object)
 			 (not (eq object (binding-target object))))
 		(binding-name (forwarding-binding-target object)))
-	      (when (and #+ignore (slot-exists-p object 'store-type)
-			 #+ignore (slot-boundp object 'store-type)
+	      (when (and (slot-exists-p object 'store-type)
+			 (slot-boundp object 'store-type)
 			 (binding-store-type object))
 		(or (apply #'encoded-type-decode
 			   (binding-store-type object))
@@ -3759,128 +3759,129 @@
 
 (defun make-store-lexical (binding source shared-reference-p funobj frame-map
 			   &key protect-registers)
-  (assert (not (and shared-reference-p
-		    (not (binding-lended-p binding))))
-      (binding)
-    "funny binding: ~W" binding)
-  (if (and nil (typep source 'constant-object-binding))
-      (make-load-constant (constant-object source) binding funobj frame-map)
-    (let ((protect-registers (cons source protect-registers)))
-      (cond
-       ((eq :untagged-fixnum-ecx source)
-	(if (eq :untagged-fixnum-ecx
-		(new-binding-location binding frame-map))
-	    nil
-	  (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx)
-		  (make-store-lexical binding :ecx shared-reference-p funobj frame-map
-				      :protect-registers protect-registers))))
-       ((typep binding 'borrowed-binding)
-	(let ((slot (borrowed-binding-reference-slot binding)))
-	  (if (not shared-reference-p)
-	      (let ((tmp-reg (chose-free-register protect-registers)
-			     #+ignore(if (eq source :eax) :ebx :eax)))
-		(when (eq :ecx source)
-		  (break "loading a word from ECX?"))
-		`((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
-			 ,tmp-reg)
-		  (:movl ,source (-1 ,tmp-reg))))
-	    `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
-       ((typep binding 'forwarding-binding)
-	(assert (not (binding-lended-p binding)) (binding))
-	(make-store-lexical (forwarding-binding-target binding)
-			    source shared-reference-p funobj frame-map))
-       ((not (new-binding-located-p binding frame-map))
-	;; (warn "Can't store to unlocated binding ~S." binding)
-	nil)
-       ((and (binding-lended-p binding)
-	     (not shared-reference-p))
-	(let ((tmp-reg (chose-free-register protect-registers)
-		       #+ignore (if (eq source :eax) :ebx :eax))
-	      (location (new-binding-location binding frame-map)))
-	  (if (integerp location)
-	      `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
-		(:movl ,source (,tmp-reg -1)))
-	    (ecase (operator location)
-	      (:argument-stack
-	       (assert (<= 2 (function-argument-argnum binding)) ()
-		 "store-lexical argnum can't be ~A." (function-argument-argnum binding))
-	       `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
-		 (:movl ,source (,tmp-reg -1))))))))
-       (t (let ((location (new-binding-location binding frame-map)))
-	    (cond
-	     ((member source '(:eax :ebx :ecx :edx :edi :esp))
-	      (if (integerp location)
-		  `((:movl ,source (:ebp ,(stack-frame-offset location))))
-		(ecase (operator location)
-		  ((:push)
-		   `((:pushl ,source)))
-		  ((:eax :ebx :ecx :edx)
-		   (unless (eq source location)
-		     `((:movl ,source ,location))))
-		  (:argument-stack
-		   (assert (<= 2 (function-argument-argnum binding)) ()
-		     "store-lexical argnum can't be ~A." (function-argument-argnum binding))
-		   `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
-		  (:untagged-fixnum-ecx
-		   (assert (not (eq source :edi)))
-		   (cond
-		    ((eq source :untagged-fixnum-ecx)
-		     nil)
-		    ((eq source :eax)
-		     `((,*compiler-global-segment-prefix*
-			:call (:edi ,(global-constant-offset 'unbox-u32)))))
-		    (t `((:movl ,source :eax)
-			 (,*compiler-global-segment-prefix*
-			  :call (:edi ,(global-constant-offset 'unbox-u32))))))))))
-	     ((member source +boolean-modes+)
-	      (let ((tmp (chose-free-register protect-registers))
-		    (label (gensym "store-lexical-bool-")))
-		(append `((:movl :edi ,tmp))
-			(list (make-branch-on-boolean source label))
-			(list label)
-			(make-store-lexical binding tmp shared-reference-p funobj frame-map
-					    :protect-registers protect-registers))))
-	     ((not (bindingp source))
-	      (error "Unknown source for store-lexical: ~S" source))
-	     ((binding-singleton source)
-	      (assert (not shared-reference-p))
-	      (let ((value (car (binding-singleton source))))
-		(etypecase value
-		  (movitz-fixnum
-		   (let ((immediate (movitz-immediate-value value)))
-		     (if (integerp location)
-			 (let ((tmp (chose-free-register protect-registers)))
-			   (append (make-immediate-move immediate tmp)
-				   `((:movl ,tmp (:ebp ,(stack-frame-offset location))))))
-		       #+ignore (if (= 0 immediate)
+  (let ((binding (ensure-local-binding binding funobj)))
+    (assert (not (and shared-reference-p
+		      (not (binding-lended-p binding))))
+	(binding)
+      "funny binding: ~W" binding)
+    (if (and nil (typep source 'constant-object-binding))
+	(make-load-constant (constant-object source) binding funobj frame-map)
+      (let ((protect-registers (cons source protect-registers)))
+	(cond
+	 ((eq :untagged-fixnum-ecx source)
+	  (if (eq :untagged-fixnum-ecx
+		  (new-binding-location binding frame-map))
+	      nil
+	    (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx)
+		    (make-store-lexical binding :ecx shared-reference-p funobj frame-map
+					:protect-registers protect-registers))))
+	 ((typep binding 'borrowed-binding)
+	  (let ((slot (borrowed-binding-reference-slot binding)))
+	    (if (not shared-reference-p)
+		(let ((tmp-reg (chose-free-register protect-registers)
+			       #+ignore(if (eq source :eax) :ebx :eax)))
+		  (when (eq :ecx source)
+		    (break "loading a word from ECX?"))
+		  `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+			   ,tmp-reg)
+		    (:movl ,source (-1 ,tmp-reg))))
+	      `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
+	 ((typep binding 'forwarding-binding)
+	  (assert (not (binding-lended-p binding)) (binding))
+	  (make-store-lexical (forwarding-binding-target binding)
+			      source shared-reference-p funobj frame-map))
+	 ((not (new-binding-located-p binding frame-map))
+	  ;; (warn "Can't store to unlocated binding ~S." binding)
+	  nil)
+	 ((and (binding-lended-p binding)
+	       (not shared-reference-p))
+	  (let ((tmp-reg (chose-free-register protect-registers)
+			 #+ignore (if (eq source :eax) :ebx :eax))
+		(location (new-binding-location binding frame-map)))
+	    (if (integerp location)
+		`((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
+		  (:movl ,source (,tmp-reg -1)))
+	      (ecase (operator location)
+		(:argument-stack
+		 (assert (<= 2 (function-argument-argnum binding)) ()
+		   "store-lexical argnum can't be ~A." (function-argument-argnum binding))
+		 `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
+		   (:movl ,source (,tmp-reg -1))))))))
+	 (t (let ((location (new-binding-location binding frame-map)))
+	      (cond
+	       ((member source '(:eax :ebx :ecx :edx :edi :esp))
+		(if (integerp location)
+		    `((:movl ,source (:ebp ,(stack-frame-offset location))))
+		  (ecase (operator location)
+		    ((:push)
+		     `((:pushl ,source)))
+		    ((:eax :ebx :ecx :edx)
+		     (unless (eq source location)
+		       `((:movl ,source ,location))))
+		    (:argument-stack
+		     (assert (<= 2 (function-argument-argnum binding)) ()
+		       "store-lexical argnum can't be ~A." (function-argument-argnum binding))
+		     `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
+		    (:untagged-fixnum-ecx
+		     (assert (not (eq source :edi)))
+		     (cond
+		      ((eq source :untagged-fixnum-ecx)
+		       nil)
+		      ((eq source :eax)
+		       `((,*compiler-global-segment-prefix*
+			  :call (:edi ,(global-constant-offset 'unbox-u32)))))
+		      (t `((:movl ,source :eax)
+			   (,*compiler-global-segment-prefix*
+			    :call (:edi ,(global-constant-offset 'unbox-u32))))))))))
+	       ((member source +boolean-modes+)
+		(let ((tmp (chose-free-register protect-registers))
+		      (label (gensym "store-lexical-bool-")))
+		  (append `((:movl :edi ,tmp))
+			  (list (make-branch-on-boolean source label))
+			  (list label)
+			  (make-store-lexical binding tmp shared-reference-p funobj frame-map
+					      :protect-registers protect-registers))))
+	       ((not (bindingp source))
+		(error "Unknown source for store-lexical: ~S" source))
+	       ((binding-singleton source)
+		(assert (not shared-reference-p))
+		(let ((value (car (binding-singleton source))))
+		  (etypecase value
+		    (movitz-fixnum
+		     (let ((immediate (movitz-immediate-value value)))
+		       (if (integerp location)
+			   (let ((tmp (chose-free-register protect-registers)))
+			     (append (make-immediate-move immediate tmp)
+				     `((:movl ,tmp (:ebp ,(stack-frame-offset location))))))
+			 #+ignore (if (= 0 immediate)
 				      (let ((tmp (chose-free-register protect-registers)))
 					`((:xorl ,tmp ,tmp)
 					  (:movl ,tmp (:ebp ,(stack-frame-offset location)))))
 				    `((:movl ,immediate (:ebp ,(stack-frame-offset location)))))
-		       (ecase (operator location)
-			 ((:argument-stack)
-			  `((:movl ,immediate (:ebp ,(argument-stack-offset binding)))))
-			 ((:eax :ebx :edx)
-			  (make-immediate-move immediate location))
-			 ((:untagged-fixnum-ecx)
-			  (make-immediate-move (movitz-fixnum-value value) :ecx))))))
-		  (movitz-heap-object
-		   (etypecase location
-		     ((member :eax :ebx :edx)
-		      (make-load-constant value location funobj frame-map))
-		     (integer
-		      (let ((tmp (chose-free-register protect-registers)))
-			(append (make-load-constant value tmp funobj frame-map)
-				(make-store-lexical binding tmp shared-reference-p
-						    funobj frame-map
-						    :protect-registers protect-registers))))
-		     ((eql :untagged-fixnum-ecx)
-		      (check-type value movitz-bignum)
-		      (let ((immediate (movitz-bignum-value value)))
-			(check-type immediate (unsigned-byte 32))
-			(make-immediate-move immediate :ecx)))
-		     )))))	       
-	     (t (error "Generalized lexb source for store-lexical not implemented: ~S" source)))))))))
+			 (ecase (operator location)
+			   ((:argument-stack)
+			    `((:movl ,immediate (:ebp ,(argument-stack-offset binding)))))
+			   ((:eax :ebx :edx)
+			    (make-immediate-move immediate location))
+			   ((:untagged-fixnum-ecx)
+			    (make-immediate-move (movitz-fixnum-value value) :ecx))))))
+		    (movitz-heap-object
+		     (etypecase location
+		       ((member :eax :ebx :edx)
+			(make-load-constant value location funobj frame-map))
+		       (integer
+			(let ((tmp (chose-free-register protect-registers)))
+			  (append (make-load-constant value tmp funobj frame-map)
+				  (make-store-lexical binding tmp shared-reference-p
+						      funobj frame-map
+						      :protect-registers protect-registers))))
+		       ((eql :untagged-fixnum-ecx)
+			(check-type value movitz-bignum)
+			(let ((immediate (movitz-bignum-value value)))
+			  (check-type immediate (unsigned-byte 32))
+			  (make-immediate-move immediate :ecx)))
+		       )))))	       
+	       (t (error "Generalized lexb source for store-lexical not implemented: ~S" source))))))))))
 
 (defun finalize-code (code funobj frame-map)
   ;; (print-code 'to-be-finalized code)
@@ -7057,6 +7058,15 @@
 		    (append (make-load-lexical term0 :eax funobj nil frame-map)
 			    `((:addl :eax :eax))
 			    (make-store :eax destination)))
+		   ((and (integerp loc0)
+			 (integerp loc1)
+			 (integerp destination-location)
+			 (/= loc0 loc1 destination-location))
+		    `((:movl (:ebp ,(stack-frame-offset loc0))
+			     :ecx)
+		      (:addl (:ebp ,(stack-frame-offset loc1))
+			     :ecx)
+		      (:movl :ecx (:ebp ,(stack-frame-offset destination-location)))))
 		   (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
 			    destination-location
 			    destination



From ffjeld at common-lisp.net  Wed Aug 31 22:31:36 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:31:36 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp 
Message-ID: <20050831223136.6B2D188546@common-lisp.net>

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

Modified Files:
	environment.lisp 
Log Message:
Added a dummy sleep function.

Date: Thu Sep  1 00:31:35 2005
Author: ffjeld

Index: movitz/losp/muerte/environment.lisp
diff -u movitz/losp/muerte/environment.lisp:1.13 movitz/losp/muerte/environment.lisp:1.14
--- movitz/losp/muerte/environment.lisp:1.13	Wed Aug 24 09:28:19 2005
+++ movitz/losp/muerte/environment.lisp	Thu Sep  1 00:31:35 2005
@@ -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.13 2005/08/24 07:28:19 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.14 2005/08/31 22:31:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -164,3 +164,6 @@
 	    (funobj-name object)
 	    arglist)))
 
+(defun sleep (seconds)
+  (declare (ignore seconds))
+  (error "There is no default implementation of sleep."))



From ffjeld at common-lisp.net  Wed Aug 31 22:32:09 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:32:09 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp 
Message-ID: <20050831223209.0BBA8884C2@common-lisp.net>

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

Modified Files:
	packages.lisp 
Log Message:
ignore k.

Date: Thu Sep  1 00:32:08 2005
Author: ffjeld

Index: movitz/losp/muerte/packages.lisp
diff -u movitz/losp/muerte/packages.lisp:1.11 movitz/losp/muerte/packages.lisp:1.12
--- movitz/losp/muerte/packages.lisp:1.11	Wed Aug 24 09:29:40 2005
+++ movitz/losp/muerte/packages.lisp	Thu Sep  1 00:32:08 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 30 15:19:43 2001
 ;;;;                
-;;;; $Id: packages.lisp,v 1.11 2005/08/24 07:29:40 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.12 2005/08/31 22:32:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -55,6 +55,7 @@
 (defun list-all-packages ()
   (let (pkgs)
     (maphash (lambda (k v)
+	       (declare (ignore k))
                (pushnew v pkgs))
              *packages*)
     pkgs))



From ffjeld at common-lisp.net  Wed Aug 31 22:33:04 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:33:04 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp 
Message-ID: <20050831223304.2B83288031@common-lisp.net>

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

Modified Files:
	bignums.lisp 
Log Message:
Added bignum-notf.

Date: Thu Sep  1 00:33:03 2005
Author: ffjeld

Index: movitz/losp/muerte/bignums.lisp
diff -u movitz/losp/muerte/bignums.lisp:1.16 movitz/losp/muerte/bignums.lisp:1.17
--- movitz/losp/muerte/bignums.lisp:1.16	Sat Aug 20 22:25:41 2005
+++ movitz/losp/muerte/bignums.lisp	Thu Sep  1 00:33:03 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 19:42:57 2004
 ;;;;                
-;;;; $Id: bignums.lisp,v 1.16 2005/08/20 20:25:41 ffjeld Exp $
+;;;; $Id: bignums.lisp,v 1.17 2005/08/31 22:33:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -548,3 +548,19 @@
 
 (defun %bignum-plus-fixnum-size (x fixnum-delta)
   (compiler-macro-call %bignum-plus-fixnum-size x fixnum-delta))
+
+(defun bignum-notf (x)
+  (check-type x bignum)
+  (macrolet
+      ((do-it ()
+	 `(with-inline-assembly (:returns :eax)
+	    (:load-lexical (:lexical-binding x) :eax)
+	    (:xorl :edx :edx)
+	    (:xorl :ecx :ecx)
+	    (:movw (:eax (:offset movitz-bignum length)) :cx)
+	   loop
+	    (:notl (:eax :edx (:offset movitz-bignum bigit0)))
+	    (:addl 4 :edx)
+	    (:cmpl :edx :ecx)
+	    (:ja 'loop))))
+    (do-it)))



From ffjeld at common-lisp.net  Wed Aug 31 22:34:17 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:34:17 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp 
Message-ID: <20050831223417.3453E8802E@common-lisp.net>

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

Modified Files:
	integers.lisp 
Log Message:
Improved bignum support for logand and lognot.

Date: Thu Sep  1 00:34:14 2005
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.109 movitz/losp/muerte/integers.lisp:1.110
--- movitz/losp/muerte/integers.lisp:1.109	Fri Aug 26 21:39:14 2005
+++ movitz/losp/muerte/integers.lisp	Thu Sep  1 00:34:14 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.109 2005/08/26 19:39:14 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.110 2005/08/31 22:34:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -328,6 +328,9 @@
 (deftype negative-fixnum ()
   `(integer #.movitz:+movitz-most-negative-fixnum+ -1))
 
+(deftype negative-bignum ()
+  `(integer * #.(cl:1- movitz::+movitz-most-negative-fixnum+)))
+
 (defun fixnump (x)
   (typep x 'fixnum))
 
@@ -1482,6 +1485,36 @@
 			     (:eax :edx (:offset movitz-bignum bigit0)))
 		      (:subl 4 :edx)
 		      (:jnc 'pb-pb-and-loop)))))
+		((negative-bignum fixnum)
+		 (with-inline-assembly (:returns :eax)
+		   (:load-lexical (:lexical-binding x) :untagged-fixnum-ecx)
+		   (:load-lexical (:lexical-binding y) :eax)
+		   (:leal ((:ecx 4) -4) :ecx)
+		   (:notl :ecx)
+		   (:andl :ecx :eax)))
+		((negative-bignum positive-bignum)
+		 (cond
+		  ((<= (%bignum-bigits y) (%bignum-bigits x))
+		   (let ((r (copy-bignum y)))
+		     (with-inline-assembly (:returns :eax)
+		       (:load-lexical (:lexical-binding r) :eax)
+		       (:load-lexical (:lexical-binding x) :ebx)
+		       (:xorl :edx :edx)
+		       (:movl #xffffffff :ecx)
+		      loop
+		       (:addl (:ebx :edx (:offset movitz-bignum bigit0))
+			      :ecx)
+		       (:notl :ecx)
+		       (:andl :ecx (:eax :edx (:offset movitz-bignum bigit0)))
+		       (:notl :ecx)
+		       (:cmpl -1 :ecx)
+		       (:je 'carry)
+		       (:xorl :ecx :ecx)
+		      carry
+		       (:addl 4 :edx)
+		       (:cmpw :dx (:eax (:offset movitz-bignum length)))
+		       (:ja 'loop))))
+		  (t (error "Logand not implemented."))))
 		)))
 	(do-it)))
    (t (&rest integers)
@@ -1639,10 +1672,7 @@
 	(reduce #'logxor integers)))))
 
 (defun lognot (integer)
-  (check-type integer fixnum)
-  (with-inline-assembly (:returns :eax)
-    (:compile-form (:result-mode :eax) integer)
-    (:xorl #.(cl:- #xffffffff movitz::+movitz-fixnum-zmask+) :eax)))
+  (- -1 integer))
 
 (defun ldb%byte (size position integer)
   "This is LDB with explicit byte-size and position parameters."



From ffjeld at common-lisp.net  Wed Aug 31 22:34:59 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:34:59 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp 
Message-ID: <20050831223459.E2A998802E@common-lisp.net>

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

Modified Files:
	debugger.lisp 
Log Message:
sync

Date: Thu Sep  1 00:34:58 2005
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.40 movitz/losp/x86-pc/debugger.lisp:1.41
--- movitz/losp/x86-pc/debugger.lisp:1.40	Thu May  5 22:52:45 2005
+++ movitz/losp/x86-pc/debugger.lisp	Thu Sep  1 00:34:58 2005
@@ -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.40 2005/05/05 20:52:45 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.41 2005/08/31 22:34:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -636,6 +636,7 @@
 	  (do () (nil)
 	    (multiple-value-bind (morep setf-name symbol)
 		(hashis)
+	      (declare (ignore setf-name))
 	      (cond
 	       ((not morep)
 		(return nil))



From ffjeld at common-lisp.net  Wed Aug 31 22:35:07 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:35:07 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp 
Message-ID: <20050831223507.317BF8802E@common-lisp.net>

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

Modified Files:
	dhcp.lisp 
Log Message:
sync

Date: Thu Sep  1 00:35:06 2005
Author: ffjeld

Index: movitz/losp/lib/net/dhcp.lisp
diff -u movitz/losp/lib/net/dhcp.lisp:1.3 movitz/losp/lib/net/dhcp.lisp:1.4
--- movitz/losp/lib/net/dhcp.lisp:1.3	Tue May 24 09:15:54 2005
+++ movitz/losp/lib/net/dhcp.lisp	Thu Sep  1 00:35:06 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri May 13 23:24:01 2005
 ;;;;                
-;;;; $Id: dhcp.lisp,v 1.3 2005/05/24 07:15:54 ffjeld Exp $
+;;;; $Id: dhcp.lisp,v 1.4 2005/08/31 22:35:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -207,7 +207,8 @@
 			       (fill-pointer packet)
 			       (incf (fill-pointer packet) length)))))))))
 
-(defun format-dhcp-request (nic &rest dhcp-options &key (xid 0) (message-type :dhcpdiscover))
+(defun format-dhcp-request (nic &rest dhcp-options &key (xid 0)
+							#+ignore (message-type :dhcpdiscover))
   (let ((packet (make-ethernet-packet)))
     (with-ether-header (ether packet)
       (setf (ether :source) (mac-address nic)



From ffjeld at common-lisp.net  Wed Aug 31 22:35:10 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:35:10 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp 
Message-ID: <20050831223510.05B358854E@common-lisp.net>

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

Modified Files:
	ethernet.lisp 
Log Message:
sync

Date: Thu Sep  1 00:35:10 2005
Author: ffjeld

Index: movitz/losp/lib/net/ethernet.lisp
diff -u movitz/losp/lib/net/ethernet.lisp:1.10 movitz/losp/lib/net/ethernet.lisp:1.11
--- movitz/losp/lib/net/ethernet.lisp:1.10	Sun Aug 14 20:52:39 2005
+++ movitz/losp/lib/net/ethernet.lisp	Thu Sep  1 00:35:10 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep 17 15:25:31 2002
 ;;;;                
-;;;; $Id: ethernet.lisp,v 1.10 2005/08/14 18:52:39 ffjeld Exp $
+;;;; $Id: ethernet.lisp,v 1.11 2005/08/31 22:35:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -85,7 +85,8 @@
 	 (start-var (gensym "ether-packet-start-")))
     `(let* ((,start-var ,start)
 	    (,packet-var (ensure-data-vector ,packet ,start-var 14))
-	    (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data))))       
+	    (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+       (declare (ignorable ,start-var ,packet-var ,offset-var))
        (macrolet ((,ether (slot)
 		    (ecase slot
 		      (:source



From ffjeld at common-lisp.net  Wed Aug 31 22:35:50 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Thu,  1 Sep 2005 00:35:50 +0200 (CEST)
Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp 
Message-ID: <20050831223550.1C23488563@common-lisp.net>

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

Modified Files:
	los0-gc.lisp 
Log Message:
sync

Date: Thu Sep  1 00:35:49 2005
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.58 movitz/losp/los0-gc.lisp:1.59
--- movitz/losp/los0-gc.lisp:1.58	Sun Aug 28 23:10:46 2005
+++ movitz/losp/los0-gc.lisp	Thu Sep  1 00:35:49 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Feb 21 17:48:32 2004
 ;;;;                
-;;;; $Id: los0-gc.lisp,v 1.58 2005/08/28 21:10:46 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.59 2005/08/31 22:35:49 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -358,7 +358,7 @@
 	   (or evacuator
 	       (lambda (x location)
 		 "If x is in oldspace, migrate it to newspace."
-		 ;; (declare (ignore location))
+		 (declare (ignore location))
 		 (cond
 		  ((null x)
 		   nil)



From ffjeld at common-lisp.net  Sun Aug 28 21:03:54 2005
From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld)
Date: Sun, 28 Aug 2005 21:03:54 -0000
Subject: [movitz-cvs] CVS update: movitz/compiler.lisp 
Message-ID: <20050828210346.F3B398855D@common-lisp.net>

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

Modified Files:
	compiler.lisp 
Log Message:
Many fixes to the compiler. Basic change is that LET init-forms are
compiled with compile-form-unprotected, and that
compile-lexical-variable and compile-self-evaluating return binding
only as "returns", not in the form of "code".

Date: Sun Aug 28 23:03:43 2005
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.160 movitz/compiler.lisp:1.161
--- movitz/compiler.lisp:1.160	Fri Aug 26 23:42:08 2005
+++ movitz/compiler.lisp	Sun Aug 28 23:03:41 2005
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.160 2005/08/26 21:42:08 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.161 2005/08/28 21:03:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1510,6 +1510,7 @@
 
 
 (defun optimize-code (unoptimized-code &rest args)
+  #+ignore (print-code 'to-optimize unoptimized-code)
   (if (not *compiler-do-optimize*)
       unoptimized-code
     (apply #'optimize-code-internal
@@ -2883,7 +2884,7 @@
   (let* ((count-init-pc (gethash binding var-counts))
 	 (count (car count-init-pc))
 	 (init-pc (second count-init-pc)))
-    ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
+    #+ignore (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
     (cond
      ((and (not *compiler-allow-transients*)
 	   (typep binding 'function-argument))
@@ -2972,7 +2973,7 @@
 	     (take-note-of-binding (binding &optional storep init-pc)
 	       (let ((count-init-pc (or (gethash binding var-counter)
 					(setf (gethash binding var-counter)
-					  (list 0 nil t)))))
+					  (list 0 nil (not storep))))))
 		 (when init-pc
 		   (assert (not (second count-init-pc)))
 		   (setf (second count-init-pc) init-pc))
@@ -2980,10 +2981,17 @@
 		   (unless (eq binding (binding-target binding))
 		     ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter))
 		     (take-note-of-binding (binding-target binding)))
+		   (setf (third count-init-pc) t)
 		   (incf (car count-init-pc))))
 	       #+ignore
 	       (when (typep binding 'forwarding-binding)
 		 (take-note-of-binding (forwarding-binding-target binding) storep)))
+	     (take-note-of-init (binding init-pc)
+	       (let ((count-init-pc (or (gethash binding var-counter)
+					(setf (gethash binding var-counter)
+					  (list 0 nil nil)))))
+		 (assert (not (second count-init-pc)))
+		 (setf (second count-init-pc) init-pc)))
 	     (do-discover-variables (code env)
 	       (loop for pc on code as instruction in code
 		   when (listp instruction)
@@ -3028,11 +3036,14 @@
 							     protect-registers protect-carry)
 			       (cdr instruction)
 			     (declare (ignore protect-registers protect-carry init-with-type))
-			     (when init-with-register
+			     (cond
+			      ((not init-with-register)
+			       (take-note-of-init binding pc))
+			      (init-with-register
 			       (take-note-of-binding binding t pc)
 			       (when (and (typep init-with-register 'binding)
 					  (not (typep binding 'forwarding-binding))) ; XXX
-				 (take-note-of-binding init-with-register)))))
+				 (take-note-of-binding init-with-register))))))
 			  (t (mapcar #'take-note-of-binding 
 				     (find-read-bindings instruction))
 			     (mapcar #'record-binding-used ; This is just concerning "unused variable"
@@ -3072,34 +3083,35 @@
 	       (let* ((stack-frame-position (env-floor env))
 		      (bindings-to-locate
 		       (loop for binding being the hash-keys of var-counts
-			   when (eq env (binding-extent-env binding))
-			   unless (let ((variable (binding-name binding)))
-				    (cond
-				     ((not (typep binding 'lexical-binding)))
-				     ((typep binding 'lambda-binding))
-				     ((typep binding 'constant-object-binding))
-				     ((typep binding 'forwarding-binding)
-				      ;; Immediately "assign" to target.
-				      (when (plusp (or (car (gethash binding var-counts)) 0))
-					(setf (new-binding-location binding frame-map)
-					  (forwarding-binding-target binding)))
-				      t)
-				     ((typep binding 'borrowed-binding))
-				     ((typep binding 'funobj-binding))
-				     ((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 ,(function-argument-argnum binding)))))
-				     ((unless (or (movitz-env-get variable 'ignore nil
-								  (binding-env binding) nil)
-						  (movitz-env-get variable 'ignorable nil
-								  (binding-env binding) nil)
-						  (typep binding 'hidden-rest-function-argument)
-						  (third (gethash binding var-counts)))
-					(warn "Unused variable: ~S"
-					      (binding-name binding))))
-				     ((not (plusp (or (car (gethash binding var-counts)) 0))))))
+			   when
+			     (and (eq env (binding-extent-env binding))
+				  (not (let ((variable (binding-name binding)))
+					 (cond
+					  ((not (typep binding 'lexical-binding)))
+					  ((typep binding 'lambda-binding))
+					  ((typep binding 'constant-object-binding))
+					  ((typep binding 'forwarding-binding)
+					   ;; Immediately "assign" to target.
+					   (when (plusp (or (car (gethash binding var-counts)) 0))
+					     (setf (new-binding-location binding frame-map)
+					       (forwarding-binding-target binding)))
+					   t)
+					  ((typep binding 'borrowed-binding))
+					  ((typep binding 'funobj-binding))
+					  ((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 ,(function-argument-argnum binding)))))
+					  ((unless (or (movitz-env-get variable 'ignore nil
+								       (binding-env binding) nil)
+						       (movitz-env-get variable 'ignorable nil
+								       (binding-env binding) nil)
+						       (typep binding 'hidden-rest-function-argument)
+						       (third (gethash binding var-counts)))
+					     (warn "Unused variable: ~S"
+						   (binding-name binding))))
+					  ((not (plusp (or (car (gethash binding var-counts)) 0))))))))
 			   collect binding))
 		      (bindings-fun-arg-sorted
 		       (when (eq env function-env)
@@ -3371,6 +3383,7 @@
   (etypecase x
     (symbol x)
     (cons (car x))
+    (constant-object-binding :constant-binding)
     (lexical-binding :lexical-binding)
     (dynamic-binding :dynamic-binding)))
 
@@ -3512,7 +3525,8 @@
   (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
     (warn "The variable ~S is used even if it was declared ignored."
 	  (binding-name binding)))
-  (let ((protect-registers (cons :edx protect-registers)))
+  (let ((binding (ensure-local-binding binding funobj))
+	(protect-registers (cons :edx protect-registers)))
     (labels ((chose-tmp-register (&optional preferred)
 	       (or tmp-register
 		   (unless (member preferred protect-registers)
@@ -3673,7 +3687,9 @@
 	       (t (make-result-and-returns-glue
 		   result-mode :eax
 		   (install-for-single-value binding binding-location :eax t)))))
-	    (t (case (result-mode-type result-mode)
+	    (t (when (integerp result-mode)
+		 (break "result-mode: ~S" result-mode))
+	     (case (result-mode-type result-mode)
 		 ((:single-value :eax :ebx :ecx :edx :esi :esp :ebp)
 		  (install-for-single-value binding binding-location
 					    (single-value-register result-mode) nil))
@@ -3816,6 +3832,14 @@
 		    (t `((:movl ,source :eax)
 			 (,*compiler-global-segment-prefix*
 			  :call (:edi ,(global-constant-offset 'unbox-u32))))))))))
+	     ((member source +boolean-modes+)
+	      (let ((tmp (chose-free-register protect-registers))
+		    (label (gensym "store-lexical-bool-")))
+		(append `((:movl :edi ,tmp))
+			(list (make-branch-on-boolean source label))
+			(list label)
+			(make-store-lexical binding tmp shared-reference-p funobj frame-map
+					    :protect-registers protect-registers))))
 	     ((not (bindingp source))
 	      (error "Unknown source for store-lexical: ~S" source))
 	     ((binding-singleton source)
@@ -4803,8 +4827,9 @@
 		   `((: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)
+		     ,@(compiler-call #'compile-form
+			 :form (list 'muerte.cl:quote
+				     (eval-form (optional-function-argument-init-form binding) env nil))
 			 :funobj funobj
 			 :env env
 			 :result-mode :ebx)
@@ -4912,8 +4937,10 @@
 				    `((:init-lexvar ,supplied-p-binding
 						    :init-with-register :edi
 						    :init-with-type null)))
-				  (compiler-call #'compile-self-evaluating
-				    :form (eval-form (optional-function-argument-init-form binding) env)
+				  (compiler-call #'compile-form
+				    :form (list 'muerte.cl:quote
+						(eval-form (optional-function-argument-init-form binding)
+							   env))
 				    :env env
 				    :funobj funobj
 				    :result-mode :eax)
@@ -5115,6 +5142,11 @@
 	   (lexical-binding
 	    (values (append code
 			    `((:load-lexical ,returns-provided ,desired-result)))
+		    desired-result))
+	   (constant-object-binding
+	    (values (if (eq *movitz-nil* (constant-object returns-provided))
+			nil
+		      `((:jmp ',(operands desired-result))))
 		    desired-result))))
 	(:boolean-branch-on-false
 	 (etypecase (operator returns-provided)
@@ -5144,9 +5176,14 @@
 	   (lexical-binding
 	    (values (append code
 			    `((:load-lexical ,returns-provided ,desired-result)))
+		    desired-result))
+	   (constant-object-binding
+	    (values (if (not (eq *movitz-nil* (constant-object returns-provided)))
+			nil
+		      `((:jmp ',(operands desired-result))))
 		    desired-result))))
 	(:untagged-fixnum-ecx
-	 (case returns-provided
+	 (case (result-mode-type returns-provided)
 	   (:untagged-fixnum-ecx
 	    (values code :untagged-fixnum-ecx))
 	   ((:eax :single-value :multiple-values :function)
@@ -5155,10 +5192,19 @@
 			       :call (:edi ,(global-constant-offset 'unbox-u32)))))
 		    :untagged-fixnum-ecx))
 	   (:ecx
+	    ;; In theory (at least..) ECX can only hold non-pointers, so don't check.
 	    (values (append code
-			    `((:testb ,+movitz-fixnum-zmask+ :cl)
-			      (:jnz '(:sub-program (not-an-integer) (:int 107))) ;
-			      (:sarl ,+movitz-fixnum-shift+ :ecx)))
+			    `((:shrl ,+movitz-fixnum-shift+ :ecx)))
+		    :untagged-fixnum-ecx))
+	   ((:ebx :edx)
+	    (values (append code
+			    `((:movl ,returns-provided :eax)
+			      (,*compiler-global-segment-prefix*
+			       :call (:edi ,(global-constant-offset 'unbox-u32)))))
+		    :untagged-fixnum-ecx))
+	   (:lexical-binding
+	    (values (append code
+			    `((:load-lexical ,returns-provided :untagged-fixnum-ecx)))
 		    :untagged-fixnum-ecx))))
 	((:single-value :eax)
 	 (cond
@@ -5226,11 +5272,6 @@
 	   (values (append code `((:load-lexical ,returns-provided ,desired-result)))
 		   desired-result))
 	  (t (case (operator returns-provided)
-	       #+ignore
-	       (:untagged-fixnum-eax
-		(values (append code
-				`((:leal ((:eax 4)) ,desired-result)))
-			desired-result))
 	       (:nothing
 		(values (append code
 				`((:movl :edi ,desired-result)))
@@ -5337,7 +5378,14 @@
 		      :multiple-values)))))
     (unless new-returns-provided
       (multiple-value-setq (new-code new-returns-provided glue-side-effects-p)
-	(ecase (operator returns-provided)
+	(ecase (result-mode-type returns-provided)
+	  (:constant-binding
+	   (case (result-mode-type desired-result)
+	     ((:eax :ebx :ecx :edx :push :lexical-binding)
+	      (values (append code
+			      `((:load-constant ,(constant-object returns-provided)
+						,desired-result)))
+		      desired-result))))
 	  (#.+boolean-modes+
 	   (make-result-and-returns-glue desired-result :eax
 					 (make-result-and-returns-glue :eax returns-provided code
@@ -5900,6 +5948,12 @@
       (:ignore
        (compiler-values ()
 	 :final-form binding))
+      (t (compiler-values ()
+	   :code nil
+	   :final-form binding
+	   :returns binding
+	   :functional-p t))
+      #+ignore
       (t (let ((returns (ecase (result-mode-type result-mode)
 			  ((:function :multiple-values :eax)
 			   :eax)
@@ -6037,13 +6091,15 @@
 	 (compiler-values (self-eval)
 	   :returns :nothing
 	   :type nil))
-	((:eax :single-value :multiple-values :function)
-	 (compiler-values (self-eval)
-	   :code `((:load-lexical ,binding :eax))
-	   :returns :eax))
 	(t (compiler-values (self-eval)
-	     :code `((:load-lexical ,binding ,result-mode))
-	     :returns result-mode))))))
+	     :returns binding))))))
+;;;	((:eax :single-value :multiple-values :function)
+;;;	 (compiler-values (self-eval)
+;;;	   :code `((:load-lexical ,binding :eax))
+;;;	   :returns :eax))
+;;;	(t (compiler-values (self-eval)
+;;;	     :code `((:load-lexical ,binding ,result-mode))
+;;;	     :returns result-mode))))))
 
 (define-compiler compile-implicit-progn (&all all &form forms &top-level-p top-level-p
 					      &result-mode result-mode)
@@ -6738,7 +6794,7 @@
   (destructuring-bind (object result-mode &key (op :movl))
       (cdr instruction)
     (when (and (eq op :movl) (typep result-mode 'binding))
-      (check-type result-mode 'lexical-binding)
+      (check-type result-mode lexical-binding)
       (values result-mode `(eql ,object)))))
 
 (define-extended-code-expander :load-constant (instruction funobj frame-map)
@@ -6795,330 +6851,333 @@
 	   (destination-location (if (or (not (bindingp destination))
 					 (typep destination 'borrowed-binding))
 				     destination
-				   (new-binding-location (binding-target destination) frame-map)))
+				   (new-binding-location (binding-target destination)
+							 frame-map
+							 :default nil)))
 	   (type0 (apply #'encoded-type-decode (binding-store-type term0)))
 	   (type1 (apply #'encoded-type-decode (binding-store-type term1)))
 	   (result-type (multiple-value-call #'encoded-integer-types-add
 			  (values-list (binding-store-type term0))
 			  (values-list (binding-store-type term1)))))
-;;;      (warn "dest: ~S ~S"
-;;;	    (apply #'encoded-type-decode (binding-store-type destination))
-;;;	    result-type)	    
-;;;      (when (binding-lended-p term0)
-;;;	(warn "Add from lend0: ~S" term0))
-;;;      (when (binding-lended-p term1)
-;;;	(warn "Add from lend1: ~S" term1))
-;;;      (when (and (bindingp destination)
-;;;		 (binding-lended-p destination))
-;;;	(warn "Add for lended dest: ~S" destination))
-;;;      (when (typep destination 'borrowed-binding)
-;;;	(warn "Add for borrowed ~S" destination))
-      (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
-	    (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
-	#+ignore
-	(warn "add: ~A for ~A" instruction result-type)
-	#+ignore
-	(warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
-	      destination result-type
-	      term0 loc0
-	      term1 loc1)
-	#+ignore
-	(when (eql destination-location 9)
-	  (warn "add for: ~S/~S~%= ~A/~A in ~S~&~A/~A in ~S."
-		destination destination-location
-		term0 loc0 (binding-extent-env (binding-target term0))
-		term1 loc1 (binding-extent-env (binding-target term1)))
-	  (print-code 'load-term1 (make-load-lexical term1 :eax funobj nil frame-map))
-	  (print-code 'load-dest (make-load-lexical destination :eax funobj nil frame-map)))
-	(flet ((make-store (source destination)
-		 (cond
-		  ((eq source destination)
-		   nil)
-		  ((member destination '(:eax :ebx :ecx :edx))
-		   `((:movl ,source ,destination)))
-		  (t (make-store-lexical destination source nil funobj frame-map))))
-	       (make-default-add ()
-		 (when (movitz-subtypep result-type '(unsigned-byte 32))
-		   (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S"
-			 destination-location
-			 destination
-			 loc0 term0
-			 loc1 term1))
-		 (append (cond
-			  ((type-specifier-singleton type0)
-			   (append (make-load-lexical term1 :eax funobj nil frame-map)
-				   (make-load-constant (car (type-specifier-singleton type0))
-						       :ebx funobj frame-map)))
-			  ((type-specifier-singleton type1)
-			   (append (make-load-lexical term0 :eax funobj nil frame-map)
-				   (make-load-constant (car (type-specifier-singleton type1))
-						       :ebx funobj frame-map)))
-			  ((and (eq :eax loc0) (eq :ebx loc1))
-			   nil)
-			  ((and (eq :ebx loc0) (eq :eax loc1))
-			   nil)		; terms order isn't important
-			  ((eq :eax loc1)
-			   (append
-			    (make-load-lexical term0 :ebx funobj nil frame-map)))
-			  (t (append
-			      (make-load-lexical term0 :eax funobj nil frame-map)
-			      (make-load-lexical term1 :ebx funobj nil frame-map))))
-			 `((:movl (:edi ,(global-constant-offset '+)) :esi))
-			 (make-compiled-funcall-by-esi 2)
-			 (etypecase destination
-			   (symbol
-			    (unless (eq destination :eax)
-			      `((:movl :eax ,destination))))
-			   (binding
-			    (make-store-lexical destination :eax nil funobj frame-map))))))
-	  (let ((constant0 (let ((x (type-specifier-singleton type0)))
-			     (when (and x (typep (car x) 'movitz-fixnum))
-			       (movitz-immediate-value (car x)))))
-		(constant1 (let ((x (type-specifier-singleton type1)))
-			     (when (and x (typep (car x) 'movitz-fixnum))
-			       (movitz-immediate-value (car x))))))
-	    (cond
-	     ((type-specifier-singleton result-type)
-	      ;; (break "constant add: ~S" instruction)
-	      (make-load-constant (car (type-specifier-singleton result-type))
-				  destination funobj frame-map))
-	     ((movitz-subtypep type0 '(integer 0 0))
-	      (cond
-	       ((eql destination loc1)
-		#+ignore (break "NOP add: ~S" instruction)
-		nil)
-	       ((and (member destination-location '(:eax :ebx :ecx :edx))
-		     (member loc1 '(:eax :ebx :ecx :edx)))
-		`((:movl ,loc1 ,destination-location)))
-	       ((integerp loc1)
-		(make-load-lexical term1 destination-location funobj nil frame-map))
-	       #+ignore
-	       ((integerp destination-location)
-		(make-store-lexical destination-location loc1 nil funobj frame-map))
-	       (t (break "Unknown X zero-add: ~S" instruction))))
-	     ((movitz-subtypep type1 '(integer 0 0))
-	      ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
-	      (cond
-	       ((eql destination loc0)
-		#+ignore (break "NOP add: ~S" instruction)
-		nil)
-	       ((and (member destination-location '(:eax :ebx :ecx :edx))
-		     (member loc0 '(:eax :ebx :ecx :edx)))
-		`((:movl ,loc0 ,destination-location)))
-	       ((integerp loc0)
-		(make-load-lexical term0 destination-location funobj nil frame-map))
-	       #+ignore
-	       ((integerp destination-location)
-		(make-store-lexical destination-location loc0 nil funobj frame-map))
-	       (t (break "Unknown Y zero-add: ~S" instruction))))
-	     ((and (movitz-subtypep type0 'fixnum)
-		   (movitz-subtypep type1 'fixnum)
-		   (movitz-subtypep result-type 'fixnum))
-	      (assert (not (and constant0 (zerop constant0))))
-	      (assert (not (and constant1 (zerop constant1))))
+      ;; A null location means the binding is unused, in which
+      ;; case there's no need to perform the addition.
+      (when destination-location
+	(let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
+	      (loc1 (new-binding-location (binding-target term1) frame-map :default nil)))
+	  #+ignore
+	  (warn "add: ~A for ~A" instruction result-type)
+	  #+ignore
+	  (warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
+		destination result-type
+		term0 loc0
+		term1 loc1)
+	  #+ignore
+	  (when (eql destination-location 9)
+	    (warn "add for: ~S/~S~%= ~A/~A in ~S~&~A/~A in ~S."
+		  destination destination-location
+		  term0 loc0 (binding-extent-env (binding-target term0))
+		  term1 loc1 (binding-extent-env (binding-target term1)))
+	    (print-code 'load-term1 (make-load-lexical term1 :eax funobj nil frame-map))
+	    (print-code 'load-dest (make-load-lexical destination :eax funobj nil frame-map)))
+	  (flet ((make-store (source destination)
+		   (cond
+		    ((eq source destination)
+		     nil)
+		    ((member destination '(:eax :ebx :ecx :edx))
+		     `((:movl ,source ,destination)))
+		    (t (make-store-lexical destination source nil funobj frame-map))))
+		 (make-default-add ()
+		   (when (movitz-subtypep result-type '(unsigned-byte 32))
+		     (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S"
+			   destination-location
+			   destination
+			   loc0 term0
+			   loc1 term1))
+		   (append (cond
+			    ((type-specifier-singleton type0)
+			     (append (make-load-lexical term1 :eax funobj nil frame-map)
+				     (make-load-constant (car (type-specifier-singleton type0))
+							 :ebx funobj frame-map)))
+			    ((type-specifier-singleton type1)
+			     (append (make-load-lexical term0 :eax funobj nil frame-map)
+				     (make-load-constant (car (type-specifier-singleton type1))
+							 :ebx funobj frame-map)))
+			    ((and (eq :eax loc0) (eq :ebx loc1))
+			     nil)
+			    ((and (eq :ebx loc0) (eq :eax loc1))
+			     nil)	; terms order isn't important
+			    ((eq :eax loc1)
+			     (append
+			      (make-load-lexical term0 :ebx funobj nil frame-map)))
+			    (t (append
+				(make-load-lexical term0 :eax funobj nil frame-map)
+				(make-load-lexical term1 :ebx funobj nil frame-map))))
+			   `((:movl (:edi ,(global-constant-offset '+)) :esi))
+			   (make-compiled-funcall-by-esi 2)
+			   (etypecase destination
+			     (symbol
+			      (unless (eq destination :eax)
+				`((:movl :eax ,destination))))
+			     (binding
+			      (make-store-lexical destination :eax nil funobj frame-map))))))
+	    (let ((constant0 (let ((x (type-specifier-singleton type0)))
+			       (when (and x (typep (car x) 'movitz-fixnum))
+				 (movitz-immediate-value (car x)))))
+		  (constant1 (let ((x (type-specifier-singleton type1)))
+			       (when (and x (typep (car x) 'movitz-fixnum))
+				 (movitz-immediate-value (car x))))))
 	      (cond
-	       ((and (not (binding-lended-p (binding-target term0)))
-		     (not (binding-lended-p (binding-target term1)))
-		     (not (and (bindingp destination)
-			       (binding-lended-p (binding-target destination)))))
+	       ((type-specifier-singleton result-type)
+		;; (break "constant add: ~S" instruction)
+		(make-load-constant (car (type-specifier-singleton result-type))
+				    destination funobj frame-map))
+	       ((movitz-subtypep type0 '(integer 0 0))
 		(cond
-		 ((and constant0
-		       (equal loc1 destination-location))
-		  (cond
-		   ((member destination-location '(:eax :ebx :ecx :edx))
-		    `((:addl ,constant0 ,destination-location)))
-		   ((integerp loc1)
-		    `((:addl ,constant0 (:ebp ,(stack-frame-offset loc1)))))
-		   ((eq :argument-stack (operator loc1))
-		    `((:addl ,constant0
-			     (:ebp ,(argument-stack-offset (binding-target term1))))))
-		   (t (error "Don't know how to add this for loc1 ~S" loc1))))
-		 ((and constant0
-		       (integerp destination-location)
-		       (eql term1 destination-location))
-		  (break "untested")
-		  `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
-		 ((and constant0
-		       (integerp destination-location)
-		       (member loc1 '(:eax :ebx :ecx :edx)))
-		  (break "check this!")
-		  `((:addl ,constant0 ,loc1)
-		    (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location)))))
-		 ((and (integerp loc0)
-		       (integerp loc1)
-		       (member destination-location '(:eax :ebx :ecx :edx)))
-		  (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
-			    (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location))))
-		 ((and (integerp destination-location)
-		       (eql loc0 destination-location)
-		       constant1)
-		  `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location)))))
-		 ((and (integerp destination-location)
-		       (eql loc1 destination-location)
-		       constant0)
-		  `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
-		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       (eq loc0 :untagged-fixnum-ecx)
-		       constant1)
-		  `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1)
-			   ,destination-location)))
-		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       (integerp loc1)
-		       constant0)
-		  `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location)
-		    (:addl ,constant0 ,destination-location)))
+		 ((eql destination loc1)
+		  #+ignore (break "NOP add: ~S" instruction)
+		  nil)
 		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       (integerp loc0)
-		       constant1)
-		  `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
-		    (:addl ,constant1 ,destination-location)))
-		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       (integerp loc0)
-		       (member loc1 '(:eax :ebx :ecx :edx))
-		       (not (eq destination-location loc1)))
-		  `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
-		    (:addl ,loc1 ,destination-location)))
-		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       constant0
 		       (member loc1 '(:eax :ebx :ecx :edx)))
-		  `((:leal (,loc1 ,constant0) ,destination-location)))
+		  `((:movl ,loc1 ,destination-location)))
+		 ((integerp loc1)
+		  (make-load-lexical term1 destination funobj nil frame-map))
+		 #+ignore
+		 ((integerp destination-location)
+		  (make-store-lexical destination-location loc1 nil funobj frame-map))
+		 (t (break "Unknown X zero-add: ~S" instruction))))
+	       ((movitz-subtypep type1 '(integer 0 0))
+		;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
+		(cond
+		 ((eql destination-location loc0)
+		  #+ignore (break "NOP add: ~S" instruction)
+		  nil)
 		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       constant1
 		       (member loc0 '(:eax :ebx :ecx :edx)))
-		  `((:leal (,loc0 ,constant1) ,destination-location)))
-		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       constant0
-		       (eq :argument-stack (operator loc1)))
-		  `((:movl (:ebp ,(argument-stack-offset (binding-target term1)))
-			   ,destination-location)
-		    (:addl ,constant0 ,destination-location)))
-		 ((and (member destination-location '(:eax :ebx :ecx :edx))
-		       constant1
-		       (eq :argument-stack (operator loc0)))
-		  `((:movl (:ebp ,(argument-stack-offset (binding-target term0)))
-			   ,destination-location)
-		    (:addl ,constant1 ,destination-location)))
-		 (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
-			  destination-location
-			  destination
-			  loc0 term0
-			  loc1 term1)
-		    #+ignore (warn "map: ~A" frame-map)
-;;; 	    (warn "ADDI: ~S" instruction)
-		    (append (cond
-			     ((type-specifier-singleton type0)
-			      (append (make-load-lexical term1 :eax funobj nil frame-map)
-				      (make-load-constant (car (type-specifier-singleton type0))
-							  :ebx funobj frame-map)))
-			     ((type-specifier-singleton type1)
-			      (append (make-load-lexical term0 :eax funobj nil frame-map)
-				      (make-load-constant (car (type-specifier-singleton type1))
-							  :ebx funobj frame-map)))
-			     ((and (eq :eax loc0) (eq :ebx loc1))
-			      nil)
-			     ((and (eq :ebx loc0) (eq :eax loc1))
-			      nil)	; terms order isn't important
-			     ((eq :eax loc1)
-			      (append
-			       (make-load-lexical term0 :ebx funobj nil frame-map)))
-			     (t (append
-				 (make-load-lexical term0 :eax funobj nil frame-map)
-				 (make-load-lexical term1 :ebx funobj nil frame-map))))
-			    `((:movl (:edi ,(global-constant-offset '+)) :esi))
-			    (make-compiled-funcall-by-esi 2)
-			    (etypecase destination
-			      (symbol
-			       (unless (eq destination :eax)
-				 `((:movl :eax ,destination))))
-			      (binding
-			       (make-store-lexical destination :eax nil funobj frame-map)))))))
-	       ((and constant0
-		     (integerp destination-location)
-		     (eql loc1 destination-location)
-		     (binding-lended-p (binding-target destination)))
-		(assert (binding-lended-p (binding-target term1)))
-		(append (make-load-lexical destination :eax funobj t frame-map)
-			`((:addl ,constant0 (-1 :eax)))))
-	       ((warn "~S" (list (and (bindingp destination)
-				      (binding-lended-p (binding-target destination)))
-				 (binding-lended-p (binding-target term0))
-				 (binding-lended-p (binding-target term1)))))
-	       (t (warn "Unknown fixnum add: ~S" instruction)
-		  (make-default-add))))
-	     ((and (movitz-subtypep type0 'fixnum)
-		   (movitz-subtypep type1 'fixnum))
-	      (flet ((mkadd-into (src destreg)
-		       (assert (eq destreg :eax) (destreg)
-			 "Movitz' INTO protocol says the overflowed value must be in EAX, ~
-but it's requested to be in ~S."
-			 destreg)
-		       (let ((srcloc (new-binding-location (binding-target src) frame-map)))
-			 (unless (eql srcloc loc1) (break))
-			 (if (integerp srcloc)
-			     `((:addl (:ebp ,(stack-frame-offset srcloc))
-				      ,destreg)
-			       (:into))
-			   (ecase (operator srcloc)
-			     ((:eax :ebx :ecx :edx)
-			      `((:addl ,srcloc ,destreg)
-				(:into)))
-			     ((:argument-stack)
-			      `((:addl (:ebx ,(argument-stack-offset src))
-				       ,destreg)
-				(:into)))
-			     )))))
+		  `((:movl ,loc0 ,destination-location)))
+		 ((member loc0 '(:eax :ebx :ecx :edx))
+		  (make-store-lexical destination loc0 nil funobj frame-map))
+		 ((integerp loc0)
+		  (make-load-lexical term0 destination funobj nil frame-map))
+		 (t (break "Unknown Y zero-add: ~S" instruction))))
+	       ((and (movitz-subtypep type0 'fixnum)
+		     (movitz-subtypep type1 'fixnum)
+		     (movitz-subtypep result-type 'fixnum))
+		(assert (not (and constant0 (zerop constant0))))
+		(assert (not (and constant1 (zerop constant1))))
 		(cond
-		 ((and (not constant0)
-		       (not constant1)
-		       (not (binding-lended-p (binding-target term0)))
+		 ((and (not (binding-lended-p (binding-target term0)))
 		       (not (binding-lended-p (binding-target term1)))
 		       (not (and (bindingp destination)
 				 (binding-lended-p (binding-target destination)))))
 		  (cond
-		   ((and (not (eq loc0 :untagged-fixnum-ecx))
-			 (not (eq loc1 :untagged-fixnum-ecx))
-			 (not (eq destination-location :untagged-fixnum-ecx)))
-		    (append (cond
-			     ((and (eq loc0 :eax) (eq loc1 :eax))
-			      `((:addl :eax :eax)
-				(:into)))
-			     ((eq loc0 :eax)
-			      (mkadd-into term1 :eax))
-			     ((eq loc1 :eax)
-			      (mkadd-into term0 :eax))
-			     (t (append (make-load-lexical term0 :eax funobj nil frame-map
-							   :protect-registers (list loc1))
-					(mkadd-into term1 :eax))))
+		   ((and constant0
+			 (equal loc1 destination-location))
+		    (cond
+		     ((member destination-location '(:eax :ebx :ecx :edx))
+		      `((:addl ,constant0 ,destination-location)))
+		     ((integerp loc1)
+		      `((:addl ,constant0 (:ebp ,(stack-frame-offset loc1)))))
+		     ((eq :argument-stack (operator loc1))
+		      `((:addl ,constant0
+			       (:ebp ,(argument-stack-offset (binding-target term1))))))
+		     (t (error "Don't know how to add this for loc1 ~S" loc1))))
+		   ((and constant0
+			 (integerp destination-location)
+			 (eql term1 destination-location))
+		    (break "untested")
+		    `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
+		   ((and constant0
+			 (integerp destination-location)
+			 (member loc1 '(:eax :ebx :ecx :edx)))
+		    `((:addl ,constant0 ,loc1)
+		      (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location)))))
+		   ((and (integerp loc0)
+			 (integerp loc1)
+			 (member destination-location '(:eax :ebx :ecx :edx)))
+		    (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+			      (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location))))
+		   ((and (integerp destination-location)
+			 (eql loc0 destination-location)
+			 constant1)
+		    `((:addl ,constant1 (:ebp ,(stack-frame-offset destination-location)))))
+		   ((and (integerp destination-location)
+			 (eql loc1 destination-location)
+			 constant0)
+		    `((:addl ,constant0 (:ebp ,(stack-frame-offset destination-location)))))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 (eq loc0 :untagged-fixnum-ecx)
+			 constant1)
+		    `((:leal ((:ecx ,+movitz-fixnum-factor+) ,constant1)
+			     ,destination-location)))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 (integerp loc1)
+			 constant0)
+		    `((:movl (:ebp ,(stack-frame-offset loc1)) ,destination-location)
+		      (:addl ,constant0 ,destination-location)))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 (integerp loc0)
+			 constant1)
+		    `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+		      (:addl ,constant1 ,destination-location)))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 (integerp loc0)
+			 (member loc1 '(:eax :ebx :ecx :edx))
+			 (not (eq destination-location loc1)))
+		    `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location)
+		      (:addl ,loc1 ,destination-location)))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 constant0
+			 (member loc1 '(:eax :ebx :ecx :edx)))
+		    `((:leal (,loc1 ,constant0) ,destination-location)))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 constant1
+			 (member loc0 '(:eax :ebx :ecx :edx)))
+		    `((:leal (,loc0 ,constant1) ,destination-location)))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 constant0
+			 (eq :argument-stack (operator loc1)))
+		    `((:movl (:ebp ,(argument-stack-offset (binding-target term1)))
+			     ,destination-location)
+		      (:addl ,constant0 ,destination-location)))
+		   ((and (member destination-location '(:eax :ebx :ecx :edx))
+			 constant1
+			 (eq :argument-stack (operator loc0)))
+		    `((:movl (:ebp ,(argument-stack-offset (binding-target term0)))
+			     ,destination-location)
+		      (:addl ,constant1 ,destination-location)))
+		   (constant0
+		    (append (make-load-lexical term1 :eax funobj nil frame-map)
+			    `((:addl ,constant0 :eax))
 			    (make-store :eax destination)))
-		  (t (make-default-add)
-		      #+ignore
-		      (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map)
-			      `((,*compiler-local-segment-prefix*
-				 :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0))))
-			      (make-load-lexical term1 :untagged-fixnum-ecx funobj nil frame-map)
-			      `((,*compiler-local-segment-prefix*
-				 :addl (:edi ,(global-constant-offset 'raw-scratch0)) :ecx))
-			      (if (integerp destination-location)
-				  `((,*compiler-local-segment-prefix*
-				     :call (:edi ,(global-constant-offset 'box-u32-ecx)))
-				    (:movl :eax (:ebp ,(stack-frame-offset destination-location))))
-				(ecase (operator destination-location)
-				  ((:untagged-fixnum-ecx)
-				   nil)
-				  ((:eax)
-				   `((,*compiler-local-segment-prefix*
-				      :call (:edi ,(global-constant-offset 'box-u32-ecx)))))
-				  ((:ebx :ecx :edx)
-				   `((,*compiler-local-segment-prefix*
-				      :call (:edi ,(global-constant-offset 'box-u32-ecx)))
-				     (:movl :eax ,destination-location)))
-				  ((:argument-stack)
-				   `((,*compiler-local-segment-prefix*
-				      :call (:edi ,(global-constant-offset 'box-u32-ecx)))
-				     (:movl :eax (:ebp ,(argument-stack-offset
-							 (binding-target destination))))))))))))
-		 (t (make-default-add)))))
-	     (t (make-default-add)))))))))
+		   (constant1
+		    (append (make-load-lexical term0 :eax funobj nil frame-map)
+			    `((:addl ,constant1 :eax))
+			    (make-store :eax destination)))
+		   ((eql loc0 loc1)
+		    (append (make-load-lexical term0 :eax funobj nil frame-map)
+			    `((:addl :eax :eax))
+			    (make-store :eax destination)))
+		   (t (warn "Unknown fixnum ADD: ~A/~S = ~A/~S + ~A/~S"
+			    destination-location
+			    destination
+			    loc0 term0
+			    loc1 term1)
+		      #+ignore (warn "map: ~A" frame-map)
+;;; 	    (warn "ADDI: ~S" instruction)
+		      (append (cond
+			       ((type-specifier-singleton type0)
+				(append (make-load-lexical term1 :eax funobj nil frame-map)
+					(make-load-constant (car (type-specifier-singleton type0))
+							    :ebx funobj frame-map)))
+			       ((type-specifier-singleton type1)
+				(append (make-load-lexical term0 :eax funobj nil frame-map)
+					(make-load-constant (car (type-specifier-singleton type1))
+							    :ebx funobj frame-map)))
+			       ((and (eq :eax loc0) (eq :ebx loc1))
+				nil)
+			       ((and (eq :ebx loc0) (eq :eax loc1))
+				nil)	; terms order isn't important
+			       ((eq :eax loc1)
+				(append
+				 (make-load-lexical term0 :ebx funobj nil frame-map)))
+			       (t (append
+				   (make-load-lexical term0 :eax funobj nil frame-map)
+				   (make-load-lexical term1 :ebx funobj nil frame-map))))
+			      `((:movl (:edi ,(global-constant-offset '+)) :esi))
+			      (make-compiled-funcall-by-esi 2)
+			      (etypecase destination
+				(symbol
+				 (unless (eq destination :eax)
+				   `((:movl :eax ,destination))))
+				(binding
+				 (make-store-lexical destination :eax nil funobj frame-map)))))))
+		 ((and constant0
+		       (integerp destination-location)
+		       (eql loc1 destination-location)
+		       (binding-lended-p (binding-target destination)))
+		  (assert (binding-lended-p (binding-target term1)))
+		  (append (make-load-lexical destination :eax funobj t frame-map)
+			  `((:addl ,constant0 (-1 :eax)))))
+		 ((warn "~S" (list (and (bindingp destination)
+					(binding-lended-p (binding-target destination)))
+				   (binding-lended-p (binding-target term0))
+				   (binding-lended-p (binding-target term1)))))
+		 (t (warn "Unknown fixnum add: ~S" instruction)
+		    (make-default-add))))
+	       ((and (movitz-subtypep type0 'fixnum)
+		     (movitz-subtypep type1 'fixnum))
+		(flet ((mkadd-into (src destreg)
+			 (assert (eq destreg :eax) (destreg)
+			   "Movitz' INTO protocol says the overflowed value must be in EAX, ~
+but it's requested to be in ~S."
+			   destreg)
+			 (let ((srcloc (new-binding-location (binding-target src) frame-map)))
+			   (unless (eql srcloc loc1) (break))
+			   (if (integerp srcloc)
+			       `((:addl (:ebp ,(stack-frame-offset srcloc))
+					,destreg)
+				 (:into))
+			     (ecase (operator srcloc)
+			       ((:eax :ebx :ecx :edx)
+				`((:addl ,srcloc ,destreg)
+				  (:into)))
+			       ((:argument-stack)
+				`((:addl (:ebx ,(argument-stack-offset src))
+					 ,destreg)
+				  (:into)))
+			       )))))
+		  (cond
+		   ((and (not constant0)
+			 (not constant1)
+			 (not (binding-lended-p (binding-target term0)))
+			 (not (binding-lended-p (binding-target term1)))
+			 (not (and (bindingp destination)
+				   (binding-lended-p (binding-target destination)))))
+		    (cond
+		     ((and (not (eq loc0 :untagged-fixnum-ecx))
+			   (not (eq loc1 :untagged-fixnum-ecx))
+			   (not (eq destination-location :untagged-fixnum-ecx)))
+		      (append (cond
+			       ((and (eq loc0 :eax) (eq loc1 :eax))
+				`((:addl :eax :eax)
+				  (:into)))
+			       ((eq loc0 :eax)
+				(mkadd-into term1 :eax))
+			       ((eq loc1 :eax)
+				(mkadd-into term0 :eax))
+			       (t (append (make-load-lexical term0 :eax funobj nil frame-map
+							     :protect-registers (list loc1))
+					  (mkadd-into term1 :eax))))
+			      (make-store :eax destination)))
+		     (t (make-default-add)
+			#+ignore
+			(append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map)
+				`((,*compiler-local-segment-prefix*
+				   :movl :ecx (:edi ,(global-constant-offset 'raw-scratch0))))
+				(make-load-lexical term1 :untagged-fixnum-ecx funobj nil frame-map)
+				`((,*compiler-local-segment-prefix*
+				   :addl (:edi ,(global-constant-offset 'raw-scratch0)) :ecx))
+				(if (integerp destination-location)
+				    `((,*compiler-local-segment-prefix*
+				       :call (:edi ,(global-constant-offset 'box-u32-ecx)))
+				      (:movl :eax (:ebp ,(stack-frame-offset destination-location))))
+				  (ecase (operator destination-location)
+				    ((:untagged-fixnum-ecx)
+				     nil)
+				    ((:eax)
+				     `((,*compiler-local-segment-prefix*
+					:call (:edi ,(global-constant-offset 'box-u32-ecx)))))
+				    ((:ebx :ecx :edx)
+				     `((,*compiler-local-segment-prefix*
+					:call (:edi ,(global-constant-offset 'box-u32-ecx)))
+				       (:movl :eax ,destination-location)))
+				    ((:argument-stack)
+				     `((,*compiler-local-segment-prefix*
+					:call (:edi ,(global-constant-offset 'box-u32-ecx)))
+				       (:movl :eax (:ebp ,(argument-stack-offset
+							   (binding-target destination))))))))))))
+		   (t (make-default-add)))))
+	       (t (make-default-add))))))))))
 
 ;;;;;;;