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@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)