From ffjeld at common-lisp.net  Sun Apr  2 20:48:34 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun,  2 Apr 2006 16:48:34 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060402204834.EAD9E19002@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv5418

Modified Files:
	sequences.lisp 
Log Message:
Implemented reduce :from-end on lists.
Improved remove-duplicates and delete-duplicates not to use O(n) stack.


--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/03/25 20:59:16	1.31
+++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/04/02 20:48:34	1.32
@@ -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.31 2006/03/25 20:59:16 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.32 2006/04/02 20:48:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -126,8 +126,6 @@
    (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."))
       (let ((start (check-the index start)))
 	(with-funcallable (funcall-function function)
 	  (with-funcallable (key)
@@ -140,18 +138,34 @@
 		   (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
+		    (cond
+		     ((not from-end)
+		      (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)))
-						    (key (pop list)))
-				  (funcall-function result (key (pop list)))))
-			((or (null list)
-			     (= end counter))
-			 result)
-		      (declare (index counter))))
+				    (funcall-function result (key (pop list)))))
+			  ((or (null list)
+			       (= end counter))
+			   result)
+			(declare (index counter))))
+		     (from-end
+		      (do* ((counter (1+ start) (1+ counter))
+			    (list (nreverse (subseq sequence start end)))
+			    (result (funcall-function (key (pop list))
+						      (if initial-value-p
+							  initial-value
+							(key (pop list))))
+				    (funcall-function (key (pop list)) result)))
+			  ((or (null list)
+			       (= end counter))
+			   result)
+			(declare (index counter))))))
 		   (vector
+		    (when from-end
+		      (error "REDUCE from-end on vectors is not implemented."))
 		    (with-subvector-accessor (sequence-ref sequence start end)
 		      (do* ((index start)
 			    (result (funcall-function (if initial-value-p
@@ -731,7 +745,7 @@
     (apply 'map-for-nil function first-sequence more-sequences))
    ((eq 'list result-type)
     (apply 'map-for-list function first-sequence more-sequences))
-   ((eq 'string result-type)
+   ((member result-type '(string simple-string))
     (apply 'map-for-string function first-sequence more-sequences))
    (t (error "MAP not implemented."))))
 
@@ -1390,21 +1404,17 @@
     (setf test (complement test-not)))
   (sequence-dispatch sequence
     (list
-     (setf sequence (nthcdr start sequence))
-     (when end (decf end start))
-     (cond
-      ((endp sequence)
-       nil)
-      ((not from-end)
-       (let* ((new-end (when end (1- end)))
-	      (tail (remove-duplicates (cdr sequence) :test test :key key :end new-end)))
-	 (cond
-	  ((find (car sequence) (cdr sequence) :test test :key key :end new-end)
-	   tail)
-	  ((eq tail (cdr sequence))
-	   sequence)
-	  (t (cons (car sequence) tail)))))		   
-      (t (error "from-end not implemented."))))
+     (let ((list (nthcdr start sequence)))
+       (cond
+	((endp list)
+	 nil)
+	((and (not end) (not from-end))
+	 (do ((r nil))
+	     ((endp list) (nreverse r))
+	   (let ((x (pop list)))
+	     (unless (member x list :key key :test test)
+	       (push x r)))))
+	(t (error "remove-duplicates not implemented.")))))
     (vector
      (error "vector remove-duplicates not implemented."))))
 



From ffjeld at common-lisp.net  Mon Apr  3 21:22:40 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon,  3 Apr 2006 17:22:40 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060403212240.0A071550D2@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv27835

Modified Files:
	defstruct.lisp 
Log Message:
Added support for :copier option to defstruct.


--- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp	2004/10/21 20:34:02	1.16
+++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp	2006/04/03 21:22:39	1.17
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.16 2004/10/21 20:34:02 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.17 2006/04/03 21:22:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -199,7 +199,9 @@
 	  (default (:constructor)
 	      (intern (concatenate 'string (string 'make-) (string struct-name))))
 	  (default (:predicate 1)
-	      (intern (concatenate 'string (string struct-name) (string '-p)))))
+	      (intern (concatenate 'string (string struct-name) (string '-p))))
+	  (default (:copier)
+	      (intern (concatenate 'string (string 'copy-) (string struct-name)))))
 	(let* ((struct-type (first (getf options :type)))
 	       (superclass (first (getf options :superclass)))
 	       (struct-named (first (getf options :named)))
@@ -243,6 +245,11 @@
 								     :type type
 								     :readonly read-only
 								     :location location))))
+		,@(loop for copier in (getf options :copier)
+		      if (and copier (symbolp copier))
+		      collect
+			`(defun ,copier (x)
+			   (copy-structure x)))
 		,@(loop for constructor in (getf options :constructor)
 		      if (and constructor (symbolp constructor))
 		      collect



From ffjeld at common-lisp.net  Wed Apr  5 23:02:22 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  5 Apr 2006 19:02:22 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060405230222.836BD15005@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv3301

Modified Files:
	format.lisp 
Log Message:
Support ~P and ~Newline.


--- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp	2005/08/26 19:39:06	1.12
+++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp	2006/04/05 23:02:22	1.13
@@ -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.12 2005/08/26 19:39:06 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.13 2006/04/05 23:02:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -142,6 +142,24 @@
 	   proceed
 	    (incf i)
 	    (case (char-upcase (schar control-string i))
+	      (#\Newline
+	       (when at-sign-p
+		 (write-char #\Newline))
+	       (unless colon-p
+		 (do ((stop (1- (length control-string))))
+		     ((or (>= i stop)
+			  (not (member (schar control-string (1+ i))
+				       '(#\space #\newline #\tab)))))
+		   (incf i))))
+	      (#\P (let ((arg (if (not colon-p)
+				  (pop args)
+				(car (nthcdr (1- (do ((i 0 (1+ i)) (p args-head (cdr p)))
+						     ((eq p args) i) ; find arg's position in arg-head.
+						   (assert p)))
+					     args-head)))))
+		     (write-string (if at-sign-p
+				       (if (eql arg 1) "y" "ies")
+				     (if (eql arg 1) "" "s")))))
 	      (#\Z (if at-sign-p
 		       (print-word-indirect (pop args) nil)
 		     (print-word (pop args) nil)))



From ffjeld at common-lisp.net  Fri Apr  7 21:33:54 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:33:54 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407213354.313596713D@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv21830

Modified Files:
	cons.lisp 
Log Message:
Added acons.


--- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2005/06/12 21:27:03	1.11
+++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2006/04/07 21:33:54	1.12
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.11 2005/06/12 21:27:03 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.12 2006/04/07 21:33:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -271,3 +271,7 @@
 		 (and (te (car tree-1) (car tree-2) test)
 		      (te (cdr tree-1) (cdr tree-2) test))))))
     (te tree-1 tree-2 (or test (and test-not (complement test-not)) #'eql))))
+
+(defun acons (key datum alist)
+  "=> new-alist"
+  (cons (cons key datum) alist))



From ffjeld at common-lisp.net  Fri Apr  7 21:35:32 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:35:32 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407213532.9CFEF710E4@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv21957

Modified Files:
	integers.lisp 
Log Message:
Added trivial versions of realpart, imagpart, and rational.


--- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp	2006/03/31 20:57:48	1.120
+++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp	2006/04/07 21:35:32	1.121
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.120 2006/03/31 20:57:48 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.121 2006/04/07 21:35:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -2250,3 +2250,13 @@
 (defun floatp (x)
   (declare (ignore x))
   nil)
+
+(defun realpart (number)
+  number)
+
+(defun imagpart (number)
+  (declare (ignore number))
+  0)
+
+(defun rational (number)
+  number)



From ffjeld at common-lisp.net  Fri Apr  7 21:47:44 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:47:44 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407214744.3586F200D@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24041

Modified Files:
	arrays.lisp 
Log Message:
Improve upgraded-array-element-type slightly.


--- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp	2005/08/24 07:27:47	1.56
+++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp	2006/04/07 21:47:44	1.57
@@ -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.56 2005/08/24 07:27:47 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.57 2006/04/07 21:47:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -105,17 +105,19 @@
        (let* ((q (cdr type-specifier))
 	      (min (if q (pop q) '*))
 	      (max (if q (pop q) '*)))
-	 (cond
-	  ((or (eq min '*) (eq max '*))
-	   t)
-	  ((<= 0 min max 1)
-	   'bit)
-	  ((<= 0 min max #xff)
-	   '(unsigned-byte 8))
-	  ((<= 0 min max #xffff)
-	   '(unsigned-byte 16))
-	  ((<= 0 min max #xffffffff)
-	   '(unsigned-byte 32)))))
+	 (let ((min (if (consp min) (1+ (car min)) min))
+	       (max (if (consp max) (1- (car max)) max)))
+	   (cond
+	    ((or (eq min '*) (eq max '*))
+	     t)
+	    ((<= 0 min max 1)
+	     'bit)
+	    ((<= 0 min max #xff)
+	     '(unsigned-byte 8))
+	    ((<= 0 min max #xffff)
+	     '(unsigned-byte 16))
+	    ((<= 0 min max #xffffffff)
+	     '(unsigned-byte 32))))))
       (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*)))
 	   (if (not deriver)
 	       t



From ffjeld at common-lisp.net  Fri Apr  7 21:48:41 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:48:41 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407214841.29372200D@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24089

Modified Files:
	common-lisp.lisp 
Log Message:
Added very primitive subtypep.


--- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp	2005/05/03 20:08:14	1.13
+++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp	2006/04/07 21:48:41	1.14
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:41:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: common-lisp.lisp,v 1.13 2005/05/03 20:08:14 ffjeld Exp $
+;;;; $Id: common-lisp.lisp,v 1.14 2006/04/07 21:48:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -52,6 +52,7 @@
 (require :muerte/interrupt)
 (require :muerte/scavenge)
 (require :muerte/simple-streams)
+(require :muerte/subtypep)
 
 (require :muerte/io-port)
 (require :muerte/cpu-id)



From ffjeld at common-lisp.net  Fri Apr  7 21:48:43 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:48:43 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407214843.9BFA22013@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24108

Added Files:
	subtypep.lisp 
Log Message:
Added very primitive subtypep.



--- /project/movitz/cvsroot/movitz/losp/muerte/subtypep.lisp	2006/04/07 21:48:43	NONE
+++ /project/movitz/cvsroot/movitz/losp/muerte/subtypep.lisp	2006/04/07 21:48:43	1.1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;    Copyright (C) 2006, 
;;    Department of Computer Science, University of Tromso, Norway.
;; 
;;    For distribution policy, see the accompanying file COPYING.
;; 
;; Filename:      subtypep.lisp
;; Description:   
;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
;; Created at:    Sun Apr  2 20:47:11 2006
;;                
;; $Id: subtypep.lisp,v 1.1 2006/04/07 21:48:43 ffjeld Exp $
;;                
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require :muerte/basic-macros)
(provide :muerte/subtypep)
  
(in-package muerte)

(defun subtypep (type-1 type-2 &optional environment)
  "Is type-1 a subtype of type-2? => subtype-p, valid-p"
  (let ((class-1 (find-class type-1 nil environment))
	(class-2 (find-class type-2 nil environment)))
    (cond
     ((and class-1 class-2)
      (values (subclassp class-1 class-2) t))
     (class-2
      (dolist (c (class-precedence-list class-2) (values nil nil))
	(when (member type-1 (getf (class-plist c) :subtypes))
	  (return (values t t)))))
     (t (values nil nil)))))
      
    
  
  


From ffjeld at common-lisp.net  Fri Apr  7 21:49:47 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:49:47 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407214947.21CA717034@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24161

Modified Files:
	setf.lisp 
Log Message:
Sort of implemented defsetf short form.


--- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp	2004/02/18 14:38:14	1.3
+++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp	2006/04/07 21:49:47	1.4
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Feb  8 20:43:20 2001
 ;;;;                
-;;;; $Id: setf.lisp,v 1.3 2004/02/18 14:38:14 ffjeld Exp $
+;;;; $Id: setf.lisp,v 1.4 2006/04/07 21:49:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -86,45 +86,54 @@
 ;;;	      `(subseq ,tmp-sequence ,tmp-start ,tmp-end)))))
 
 (defmacro defsetf (access-fn &rest more-args)
-  ;; long form
-  (destructuring-bind (lambda-list store-variables &body body)
-      more-args
-    (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl)))
-      (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes)
-	  (movitz::decode-macro-lambda-list movitz-lambda)
-	(assert (null restvar))
-	(assert (null envvars))
-	(assert (null wholevars))
-	(assert (null auxes))
-	(assert (null keys))
-	(let* ((req-tmps (mapcar (lambda (x) (list x (gensym)))
-				 reqvars))
-	       (opt-vars (mapcar #'movitz::decode-optional-formal
-				 optionalvars))
-	       (opt-tmps (mapcar (lambda (x) (list x (gensym)))
-				 opt-vars))
-	       (tmp-lets (append (mapcar (lambda (rt)
-					   (list (second rt) '(gensym)))
-					 req-tmps)
-				 (mapcar (lambda (rt)
-					   (list (second rt) '(gensym)))
-					 opt-tmps)
-				 `((init-form (list , at reqvars , at opt-vars)))
-				 (mapcar (lambda (rt)
-					   (list rt '(gensym)))
-					 store-variables)))
-	       (lambda-lets (append req-tmps opt-tmps)))
-	  `(define-setf-expander ,access-fn ,movitz-lambda
-	     (let ,tmp-lets
-	       (let ,lambda-lets
-		 (values (list ,@(mapcar #'second req-tmps)
-			       ,@(mapcar #'second opt-tmps))
-			 init-form
-			 (list , at store-variables)
-			 (progn , at body)
-			 (list ',access-fn
-			       ,@(mapcar #'first req-tmps)
-			       ,@(mapcar #'first opt-tmps)))))))))))
+  (cond
+   ((symbolp (first more-args))
+    ;; short form XXX not really good.
+    `(defun (setf ,access-fn) (fu foo)
+       (,(first more-args) fu foo)))
+   (t ;; long form
+    (destructuring-bind (lambda-list store-variables &body body-decl-docstring)
+	more-args
+      (multiple-value-bind (body declarations docstring)
+	  (movitz::parse-docstring-declarations-and-body body-decl-docstring 'cl:declare)
+	(let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl)))
+	  (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes)
+	      (movitz::decode-macro-lambda-list movitz-lambda)
+	    (assert (null restvar))
+	    (assert (null envvars))
+	    (assert (null wholevars))
+	    (assert (null auxes))
+	    (assert (null keys))
+	    (let* ((req-tmps (mapcar (lambda (x) (list x (gensym)))
+				     reqvars))
+		   (opt-vars (mapcar #'movitz::decode-optional-formal
+				     optionalvars))
+		   (opt-tmps (mapcar (lambda (x) (list x (gensym)))
+				     opt-vars))
+		   (tmp-lets (append (mapcar (lambda (rt)
+					       (list (second rt) '(gensym)))
+					     req-tmps)
+				     (mapcar (lambda (rt)
+					       (list (second rt) '(gensym)))
+					     opt-tmps)
+				     `((init-form (list , at reqvars , at opt-vars)))
+				     (mapcar (lambda (rt)
+					       (list rt '(gensym)))
+					     store-variables)))
+		   (lambda-lets (append req-tmps opt-tmps)))
+	      `(define-setf-expander ,access-fn ,movitz-lambda
+		 (declare , at declarations)
+		 ,@(when docstring (list docstring))
+		 (let ,tmp-lets
+		   (let ,lambda-lets
+		     (values (list ,@(mapcar #'second req-tmps)
+				   ,@(mapcar #'second opt-tmps))
+			     init-form
+			     (list , at store-variables)
+			     (progn , at body)
+			     (list ',access-fn
+				   ,@(mapcar #'first req-tmps)
+				   ,@(mapcar #'first opt-tmps))))))))))))))
 
 
 (defmacro define-modify-macro (name lambda-list function &optional documentation)



From ffjeld at common-lisp.net  Fri Apr  7 21:50:37 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:50:37 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407215037.33A9A1E006@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24273

Modified Files:
	read.lisp 
Log Message:
Added *readtable* variable and copy-readtable mockup.


--- /project/movitz/cvsroot/movitz/losp/muerte/read.lisp	2005/08/26 19:38:35	1.13
+++ /project/movitz/cvsroot/movitz/losp/muerte/read.lisp	2006/04/07 21:50:37	1.14
@@ -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.13 2005/08/26 19:38:35 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.14 2006/04/07 21:50:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,7 +20,11 @@
 (in-package muerte)
 
 (defvar *read-suppress*)
-(defvar *readtable*)
+(defvar *readtable* nil)
+
+(defun copy-readtable (&optional from-readtable to-readtable)
+  (declare (ignore from-readtable to-readtable))
+  nil)
 
 (defun substring (string start end)
   (if (and (zerop start) (= end (length string)))



From ffjeld at common-lisp.net  Fri Apr  7 21:51:53 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:51:53 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407215153.93FE820012@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24315

Modified Files:
	conditions.lisp 
Log Message:
Add style-warning condition.


--- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp	2005/08/11 21:34:26	1.17
+++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp	2006/04/07 21:51:53	1.18
@@ -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.17 2005/08/11 21:34:26 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.18 2006/04/07 21:51:53 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -63,6 +63,7 @@
 (define-condition serious-condition () ())
 (define-condition error (serious-condition) ())
 (define-condition warning () ())
+(define-condition style-warning () ())
 (define-condition simple-error (simple-condition error) ())
 (define-condition simple-warning (simple-condition warning) ())
 
@@ -282,7 +283,10 @@
    ((not *debugger-function*)
     (let ((*never-use-print-object* t))
       (backtrace :spartan t))
-    (format t "~&No debugger in *debugger-function*. Trying to continue or abort.")
+    (format t "~&No debugger in *debugger-function*...")
+    (dotimes (i 100000)
+      (write-string ""))
+    (format t "Trying to continue or abort.")
     (invoke-restart (or (find-restart 'continue)
 			(find-restart 'abort)
 			(format t "~%Condition for debugger: ~Z" condition)



From ffjeld at common-lisp.net  Fri Apr  7 21:52:17 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:52:17 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407215217.7325A24009@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24361

Modified Files:
	functions.lisp 
Log Message:
Smart up complement somewhat.


--- /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp	2005/04/20 06:53:28	1.29
+++ /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp	2006/04/07 21:52:17	1.30
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.29 2005/04/20 06:53:28 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.30 2006/04/07 21:52:17 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -60,22 +60,15 @@
   (declare (dynamic-extent args))
   (not (apply 'function args)))
 
-(define-compiler-macro complement (&whole form function-form)
+(define-compiler-macro complement (&whole form function-form &environment env)
   (cond
-   ((movitz:movitz-constantp function-form)
-    (let ((function (movitz:movitz-eval function-form)))
-      `(make-prototyped-function (complement ,function)
-				 complement-prototype
-				 (function ,function))))
    ((and (listp function-form)
 	 (eq 'function (first function-form))
-	 (symbolp (second function-form))
-	 (typep (movitz:movitz-eval (translate-program function-form :cl :muerte.cl))
+	 (typep (movitz:movitz-eval (translate-program function-form :cl :muerte.cl) env)
 		'movitz:movitz-funobj))
-    `(make-prototyped-function (complement ,function-form)
+    `(make-prototyped-function `(complement ,(second function-form))
 			       complement-prototype
-			       (function ,(movitz:movitz-eval (translate-program function-form
-									      :cl :muerte.cl)))))
+			       ,(movitz:movitz-eval (translate-program function-form :cl :muerte.cl))))
    (t form)))
 
 (defun complement (function)



From ffjeld at common-lisp.net  Fri Apr  7 21:52:36 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:52:36 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407215236.650D524009@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24399

Modified Files:
	hash-tables.lisp 
Log Message:
Support equalp hashing.


--- /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp	2005/08/26 19:38:50	1.11
+++ /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp	2006/04/07 21:52:36	1.12
@@ -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.11 2005/08/26 19:38:50 ffjeld Exp $
+;;;; $Id: hash-tables.lisp,v 1.12 2006/04/07 21:52:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -42,7 +42,8 @@
 	       test)
 	(eq (values #'eq #'sxhash-eq))
 	(eql (values #'eql #'sxhash-eql))
-	(equal (values #'equal #'sxhash)))
+	(equal (values #'equal #'sxhash))
+	(equalp (values #'equalp #'sxhash)))
     (make-hash-table-object
      :test test
      :bucket (make-array (* 2 size) :initial-element '--no-hash-key--)



From ffjeld at common-lisp.net  Fri Apr  7 21:53:02 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:53:02 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407215302.04B422A015@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24435

Modified Files:
	loop.lisp 
Log Message:
We need loop-copylist* at runtime.


--- /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp	2004/09/06 12:33:43	1.6
+++ /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp	2006/04/07 21:53:02	1.7
@@ -70,6 +70,12 @@
 ;;;This is the "current" loop context in use when we are expanding a
 ;;;loop.  It gets bound on each invocation of LOOP.
 
+#+movitz
+(defmacro loop-copylist* (l)
+  #+Genera `(lisp:copy-list ,l nil t)		; arglist = (list &optional area force-dotted)
+  ;;@@@@Explorer??
+  #-Genera `(copy-list ,l))
+
 (eval-when (:compile-toplevel)
   (defvar *loop-real-data-type* 'real)
   (defvar *loop-universe*)



From ffjeld at common-lisp.net  Fri Apr  7 21:53:47 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:53:47 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407215347.C88A82A015@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24476

Modified Files:
	environment.lisp 
Log Message:
random-state and pathname types.


--- /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp	2005/08/31 22:31:35	1.14
+++ /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp	2006/04/07 21:53:47	1.15
@@ -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.14 2005/08/31 22:31:35 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.15 2006/04/07 21:53:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -167,3 +167,6 @@
 (defun sleep (seconds)
   (declare (ignore seconds))
   (error "There is no default implementation of sleep."))
+
+(defstruct random-state state)
+(defstruct pathname name)



From ffjeld at common-lisp.net  Fri Apr  7 21:54:23 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri,  7 Apr 2006 17:54:23 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060407215423.DB6F22E18A@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24514

Modified Files:
	print.lisp 
Log Message:
Added write-to-string.


--- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp	2005/08/26 19:38:41	1.21
+++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp	2006/04/07 21:54:23	1.22
@@ -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.21 2005/08/26 19:38:41 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.22 2006/04/07 21:54:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -201,6 +201,12 @@
 	    (print-unreadable-object (c *standard-output* :type t :identity t)
 	      (format t "(while printing ~Z)" object))))))))
 
+(defun write-to-string (object &rest args)
+  (declare (dynamic-extent args))
+  (apply 'write object
+	 :stream (make-array 24 :element-type 'character :fill-pointer 0 :adjustable t)
+	 args))
+
 (defun internal-write (object)
   (let ((stream *standard-output*))
     (cond



From ffjeld at common-lisp.net  Mon Apr 10 11:45:37 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:45:37 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060410114537.123621D006@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv4553

Modified Files:
	movitz.lisp 
Log Message:
Added support for #. reader syntax (i.e. translate muerte.cl to cl package).


--- /project/movitz/cvsroot/movitz/movitz.lisp	2004/11/15 14:42:15	1.10
+++ /project/movitz/cvsroot/movitz/movitz.lisp	2006/04/10 11:45:36	1.11
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Oct  9 20:52:58 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: movitz.lisp,v 1.10 2004/11/15 14:42:15 ffjeld Exp $
+;;;; $Id: movitz.lisp,v 1.11 2006/04/10 11:45:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -56,6 +56,12 @@
 	 , at body
 	 (write-char #\> ,stream-var)))))
 
+(defun movitz-syntax-sharp-dot (stream subchar arg)
+  (declare (ignore arg subchar))
+  (let ((form (read stream t nil t)))
+    (values (unless *read-suppress*
+	      (eval (muerte::translate-program form :muerte.cl :cl))))))
+
 (defmacro with-movitz-syntax (options &body body)
   (declare (ignore options))
   `(let ((*readtable* (copy-readtable)))
@@ -71,6 +77,11 @@
 				       (make-movitz-vector (length data)
 							   :element-type 'movitz-unboxed-integer-u8
 							   :initial-contents data))))
+     (set-dispatch-macro-character #\# #\. (lambda (stream subchar arg)
+					     (declare (ignore arg subchar))
+					     (let ((form (read stream t nil t)))
+					       (values (unless *read-suppress*
+							 (eval (muerte::translate-program form :muerte.cl :cl)))))))
      (set-macro-character #\` (lambda (stream char)
 				(declare (ignore char))
 				(let ((*bq-level* (1+ *bq-level*)))



From ffjeld at common-lisp.net  Mon Apr 10 11:46:25 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:46:25 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060410114625.040A91D007@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv4599

Modified Files:
	procfs-image.lisp 
Log Message:
Invoke debugger with a string only.


--- /project/movitz/cvsroot/movitz/procfs-image.lisp	2005/05/03 20:11:43	1.24
+++ /project/movitz/cvsroot/movitz/procfs-image.lisp	2006/04/10 11:46:25	1.25
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Aug 24 11:39:37 2001
 ;;;;                
-;;;; $Id: procfs-image.lisp,v 1.24 2005/05/03 20:11:43 ffjeld Exp $
+;;;; $Id: procfs-image.lisp,v 1.25 2006/04/10 11:46:25 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -319,10 +319,11 @@
 	      (let ((x (eval form)))
 		(format t "~&~W" x)
 		x)
-	    (invoke-debugger "Established Bochs session [pid=~D]. ~S is ~S"
-			     (image-pid image)
-			     '*previous-image*
-			     *previous-image*)))))))
+	    (invoke-debugger
+	     (format nil "Established Bochs session [pid=~D]. ~S is ~S"
+		     (image-pid image)
+		     '*previous-image*
+		     *previous-image*))))))))
 
 #+allegro
 (top-level:alias ("unbochs" 3) (&optional form)



From ffjeld at common-lisp.net  Mon Apr 10 11:47:14 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:47:14 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060410114714.C7AB21E006@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv4635

Modified Files:
	special-operators.lisp 
Log Message:
Just warn rather than error upon non-toplevel declaim.


--- /project/movitz/cvsroot/movitz/special-operators.lisp	2005/08/28 21:03:53	1.54
+++ /project/movitz/cvsroot/movitz/special-operators.lisp	2006/04/10 11:47:14	1.55
@@ -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.54 2005/08/28 21:03:53 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.55 2006/04/10 11:47:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -598,7 +598,7 @@
 
 (define-special-operator muerte::declaim-compile-time (&form form &top-level-p top-level-p)
   (unless top-level-p
-    (error "DECLAIM not at top-level."))
+    (warn "DECLAIM not at top-level."))
   (let ((declaration-specifiers (cdr form)))
     (movitz-env-load-declarations declaration-specifiers *movitz-global-environment* :declaim))
   (compiler-values ()))



From ffjeld at common-lisp.net  Mon Apr 10 11:47:41 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:47:41 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060410114741.D327A22009@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv4685

Modified Files:
	storage-types.lisp 
Log Message:
Added missing update-movitz-object method.


--- /project/movitz/cvsroot/movitz/storage-types.lisp	2005/07/21 18:48:33	1.55
+++ /project/movitz/cvsroot/movitz/storage-types.lisp	2006/04/10 11:47:41	1.56
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.55 2005/07/21 18:48:33 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.56 2006/04/10 11:47:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1309,6 +1309,10 @@
   (assert (= (movitz-ratio-value object) lisp-object))
   object)
 
+(defmethod update-movitz-object ((object movitz-ratio) (lisp-object float))
+  (assert (= (movitz-ratio-value object) (rationalize lisp-object)))
+  object)
+
 (defmethod print-object ((x movitz-ratio) stream)
   (print-unreadable-object (x stream :type t)
     (format stream "~D" (slot-value x 'value)))



From ffjeld at common-lisp.net  Mon Apr 10 11:48:20 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:48:20 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060410114820.5C4F424006@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv4724

Modified Files:
	image.lisp 
Log Message:
Read floats by rationalizing.


--- /project/movitz/cvsroot/movitz/image.lisp	2005/08/21 13:47:16	1.104
+++ /project/movitz/cvsroot/movitz/image.lisp	2006/04/10 11:48:20	1.105
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.104 2005/08/21 13:47:16 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.105 2006/04/10 11:48:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1495,7 +1495,9 @@
 		   (mapcar #'(lambda (slot)
 			       (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
 			   slot-descriptions))
-		 movitz-object))))))))
+		 movitz-object)))
+	    (float			; XXX
+	     (movitz-read (rationalize expr))))))))
 
 ;;;
 



From ffjeld at common-lisp.net  Mon Apr 10 11:49:41 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:49:41 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060410114941.5F8BC24006@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv4760

Modified Files:
	compiler.lisp 
Log Message:
minor tweaks.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2005/10/31 09:22:54	1.166
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2006/04/10 11:49:41	1.167
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.166 2005/10/31 09:22:54 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.167 2006/04/10 11:49:41 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1400,8 +1400,7 @@
 		       (pathname-directory path))
 	    (path)
 	  "Refusing to delete file not in /tmp.")
-	(delete-file path))))
-  (values))
+	(delete-file path)))))
 
 (defun movitz-compile-file-internal (path
 				     &optional (*default-load-priority*
@@ -1440,9 +1439,9 @@
 			  (when *compiler-verbose-p*
 			    (format *query-io* "~&Movitz Compiling ~S..~%"
 				    (cond
-				      ((symbolp form) form)
-				      ((symbolp (car form))
-				       (xsubseq form 0 2)))))
+				     ((symbolp form) form)
+				     ((symbolp (car form))
+				      (xsubseq form 0 2)))))
 			  (compiler-call #'compile-form
 			    :form form
 			    :funobj funobj
@@ -1452,13 +1451,16 @@
 	(cond
 	 ((null file-code)
 	  (setf (image-load-time-funobjs *image*)
-	    (delete funobj (image-load-time-funobjs *image*) :key #'first)))
+	    (delete funobj (image-load-time-funobjs *image*) :key #'first))
+	  'muerte::constantly-true)
 	 (t (setf (extended-code function-env) file-code
 		  (need-normalized-ecx-p function-env) nil
 		  (function-envs funobj) (list (cons 'muerte.cl::t function-env))
 		  (funobj-env funobj) funobj-env)
-	    (make-compiled-funobj-pass2 funobj)))
-	t))))
+	    (make-compiled-funobj-pass2 funobj)
+	    (let ((name (funobj-name funobj)))
+	      (setf (movitz-env-named-function name) funobj)
+	      name)))))))
 
 ;;;;
 



From ffjeld at common-lisp.net  Mon Apr 10 11:50:34 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:50:34 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115034.955212A01E@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv4874

Modified Files:
	arithmetic-macros.lisp 
Log Message:
No need to give cl package prefix inside #.(..) anymore.


--- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp	2005/09/18 16:20:04	1.15
+++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp	2006/04/10 11:50:34	1.16
@@ -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.15 2005/09/18 16:20:04 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.16 2006/04/10 11:50:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -216,7 +216,7 @@
 		 ,@(loop repeat count
 		       append `((:addl (:result-register) (:result-register))
 				(:into)))))
-	     ((< 0 count #.(cl:1- movitz::+movitz-fixnum-bits+))
+	     ((< 0 count #.(1- movitz::+movitz-fixnum-bits+))
 	      `(with-inline-assembly (:returns :register :side-effects nil :type integer)
 		 , at load-integer
 		 (:cmpl ,(ash 1 (- (- 31 0) count))



From ffjeld at common-lisp.net  Mon Apr 10 11:51:03 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:51:03 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115103.2CFC42A01E@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv4911

Modified Files:
	basic-macros.lisp 
Log Message:
Have find-class compiler-macro accept optional environment arg.


--- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2005/08/28 20:53:13	1.65
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2006/04/10 11:51:03	1.66
@@ -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.65 2005/08/28 20:53:13 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.66 2006/04/10 11:51:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -914,9 +914,9 @@
      (error "Array backquote not implemented."))
     (t (list 'quote form))))
 
-(define-compiler-macro find-class (&whole form &environment env symbol &optional (errorp t))
-  (declare (ignore errorp))
-  (if (not (movitz:movitz-constantp symbol env))
+(define-compiler-macro find-class (&whole form &environment env symbol &optional (errorp t) (environment nil envp))
+  (declare (ignore errorp environment))
+  (if (or envp (not (movitz:movitz-constantp symbol env)))
       form
     (let* ((type (movitz:movitz-eval symbol env))
 	   (movitz-type (movitz-program type))



From ffjeld at common-lisp.net  Mon Apr 10 11:52:21 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:52:21 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115221.C396D2B007@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv4947

Modified Files:
	los-closette.lisp 
Log Message:
Have find-class compiler-macro accept optional environment arg.
Take note that character class contains base-char and extended-char.


--- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp	2005/08/21 17:55:54	1.35
+++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp	2006/04/10 11:52:21	1.36
@@ -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.35 2005/08/21 17:55:54 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.36 2006/04/10 11:52:21 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -99,6 +99,10 @@
 (defmacro push-on-end (value location)
   `(setf ,location (nconc ,location (list ,value))))
 
+
+(defmacro define-method-combination (name &rest options)
+  (declare (ignore options))
+  (warn "Method-combinations not implemented: ~S" name))
 ;;;
 
 
@@ -210,7 +214,8 @@
 
 ;;;
 
-(defun find-class (symbol &optional (errorp t))
+(defun find-class (symbol &optional (errorp t) environment)
+  (declare (ignore environment))
   (let ((class (gethash symbol *class-table*)))
     (if (and (null class) errorp)
 	(error "No class named ~S." symbol)
@@ -951,7 +956,9 @@
 (defclass symbol (t) () (:metaclass built-in-class))
 (defclass sequence (t) () (:metaclass built-in-class))
 (defclass array (t) () (:metaclass built-in-class))
-(defclass character (t) () (:metaclass built-in-class))
+(defclass character (t) ()
+	  (:metaclass built-in-class)
+	  (:plist (:subtypes (base-char extended-char))))
 (defclass list (sequence) () (:metaclass built-in-class))
 (defclass null (symbol list) () (:metaclass built-in-class))
 (defclass cons (list) () (:metaclass built-in-class))



From ffjeld at common-lisp.net  Mon Apr 10 11:54:52 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:54:52 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115452.617873000E@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv4992

Modified Files:
	more-macros.lisp 
Log Message:
Added trivial locally macro. Also a mock-up load compiler-macro.


--- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2005/08/26 19:39:26	1.29
+++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2006/04/10 11:54:52	1.30
@@ -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.29 2005/08/26 19:39:26 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.30 2006/04/10 11:54:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -431,3 +431,12 @@
 (define-unimplemented-macro with-open-file)
 (define-unimplemented-macro restart-case)
 
+(define-compiler-macro load (filespec &key verbose print if-does-not-exist external-format)
+  "hm..."
+  (assert (movitz:movitz-constantp filespec) (filespec)
+    "Can't load a non-constant filename: ~S" filespec)
+  (warn "load-compile: ~S" filespec)
+  `(funcall ',(movitz:movitz-compile-file (format nil "losp/ansi-tests/~A" filespec))))
+
+(defmacro locally (&body body)
+  `(let () , at body))



From ffjeld at common-lisp.net  Mon Apr 10 11:56:28 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:56:28 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115628.B14903401F@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv5113

Modified Files:
	sequences.lisp 
Log Message:
Improved map and remove-if.


--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/04/02 20:48:34	1.32
+++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp	2006/04/10 11:56:28	1.33
@@ -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.32 2006/04/02 20:48:34 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.33 2006/04/10 11:56:28 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -716,22 +716,21 @@
 	       (ignore function first-sequence more-sequences))
       (error "MAP not implemented."))))
 
-(defun map-for-string (function first-sequence &rest more-sequences)
+(defun map-for-vector (result function first-sequence &rest more-sequences)
   (numargs-case
-   (2 (function first-sequence)
+   (3 (result function first-sequence)
       (with-funcallable (mapf function)
-	(let ((result (make-string (length first-sequence))))
-	  (sequence-dispatch first-sequence
-	    (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)))))))))
+	(sequence-dispatch first-sequence
+	  (vector
+	   (do ((i 0 (1+ i)))
+	       ((>= i (length result)) result)
+	     (declare (index i))
+	     (setf (aref result i) (mapf (aref first-sequence i)))))
+	  (list
+	   (do ((i 0 (1+ i)))
+	       ((>= i (length result)) result)
+	     (declare (index i))
+	     (setf (aref result i) (mapf (pop first-sequence))))))))
    (t (function first-sequence &rest more-sequences)
       (declare (ignore function first-sequence more-sequences))
       (error "MAP not implemented."))))
@@ -746,7 +745,13 @@
    ((eq 'list result-type)
     (apply 'map-for-list function first-sequence more-sequences))
    ((member result-type '(string simple-string))
-    (apply 'map-for-string function first-sequence more-sequences))
+    (apply 'map-for-vector
+	   (make-string (length first-sequence))
+	   function first-sequence more-sequences))
+   ((member result-type '(vector simple-vector))
+    (apply 'map-for-vector
+	   (make-array (length first-sequence))
+	   function first-sequence more-sequences))
    (t (error "MAP not implemented."))))
 
 (defun fill (sequence item &key (start 0) end)
@@ -1253,30 +1258,33 @@
     list)
    (t (with-funcallable (test)
 	(with-funcallable (key)
-	  (if (test (key (car list)))
-	      (list-remove-if test (cdr list) key
-			      (when end (1- end))
-			      (when count (1- count)))
-	    (do ((i 1 (1+ i))
-		 (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
-		  ;; the copy's tail being the recursive call to list-remove.
-		  (do* ((new-list (cons (car list) nil))
-			(x (cdr list) (cdr x))
-			(new-x new-list))
-		      ((eq x p1)
-		       (setf (cdr new-x) (list-remove-if test (cdr p1) key
-							 (when end (- end i 1))
-							 (when count (1- count))))
-		       new-list)
-		    (setf new-x
-		      (setf (cdr new-x)
-			(cons (car x) nil)))))))))))))
+	  (and (do () ((or (endp list)
+			   (and end (<= end 0))
+			   (not (test (key (car list))))
+			   (and count (<= (decf count) 0)))
+		       list)
+		 (when end (decf end))
+		 (setf list (cdr list)))
+	       (do ((i 1 (1+ i))
+		    (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
+		     ;; the copy's tail being the recursive call to list-remove.
+		     (do* ((new-list (cons (car list) nil))
+			   (x (cdr list) (cdr x))
+			   (new-x new-list))
+			 ((eq x p1)
+			  (setf (cdr new-x) (list-remove-if test (cdr p1) key
+							    (when end (- end i 1))
+							    (when count (1- count))))
+			  new-list)
+		       (setf new-x
+			 (setf (cdr new-x)
+			   (cons (car x) nil)))))))))))))
 
 (defun remove-if (test sequence &key from-end (start 0) end count (key 'identity))
   (sequence-dispatch sequence



From ffjeld at common-lisp.net  Mon Apr 10 11:57:24 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:57:24 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115724.1931D3401F@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv5157

Modified Files:
	streams.lisp 
Log Message:
Have finish-output accept a function as stream designator.


--- /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp	2004/11/24 16:19:36	1.4
+++ /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp	2006/04/10 11:57:24	1.5
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Jun 30 14:33:15 2003
 ;;;;                
-;;;; $Id: streams.lisp,v 1.4 2004/11/24 16:19:36 ffjeld Exp $
+;;;; $Id: streams.lisp,v 1.5 2006/04/10 11:57:24 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -125,6 +125,7 @@
 destination, and then returns."
   (let ((stream (output-stream-designator stream)))
     (etypecase stream
+      (function)			; NOP
       (simple-stream
        (%finish-output stream)))))
 



From ffjeld at common-lisp.net  Mon Apr 10 11:58:15 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:58:15 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115815.3444F3A007@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv5192

Modified Files:
	typep.lisp 
Log Message:
Improved coerce.


--- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp	2005/10/25 19:27:46	1.52
+++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp	2006/04/10 11:58:15	1.53
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.52 2005/10/25 19:27:46 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.53 2006/04/10 11:58:15 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -704,7 +704,7 @@
 	 (cond
 	  ((typep object result-type)
 	   object)
-	  ((member result-type '(list array vector))
+	  ((member result-type '(list array vector simple-vector string simple-string))
 	   (map result-type #'identity object))
 	  ((and (consp result-type)
 		(eq (car result-type) 'vector))



From ffjeld at common-lisp.net  Mon Apr 10 11:58:28 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Mon, 10 Apr 2006 07:58:28 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060410115828.0ADBC42001@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv5221

Modified Files:
	variables.lisp 
Log Message:
Added some variables.


--- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp	2005/06/10 23:05:50	1.9
+++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp	2006/04/10 11:58:27	1.10
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov  5 21:53:34 2003
 ;;;;                
-;;;; $Id: variables.lisp,v 1.9 2005/06/10 23:05:50 ffjeld Exp $
+;;;; $Id: variables.lisp,v 1.10 2006/04/10 11:58:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -45,4 +45,28 @@
 
 (defvar *gc-hooks* nil)
 
+(defvar *load-pathname* nil)
+
+
+(defvar most-positive-short-float 1000000)
+(defvar most-positive-single-float 1000000)
+(defvar most-positive-double-float 1000000)
+(defvar most-positive-long-float 1000000)
+
+(defvar short-float-epsilon 1/1000)
+(defvar single-float-epsilon 1/1000)
+(defvar double-float-epsilon 1/1000)
+(defvar long-float-epsilon 1/1000)
+
+(defvar short-float-negative-epsilon -1/1000)
+(defvar single-float-negative-epsilon -1/1000)
+(defvar double-float-negative-epsilon -1/1000)
+(defvar long-float-negative-epsilon -1/1000)
+
+
+(defconstant call-arguments-limit #xffff0)
+(defconstant lambda-parameters-limit #x1000) ; ?
+
+(defvar *print-pprint-dispatch* nil)
+
 (declaim (special *build-number*))



From ffjeld at common-lisp.net  Fri Apr 28 21:18:48 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 28 Apr 2006 17:18:48 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060428211848.E548C5614D@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv15406

Modified Files:
	more-macros.lisp 
Log Message:
Added trivial with-standard-io-syntax macro.


--- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2006/04/10 11:54:52	1.30
+++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2006/04/28 21:18:48	1.31
@@ -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.30 2006/04/10 11:54:52 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.31 2006/04/28 21:18:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -440,3 +440,27 @@
 
 (defmacro locally (&body body)
   `(let () , at body))
+
+(defmacro with-standard-io-syntax (&body body)
+  `(let ((*package* (find-package :init))
+	 (*print-array* t)
+	 (*print-base* 10)
+	 (*print-case* :upcase)
+	 (*print-circle* nil)
+	 (*print-escape* t)
+	 (*print-gensym* t)
+	 (*print-length* nil)
+	 (*print-level* nil)
+	 (*print-lines* nil)
+	 #+ignore (*print-miser-width* nil)
+	 #+ignore (*print-pprint-dispatch* nil)
+	 (*print-pretty* nil)
+	 (*print-radix* nil)
+	 (*print-readably* t)
+	 #+ignore (*print-right-margin* nil)
+	 (*read-base* 10)
+	 (*read-default-float-format* 'ratio)
+	 (*read-eval* t)
+	 (*read-suppress* nil)
+	 #+ignore (*readtable* nil))
+     , at body))



From ffjeld at common-lisp.net  Fri Apr 28 21:19:06 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 28 Apr 2006 17:19:06 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060428211906.833CE56161@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv15447

Modified Files:
	image.lisp 
Log Message:
Implement package-nicknames.


--- /project/movitz/cvsroot/movitz/image.lisp	2006/04/10 11:48:20	1.105
+++ /project/movitz/cvsroot/movitz/image.lisp	2006/04/28 21:19:06	1.106
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.105 2006/04/10 11:48:20 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.106 2006/04/28 21:19:06 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1117,7 +1117,7 @@
 	  (pushnew :constant-variable (movitz-symbol-flags symbol))
 	  (setf (movitz-symbol-value symbol)
 	    (movitz-read (translate-program (symbol-value (translate-program name :muerte.cl :cl))
-					 :cl :muerte.cl))))
+					    :cl :muerte.cl))))
 	symbol)))
 
 (defun make-packages-hash (&optional (*image* *image*))
@@ -1143,16 +1143,20 @@
 		 lisp-package context)
 	       (setf (gethash lisp-package lisp-to-movitz-package)
 		 (or (gethash package-name packages-hash nil)
-		     (let ((p (funcall 'muerte::make-package-object
-				       :name package-name
-				       :shadowing-symbols-list (package-shadowing-symbols lisp-package)
-				       :external-symbols (make-hash-table :test #'equal)
-				       :internal-symbols (make-hash-table :test #'equal)
-				       :use-list (mapcar #'(lambda (up) 
-							     (ensure-package (movitz-package-name (package-name up))
-									     up context))
-							 (package-use-list lisp-package)))))
+		     (let* ((nicks (mapcar #'movitz-package-name (package-nicknames lisp-package)))
+			    (p (funcall 'muerte::make-package-object
+					:name package-name
+					:shadowing-symbols-list (package-shadowing-symbols lisp-package)
+					:external-symbols (make-hash-table :test #'equal)
+					:internal-symbols (make-hash-table :test #'equal)
+					:nicknames nicks
+					:use-list (mapcar #'(lambda (up) 
+							      (ensure-package (movitz-package-name (package-name up))
+									      up context))
+							  (package-use-list lisp-package)))))
 		       (setf (gethash package-name packages-hash) p)
+		       (dolist (nick nicks)
+			 (setf (gethash nick packages-hash) p))
 		       p)))))
       (let ((movitz-cl-package (ensure-package (symbol-name :common-lisp)
 					       (find-package :muerte.common-lisp))))



From ffjeld at common-lisp.net  Fri Apr 28 21:19:08 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 28 Apr 2006 17:19:08 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060428211908.1F40956166@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv15466

Modified Files:
	packages.lisp 
Log Message:
Implement package-nicknames.


--- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp	2005/08/31 22:32:08	1.12
+++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp	2006/04/28 21:19:08	1.13
@@ -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.12 2005/08/31 22:32:08 ffjeld Exp $
+;;;; $Id: packages.lisp,v 1.13 2006/04/28 21:19:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -28,13 +28,17 @@
   external-symbols
   internal-symbols
   shadowing-symbols-list
-  use-list)
+  use-list
+  nicknames)
 
 (defvar *packages*)			; Set by dump-image.
 
 (defun package-name (object)
   (package-object-name (find-package object)))
 
+(defun package-nicknames (package-designator)
+  (package-object-nicknames (find-package package-designator)))
+
 (defun package-use-list (package-name)
   (package-object-use-list (find-package package-name)))
 



From ffjeld at common-lisp.net  Fri Apr 28 23:20:45 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 28 Apr 2006 19:20:45 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060428232045.88E7E2E189@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv29847

Modified Files:
	compiler.lisp 
Log Message:
If a compiler-macro signals error, print a warning and pretend the
compiler-macro declined.


--- /project/movitz/cvsroot/movitz/compiler.lisp	2006/04/10 11:49:41	1.167
+++ /project/movitz/cvsroot/movitz/compiler.lisp	2006/04/28 23:20:45	1.168
@@ -8,7 +8,7 @@
 ;;;; Created at:    Wed Oct 25 12:30:49 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: compiler.lisp,v 1.167 2006/04/10 11:49:41 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.168 2006/04/28 23:20:45 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -5550,9 +5550,13 @@
 	(compiler-call (movitz-special-operator-compiler operator) :forward all)
       (let* ((compiler-macro-function (movitz-compiler-macro-function operator env))
 	     (compiler-macro-expansion (and compiler-macro-function
-					    (funcall *movitz-macroexpand-hook*
-						     compiler-macro-function
-						     form env))))
+					    (handler-case
+						(funcall *movitz-macroexpand-hook*
+							 compiler-macro-function
+							 form env)
+					      (error (c)
+						(warn "Compiler-macro for ~S failed: ~A" operator c)
+						form)))))
 	(cond
 	 ((and compiler-macro-function
 	       (not (movitz-env-get operator 'notinline nil env))
@@ -6671,7 +6675,6 @@
 (define-extended-code-expander :cons-get (instruction funobj frame-map)
   (destructuring-bind (op cell dst)
       (cdr instruction)
-    (check-type cell lexical-binding)
     (check-type dst (member :eax :ebx :ecx :edx))
     (multiple-value-bind (op-offset fast-op fast-op-ebx)
 	(ecase op
@@ -6684,8 +6687,7 @@
       (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj)))
 	     (location (new-binding-location (binding-target binding) frame-map))
 	     (binding-is-list-p (binding-store-subtypep binding 'list)))
-	#+ignore (warn "car of loc ~A bind ~A"
-		       location binding)
+	#+ignore (warn "~A of loc ~A bind ~A" op location binding)
 	(cond
 	 ((and binding-is-list-p
 	       (member location '(:eax :ebx :ecx :edx)))



From ffjeld at common-lisp.net  Fri Apr 28 23:20:47 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 28 Apr 2006 19:20:47 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20060428232047.44E132E192@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv29871

Modified Files:
	eval.lisp 
Log Message:
If a compiler-macro signals error, print a warning and pretend the
compiler-macro declined.


--- /project/movitz/cvsroot/movitz/eval.lisp	2005/09/16 22:49:34	1.10
+++ /project/movitz/cvsroot/movitz/eval.lisp	2006/04/28 23:20:47	1.11
@@ -9,7 +9,7 @@
 ;;;; Created at:    Thu Nov  2 17:45:05 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: eval.lisp,v 1.10 2005/09/16 22:49:34 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.11 2006/04/28 23:20:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -66,9 +66,11 @@
     (cons
      (let* ((compiler-macro-function (movitz-compiler-macro-function (car form) env))
 	    (compiler-macro-expansion (and compiler-macro-function
-					   (funcall *movitz-macroexpand-hook*
-						    compiler-macro-function
-						    form env))))
+					   (handler-case
+					       (funcall *movitz-macroexpand-hook*
+							compiler-macro-function
+							form env)
+					     (error () form)))))
        (or (let ((form (translate-program form :cl :muerte.cl)))
 	     (case (car form)
 	       ((muerte.cl:quote) t)



From ffjeld at common-lisp.net  Fri Apr 28 23:21:32 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 28 Apr 2006 19:21:32 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060428232132.E1EEB34020@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv29923

Modified Files:
	more-macros.lisp 
Log Message:
Have the silly load implementation be a macro rather than
compiler-macro, since there's no function to back it up.


--- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2006/04/28 21:18:48	1.31
+++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2006/04/28 23:21:32	1.32
@@ -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.31 2006/04/28 21:18:48 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.32 2006/04/28 23:21:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -431,7 +431,7 @@
 (define-unimplemented-macro with-open-file)
 (define-unimplemented-macro restart-case)
 
-(define-compiler-macro load (filespec &key verbose print if-does-not-exist external-format)
+(defmacro load (filespec &key verbose print if-does-not-exist external-format)
   "hm..."
   (assert (movitz:movitz-constantp filespec) (filespec)
     "Can't load a non-constant filename: ~S" filespec)



From ffjeld at common-lisp.net  Fri Apr 28 23:21:59 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 28 Apr 2006 19:21:59 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060428232159.CF0783800B@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv29966

Modified Files:
	conditions.lisp 
Log Message:
Add simple-condition-format-control and
simple-condition-format-arguments readers.


--- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp	2006/04/07 21:51:53	1.18
+++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp	2006/04/28 23:21:59	1.19
@@ -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.18 2006/04/07 21:51:53 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.19 2006/04/28 23:21:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -59,7 +59,11 @@
 		      (condition-format-control condition)
 		      (condition-format-arguments condition))))))
 
-(define-condition simple-condition (condition) ())
+(define-condition simple-condition (condition)
+  ((format-control
+    :reader simple-condition-format-control)
+   (format-arguments
+    :reader simple-condition-format-arguments)))
 (define-condition serious-condition () ())
 (define-condition error (serious-condition) ())
 (define-condition warning () ())



From ffjeld at common-lisp.net  Sat Apr 29 11:30:35 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Sat, 29 Apr 2006 07:30:35 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060429113035.3C3B22F008@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv27486

Modified Files:
	lists.lisp 
Log Message:
Added (setf first) and (setf rest).


--- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2005/08/21 19:00:16	1.12
+++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2006/04/29 11:30:35	1.13
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.12 2005/08/21 19:00:16 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.13 2006/04/29 11:30:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,6 +25,12 @@
 (defun rest (x)
   (cdr x))
 
+(defun (setf first) (x y)
+  (setf (car x) y))
+
+(defun (setf rest) (x y)
+  (setf (cdr x) y))
+
 ;; Compiler-macros for first and rest in basic-macros.lisp.
 
 (defun second  (x) (cadr x))



From ffjeld at common-lisp.net  Sat Apr 29 11:41:34 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Sat, 29 Apr 2006 07:41:34 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060429114134.9895A7D000@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv27802

Modified Files:
	lists.lisp 
Log Message:
Added (setf first) and (setf rest).


--- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2006/04/29 11:30:35	1.13
+++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2006/04/29 11:41:34	1.14
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.13 2006/04/29 11:30:35 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.14 2006/04/29 11:41:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -25,10 +25,10 @@
 (defun rest (x)
   (cdr x))
 
-(defun (setf first) (x y)
+(defun (setf first) (y x)
   (setf (car x) y))
 
-(defun (setf rest) (x y)
+(defun (setf rest) (y x)
   (setf (cdr x) y))
 
 ;; Compiler-macros for first and rest in basic-macros.lisp.
@@ -431,8 +431,6 @@
 		     :test (if test-not
 			       (complement test-not)
 			     test)))
-
-  
   
 (defun subsetp (list-1 list-2 &key (key 'identity) (test 'eql) test-not)
   "=> generalized-boolean"



From ffjeld at common-lisp.net  Sun Apr 30 21:38:40 2006
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 30 Apr 2006 17:38:40 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20060430213840.065034610C@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv18377

Modified Files:
	cons.lisp 
Log Message:
Lifted sublis and nsublis from cmucl.


--- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2006/04/07 21:33:54	1.12
+++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2006/04/30 21:38:40	1.13
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.12 2006/04/07 21:33:54 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.13 2006/04/30 21:38:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -275,3 +275,42 @@
 (defun acons (key datum alist)
   "=> new-alist"
   (cons (cons key datum) alist))
+
+(defun sublis (alist tree &key key (test 'eql) test-not)
+  "Substitutes from alist into tree nondestructively."
+  (declare (inline assoc))
+  (let ((key (or key 'identity))
+	(test (if test-not (complement test-not) test)))
+    (labels ((s (subtree)
+	       (let* ((key-val (funcall key subtree))
+		      (assoc (assoc key-val alist :test test)))
+		 (cond (assoc (cdr assoc))
+		       ((atom subtree) subtree)
+		       (t (let ((car (s (car subtree)))
+				(cdr (s (cdr subtree))))
+			    (if (and (eq car (car subtreE))
+				     (eq cdr (cdr subtree)))
+				subtree
+			      (cons car cdr))))))))
+      (s tree))))
+
+(defun nsublis (alist tree &key key (test #'eql) (test-not nil notp))
+  "Substitutes new for subtrees matching old."
+  (declare (inline assoc))
+  (let ((key (or key 'identity))
+	(test (if test-not (complement test-not) test))
+	(temp))
+    (labels ((s (subtree)
+	       (cond ((Setq temp (nsublis-macro))
+		      (cdr temp))
+		     ((atom subtree) subtree)
+		     (t (do* ((last nil subtree)
+			      (subtree subtree (Cdr subtree)))
+			    ((atom subtree)
+			     (if (setq temp (assoc (funcall key subtree) alist :test test))
+				 (setf (cdr last) (cdr temp))))
+			  (if (setq temp (assoc (funcall key subtree) alist :test test))
+			      (return (setf (Cdr last) (Cdr temp)))
+			    (setf (car subtree) (s (car subtree)))))
+			subtree))))
+      (s tree))))