[movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	functions.lisp 
Log Message:
Added special-cased compilation of (constantly t) and (constantly nil).

Date: Fri Apr 23 11:05:35 2004
Author: ffjeld

Index: movitz/losp/muerte/functions.lisp
diff -u movitz/losp/muerte/functions.lisp:1.10 movitz/losp/muerte/functions.lisp:1.11
--- movitz/losp/muerte/functions.lisp:1.10	Sun Apr 18 19:18:31 2004
+++ movitz/losp/muerte/functions.lisp	Fri Apr 23 11:05:35 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Mar 12 22:58:54 2002
 ;;;;                
-;;;; $Id: functions.lisp,v 1.10 2004/04/18 23:18:31 ffjeld Exp $
+;;;; $Id: functions.lisp,v 1.11 2004/04/23 15:05:35 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -26,13 +26,24 @@
   (declare (ignore ignore))
   'value)
 
-(define-compiler-macro constantly (&whole form value-form)
+(defun constantly-true (&rest ignore) 
+  (declare (ignore ignore))
+  t)
+
+(defun constantly-false (&rest ignore) 
+  (declare (ignore ignore))
+  nil)
+
+(define-compiler-macro constantly (&whole form value-form &environment env)
   (cond
-   ((movitz:movitz-constantp value-form)
-    (let ((value (movitz:movitz-eval value-form)))
-      `(make-prototyped-function (constantly ,value)
-				 constantly-prototype
-				 (value ,value))))
+   ((movitz:movitz-constantp value-form env)
+    (let ((value (movitz:movitz-eval value-form env)))
+      (case (translate-program value :muerte.cl :cl)
+	((t) `(function constantly-true))
+	((nil) `(function constantly-false))
+	(t `(make-prototyped-function (constantly ,value)
+				      constantly-prototype
+				      (value ,value))))))
    (t (error "Non-constant constantly forms not yet supported: ~S" form)
       form)))
 
@@ -64,7 +75,7 @@
     (not (apply function args))))
 
 (defun unbound-function (&edx edx &rest args)
-  (declare (dynamic-extent args) (ignore args))
+  (declare (ignore args))
   (let ((function-name (typecase edx
 			 (symbol
 			  edx)