X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=cbc59cab489620feecc5e1f2bfa4b4e697558cf6;hb=1217810e750e3e6b04641309fb8475eb5963e35e;hp=71a2313179db5d7e1c44af25c471f347530d6355;hpb=5ef7f500a505f5711b1c76ff8c15f443d4815367;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 71a2313..cbc59ca 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)
@@ -2121,7 +2132,8 @@
       (values nil t t)))
 
 (defun logand-derive-type-aux (x y &optional same-leaf)
-  (declare (ignore same-leaf))
+  (when same-leaf
+    (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)
@@ -2153,7 +2165,8 @@
 		  (specifier-type 'integer)))))))
 
 (defun logior-derive-type-aux (x y &optional same-leaf)
-  (declare (ignore same-leaf))
+  (when same-leaf
+    (return-from logior-derive-type-aux x))
   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
       (cond
@@ -2192,7 +2205,8 @@
 		(specifier-type 'integer))))))))
 
 (defun logxor-derive-type-aux (x y &optional same-leaf)
-  (declare (ignore same-leaf))
+  (when same-leaf
+    (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
       (cond
@@ -2230,7 +2244,7 @@
 (defoptimizer (logeqv derive-type) ((x y))
   (two-arg-derive-type x y (lambda (x y same-leaf)
 			     (lognot-derive-type-aux 
-			      (logxor-derive-type-aux x y same-leaf))) 
+			      (logxor-derive-type-aux x y same-leaf)))
 		       #'logeqv))
 (defoptimizer (lognand derive-type) ((x y))
   (two-arg-derive-type x y (lambda (x y same-leaf)
@@ -2242,25 +2256,34 @@
 			     (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)
-			     (logand-derive-type-aux
-			      (lognot-derive-type-aux x) y nil))
+			     (if same-leaf
+				 (specifier-type '(eql 0))
+				 (logand-derive-type-aux
+				  (lognot-derive-type-aux x) y nil)))
 		       #'logandc1))
 (defoptimizer (logandc2 derive-type) ((x y))
   (two-arg-derive-type x y (lambda (x y same-leaf)
-			     (logand-derive-type-aux
-			      x (lognot-derive-type-aux y) nil))
+			     (if same-leaf
+				 (specifier-type '(eql 0))
+				 (logand-derive-type-aux
+				  x (lognot-derive-type-aux y) nil)))
 		       #'logandc2))
 (defoptimizer (logorc1 derive-type) ((x y))
   (two-arg-derive-type x y (lambda (x y same-leaf)
-			     (logior-derive-type-aux
-			      (lognot-derive-type-aux x) y nil))
+			     (if same-leaf
+				 (specifier-type '(eql -1))
+				 (logior-derive-type-aux
+				  (lognot-derive-type-aux x) y nil)))
 		       #'logorc1))
 (defoptimizer (logorc2 derive-type) ((x y))
   (two-arg-derive-type x y (lambda (x y same-leaf)
-			     (logior-derive-type-aux
-			      x (lognot-derive-type-aux y) nil))
+			     (if same-leaf
+				 (specifier-type '(eql -1))
+				 (logior-derive-type-aux
+				  x (lognot-derive-type-aux y) nil)))
 		       #'logorc2))
 
 ;;;; miscellaneous derive-type methods
@@ -3285,12 +3308,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
@@ -3307,18 +3324,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)
@@ -3391,18 +3405,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