[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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)