X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=a17d64049abe72bfd023cdaaf48be9eb7ca5ebed;hb=ad461399cb70f01e2f3871373b19b3716864533c;hp=af914ef24b12693cd747f0f45e77949d194034ba;hpb=d323b0249b9b1e4a91ddf8716ac9185cd268d973;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index af914ef..a17d640 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -1,6 +1,6 @@
 ;;;; This file contains macro-like source transformations which
 ;;;; convert uses of certain functions into the canonical form desired
-;;;; within the compiler. ### and other IR1 transforms and stuff.
+;;;; within the compiler. FIXME: and other IR1 transforms and stuff.
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -180,7 +180,8 @@
 (define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
 (define-source-transform logbitp (index integer)
   `(not (zerop (logand (ash 1 ,index) ,integer))))
-(define-source-transform byte (size position) `(cons ,size ,position))
+(define-source-transform byte (size position)
+  `(cons ,size ,position))
 (define-source-transform byte-size (spec) `(car ,spec))
 (define-source-transform byte-position (spec) `(cdr ,spec))
 (define-source-transform ldb-test (bytespec integer)
@@ -3082,21 +3083,28 @@
 (define-source-transform char-not-equal (&rest args)
   (multi-not-equal 'char-equal args))
 
+;;; FIXME: can go away once bug 194 is fixed and we can use (THE REAL X)
+;;; as God intended
+(defun error-not-a-real (x)
+  (error 'simple-type-error
+	 :datum x
+	 :expected-type 'real
+	 :format-control "not a REAL: ~S"
+	 :format-arguments (list x)))
+
 ;;; Expand MAX and MIN into the obvious comparisons.
-(define-source-transform max (arg &rest more-args)
-  (if (null more-args)
-      `(values ,arg)
-      (once-only ((arg1 arg)
-		  (arg2 `(max ,@more-args)))
-	`(if (> ,arg1 ,arg2)
-	     ,arg1 ,arg2))))
-(define-source-transform min (arg &rest more-args)
-  (if (null more-args)
-      `(values ,arg)
-      (once-only ((arg1 arg)
-		  (arg2 `(min ,@more-args)))
-	`(if (< ,arg1 ,arg2)
-	     ,arg1 ,arg2))))
+(define-source-transform max (arg0 &rest rest)
+  (once-only ((arg0 arg0))
+    (if (null rest)
+	`(values (the real ,arg0))
+	`(let ((maxrest (max ,@rest)))
+	  (if (> ,arg0 maxrest) ,arg0 maxrest)))))
+(define-source-transform min (arg0 &rest rest)
+  (once-only ((arg0 arg0))
+    (if (null rest)
+	`(values (the real ,arg0))
+	`(let ((minrest (min ,@rest)))
+	  (if (< ,arg0 minrest) ,arg0 minrest)))))
 
 ;;;; converting N-arg arithmetic functions
 ;;;;
@@ -3114,29 +3122,30 @@
 
 ;;; Do source transformations for transitive functions such as +.
 ;;; One-arg cases are replaced with the arg and zero arg cases with
-;;; the identity. If LEAF-FUN is true, then replace two-arg calls with
-;;; a call to that function.
-(defun source-transform-transitive (fun args identity &optional leaf-fun)
+;;; the identity.  ONE-ARG-RESULT-TYPE is, if non-NIL, the type to
+;;; ensure (with THE) that the argument in one-argument calls is.
+(defun source-transform-transitive (fun args identity
+				    &optional one-arg-result-type)
   (declare (symbol fun leaf-fun) (list args))
   (case (length args)
     (0 identity)
-    (1 `(values ,(first args)))
-    (2 (if leaf-fun
-	   `(,leaf-fun ,(first args) ,(second args))
-	   (values nil t)))
+    (1 (if one-arg-result-type
+	   `(values (the ,one-arg-result-type ,(first args)))
+	   `(values ,(first args))))
+    (2 (values nil t))
     (t
      (associate-args fun (first args) (rest args)))))
 
 (define-source-transform + (&rest args)
-  (source-transform-transitive '+ args 0))
+  (source-transform-transitive '+ args 0 'number))
 (define-source-transform * (&rest args)
-  (source-transform-transitive '* args 1))
+  (source-transform-transitive '* args 1 'number))
 (define-source-transform logior (&rest args)
-  (source-transform-transitive 'logior args 0))
+  (source-transform-transitive 'logior args 0 'integer))
 (define-source-transform logxor (&rest args)
-  (source-transform-transitive 'logxor args 0))
+  (source-transform-transitive 'logxor args 0 'integer))
 (define-source-transform logand (&rest args)
-  (source-transform-transitive 'logand args -1))
+  (source-transform-transitive 'logand args -1 'integer))
 
 (define-source-transform logeqv (&rest args)
   (if (evenp (length args))
@@ -3300,7 +3309,7 @@
               *universal-type*)))))
 
 (defoptimizer (array-element-type derive-type) ((array))
-  (let* ((array-type (continuation-type array)))
+  (let ((array-type (continuation-type array)))
     (labels ((consify (list)
               (if (endp list)
                   '(eql nil)