From c68bb6b62d2813eb5af3cb7d4502625990a933d6 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 29 May 2003 12:28:01 +0000 Subject: [PATCH] 0.8.0.15: A couple more minor fixes: ... LOOP FOR ... FROM ... can apparently accept complex numbers in some cases. Ew. Make it so, but attempt to limit the damage by still providing compile-time diagnostics where possible. ... disassemble FUCOM on x86 correctly. (thanks to Raymond Toy) ... unBAshify test script. (thanks to Henrik Motakef) --- NEWS | 2 ++ src/code/loop.lisp | 61 +++++++++++++++++++++++++++++-------------- src/compiler/x86/insts.lisp | 3 +-- tests/run-tests.sh | 16 ++++++------ version.lisp-expr | 2 +- 5 files changed, 54 insertions(+), 30 deletions(-) diff --git a/NEWS b/NEWS index d1705d1..11f5fd3 100644 --- a/NEWS +++ b/NEWS @@ -1785,6 +1785,8 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: classes. (thanks to Antonio Martinez) * fixed some bugs revealed by Paul Dietz' test suite: ** NIL is now allowed as a structure slot name. + ** arbitrary numbers, not just reals, are allowed in certain + circumstances in LOOP for-as-arithmetic clauses. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 1f86e9f..4be06cb 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -511,7 +511,8 @@ code to be loaded. (setq constant-value (eval new-form))) (when (and constantp expected-type) (unless (sb!xc:typep constant-value expected-type) - (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." + (loop-warn "~@" form constant-value expected-type) (setq constantp nil constant-value nil))) (values new-form constantp constant-value))) @@ -534,6 +535,11 @@ code to be loaded. ;; CLTL2, removed from ANSI standard) we could set these ;; values flexibly. Without DECLARATION-INFORMATION, we have ;; to set them to constants. + ;; + ;; except FIXME: we've lost all pretence of portability, + ;; considering this instead an internal implementation, so + ;; we're free to couple to our own representation of the + ;; environment. (speed 1) (space 1)) (+ 40 (* (- speed space) 10)))) @@ -1717,21 +1723,22 @@ code to be loaded. ((loop-tequal prep :below) (setq dir ':up))) (setq limit-given t) (multiple-value-setq (form limit-constantp limit-value) - (loop-constant-fold-if-possible form indexv-type)) + (loop-constant-fold-if-possible form `(and ,indexv-type real))) (setq endform (if limit-constantp `',limit-value (loop-make-var - (gensym "LOOP-LIMIT-") form indexv-type)))) + (gensym "LOOP-LIMIT-") form + `(and ,indexv-type real))))) (:by - (multiple-value-setq (form stepby-constantp stepby) - (loop-constant-fold-if-possible form indexv-type)) - (unless stepby-constantp - (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) - form - indexv-type))) + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form `(and ,indexv-type (real (0))))) + (unless stepby-constantp + (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) + form + `(and ,indexv-type (real (0)))))) (t (loop-error - "~S invalid preposition in sequencing or sequence path;~@ - maybe invalid prepositions were specified in iteration path descriptor?" + "~S invalid preposition in sequencing or sequence path;~@ + maybe invalid prepositions were specified in iteration path descriptor?" prep))) (when (and odir dir (not (eq dir odir))) (loop-error "conflicting stepping directions in LOOP sequencing path")) @@ -1739,12 +1746,27 @@ code to be loaded. (when (and sequence-variable (not sequencep)) (loop-error "missing OF or IN phrase in sequence path")) ;; Now fill in the defaults. - (unless start-given - (loop-make-iteration-var - indexv - (setq start-constantp t - start-value (or (loop-typed-init indexv-type) 0)) - indexv-type)) + (if start-given + (when limit-given + ;; if both start and limit are given, they had better both + ;; be REAL. We already enforce the REALness of LIMIT, + ;; above; here's the KLUDGE to enforce the type of START. + (flet ((type-declaration-of (x) + (and (eq (car x) 'type) (caddr x)))) + (let ((decl (find indexv *loop-declarations* + :key #'type-declaration-of)) + (%decl (find indexv *loop-declarations* + :key #'type-declaration-of + :from-end t))) + (sb!int:aver (eq decl %decl)) + (setf (cadr decl) + `(and real ,(cadr decl)))))) + ;; default start + (loop-make-iteration-var + indexv + (setq start-constantp t + start-value (or (loop-typed-init indexv-type) 0)) + `(and ,indexv-type real))) (cond ((member dir '(nil :up)) (when (or limit-given default-top) (unless limit-given @@ -1771,7 +1793,8 @@ code to be loaded. (setq step-hack `(,variable ,step-hack))) (let ((first-test test) (remaining-tests test)) - (when (and stepby-constantp start-constantp limit-constantp) + (when (and stepby-constantp start-constantp limit-constantp + (realp start-value) (realp limit-value)) (when (setq first-test (funcall (symbol-function testfn) start-value @@ -1784,7 +1807,7 @@ code to be loaded. (defun loop-for-arithmetic (var val data-type kwd) (loop-sequencer - var (loop-check-data-type data-type 'real) + var (loop-check-data-type data-type 'number) nil nil nil nil nil nil (loop-collect-prepositional-phrases '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 514f116..c64e761 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -2455,8 +2455,7 @@ ;;; unordered comparison (define-instruction fucom (segment src) - ;; XX Printer conflicts with frstor - ;; (:printer floating-point ((op '(#b101 #b100)))) + (:printer floating-point-fp ((op '(#b101 #b100)))) (:emitter (aver (fp-reg-tn-p src)) (emit-byte segment #b11011101) diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 3a4d283..6c52448 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -44,10 +44,10 @@ echo /with SBCL_ALLOWING_CORE=\'$SBCL_ALLOWING_CORE\' # returned unless we exit through the intended explicit "test # successful" path. tenfour () { - if [ $? = 104 ]; then + if [ $1 = 104 ]; then echo ok else - echo test failed, expected 104 return code, got $? + echo test failed, expected 104 return code, got $1 exit 1 fi } @@ -66,7 +66,7 @@ for f in *.pure.lisp; do fi done echo " (sb-ext:quit :unix-status 104)) ; Return status=success." -) | $SBCL ; tenfour +) | $SBCL ; tenfour $? # *.impure.lisp files are Lisp code with side effects (e.g. doing # DEFSTRUCT or DEFTYPE or DEFVAR, or messing with the read table). @@ -77,7 +77,7 @@ echo //running '*.impure.lisp' tests for f in *.impure.lisp; do if [ -f $f ]; then echo //running $f test - echo "(load \"$f\")" | $SBCL ; tenfour + echo "(load \"$f\")" | $SBCL ; tenfour $? fi done @@ -89,7 +89,7 @@ echo //running '*.test.sh' tests for f in *.test.sh; do if [ -f $f ]; then echo //running $f test - sh $f "$SBCL"; tenfour + sh $f "$SBCL"; tenfour $? fi done @@ -99,7 +99,7 @@ echo //running '*.assertoids' tests for f in *.assertoids; do if [ -f $f ]; then echo //running $f test - echo "(load \"$f\")" | $SBCL --eval '(load "assertoid.lisp")' ; tenfour + echo "(load \"$f\")" | $SBCL --eval '(load "assertoid.lisp")' ; tenfour $? fi done @@ -112,7 +112,7 @@ for f in *.pure-cload.lisp; do # to LOAD them all into the same Lisp.) if [ -f $f ]; then echo //running $f test - $SBCL <