From 8350d9d9165f1c70bfc2371ab939c217b496b2d3 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sat, 26 Jul 2003 19:21:24 +0000
Subject: [PATCH] 	* src/compiler/srctran.lisp (format): Don't define
 deftransforms 	for the same types but differing :policies because one
 overwrites 	the other.

---
 compiler/srctran.lisp | 39 ++++++++++++++++++++-------------------
 1 file changed, 20 insertions(+), 19 deletions(-)

diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index f2cbde4b7..8c8d8cdb2 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.123 2003/07/03 17:11:21 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.124 2003/07/26 19:21:24 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3375,31 +3375,32 @@
 		"Too many args (~d) to FORMAT, wants at most ~d"
 		nargs max-args)))))))
 
-(deftransform format ((dest control &rest args) (t simple-string &rest t) *
-		      :policy (> speed space))
-  (unless (constant-continuation-p control)
-    (give-up "Control string is not a constant."))
-  (let ((string (continuation-value control)))
-    (check-format-args string args)
-    (let ((arg-names (mapcar (lambda (x) (declare (ignore x)) (gensym)) args)))
-      `(lambda (dest control ,@arg-names)
-	 (declare (ignore control))
-	 (format dest (formatter ,string) ,@arg-names)))))
-
-(deftransform format ((dest control &rest args) (t simple-string &rest t) *
-		      :policy (<= speed space))
-  (when (constant-continuation-p control)
-    (check-format-args (continuation-value control) args))
-  (give-up))
-
 ;;;
+;;; Note that two DEFTRANSFORMs differing in their :POLICY only cannot
+;;; be defined; one replaces the other.
+;;;
+(deftransform format ((dest control &rest args) (t simple-string &rest t) *)
+  (cond ((policy nil (> speed space))
+	 (unless (constant-continuation-p control)
+	   (give-up "Control string is not a constant."))
+	 (let ((string (continuation-value control)))
+	   (check-format-args string args)
+	   (let ((arg-names (loop repeat (length args) collect (gensym))))
+	     `(lambda (dest control ,@arg-names)
+		(declare (ignore control))
+		(format dest (formatter ,string) ,@arg-names)))))
+	(t
+	 (when (constant-continuation-p control)
+	   (check-format-args (continuation-value control) args))
+	 (give-up))))
+
 (deftransform format ((stream control &rest args) (stream function &rest t) *
 		      :policy (> speed space))
   (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
     `(lambda (stream control ,@arg-names)
        (funcall control stream ,@arg-names)
        nil)))
-;;;
+
 (deftransform format ((tee control &rest args) ((member t) function &rest t) *
 		      :policy (> speed space))
   (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
-- 
GitLab