(def-source-transform not (x) `(if ,x nil t))
(def-source-transform null (x) `(if ,x nil t))
-;;; ENDP is just NULL with a LIST assertion.
+;;; ENDP is just NULL with a LIST assertion. The assertion will be
+;;; optimized away when SAFETY optimization is low; hopefully that
+;;; is consistent with ANSI's "should return an error".
(def-source-transform endp (x) `(null (the list ,x)))
-;;; FIXME: Is THE LIST a strong enough assertion for ANSI's "should
-;;; return an error"? (THE LIST is optimized away when safety is low;
-;;; does that satisfy the spec?)
;;; We turn IDENTITY into PROG1 so that it is obvious that it just
;;; returns the first value of its argument. Ditto for VALUES with one
(def-source-transform values (x) `(prog1 ,x))
;;; Bind the values and make a closure that returns them.
-(def-source-transform constantly (value &rest values)
- (let ((temps (make-gensym-list (1+ (length values))))
- (dum (gensym)))
- `(let ,(loop for temp in temps and
- value in (list* value values)
- collect `(,temp ,value))
- #'(lambda (&rest ,dum)
- (declare (ignore ,dum))
- (values ,@temps)))))
+(def-source-transform constantly (value)
+ (let ((rest (gensym "CONSTANTLY-REST-")))
+ `(lambda (&rest ,rest)
+ (declare (ignore ,rest))
+ ,value)))
;;; If the function has a known number of arguments, then return a
;;; lambda with the appropriate fixed number of args. If the
;;; The basic interval type. It can handle open and closed intervals.
;;; A bound is open if it is a list containing a number, just like
;;; Lisp says. NIL means unbounded.
-(defstruct (interval
- (:constructor %make-interval))
+(defstruct (interval (:constructor %make-interval)
+ (:copier nil))
low high)
(defun make-interval (&key low high)
(bound-value ,y))
(or (consp ,x) (consp ,y))))))
-;;; NUMERIC-TYPE->INTERVAL
-;;;
;;; Convert a numeric-type object to an interval object.
-
(defun numeric-type->interval (x)
(declare (type numeric-type x))
(make-interval :low (numeric-type-low x)
(make-interval :low (copy-interval-limit (interval-low x))
:high (copy-interval-limit (interval-high x))))
-;;; INTERVAL-SPLIT
-;;;
;;; Given a point P contained in the interval X, split X into two
;;; interval at the point P. If CLOSE-LOWER is T, then the left
;;; interval contains P. If CLOSE-UPPER is T, the right interval
(make-interval :low (if close-upper (list p) p)
:high (copy-interval-limit (interval-high x)))))
-;;; INTERVAL-CLOSURE
-;;;
;;; Return the closure of the interval. That is, convert open bounds
;;; to closed bounds.
(defun interval-closure (x)
(>= (float-sign (float x))
(float-sign (float y))))))
-;;; INTERVAL-RANGE-INFO
-;;;
;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
;;; '-. Otherwise return NIL.
#+nil
(t
nil)))))
-;;; INTERVAL-BOUNDED-P
-;;;
;;; Test to see whether the interval X is bounded. HOW determines the
;;; test, and should be either ABOVE, BELOW, or BOTH.
(defun interval-bounded-p (x how)
('both
(and (interval-low x) (interval-high x)))))
-;;; Signed zero comparison functions. Use these functions if we need
+;;; signed zero comparison functions. Use these functions if we need
;;; to distinguish between signed zeroes.
-
(defun signed-zero-< (x y)
(declare (real x y))
(or (< x y)
(and (= x y)
(> (float-sign (float x))
(float-sign (float y))))))
-
(defun signed-zero-= (x y)
(declare (real x y))
(and (= x y)
(= (float-sign (float x))
(float-sign (float y)))))
-
(defun signed-zero-<= (x y)
(declare (real x y))
(or (< x y)
(<= (float-sign (float x))
(float-sign (float y))))))
-;;; INTERVAL-CONTAINS-P
-;;;
-;;; See whether the interval X contains the number P, taking into account
-;;; that the interval might not be closed.
+;;; See whether the interval X contains the number P, taking into
+;;; account that the interval might not be closed.
(defun interval-contains-p (p x)
(declare (type number p)
(type interval x))
;; Interval with no bounds
t))))
-;;; INTERVAL-INTERSECT-P
-;;;
;;; Determine if two intervals X and Y intersect. Return T if so. If
;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were
;;; closed. Otherwise the intervals are treated as they are.
(or (adjacent (interval-low y) (interval-high x))
(adjacent (interval-low x) (interval-high y)))))
-;;; INTERVAL-INTERSECTION/DIFFERENCE
-;;;
;;; Compute the intersection and difference between two intervals.
;;; Two values are returned: the intersection and the difference.
;;;
(y-hi-in-x
(values y-hi (opposite-bound y-hi) x-hi)))
(values (make-interval :low lo :high hi)
- (list (make-interval :low left-lo :high left-hi)
- (make-interval :low right-lo :high right-hi))))))
+ (list (make-interval :low left-lo
+ :high left-hi)
+ (make-interval :low right-lo
+ :high right-hi))))))
(t
(values nil (list x y))))))))
-;;; INTERVAL-MERGE-PAIR
-;;;
;;; If intervals X and Y intersect, return a new interval that is the
;;; union of the two. If they do not intersect, return NIL.
(defun interval-merge-pair (x y)
(make-interval :low (select-bound x-lo y-lo #'< #'>)
:high (select-bound x-hi y-hi #'> #'<))))))
-;;; Basic arithmetic operations on intervals. We probably should do
+;;; basic arithmetic operations on intervals. We probably should do
;;; true interval arithmetic here, but it's complicated because we
;;; have float and integer types and bounds can be open or closed.
-;;; INTERVAL-NEG
-;;;
;;; The negative of an interval
(defun interval-neg (x)
(declare (type interval x))
(make-interval :low (bound-func #'- (interval-high x))
:high (bound-func #'- (interval-low x))))
-;;; INTERVAL-ADD
-;;;
;;; Add two intervals
(defun interval-add (x y)
(declare (type interval x y))
(make-interval :low (bound-binop + (interval-low x) (interval-low y))
:high (bound-binop + (interval-high x) (interval-high y))))
-;;; INTERVAL-SUB
-;;;
;;; Subtract two intervals
(defun interval-sub (x y)
(declare (type interval x y))
(make-interval :low (bound-binop - (interval-low x) (interval-high y))
:high (bound-binop - (interval-high x) (interval-low y))))
-;;; INTERVAL-MUL
-;;;
;;; Multiply two intervals
(defun interval-mul (x y)
(declare (type interval x y))
(t
(error "This shouldn't happen!"))))))
-;;; INTERVAL-DIV
-;;;
;;; Divide two intervals.
(defun interval-div (top bot)
(declare (type interval top bot))
(t
(error "This shouldn't happen!"))))))
-;;; INTERVAL-FUNC
-;;;
;;; 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
;;; result makes sense. It will if F is monotonic increasing (or
(hi (bound-func f (interval-high x))))
(make-interval :low lo :high hi)))
-;;; INTERVAL-<
-;;;
;;; Return T if X < Y. That is every number in the interval X is
;;; always less than any number in the interval Y.
(defun interval-< (x y)
;; Don't overlap if one or the other are open.
(or (consp left) (consp right)))))))
-;;; INVTERVAL->=
-;;;
;;; Return T if X >= Y. That is, every number in the interval X is
;;; always greater than any number in the interval Y.
(defun interval->= (x y)
(interval-bounded-p y 'above))
(>= (bound-value (interval-low x)) (bound-value (interval-high y)))))
-;;; INTERVAL-ABS
-;;;
-;;; Return an interval that is the absolute value of X. Thus, if X =
-;;; [-1 10], the result is [0, 10].
+;;; Return an interval that is the absolute value of X. Thus, if
+;;; X = [-1 10], the result is [0, 10].
(defun interval-abs (x)
(declare (type interval x))
(case (interval-range-info x)
(destructuring-bind (x- x+) (interval-split 0 x t t)
(interval-merge-pair (interval-neg x-) x+)))))
-;;; INTERVAL-SQR
-;;;
;;; Compute the square of an interval.
(defun interval-sqr (x)
(declare (type interval x))
\f
;;;; numeric derive-type methods
-;;; Utility for defining derive-type methods of integer operations. If the
-;;; types of both X and Y are integer types, then we compute a new integer type
-;;; with bounds determined Fun when applied to X and Y. Otherwise, we use
-;;; Numeric-Contagion.
+;;; a utility for defining derive-type methods of integer operations. If
+;;; the types of both X and Y are integer types, then we compute a new
+;;; integer type with bounds determined Fun when applied to X and Y.
+;;; Otherwise, we use Numeric-Contagion.
(defun derive-integer-type (x y fun)
(declare (type continuation x y) (type function fun))
(let ((x (continuation-type x))
#!+(or propagate-float-type propagate-fun-type)
(progn
-;; Simple utility to flatten a list
+;;; simple utility to flatten a list
(defun flatten-list (x)
(labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
(cond ((null x) r)
(t
type-list)))
-;;; Make-Canonical-Union-Type
-;;;
+;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
+;;; belong in the kernel's type logic, invoked always, instead of in
+;;; the compiler, invoked only during some type optimizations.
+
;;; Take a list of types and return a canonical type specifier,
-;;; combining any members types together. If both positive and
-;;; negative members types are present they are converted to a float
-;;; type. X This would be far simpler if the type-union methods could
-;;; handle member/number unions.
+;;; combining any MEMBER types together. If both positive and negative
+;;; MEMBER types are present they are converted to a float type.
+;;; XXX This would be far simpler if the type-union methods could handle
+;;; member/number unions.
(defun make-canonical-union-type (type-list)
(let ((members '())
(misc-types '()))
#!+negative-zero-is-not-zero
(push (specifier-type '(single-float -0f0 0f0)) misc-types)
(setf members (set-difference members '(-0f0 0f0))))
- (cond ((null members)
- (let ((res (first misc-types)))
- (dolist (type (rest misc-types))
- (setq res (type-union res type)))
- res))
- ((null misc-types)
- (make-member-type :members members))
- (t
- (let ((res (first misc-types)))
- (dolist (type (rest misc-types))
- (setq res (type-union res type)))
- (dolist (type members)
- (setq res (type-union
- res (make-member-type :members (list type)))))
- res)))))
-
-;;; Convert-Member-Type
-;;;
+ (if members
+ (apply #'type-union (make-member-type :members members) misc-types)
+ (apply #'type-union misc-types))))
+
;;; Convert a member type with a single member to a numeric type.
(defun convert-member-type (arg)
(let* ((members (member-type-members arg))
member-type)
,member ,member))))
-;;; ONE-ARG-DERIVE-TYPE
-;;;
;;; This is used in defoptimizers for computing the resulting type of
;;; a function.
;;;
(make-canonical-union-type results)
(first results)))))))
-;;; TWO-ARG-DERIVE-TYPE
-;;;
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
;;; two arguments. DERIVE-FCN takes 3 args in this case: the two
;;; original args and a third which is T to indicate if the two args
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer))
- ;; The product of integers is always an integer
+ ;; The product of integers is always an integer.
'integer
(numeric-type-class result-type))
:format (numeric-type-format result-type)
(if (and (numeric-type-real-p x)
(numeric-type-real-p y))
(let ((result
- ;; (/ x x) is always 1, except if x can contain 0. In
+ ;; (/ X X) is always 1, except if X can contain 0. In
;; that case, we shouldn't optimize the division away
;; because we want 0/0 to signal an error.
(if (and same-arg
) ; PROGN
+
;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
(progn
#!-propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
+ ;; Large resulting bounds are easy to generate but are not
+ ;; particularly useful, so an open outer bound is returned for a
+ ;; shift greater than 64 - the largest word size of any of the ports.
+ ;; Large negative shifts are also problematic as the ASH
+ ;; implementation only accepts shifts greater than
+ ;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local
+ ;; functions:
+ ;; ASH-OUTER: Perform the shift when within an acceptable range,
+ ;; otherwise return an open bound.
+ ;; ASH-INNER: Perform the shift when within range, limited to a
+ ;; maximum of 64, otherwise returns the inner limit.
+ ;;
+ ;; FIXME: The magic number 64 should be given a mnemonic name as a
+ ;; symbolic constant -- perhaps +MAX-REGISTER-SIZE+. And perhaps is
+ ;; should become an architecture-specific SB!VM:+MAX-REGISTER-SIZE+
+ ;; instead of trying to have a single magic number which covers
+ ;; all possible ports.
+ (flet ((ash-outer (n s)
+ (when (and (fixnump s)
+ (<= s 64)
+ (> s sb!vm:*target-most-negative-fixnum*))
+ (ash n s)))
+ (ash-inner (n s)
+ (if (and (fixnump s)
+ (> s sb!vm:*target-most-negative-fixnum*))
+ (ash n (min s 64))
+ (if (minusp n) -1 0))))
+ (or (let ((n-type (continuation-type n)))
+ (when (numeric-type-p n-type)
+ (let ((n-low (numeric-type-low n-type))
+ (n-high (numeric-type-high n-type)))
+ (if (constant-continuation-p shift)
+ (let ((shift (continuation-value shift)))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low (when n-low (ash n-low shift))
+ :high (when n-high (ash n-high shift))))
+ (let ((s-type (continuation-type shift)))
+ (when (numeric-type-p s-type)
+ (let* ((s-low (numeric-type-low s-type))
+ (s-high (numeric-type-high s-type))
+ (low-slot (when n-low
+ (if (minusp n-low)
+ (ash-outer n-low s-high)
+ (ash-inner n-low s-low))))
+ (high-slot (when n-high
+ (if (minusp n-high)
+ (ash-inner n-high s-low)
+ (ash-outer n-high s-high)))))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low low-slot
+ :high high-slot))))))))
+ *universal-type*))
(or (let ((n-type (continuation-type n)))
(when (numeric-type-p n-type)
(let ((n-low (numeric-type-low n-type))
(make-numeric-type :class 'integer
:complexp :real)))))))))
*universal-type*))
+
#!+propagate-fun-type
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
- (or (and (csubtypep n-type (specifier-type 'integer))
- (csubtypep shift (specifier-type 'integer))
- (let ((n-low (numeric-type-low n-type))
- (n-high (numeric-type-high n-type))
- (s-low (numeric-type-low shift))
- (s-high (numeric-type-high shift)))
- ;; KLUDGE: The bare 64's here should be related to
- ;; symbolic machine word size values somehow.
- (if (and s-low s-high (<= s-low 64) (<= s-high 64))
- (make-numeric-type :class 'integer :complexp :real
- :low (when n-low
- (min (ash n-low s-high)
- (ash n-low s-low)))
- :high (when n-high
- (max (ash n-high s-high)
- (ash n-high s-low))))
- (make-numeric-type :class 'integer
- :complexp :real))))
- *universal-type*))
+ (flet ((ash-outer (n s)
+ (when (and (fixnump s)
+ (<= s 64)
+ (> s sb!vm:*target-most-negative-fixnum*))
+ (ash n s)))
+ ;; KLUDGE: The bare 64's here should be related to
+ ;; symbolic machine word size values somehow.
+
+ (ash-inner (n s)
+ (if (and (fixnump s)
+ (> s sb!vm:*target-most-negative-fixnum*))
+ (ash n (min s 64))
+ (if (minusp n) -1 0))))
+ (or (and (csubtypep n-type (specifier-type 'integer))
+ (csubtypep shift (specifier-type 'integer))
+ (let ((n-low (numeric-type-low n-type))
+ (n-high (numeric-type-high n-type))
+ (s-low (numeric-type-low shift))
+ (s-high (numeric-type-high shift)))
+ (make-numeric-type :class 'integer :complexp :real
+ :low (when n-low
+ (if (minusp n-low)
+ (ash-outer n-low s-high)
+ (ash-inner n-low s-low)))
+ :high (when n-high
+ (if (minusp n-high)
+ (ash-inner n-high s-low)
+ (ash-outer n-high s-high))))))
+ *universal-type*)))
+
#!+propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
#!+propagate-float-type
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int
- #'(lambda (type type2)
- (declare (ignore type2))
- (let ((lo (numeric-type-low type))
- (hi (numeric-type-high type)))
- (values (if hi (lognot hi) nil)
- (if lo (lognot lo) nil)
- (numeric-type-class type)
- (numeric-type-format type))))))
+ (lambda (type type2)
+ (declare (ignore type2))
+ (let ((lo (numeric-type-low type))
+ (hi (numeric-type-high type)))
+ (values (if hi (lognot hi) nil)
+ (if lo (lognot lo) nil)
+ (numeric-type-class type)
+ (numeric-type-format type))))))
#!+propagate-float-type
(defoptimizer (%negate derive-type) ((num))
(flet ((negate-bound (b)
(set-bound (- (bound-value b)) (consp b))))
(one-arg-derive-type num
- #'(lambda (type)
- (let ((lo (numeric-type-low type))
- (hi (numeric-type-high type))
- (result (copy-numeric-type type)))
- (setf (numeric-type-low result)
- (if hi (negate-bound hi) nil))
- (setf (numeric-type-high result)
- (if lo (negate-bound lo) nil))
- result))
+ (lambda (type)
+ (let ((lo (numeric-type-low type))
+ (hi (numeric-type-high type))
+ (result (copy-numeric-type type)))
+ (setf (numeric-type-low result)
+ (if hi (negate-bound hi) nil))
+ (setf (numeric-type-high result)
+ (if lo (negate-bound lo) nil))
+ result))
#'-)))
#!-propagate-float-type
(frob-opt ffloor floor-quotient-bound floor-rem-bound)
(frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
-;;; Functions to compute the bounds on the quotient and remainder for
-;;; the FLOOR function.
+;;; functions to compute the bounds on the quotient and remainder for
+;;; the FLOOR function
(defun floor-quotient-bound (quot)
;; Take the floor of the quotient and then massage it into what we
;; need.
;;;; functions into boolean operations when the size and position are constant
;;;; and the operands are fixnums.
-(macrolet (;; Evaluate body with Size-Var and Pos-Var bound to expressions that
- ;; evaluate to the Size and Position of the byte-specifier form
- ;; Spec. We may wrap a let around the result of the body to bind
+(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to expressions that
+ ;; evaluate to the SIZE and POSITION of the byte-specifier form
+ ;; SPEC. We may wrap a let around the result of the body to bind
;; some variables.
;;
- ;; If the spec is a Byte form, then bind the vars to the subforms.
- ;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position.
+ ;; If the spec is a BYTE form, then bind the vars to the subforms.
+ ;; otherwise, evaluate SPEC and use the BYTE-SIZE and BYTE-POSITION.
;; The goal of this transformation is to avoid consing up byte
;; specifiers and then immediately throwing them away.
(with-byte-specifier ((size-var pos-var spec) &body body)
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(logand (ash int (- posn))
(ash ,(1- (ash 1 sb!vm:word-bits))
(- size ,sb!vm:word-bits))))
(deftransform %mask-field ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(logand int
(ash (ash ,(1- (ash 1 sb!vm:word-bits))
(- size ,sb!vm:word-bits))
(deftransform %dpb ((new size posn int)
*
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %dpb ((new size posn int)
*
(signed-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %deposit-field ((new size posn int)
*
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
(deftransform %deposit-field ((new size posn int)
*
(signed-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
;;; Handle the case of a constant BOOLE-CODE.
(deftransform boole ((op x y) * * :when :both)
- "convert to inline logical ops"
+ "convert to inline logical operations"
(unless (constant-continuation-p op)
(give-up-ir1-transform "BOOLE code is not a constant."))
(let ((control (continuation-value op)))
;;; Perhaps we should have to prove that the denominator is nonzero before
;;; doing them? (Also the DOLIST over macro calls is weird. Perhaps
;;; just FROB?) -- WHN 19990917
+;;;
+;;; FIXME: What gives with the single quotes in the argument lists
+;;; for DEFTRANSFORMs here? Does that work? Is it needed? Why?
(dolist (name '(ash /))
(deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
:eval-name t :when :both)
;;; If X and Y are the same leaf, then the result is true. Otherwise, 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
+(deftransform simple-equality-transform ((x y) * *
+ :defun-only t
:when :both)
(cond ((same-leaf-ref-p x y)
't)
(dolist (x '(eq char= equal))
(%deftransform x '(function * *) #'simple-equality-transform))
-;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
-;;; to a type-specific predicate or EQ:
-;;; -- If both args are characters, convert to CHAR=. This is better than just
-;;; converting to EQ, since CHAR= may have special compilation strategies
-;;; for non-standard representations, etc.
-;;; -- If either arg is definitely not a number, then we can compare with EQ.
-;;; -- Otherwise, we try to put the arg we know more about second. If X is
-;;; constant then we put it second. If X is a subtype of Y, we put it
-;;; second. These rules make it easier for the back end to match these
-;;; interesting cases.
-;;; -- If Y is a fixnum, then we quietly pass because the back end can handle
-;;; that case, otherwise give an efficency note.
+;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to
+;;; convert to a type-specific predicate or EQ:
+;;; -- If both args are characters, convert to CHAR=. This is better than
+;;; just converting to EQ, since CHAR= may have special compilation
+;;; strategies for non-standard representations, etc.
+;;; -- If either arg is definitely not a number, then we can compare
+;;; with EQ.
+;;; -- Otherwise, we try to put the arg we know more about second. If X
+;;; is constant then we put it second. If X is a subtype of Y, we put
+;;; it second. These rules make it easier for the back end to match
+;;; these interesting cases.
+;;; -- If Y is a fixnum, then we quietly pass because the back end can
+;;; handle that case, otherwise give an efficency note.
(deftransform eql ((x y) * * :when :both)
"convert to simpler equality predicate"
(let ((x-type (continuation-type x))
(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
-(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
-(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
+(def-source-transform char-greaterp (&rest args)
+ (multi-compare 'char-greaterp args nil))
+(def-source-transform char-not-greaterp (&rest args)
+ (multi-compare 'char-greaterp args t))
(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
;;; This function does source transformation of N-arg inequality
;;; 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
+;;; 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)
(declare (symbol fun leaf-fun) (list args))
(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
-(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
-(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
-(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
+(def-source-transform logior (&rest args)
+ (source-transform-transitive 'logior args 0))
+(def-source-transform logxor (&rest args)
+ (source-transform-transitive 'logxor args 0))
+(def-source-transform logand (&rest args)
+ (source-transform-transitive 'logand args -1))
(def-source-transform logeqv (&rest args)
(if (evenp (length args))
(def-source-transform / (&rest args)
(source-transform-intransitive '/ args '(/ 1)))
\f
-;;;; APPLY
+;;;; transforming APPLY
;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
;;; only needs to understand one kind of variable-argument call. It is
(butlast args))
(values-list ,(car (last args))))))
\f
-;;;; FORMAT
+;;;; transforming FORMAT
;;;;
;;;; If the control string is a compile-time constant, then replace it
;;;; with a use of the FORMATTER macro so that the control string is
projects / sbcl.git / blobdiff