From ffjeld at common-lisp.net  Sun Jul 19 18:32:36 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:32:36 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSbBc-0003CU-Lo@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv12296

Modified Files:
	basic-functions.lisp 
Log Message:
Fix a bug for apply with more than 255 arguments.


--- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp	2008/04/21 19:31:10	1.27
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp	2009/07/19 18:32:34	1.28
@@ -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.27 2008/04/21 19:31:10 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.28 2009/07/19 18:32:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -270,8 +270,8 @@
 	  (:subl :esp :ecx)
 	  (:shrl 2 :ecx)
 	  ;; Encode ECX
-	  (:testb :cl :cl)
-	  (:jns 'ecx-ok)
+          (:testl #xffffff80 :ecx)
+	  (:jz 'ecx-ok)
 	  (:shll 8 :ecx)
 	  (:movb #xff :cl)
 	 ecx-ok




From ffjeld at common-lisp.net  Sun Jul 19 18:49:23 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:49:23 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSbRr-0004FX-6Q@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv16334

Modified Files:
	basic-macros.lisp 
Log Message:
Improved ccase/ecase. Run-time define-symbol-macro.


--- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2008/07/09 20:08:52	1.77
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2009/07/19 18:49:22	1.78
@@ -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.77 2008/07/09 20:08:52 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.78 2009/07/19 18:49:22 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -348,16 +348,17 @@
 	 ,@(mapcar (lambda (clause)
 		     (destructuring-bind (keys . forms)
 			 clause
-		       (cond
-			 ((or (eq keys 't)
-			      (eq keys 'otherwise))
-			  `(t , at forms))
-			 ((atom keys)
-			  `((eql ,key-var ',keys) , at forms))
-			 (t `((or ,@(mapcar (lambda (k)
-					      `(eql ,key-var ',k))
-					    keys))
-			      , at forms)))))
+		       (let ((forms (or forms '(nil))))
+                         (cond
+                           ((or (eq keys 't)
+                                (eq keys 'otherwise))
+                            `(t , at forms))
+                           ((not (listp keys))
+                            `((eql ,key-var ',keys) , at forms))
+                           (t `((or ,@(mapcar (lambda (k)
+                                                `(eql ,key-var ',k))
+                                              keys))
+                                , at forms))))))
 		   clauses)))))
 
 (define-compiler-macro case (keyform &rest clauses)
@@ -374,19 +375,6 @@
 		`(compiled-case ,keyform , at clauses))))))
     (t `(compiled-case ,keyform , at clauses))))
 
-(defmacro ecase (keyform &rest clauses)
-  (let ((ecase-var (gensym)))
-    `(let ((,ecase-var ,keyform))
-       (case ,ecase-var
-	 , at clauses
-	 (t (ecase-error ,ecase-var
-			 ',(mapcan (lambda (clause)
-				     (let ((x (car clause)))
-				       (if (atom x)
-					   (list x)
-					   (copy-list x))))
-				   clauses)))))))
-
 (define-compiler-macro asm-register (register-name)
   (if (member register-name '(:eax :ebx :ecx :untagged-fixnum-ecx :edx))
       `(with-inline-assembly (:returns ,register-name) ())
@@ -549,16 +537,19 @@
 	       (symbol-value movitz-name) movitz-value)))
      (declaim (muerte::constant-variable ,name))))
 
+(define-compile-time-variable *symbol-macros* (make-hash-table :test #'eq))
+
 (defmacro/cross-compilation define-symbol-macro (symbol expansion)
   (check-type symbol symbol "a symbol-macro symbol")
   `(progn
      (eval-when (:compile-toplevel)
        (movitz::movitz-env-add-binding nil (make-instance 'movitz::symbol-macro-binding
-					:name ',symbol
-					:expander (lambda (form env)
-						    (declare (ignore form env))
-						    (movitz::translate-program ',expansion
-									     :cl :muerte.cl)))))
+                                            :name ',symbol
+                                            :expander (lambda (form env)
+                                                        (declare (ignore form env))
+                                                        (movitz::translate-program ',expansion
+                                                         :cl :muerte.cl)))))
+     (setf (gethash ',symbol *symbol-macros*) ',expansion)
      ',symbol))
 
 (defmacro check-type (place type &optional type-string)




From ffjeld at common-lisp.net  Sun Jul 19 18:51:28 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:51:28 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSbTq-0004IF-WA@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv16502

Modified Files:
	characters.lisp 
Log Message:
Tweak char/= and char= for ansi-tests.


--- /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp	2008/04/27 19:30:12	1.6
+++ /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp	2009/07/19 18:51:26	1.7
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Mon Feb  5 19:05:01 2001
 ;;;;                
-;;;; $Id: characters.lisp,v 1.6 2008/04/27 19:30:12 ffjeld Exp $
+;;;; $Id: characters.lisp,v 1.7 2009/07/19 18:51:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -53,25 +53,23 @@
 (defun char= (first-character &rest characters)
   (numargs-case
    (2 (x y)
-      (and (eql x y) 'pinglo))
+      (eql x y))
    (t (first-character &rest characters)
       (declare (dynamic-extent characters))
-      (dolist (c characters 'dumbolo)
+      (dolist (c characters t)
 	(unless (char= c first-character)
 	  (return nil))))))
 
 (defun char/= (first-character &rest characters)
   (numargs-case
+   (1 (x) (declare (ignore x)) t)
    (2 (x y) (not (eql x y)))
-   (t (&rest characters)
-      (declare (dynamic-extent characters))
-      (do ((p (cdr characters) (cdr p)))
-	  ((null p) t)
-	(do ((v characters (cdr v)))
-	    ((eq p v))
-	  (when (eql (car p) (car v))
-	    (return-from char/= nil)))))))
-
+   (t (first-character &rest more-characters)
+      (declare (dynamic-extent more-characters))
+      (do ((c first-character (pop more-characters)))
+          ((null more-characters) t)
+        (when (member c more-characters)
+          (return nil))))))
 
 (defmacro/cross-compilation define-char-cmp (name mode not-branch)
   `(defun ,name (first-character &rest more-characters)




From ffjeld at common-lisp.net  Sun Jul 19 18:52:09 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:52:09 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSbUX-0004Jp-0o@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv16602

Modified Files:
	complexes.lisp 
Log Message:
Improved functions imagpart and realpart.


--- /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp	2008/07/09 20:17:46	1.3
+++ /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp	2009/07/19 18:52:08	1.4
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: complexes.lisp,v 1.3 2008/07/09 20:17:46 ffjeld Exp $
+;;;; $Id: complexes.lisp,v 1.4 2009/07/19 18:52:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -17,8 +17,7 @@
 
 (provide :muerte/complexes)
 
-(defstruct (complex (:constructor make-complex-number)
-		    (:conc-name #:||)
+(defstruct (complex (:constructor make-complex (realpart imagpart))
 		    (:predicate complexp))
   realpart
   imagpart)
@@ -28,5 +27,23 @@
   (check-type imagpart real)
   (if (= 0 imagpart)
       realpart
-      (make-complex-number :realpart realpart
-                           :imagpart imagpart)))
+      (make-complex realpart imagpart)))
+
+(defmethod print-object ((x complex) stream)
+  (format stream "#c(~W ~W)"
+          (complex-realpart x)
+          (complex-imagpart x)))
+
+(defun realpart (x)
+  (etypecase x
+    (complex
+     (complex-realpart x))
+    (real
+     x)))
+
+(defun imagpart (x)
+  (etypecase x
+    (complex
+     (complex-imagpart x))
+    (real
+     0)))




From ffjeld at common-lisp.net  Sun Jul 19 18:54:32 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:54:32 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSbWq-0004Mj-FY@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv16782

Modified Files:
	conditions.lisp 
Log Message:
Improved reporting of condition wrong-argument-count.


--- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp	2008/04/21 19:31:54	1.28
+++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp	2009/07/19 18:54:32	1.29
@@ -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.28 2008/04/21 19:31:54 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.29 2009/07/19 18:54:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -179,7 +179,7 @@
     :initarg :argument-count
     :reader condition-argument-count))
   (:report (lambda (c s)
-	     (format s "Function ~S ~:A received ~D arguments."
+	     (format s "Function ~S ~:A received ~:[an incorrect number of~;~:*~D~] arguments."
 		     (funobj-name (condition-function c))
 		     (funobj-lambda-list (condition-function c))
 		     (condition-argument-count c)))))




From ffjeld at common-lisp.net  Sun Jul 19 18:56:59 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:56:59 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSbZD-0004Pu-IB@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv16977

Modified Files:
	defmacro-runtime.lisp 
Log Message:
Tweak defmacro.


--- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp	2008/04/12 16:23:31	1.3
+++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp	2009/07/19 18:56:58	1.4
@@ -7,7 +7,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defmacro-runtime.lisp,v 1.3 2008/04/12 16:23:31 ffjeld Exp $
+;;;; $Id: defmacro-runtime.lisp,v 1.4 2009/07/19 18:56:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -15,7 +15,7 @@
 
 (provide :muerte/defmacro-runtime)
 
-(defmacro defmacro (name lambda-list &body macro-body)
+(defmacro/cross-compilation defmacro (name lambda-list &body macro-body)
   `(progn
      (defmacro/run-time ,name ,lambda-list , at macro-body)
      (defmacro/compile-time ,name ,lambda-list ,macro-body)




From ffjeld at common-lisp.net  Sun Jul 19 18:57:48 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:57:48 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSba0-0004RR-C5@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv17073

Modified Files:
	environment.lisp 
Log Message:
Add *random-state* and gf documentation.


--- /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp	2008/04/27 19:40:25	1.18
+++ /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp	2009/07/19 18:57:48	1.19
@@ -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.18 2008/04/27 19:40:25 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.19 2009/07/19 18:57:48 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -189,4 +189,7 @@
 
 (defstruct random-state state)
 
+(defvar *random-state* #s(random-state :state 0))
 
+(defmethod documentation (x doc-type)
+  nil)




From ffjeld at common-lisp.net  Sun Jul 19 18:58:33 2009
From: ffjeld at common-lisp.net (ffjeld)
Date: Sun, 19 Jul 2009 14:58:33 -0400
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <E1MSbaj-0004TC-2S@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory cl-net:/tmp/cvs-serv17183

Modified Files:
	functions.lisp 
Log Message:
Add (setf funobj-type) and make-macro-function.


--- /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp	2006/05/02 20:01:46	1.31
+++ /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp	2009/07/19 18:58:33	1.32
@@ -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.31 2006/05/02 20:01:46 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.32 2009/07/19 18:58:33 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -79,6 +79,8 @@
 			 (compiled-function
 			  (funobj-name edx))
 			 (t '(unknown)))))
+;;     (when los0::*funbound-counter*
+;;       (incf (gethash function-name los0::*funbound-counter* 0)))
     (with-simple-restart (continue "Return NIL from ~S." function-name)
       (error 'undefined-function-call
 	     :name function-name
@@ -92,7 +94,13 @@
   (with-inline-assembly (:returns :untagged-fixnum-ecx)
     (:xorl :ecx :ecx)
     (:compile-form (:result-mode :eax) funobj)
-    (:movb (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:funobj-type)) :cl)))
+    (:movb (:eax (:offset movitz-funobj funobj-type)) :cl)))
+
+(defun (setf funobj-type) (type funobj)
+  (check-type funobj function)
+  (with-inline-assembly (:returns :untagged-fixnum-ecx)
+    (:compile-two-forms (:eax :untagged-fixnum-ecx) funobj type)
+    (:movb :cl (:eax (:offset movitz-funobj funobj-type)))))
 
 (defun funobj-code-vector (funobj)
   (check-type funobj function)
@@ -490,4 +498,16 @@
 
 (defun fmakunbound (function-name)
   (setf (fdefinition function-name)
-    (load-global-constant unbound-function)))
+    (load-global-constant unbound-function))
+  function-name)
+
+(defun make-macro-function (expander name)
+  "From a regular function, such as a (lambda (form env) ...), make a bona fide macro-function."
+  (let ((macro-function (install-funobj-name name
+                                             (lambda (&edx edx &optional form env (first-extra nil extras-p) &rest more-extras)
+                                               (declare (ignore first-extra more-extras))
+                                               (verify-macroexpand-call edx name extras-p)
+                                               (funcall expander form env)))))
+    (setf (funobj-type macro-function)
+          #.(bt:enum-value 'movitz::movitz-funobj-type :macro-function))
+    macro-function))