From 6e73f7320651975ce7cd8e72e2334041b7e80df1 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 16 Sep 2002 08:28:41 +0000 Subject: [PATCH] 0.7.7.27: MIN, MAX, +, *, LOGIOR, LOGAND, LOGXOR argument checking ... should now signal an error with bogus arguments ... still weirdness (connected with #194?) wrt tests --- src/code/numbers.lisp | 12 +++++--- src/compiler/srctran.lisp | 59 +++++++++++++++------------------------ tests/arith.impure.lisp | 68 +++++++++++++++++++++++++++++++++++++++++++++ tests/arith.pure.lisp | 7 +++++ version.lisp-expr | 2 +- 5 files changed, 106 insertions(+), 42 deletions(-) create mode 100644 tests/arith.impure.lisp diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 03ba7c5..e6ae297 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -919,7 +919,8 @@ (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) @@ -928,7 +929,8 @@ (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) @@ -937,7 +939,8 @@ (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) @@ -946,7 +949,8 @@ (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) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index d1c19d3..a17d640 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1,6 +1,6 @@ ;;;; 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. @@ -3095,32 +3095,16 @@ ;;; 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))))) ;;;; converting N-arg arithmetic functions ;;;; @@ -3138,29 +3122,30 @@ ;;; 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)) diff --git a/tests/arith.impure.lisp b/tests/arith.impure.lisp new file mode 100644 index 0000000..6604a9f --- /dev/null +++ b/tests/arith.impure.lisp @@ -0,0 +1,68 @@ +;;;; 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 diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index ad6abc2..e2b5e4c 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -51,6 +51,12 @@ ;;; 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))))) @@ -63,3 +69,4 @@ (assert (= (max -1 10.0) 10.0)) (assert (null (ignore-errors (max 3 #'max)))) (assert (= (max -3 0) 0)) +||# diff --git a/version.lisp-expr b/version.lisp-expr index 188e59a..2cfa302 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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" -- 1.7.10.4