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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index f48639c..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.
@@ -40,7 +40,7 @@
 ;;; lambda with the appropriate fixed number of args. If the
 ;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
 ;;; MV optimization figure things out.
-(deftransform complement ((fun) * * :node node :when :both)
+(deftransform complement ((fun) * * :node node)
   "open code"
   (multiple-value-bind (min max)
       (fun-type-nargs (continuation-type fun))
@@ -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)
@@ -2492,7 +2493,7 @@
 		 "place constant arg last"))
 
 ;;; Handle the case of a constant BOOLE-CODE.
-(deftransform boole ((op x y) * * :when :both)
+(deftransform boole ((op x y) * *)
   "convert to inline logical operations"
   (unless (constant-continuation-p op)
     (give-up-ir1-transform "BOOLE code is not a constant."))
@@ -2521,7 +2522,7 @@
 ;;;; converting special case multiply/divide to shifts
 
 ;;; If arg is a constant power of two, turn * into a shift.
-(deftransform * ((x y) (integer integer) * :when :both)
+(deftransform * ((x y) (integer integer) *)
   "convert x*2^k to shift"
   (unless (constant-continuation-p y)
     (give-up-ir1-transform))
@@ -2608,7 +2609,7 @@
     (frob y t)))
 
 ;;; Do the same for MOD.
-(deftransform mod ((x y) (integer integer) * :when :both)
+(deftransform mod ((x y) (integer integer) *)
   "convert remainder mod 2^k to LOGAND"
   (unless (constant-continuation-p y)
     (give-up-ir1-transform))
@@ -2645,7 +2646,7 @@
 		   (logand x ,mask))))))
 
 ;;; And the same for REM.
-(deftransform rem ((x y) (integer integer) * :when :both)
+(deftransform rem ((x y) (integer integer) *)
   "convert remainder mod 2^k to LOGAND"
   (unless (constant-continuation-p y)
     (give-up-ir1-transform))
@@ -2664,8 +2665,7 @@
 ;;; Flush calls to various arith functions that convert to the
 ;;; identity function or a constant.
 (macrolet ((def (name identity result)
-             `(deftransform ,name ((x y) (* (constant-arg (member ,identity)))
-                                    * :when :both)
+             `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *)
                 "fold identity operations"
                 ',result)))
   (def ash 0 x)
@@ -2678,12 +2678,10 @@
 
 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
 ;;; (* 0 -4.0) is -0.0.
-(deftransform - ((x y) ((constant-arg (member 0)) rational) *
-		 :when :both)
+(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
   "convert (- 0 x) to negate"
   '(%negate y))
-(deftransform * ((x y) (rational (constant-arg (member 0))) *
-		 :when :both)
+(deftransform * ((x y) (rational (constant-arg (member 0))) *)
   "convert (* x 0) to 0"
   0)
 
@@ -2725,7 +2723,7 @@
 ;;;
 ;;; If y is not constant, not zerop, or is contagious, or a positive
 ;;; float +0.0 then give up.
-(deftransform + ((x y) (t (constant-arg t)) * :when :both)
+(deftransform + ((x y) (t (constant-arg t)) *)
   "fold zero arg"
   (let ((val (continuation-value y)))
     (unless (and (zerop val)
@@ -2738,7 +2736,7 @@
 ;;;
 ;;; If y is not constant, not zerop, or is contagious, or a negative
 ;;; float -0.0 then give up.
-(deftransform - ((x y) (t (constant-arg t)) * :when :both)
+(deftransform - ((x y) (t (constant-arg t)) *)
   "fold zero arg"
   (let ((val (continuation-value y)))
     (unless (and (zerop val)
@@ -2749,8 +2747,7 @@
 
 ;;; Fold (OP x +/-1)
 (macrolet ((def (name result minus-result)
-             `(deftransform ,name ((x y) (t (constant-arg real))
-                                    * :when :both)
+             `(deftransform ,name ((x y) (t (constant-arg real)) *)
                 "fold identity operations"
                 (let ((val (continuation-value y)))
                   (unless (and (= (abs val) 1)
@@ -2787,7 +2784,7 @@
 ;;; doing them?  -- WHN 19990917
 (macrolet ((def (name)
              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
-                                   * :when :both)
+                                   *)
                 "fold zero arg"
                 0)))
   (def ash)
@@ -2795,7 +2792,7 @@
 
 (macrolet ((def (name)
              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
-                                   * :when :both)
+                                   *)
                 "fold zero arg"
                 '(values 0 0))))
   (def truncate)
@@ -2849,8 +2846,7 @@
 ;;; if there is no intersection between the types of the arguments,
 ;;; then the result is definitely false.
 (deftransform simple-equality-transform ((x y) * *
-					 :defun-only t
-					 :when :both)
+					 :defun-only t)
   (cond ((same-leaf-ref-p x y)
 	 t)
 	((not (types-equal-or-intersect (continuation-type x)
@@ -2878,7 +2874,7 @@
 ;;;    these interesting cases.
 ;;; -- If Y is a fixnum, then we quietly pass because the back end can
 ;;;    handle that case, otherwise give an efficiency note.
-(deftransform eql ((x y) * * :when :both)
+(deftransform eql ((x y) * *)
   "convert to simpler equality predicate"
   (let ((x-type (continuation-type x))
 	(y-type (continuation-type y))
@@ -2904,7 +2900,7 @@
 
 ;;; Convert to EQL if both args are rational and complexp is specified
 ;;; and the same for both.
-(deftransform = ((x y) * * :when :both)
+(deftransform = ((x y) * *)
   "open code"
   (let ((x-type (continuation-type x))
 	(y-type (continuation-type y)))
@@ -2982,18 +2978,18 @@
 	      (t
 	       (give-up-ir1-transform))))))
 
-(deftransform < ((x y) (integer integer) * :when :both)
+(deftransform < ((x y) (integer integer) *)
   (ir1-transform-< x y x y '>))
 
-(deftransform > ((x y) (integer integer) * :when :both)
+(deftransform > ((x y) (integer integer) *)
   (ir1-transform-< y x x y '<))
 
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform < ((x y) (float float) * :when :both)
+(deftransform < ((x y) (float float) *)
   (ir1-transform-< x y x y '>))
 
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform > ((x y) (float float) * :when :both)
+(deftransform > ((x y) (float float) *)
   (ir1-transform-< y x x y '<))
 
 ;;;; converting N-arg comparisons
@@ -3087,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
 ;;;;
@@ -3119,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))
@@ -3305,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)