X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=8f1739fda57044b0b739cfcc75e8346ca4dd7465;hb=28dcf682ef2a3c80b7bcdda00787dbb5e3893abe;hp=83fcba21a6c77d2dbf6013f2eab8aaeeb3fa34fe;hpb=15e14ef1ccd3ab6f4711632435a40493dc4cdd9d;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 83fcba2..8f1739f 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -65,10 +65,14 @@
 (defun source-transform-cxr (form)
   (if (/= (length form) 2)
       (values nil t)
-      (let ((name (symbol-name (car form))))
-	(do ((i (- (length name) 2) (1- i))
+      (let* ((name (car form))
+	     (string (symbol-name
+		      (etypecase name
+			(symbol name)
+			(leaf (leaf-source-name name))))))
+	(do ((i (- (length string) 2) (1- i))
 	     (res (cadr form)
-		  `(,(ecase (char name i)
+		  `(,(ecase (char string i)
 		       (#\A 'car)
 		       (#\D 'cdr))
 		    ,res)))
@@ -1616,6 +1620,13 @@
 		       #'%unary-truncate-derive-type-aux
 		       #'%unary-truncate))
 
+(defoptimizer (%unary-ftruncate derive-type) ((number))
+  (let ((divisor (specifier-type '(integer 1 1))))
+    (one-arg-derive-type number
+                         #'(lambda (n)
+                             (ftruncate-derive-type-quot-aux n divisor nil))
+                         #'%unary-ftruncate)))
+
 ;;; Define optimizers for FLOOR and CEILING.
 (macrolet
     ((def (name q-name r-name)
@@ -2125,14 +2136,18 @@
     (return-from logand-derive-type-aux x))
   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
     (declare (ignore x-pos))
-    (multiple-value-bind (y-len y-pos y-neg) (integer-type-length  y)
+    (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
       (declare (ignore y-pos))
       (if (not x-neg)
 	  ;; X must be positive.
 	  (if (not y-neg)
 	      ;; They must both be positive.
-	      (cond ((or (null x-len) (null y-len))
+	      (cond ((and (null x-len) (null y-len))
 		     (specifier-type 'unsigned-byte))
+		    ((null x-len)
+		     (specifier-type `(unsigned-byte* ,y-len)))
+		    ((null y-len)
+		     (specifier-type `(unsigned-byte* ,x-len)))
 		    (t
 		     (specifier-type `(unsigned-byte* ,(min x-len y-len)))))
 	      ;; X is positive, but Y might be negative.
@@ -2207,7 +2222,7 @@
 					      (max x-len y-len)
 					      '*))))
        ((or (and (not x-pos) (not y-neg))
-	    (and (not y-neg) (not y-pos)))
+	    (and (not y-pos) (not x-neg)))
 	;; Either X is negative and Y is positive or vice-versa. The
 	;; result will be negative.
 	(specifier-type `(integer ,(if (and x-len y-len)
@@ -2229,7 +2244,6 @@
   (deffrob logior)
   (deffrob logxor))
 
-;;; FIXME: could actually do stuff with SAME-LEAF
 (defoptimizer (logeqv derive-type) ((x y))
   (two-arg-derive-type x y (lambda (x y same-leaf)
 			     (lognot-derive-type-aux 
@@ -2245,7 +2259,6 @@
 			     (lognot-derive-type-aux
 			      (logior-derive-type-aux x y same-leaf)))
 		       #'lognor))
-;;; FIXME: use SAME-LEAF instead of ignoring it.
 (defoptimizer (logandc1 derive-type) ((x y))
   (two-arg-derive-type x y (lambda (x y same-leaf)
 			     (if same-leaf
@@ -2654,7 +2667,7 @@
   (let* ((y (lvar-value y))
 	 (y-abs (abs y))
 	 (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (if (minusp y)
 	`(- (ash x ,len))
@@ -2669,7 +2682,7 @@
 	 (let* ((y (lvar-value y))
 		(y-abs (abs y))
 		(len (1- (integer-length y-abs))))
-	   (unless (= y-abs (ash 1 len))
+	   (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
 	     (give-up-ir1-transform))
 	   (let ((shift (- len))
 		 (mask (1- y-abs))
@@ -2695,7 +2708,7 @@
   (let* ((y (lvar-value y))
 	 (y-abs (abs y))
 	 (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (let ((mask (1- y-abs)))
       (if (minusp y)
@@ -2710,7 +2723,7 @@
   (let* ((y (lvar-value y))
 	 (y-abs (abs y))
 	 (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (let* ((shift (- len))
 	   (mask (1- y-abs)))
@@ -2732,7 +2745,7 @@
   (let* ((y (lvar-value y))
 	 (y-abs (abs y))
 	 (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len))
+    (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
       (give-up-ir1-transform))
     (let ((mask (1- y-abs)))
       `(if (minusp x)
@@ -3297,12 +3310,6 @@
 
 ;;; for compile-time argument count checking.
 ;;;
-;;; FIXME I: this is currently called from DEFTRANSFORMs, the vast
-;;; majority of which are not going to transform the code, but instead
-;;; are going to GIVE-UP-IR1-TRANSFORM unconditionally.  It would be
-;;; nice to make this explicit, maybe by implementing a new
-;;; "optimizer" (say, DEFOPTIMIZER CONSISTENCY-CHECK).
-;;;
 ;;; FIXME II: In some cases, type information could be correlated; for
 ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
 ;;; of a corresponding argument is known and does not intersect the
@@ -3319,18 +3326,15 @@
       (let ((nargs (length args)))
 	(cond
 	  ((< nargs min)
-	   (compiler-warn "Too few arguments (~D) to ~S ~S: ~
-                           requires at least ~D."
-			  nargs fun string min))
+	   (warn 'format-too-few-args-warning
+		 :format-control
+		 "Too few arguments (~D) to ~S ~S: requires at least ~D."
+		 :format-arguments (list nargs fun string min)))
 	  ((> nargs max)
-	   (;; to get warned about probably bogus code at
-	    ;; cross-compile time.
-	    #+sb-xc-host compiler-warn
-	    ;; ANSI saith that too many arguments doesn't cause a
-	    ;; run-time error.
-	    #-sb-xc-host compiler-style-warn
-	    "Too many arguments (~D) to ~S ~S: uses at most ~D."
-	    nargs fun string max)))))))
+	   (warn 'format-too-many-args-warning
+		 :format-control
+		 "Too many arguments (~D) to ~S ~S: uses at most ~D."
+		 :format-arguments (list nargs fun string max))))))))
 
 (defoptimizer (format optimizer) ((dest control &rest args))
   (when (constant-lvar-p control)
@@ -3403,18 +3407,19 @@
 		(let ((nargs (length args)))
 		  (cond
 		    ((< nargs (min min1 min2))
-		     (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~
-                                     requires at least ~D."
-				    nargs 'cerror y x (min min1 min2)))
+		     (warn 'format-too-few-args-warning
+			   :format-control
+			   "Too few arguments (~D) to ~S ~S ~S: ~
+                            requires at least ~D."
+			   :format-arguments
+			   (list nargs 'cerror y x (min min1 min2))))
 		    ((> nargs (max max1 max2))
-		     (;; to get warned about probably bogus code at
-		      ;; cross-compile time.
-		      #+sb-xc-host compiler-warn
-		      ;; ANSI saith that too many arguments doesn't cause a
-		      ;; run-time error.
-		      #-sb-xc-host compiler-style-warn
-		      "Too many arguments (~D) to ~S ~S ~S: uses at most ~D."
-		      nargs 'cerror y x (max max1 max2)))))))))))))
+		     (warn 'format-too-many-args-warning
+			   :format-control
+			   "Too many arguments (~D) to ~S ~S ~S: ~
+                            uses at most ~D."
+			   :format-arguments
+			   (list nargs 'cerror y x (max max1 max2))))))))))))))
 
 (defoptimizer (coerce derive-type) ((value type))
   (cond