X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=9855e467c0ebce74c94ce10176f9badd2c4fb48e;hb=5edd74f6911093805a009a152b32216b3dba59f7;hp=e7bae1b0e108f078fb6c91291aa7f95a135c606c;hpb=4ad052044a22f502d9dc6faf6dfe01f3bab84262;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index e7bae1b..9855e46 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -630,7 +630,7 @@
 	      :low (bound-mul (interval-low x) (interval-low y))
 	      :high (bound-mul (interval-high x) (interval-high y))))
 	    (t
-	     (error "internal error in INTERVAL-MUL"))))))
+	     (bug "excluded case in INTERVAL-MUL"))))))
 
 ;;; Divide two intervals.
 (defun interval-div (top bot)
@@ -680,7 +680,7 @@
 	      :low (bound-div (interval-low top) (interval-high bot) t)
 	      :high (bound-div (interval-high top) (interval-low bot) nil)))
 	    (t
-	     (error "internal error in INTERVAL-DIV"))))))
+	     (bug "excluded case in INTERVAL-DIV"))))))
 
 ;;; Apply the function F to the interval X. If X = [a, b], then the
 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
@@ -1647,7 +1647,7 @@
 
 ;;; Define optimizers for FLOOR and CEILING.
 (macrolet
-    ((frob-opt (name q-name r-name)
+    ((def (name q-name r-name)
        (let ((q-aux (symbolicate q-name "-AUX"))
 	     (r-aux (symbolicate r-name "-AUX")))
 	 `(progn
@@ -1711,54 +1711,52 @@
 		 (when (and quot rem)
 		   (make-values-type :required (list quot rem))))))))))
 
-  ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
-  (frob-opt floor floor-quotient-bound floor-rem-bound)
-  (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
+  (def floor floor-quotient-bound floor-rem-bound)
+  (def ceiling ceiling-quotient-bound ceiling-rem-bound))
 
 ;;; Define optimizers for FFLOOR and FCEILING
-(macrolet
-    ((frob-opt (name q-name r-name)
-       (let ((q-aux (symbolicate "F" q-name "-AUX"))
-	     (r-aux (symbolicate r-name "-AUX")))
-	 `(progn
-	   ;; Compute type of quotient (first) result.
-	   (defun ,q-aux (number-type divisor-type)
-	     (let* ((number-interval
-		     (numeric-type->interval number-type))
-		    (divisor-interval
-		     (numeric-type->interval divisor-type))
-		    (quot (,q-name (interval-div number-interval
-						 divisor-interval)))
-		    (res-type (numeric-contagion number-type divisor-type)))
-	       (make-numeric-type
-		:class (numeric-type-class res-type)
-		:format (numeric-type-format res-type)
-		:low  (interval-low quot)
-		:high (interval-high quot))))
-
-	   (defoptimizer (,name derive-type) ((number divisor))
-	     (flet ((derive-q (n d same-arg)
-		      (declare (ignore same-arg))
-		      (if (and (numeric-type-real-p n)
-			       (numeric-type-real-p d))
-			  (,q-aux n d)
-			  *empty-type*))
-		    (derive-r (n d same-arg)
-		      (declare (ignore same-arg))
-		      (if (and (numeric-type-real-p n)
-			       (numeric-type-real-p d))
-			  (,r-aux n d)
-			  *empty-type*)))
-	       (let ((quot (two-arg-derive-type
-			    number divisor #'derive-q #',name))
-		     (rem (two-arg-derive-type
-			   number divisor #'derive-r #'mod)))
-		 (when (and quot rem)
-		   (make-values-type :required (list quot rem))))))))))
-
-  ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
-  (frob-opt ffloor floor-quotient-bound floor-rem-bound)
-  (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
+(macrolet ((def (name q-name r-name)
+	     (let ((q-aux (symbolicate "F" q-name "-AUX"))
+		   (r-aux (symbolicate r-name "-AUX")))
+	       `(progn
+		  ;; Compute type of quotient (first) result.
+		  (defun ,q-aux (number-type divisor-type)
+		    (let* ((number-interval
+			    (numeric-type->interval number-type))
+			   (divisor-interval
+			    (numeric-type->interval divisor-type))
+			   (quot (,q-name (interval-div number-interval
+							divisor-interval)))
+			   (res-type (numeric-contagion number-type
+							divisor-type)))
+		      (make-numeric-type
+		       :class (numeric-type-class res-type)
+		       :format (numeric-type-format res-type)
+		       :low  (interval-low quot)
+		       :high (interval-high quot))))
+
+		  (defoptimizer (,name derive-type) ((number divisor))
+		    (flet ((derive-q (n d same-arg)
+			     (declare (ignore same-arg))
+			     (if (and (numeric-type-real-p n)
+				      (numeric-type-real-p d))
+				 (,q-aux n d)
+				 *empty-type*))
+			   (derive-r (n d same-arg)
+			     (declare (ignore same-arg))
+			     (if (and (numeric-type-real-p n)
+				      (numeric-type-real-p d))
+				 (,r-aux n d)
+				 *empty-type*)))
+		      (let ((quot (two-arg-derive-type
+				   number divisor #'derive-q #',name))
+			    (rem (two-arg-derive-type
+				  number divisor #'derive-r #'mod)))
+			(when (and quot rem)
+			  (make-values-type :required (list quot rem))))))))))
+
+  (def ffloor floor-quotient-bound floor-rem-bound)
+  (def fceiling ceiling-quotient-bound ceiling-rem-bound))
 
 ;;; functions to compute the bounds on the quotient and remainder for
 ;;; the FLOOR function
@@ -2298,8 +2296,8 @@
 
 (defoptimizer (values derive-type) ((&rest values))
   (values-specifier-type
-   `(values ,@(mapcar #'(lambda (x)
-			  (type-specifier (continuation-type x)))
+   `(values ,@(mapcar (lambda (x)
+			(type-specifier (continuation-type x)))
 		      values))))
 
 ;;;; byte operations
@@ -2665,26 +2663,26 @@
 
 ;;; Flush calls to various arith functions that convert to the
 ;;; identity function or a constant.
-(macrolet ((def-frob (name identity result)
-             `(deftransform ,name ((x y) (* (constant-argument (member ,identity)))
+(macrolet ((def (name identity result)
+             `(deftransform ,name ((x y) (* (constant-arg (member ,identity)))
                                     * :when :both)
                 "fold identity operations"
                 ',result)))
-  (def-frob ash 0 x)
-  (def-frob logand -1 x)
-  (def-frob logand 0 0)
-  (def-frob logior 0 x)
-  (def-frob logior -1 -1)
-  (def-frob logxor -1 (lognot x))
-  (def-frob logxor 0 x))
+  (def ash 0 x)
+  (def logand -1 x)
+  (def logand 0 0)
+  (def logior 0 x)
+  (def logior -1 -1)
+  (def logxor -1 (lognot x))
+  (def logxor 0 x))
 
 ;;; 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-argument (member 0)) rational) *
+(deftransform - ((x y) ((constant-arg (member 0)) rational) *
 		 :when :both)
   "convert (- 0 x) to negate"
   '(%negate y))
-(deftransform * ((x y) (rational (constant-argument (member 0))) *
+(deftransform * ((x y) (rational (constant-arg (member 0))) *
 		 :when :both)
   "convert (* x 0) to 0"
   0)
@@ -2727,7 +2725,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-argument t)) * :when :both)
+(deftransform + ((x y) (t (constant-arg t)) * :when :both)
   "fold zero arg"
   (let ((val (continuation-value y)))
     (unless (and (zerop val)
@@ -2740,7 +2738,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-argument t)) * :when :both)
+(deftransform - ((x y) (t (constant-arg t)) * :when :both)
   "fold zero arg"
   (let ((val (continuation-value y)))
     (unless (and (zerop val)
@@ -2750,8 +2748,8 @@
   'x)
 
 ;;; Fold (OP x +/-1)
-(macrolet ((def-frob (name result minus-result)
-             `(deftransform ,name ((x y) (t (constant-argument real))
+(macrolet ((def (name result minus-result)
+             `(deftransform ,name ((x y) (t (constant-arg real))
                                     * :when :both)
                 "fold identity operations"
                 (let ((val (continuation-value y)))
@@ -2759,13 +2757,13 @@
                                (not-more-contagious y x))
                     (give-up-ir1-transform))
                   (if (minusp val) ',minus-result ',result)))))
-  (def-frob * x (%negate x))
-  (def-frob / x (%negate x))
-  (def-frob expt x (/ 1 x)))
+  (def * x (%negate x))
+  (def / x (%negate x))
+  (def expt x (/ 1 x)))
 
 ;;; Fold (expt x n) into multiplications for small integral values of
 ;;; N; convert (expt x 1/2) to sqrt.
-(deftransform expt ((x y) (t (constant-argument real)) *)
+(deftransform expt ((x y) (t (constant-arg real)) *)
   "recode as multiplication or sqrt"
   (let ((val (continuation-value y)))
     ;; If Y would cause the result to be promoted to the same type as
@@ -2787,24 +2785,23 @@
 ;;; transformations?
 ;;; Perhaps we should have to prove that the denominator is nonzero before
 ;;; doing them?  -- WHN 19990917
-(macrolet ((def-frob (name)
-             `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+(macrolet ((def (name)
+             `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
                                    * :when :both)
                 "fold zero arg"
                 0)))
-  (def-frob ash)
-  (def-frob /))
+  (def ash)
+  (def /))
 
-(macrolet ((def-frob (name)
-             `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+(macrolet ((def (name)
+             `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
                                    * :when :both)
                 "fold zero arg"
                 '(values 0 0))))
-  (def-frob truncate)
-  (def-frob round)
-  (def-frob floor)
-  (def-frob ceiling))
-
+  (def truncate)
+  (def round)
+  (def floor)
+  (def ceiling))
 
 ;;;; character operations
 
@@ -2862,11 +2859,11 @@
 	(t
 	 (give-up-ir1-transform))))
 
-(macrolet ((def-frob (x)
+(macrolet ((def (x)
              `(%deftransform ',x '(function * *) #'simple-equality-transform)))
-  (def-frob eq)
-  (def-frob char=)
-  (def-frob equal))
+  (def eq)
+  (def char=)
+  (def equal))
 
 ;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
 ;;; try to convert to a type-specific predicate or EQ:
@@ -3112,13 +3109,13 @@
 ;;;; versions, and degenerate cases are flushed.
 
 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
-(declaim (ftype (function (symbol t list) list) associate-arguments))
-(defun associate-arguments (function first-arg more-args)
+(declaim (ftype (function (symbol t list) list) associate-args))
+(defun associate-args (function first-arg more-args)
   (let ((next (rest more-args))
 	(arg (first more-args)))
     (if (null next)
 	`(,function ,first-arg ,arg)
-	(associate-arguments function `(,function ,first-arg ,arg) next))))
+	(associate-args function `(,function ,first-arg ,arg) next))))
 
 ;;; Do source transformations for transitive functions such as +.
 ;;; One-arg cases are replaced with the arg and zero arg cases with
@@ -3133,7 +3130,7 @@
 	   `(,leaf-fun ,(first args) ,(second args))
 	   (values nil t)))
     (t
-     (associate-arguments fun (first args) (rest args)))))
+     (associate-args fun (first args) (rest args)))))
 
 (define-source-transform + (&rest args)
   (source-transform-transitive '+ args 0))
@@ -3160,14 +3157,14 @@
     (0 0)
     (1 `(abs (the integer ,(first args))))
     (2 (values nil t))
-    (t (associate-arguments 'gcd (first args) (rest args)))))
+    (t (associate-args 'gcd (first args) (rest args)))))
 
 (define-source-transform lcm (&rest args)
   (case (length args)
     (0 1)
     (1 `(abs (the integer ,(first args))))
     (2 (values nil t))
-    (t (associate-arguments 'lcm (first args) (rest args)))))
+    (t (associate-args 'lcm (first args) (rest args)))))
 
 ;;; Do source transformations for intransitive n-arg functions such as
 ;;; /. With one arg, we form the inverse. With two args we pass.
@@ -3177,7 +3174,7 @@
   (case (length args)
     ((0 2) (values nil t))
     (1 `(,@inverse ,(first args)))
-    (t (associate-arguments function (first args) (rest args)))))
+    (t (associate-args function (first args) (rest args)))))
 
 (define-source-transform - (&rest args)
   (source-transform-intransitive '- args '(%negate)))
@@ -3192,8 +3189,8 @@
 (define-source-transform apply (fun arg &rest more-args)
   (let ((args (cons arg more-args)))
     `(multiple-value-call ,fun
-       ,@(mapcar #'(lambda (x)
-		     `(values ,x))
+       ,@(mapcar (lambda (x)
+		   `(values ,x))
 		 (butlast args))
        (values-list ,(car (last args))))))