(declare (list integers))
(if integers
(do ((result (pop integers) (logior result (pop integers))))
- ((null integers) result))
+ ((null integers) result)
+ (declare (integer result)))
0))
(defun logxor (&rest integers)
(declare (list integers))
(if integers
(do ((result (pop integers) (logxor result (pop integers))))
- ((null integers) result))
+ ((null integers) result)
+ (declare (integer result)))
0))
(defun logand (&rest integers)
(declare (list integers))
(if integers
(do ((result (pop integers) (logand result (pop integers))))
- ((null integers) result))
+ ((null integers) result)
+ (declare (integer result)))
-1))
(defun logeqv (&rest integers)
(declare (list integers))
(if integers
(do ((result (pop integers) (logeqv result (pop integers))))
- ((null integers) result))
+ ((null integers) result)
+ (declare (integer result)))
-1))
(defun lognand (integer1 integer2)
;;;; 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.
;;; Expand MAX and MIN into the obvious comparisons.
(define-source-transform max (arg0 &rest rest)
(once-only ((arg0 arg0))
- ;; ANSI says MAX should signal TYPE-ERROR if any arg isn't a REAL.
- ;;
- ;; KLUDGE: This UNLESS hackery is a workaround for bug 194.
- ;; Better, when that bug is fixed, would be (THE REAL ,ARG0).
- ;; -- WHN 2002-09-02
- `(progn
- (unless (realp ,arg0)
- (error-not-a-real ,arg0))
- ,(if (null rest)
- arg0
- `(let ((maxrest (max ,@rest)))
- (if (> ,arg0 maxrest) ,arg0 maxrest))))))
+ (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))
- ;; ANSI says MIN should signal TYPE-ERROR if any arg isn't a REAL.
- ;;
- ;; KLUDGE: This UNLESS hackery is a workaround for bug 194.
- ;; Better, when that bug is fixed, would be (THE REAL ,ARG0).
- ;; -- WHN 2002-09-02
- `(progn
- (unless (realp ,arg0)
- (error-not-a-real ,arg0))
- ,(if (null rest)
- arg0
- `(let ((minrest (min ,@rest)))
- (if (< ,arg0 minrest) ,arg0 minrest))))))
+ (if (null rest)
+ `(values (the real ,arg0))
+ `(let ((minrest (min ,@rest)))
+ (if (< ,arg0 minrest) ,arg0 minrest)))))
\f
;;;; converting N-arg arithmetic functions
;;;;
;;; 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))
--- /dev/null
+;;;; arithmetic tests with side effects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(load "assertoid.lisp")
+
+(defmacro define-compiled-fun (fun name)
+ `(progn
+ (declaim (notinline ,name))
+ (defun ,name (&rest args)
+ (declare (optimize safety))
+ (case (length args)
+ (0 (,fun))
+ (1 (,fun (car args)))
+ (2 (,fun (car args) (cadr args)))
+ (t (apply #',fun args))))))
+
+(define-compiled-fun min compiled-min)
+(define-compiled-fun max compiled-max)
+(define-compiled-fun + compiled-+)
+(define-compiled-fun * compiled-*)
+(define-compiled-fun logand compiled-logand)
+(define-compiled-fun logior compiled-logior)
+(define-compiled-fun logxor compiled-logxor)
+
+(assert (null (ignore-errors (compiled-min '(1 2 3)))))
+(assert (= (compiled-min -1) -1))
+(assert (null (ignore-errors (compiled-min 1 #(1 2 3)))))
+(assert (= (compiled-min 10 11) 10))
+(assert (null (ignore-errors (compiled-min (find-package "CL") -5.0))))
+(assert (= (compiled-min 5.0 -3) -3))
+(assert (null (ignore-errors (compiled-max #c(4 3)))))
+(assert (= (compiled-max 0) 0))
+(assert (null (ignore-errors (compiled-max "MIX" 3))))
+(assert (= (compiled-max -1 10.0) 10.0))
+(assert (null (ignore-errors (compiled-max 3 #'max))))
+(assert (= (compiled-max -3 0) 0))
+
+(assert (null (ignore-errors (compiled-+ "foo"))))
+(assert (= (compiled-+ 3f0) 3f0))
+(assert (null (ignore-errors (compiled-+ 1 #p"tmp"))))
+(assert (= (compiled-+ 1 2) 3))
+(assert (null (ignore-errors (compiled-+ '(1 2 3) 3))))
+(assert (= (compiled-+ 3f0 4f0) 7f0))
+(assert (null (ignore-errors (compiled-* "foo"))))
+(assert (= (compiled-* 3f0) 3f0))
+(assert (null (ignore-errors (compiled-* 1 #p"tmp"))))
+(assert (= (compiled-* 1 2) 2))
+(assert (null (ignore-errors (compiled-* '(1 2 3) 3))))
+(assert (= (compiled-* 3f0 4f0) 12f0))
+
+(assert (null (ignore-errors (compiled-logand #(1)))))
+(assert (= (compiled-logand 1) 1))
+(assert (null (ignore-errors (compiled-logior 3f0))))
+(assert (= (compiled-logior 4) 4))
+(assert (null (ignore-errors (compiled-logxor #c(2 3)))))
+(assert (= (compiled-logxor -6) -6))
+
+(sb-ext:quit :unix-status 104)
\ No newline at end of file
;;; ANSI says MIN and MAX should signal TYPE-ERROR if any argument
;;; isn't REAL. SBCL 0.7.7 didn't in the 1-arg case. (reported as a
;;; bug in CMU CL on #lisp IRC by lrasinen 2002-09-01)
+#||
+
+FIXME: These tests would be good to have. But although, in
+sbcl-0.7.7.2x, (NULL (IGNORE-ERRORS (MIN 1 #(1 2 3)))) returns T, the
+ASSERTion fails, probably in something related to bug #194.
+
(assert (null (ignore-errors (min '(1 2 3)))))
(assert (= (min -1) -1))
(assert (null (ignore-errors (min 1 #(1 2 3)))))
(assert (= (max -1 10.0) 10.0))
(assert (null (ignore-errors (max 3 #'max))))
(assert (= (max -3 0) 0))
+||#
;;; internal versions off the main CVS branch, it gets hairier, e.g.
;;; "0.pre7.14.flaky4.13".)
-"0.7.7.26"
+"0.7.7.27"
projects / sbcl.git / commitdiff