From 54a2e62234dc9a399ae12e56fe212d2137b43556 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 29 Mar 2001 00:17:20 +0000 Subject: [PATCH] 0.6.11.29: fixed bug 92: (< SB-EXT:SINGLE-FLOAT-POSITIVE-INFINITY 100) now works, thanks to Raymond Toy's patch to CMU CL. added more infinity-related tests in tests/ deleted bad DECLAIM FTYPE for PARSE-DEFTRANSFORM, to fix bug reported by Christophe Rhodes sbcl-devel 2001-03-28 converted some INTERNs to SYMBOLICATE or KEYWORDICATE converted DEF-DEBUG-COMMAND to !DEF-DEBUG-COMMAND as per FIXME --- BUGS | 18 +++++++---- src/code/debug.lisp | 72 ++++++++++++++++++++---------------------- src/code/defstruct.lisp | 3 +- src/code/fd-stream.lisp | 16 +++++----- src/code/target-numbers.lisp | 30 ++++++++++++++---- src/compiler/assem.lisp | 3 +- src/compiler/ir1tran.lisp | 2 +- src/compiler/macros.lisp | 3 +- src/pcl/vector.lisp | 9 +++--- tests/float.pure.lisp | 42 +++++++++++++++--------- version.lisp-expr | 2 +- 11 files changed, 115 insertions(+), 85 deletions(-) diff --git a/BUGS b/BUGS index a2c61e5..37e8fed 100644 --- a/BUGS +++ b/BUGS @@ -838,13 +838,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: clear what's the best fix. (See the "bug in type handling" discussion on cmucl-imp ca. 2001-03-22 and ca. 2001-02-12.) -92: - (< SB-EXT:SINGLE-FLOAT-POSITIVE-INFINITY 100) signals an error: - error in function SB-KERNEL:INTEGER-DECODE-SINGLE-FLOAT: - can't decode NaN or infinity: #.EXT:SINGLE-FLOAT-POSITIVE-INFINITY - This is a bug in the original CMU CL code. I reported it to cmucl-imp - 2001-03-22 in hopes that they'll fix it for us. - 93: In sbcl-0.6.11.26, (COMPILE 'IN-HOST-COMPILATION-MODE) in src/cold/shared.lisp doesn't correctly translate the @@ -864,6 +857,17 @@ Error in function C::GET-LAMBDA-TO-COMPILE: (:LINUX :X86 :IEEE-FLOATING-POINT :SB-CONSTRAIN-FLOAT-TYPE :SB-TEST :SB-INTERPRETER :SB-DOC :UNIX ...) is not of type SYMBOL. +94: + As reported by Christophe Rhodes on sbcl-devel 2001-03-28, the + old declaration + (declaim (ftype (function (list list symbol t) list) parse-deftransform)) + above DEFUN PARSE-DEFTRANSFORM was incorrect. The bad declaration was + removed in sbcl-0.6.11.28, but the compiler problem remains: the compiler + should've complained about the mismatch between the declaration and the + definition, and didn't. (The compiler in cmucl-2.5.1 does detect the + problem and complain.) + + KNOWN BUGS RELATED TO THE IR1 INTERPRETER (Note: At some point, the pure interpreter (actually a semi-pure diff --git a/src/code/debug.lisp b/src/code/debug.lisp index ea374d1..29e47a9 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -1011,10 +1011,8 @@ argument") ;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are ;;; permitted. -;;; -;;; FIXME: This is not needed in the target Lisp system. -(defmacro def-debug-command (name args &rest body) - (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND")))) +(defmacro !def-debug-command (name args &rest body) + (let ((fun-name (symbolicate name "-DEBUG-COMMAND"))) `(progn (setf *debug-commands* (remove ,name *debug-commands* :key #'car :test #'string=)) @@ -1025,7 +1023,7 @@ argument") (push (cons ,name #',fun-name) *debug-commands*) ',fun-name))) -(defun def-debug-command-alias (new-name existing-name) +(defun !def-debug-command-alias (new-name existing-name) (let ((pair (assoc existing-name *debug-commands* :test #'string=))) (unless pair (error "unknown debug command name: ~S" existing-name)) (push (cons new-name (cdr pair)) *debug-commands*)) @@ -1096,7 +1094,7 @@ argument") ;;;; frame-changing commands -(def-debug-command "UP" () +(!def-debug-command "UP" () (let ((next (sb!di:frame-up *current-frame*))) (cond (next (setf *current-frame* next) @@ -1104,7 +1102,7 @@ argument") (t (format t "~&Top of stack."))))) -(def-debug-command "DOWN" () +(!def-debug-command "DOWN" () (let ((next (sb!di:frame-down *current-frame*))) (cond (next (setf *current-frame* next) @@ -1112,29 +1110,29 @@ argument") (t (format t "~&Bottom of stack."))))) -(def-debug-command-alias "D" "DOWN") +(!def-debug-command-alias "D" "DOWN") ;;; CMU CL had this command, but SBCL doesn't, since it's redundant ;;; with "FRAME 0", and it interferes with abbreviations for the ;;; TOPLEVEL restart. -;;;(def-debug-command "TOP" () +;;;(!def-debug-command "TOP" () ;;; (do ((prev *current-frame* lead) ;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead))) ;;; ((null lead) ;;; (setf *current-frame* prev) ;;; (print-frame-call prev)))) -(def-debug-command "BOTTOM" () +(!def-debug-command "BOTTOM" () (do ((prev *current-frame* lead) (lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead))) ((null lead) (setf *current-frame* prev) (print-frame-call prev)))) -(def-debug-command-alias "B" "BOTTOM") +(!def-debug-command-alias "B" "BOTTOM") -(def-debug-command "FRAME" (&optional - (n (read-prompting-maybe "frame number: "))) +(!def-debug-command "FRAME" (&optional + (n (read-prompting-maybe "frame number: "))) (setf *current-frame* (multiple-value-bind (next-frame-fun limit-string) (if (< n (sb!di:frame-number *current-frame*)) @@ -1153,7 +1151,7 @@ argument") (return frame))))))) (print-frame-call *current-frame*)) -(def-debug-command-alias "F" "FRAME") +(!def-debug-command-alias "F" "FRAME") ;;;; commands for entering and leaving the debugger @@ -1163,16 +1161,16 @@ argument") ;;; things in the system, "restart the top level REPL" in the debugger ;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.) ;;; -;;;(def-debug-command "QUIT" () +;;;(!def-debug-command "QUIT" () ;;; (throw 'sb!impl::top-level-catcher nil)) ;;; CMU CL supported this GO debug command, but SBCL doesn't -- just ;;; type the CONTINUE restart name. -;;;(def-debug-command "GO" () +;;;(!def-debug-command "GO" () ;;; (continue *debug-condition*) ;;; (error "There is no restart named CONTINUE.")) -(def-debug-command "RESTART" () +(!def-debug-command "RESTART" () (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts* *debug-io*) @@ -1200,7 +1198,7 @@ argument") ;;;; information commands -(def-debug-command "HELP" () +(!def-debug-command "HELP" () ;; CMU CL had a little toy pager here, but "if you aren't running ;; ILISP (or a smart windowing system, or something) you deserve to ;; lose", so we've dropped it in SBCL. However, in case some @@ -1211,21 +1209,21 @@ argument") *debug-help-string* '*debug-help-string*)) -(def-debug-command-alias "?" "HELP") +(!def-debug-command-alias "?" "HELP") -(def-debug-command "ERROR" () +(!def-debug-command "ERROR" () (format *debug-io* "~A~%" *debug-condition*) (show-restarts *debug-restarts* *debug-io*)) -(def-debug-command "BACKTRACE" () +(!def-debug-command "BACKTRACE" () (backtrace (read-if-available most-positive-fixnum))) -(def-debug-command "PRINT" () +(!def-debug-command "PRINT" () (print-frame-call *current-frame*)) -(def-debug-command-alias "P" "PRINT") +(!def-debug-command-alias "P" "PRINT") -(def-debug-command "LIST-LOCALS" () +(!def-debug-command "LIST-LOCALS" () (let ((d-fun (sb!di:frame-debug-function *current-frame*))) (if (sb!di:debug-var-info-available d-fun) (let ((*standard-output* *debug-io*) @@ -1256,9 +1254,9 @@ argument") prefix)))) (write-line "There is no variable information available.")))) -(def-debug-command-alias "L" "LIST-LOCALS") +(!def-debug-command-alias "L" "LIST-LOCALS") -(def-debug-command "SOURCE" () +(!def-debug-command "SOURCE" () (fresh-line) (print-code-location-source-form (sb!di:frame-code-location *current-frame*) (read-if-available 0))) @@ -1382,7 +1380,7 @@ argument") ;;; breakpoint and step commands ;;; Step to the next code-location. -(def-debug-command "STEP" () +(!def-debug-command "STEP" () (setf *number-of-steps* (read-if-available 1)) (set-step-breakpoint *current-frame*) (continue *debug-condition*) @@ -1392,7 +1390,7 @@ argument") ;;; where the CONTINUE restart will transfer control. Set ;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be ;;; used by sbreakpoint. -(def-debug-command "LIST-LOCATIONS" () +(!def-debug-command "LIST-LOCATIONS" () (let ((df (read-if-available *default-breakpoint-debug-function*))) (cond ((consp df) (setf df (sb!di:function-debug-function (eval df))) @@ -1453,10 +1451,10 @@ argument") :function-end) (format t "~&::FUNCTION-END *Active* ")))) -(def-debug-command-alias "LL" "LIST-LOCATIONS") +(!def-debug-command-alias "LL" "LIST-LOCATIONS") ;;; Set breakpoint at the given number. -(def-debug-command "BREAKPOINT" () +(!def-debug-command "BREAKPOINT" () (let ((index (read-prompting-maybe "location number, :START, or :END: ")) (break t) (condition t) @@ -1554,20 +1552,20 @@ argument") (print-breakpoint-info (first *breakpoints*)) (format t "~&added")))) -(def-debug-command-alias "BP" "BREAKPOINT") +(!def-debug-command-alias "BP" "BREAKPOINT") ;;; List all breakpoints which are set. -(def-debug-command "LIST-BREAKPOINTS" () +(!def-debug-command "LIST-BREAKPOINTS" () (setf *breakpoints* (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) (dolist (info *breakpoints*) (print-breakpoint-info info))) -(def-debug-command-alias "LB" "LIST-BREAKPOINTS") -(def-debug-command-alias "LBP" "LIST-BREAKPOINTS") +(!def-debug-command-alias "LB" "LIST-BREAKPOINTS") +(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS") ;;; Remove breakpoint N, or remove all breakpoints if no N given. -(def-debug-command "DELETE-BREAKPOINT" () +(!def-debug-command "DELETE-BREAKPOINT" () (let* ((index (read-if-available nil)) (bp-info (find index *breakpoints* :key #'breakpoint-info-breakpoint-number))) @@ -1582,11 +1580,11 @@ argument") (setf *breakpoints* nil) (format t "all breakpoints deleted~%"))))) -(def-debug-command-alias "DBP" "DELETE-BREAKPOINT") +(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT") ;;; miscellaneous commands -(def-debug-command "DESCRIBE" () +(!def-debug-command "DESCRIBE" () (let* ((curloc (sb!di:frame-code-location *current-frame*)) (debug-fun (sb!di:code-location-debug-function curloc)) (function (sb!di:debug-function-function debug-fun))) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 241bf15..8ea7dae 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1267,8 +1267,7 @@ (dolist (slot (dd-slots defstruct)) (let ((dum (gensym)) (name (dsd-name slot))) - (arglist `((,(intern (string name) "KEYWORD") ,dum) - ,(dsd-default slot))) + (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot))) (types (dsd-type slot)) (vals dum))) (funcall creator diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 6f56179..d7a1199 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -188,16 +188,16 @@ (do-output stream (fd-stream-obuf-sap stream) 0 length t) (setf (fd-stream-obuf-tail stream) 0)))) -;;; Define output routines that output numbers size bytes long for the -;;; given bufferings. Use body to do the actual output. -(defmacro def-output-routines ((name size &rest bufferings) &body body) +;;; Define output routines that output numbers SIZE bytes long for the +;;; given bufferings. Use BODY to do the actual output. +(defmacro def-output-routines ((name-fmt size &rest bufferings) &body body) (declare (optimize (speed 1))) (cons 'progn (mapcar #'(lambda (buffering) (let ((function (intern (let ((*print-case* :upcase)) - (format nil name (car buffering)))))) + (format nil name-fmt (car buffering)))))) `(progn (defun ,function (stream byte) ,(unless (eq (car buffering) :none) @@ -399,10 +399,10 @@ ;;;; input routines and related noise -(defvar *input-routines* () - #!+sb-doc - "List of all available input routines. Each element is a list of the - element-type input, the function name, and the number of bytes per element.") +;;; a list of all available input routines. Each element is a list of +;;; the element-type input, the function name, and the number of bytes +;;; per element. +(defvar *input-routines* ()) ;;; Fill the input buffer, and return the first character. Throw to ;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER diff --git a/src/code/target-numbers.lisp b/src/code/target-numbers.lisp index 0df39f0..aa7304a 100644 --- a/src/code/target-numbers.lisp +++ b/src/code/target-numbers.lisp @@ -772,7 +772,14 @@ (eval-when (:compile-toplevel :execute) -(defun basic-compare (op) +;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how +;;; to handle the case when X or Y is a floating-point infinity and +;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec +;;; says that comparisons are done by converting the float to a +;;; rational when comparing with a rational, but infinities can't be +;;; converted to a rational, so we show some initiative and do it this +;;; way instead.) +(defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x) `(((fixnum fixnum) (,op x y)) ((single-float single-float) (,op x y)) @@ -789,15 +796,24 @@ (((foreach single-float double-float #!+long-float long-float) rational) (if (eql y 0) (,op x (coerce 0 '(dispatch-type x))) - (,op (rational x) y))) + (if (float-infinity-p x) + ,infinite-x-finite-y + (,op (rational x) y)))) (((foreach bignum fixnum ratio) float) - (,op x (rational y))))) + (if (float-infinity-p y) + ,infinite-y-finite-x + (,op x (rational y)))))) ) ; EVAL-WHEN (macrolet ((def-two-arg- (name op ratio-arg1 ratio-arg2 &rest cases) `(defun ,name (x y) (number-dispatch ((x real) (y real)) - (basic-compare ,op) + (basic-compare + ,op + :infinite-x-finite-y + (,op x (coerce 0 '(dispatch-type x))) + :infinite-y-finite-x + (,op (coerce 0 '(dispatch-type y)) y)) (((foreach fixnum bignum) ratio) (,op x (,ratio-arg2 (numerator y) (denominator y)))) @@ -828,8 +844,10 @@ (defun two-arg-= (x y) (number-dispatch ((x number) (y number)) - (basic-compare =) - + (basic-compare = + ;; An infinite value is never equal to a finite value. + :infinite-x-finite-y nil + :infinite-y-finite-x nil) ((fixnum (or bignum ratio)) nil) ((bignum (or fixnum ratio)) nil) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index a6137b0..65caaec 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1445,8 +1445,7 @@ p ;; the branch has two dependents and one of them dpends on (multiple-value-bind (key var) (if (consp name) (values (first name) (second name)) - (values (intern (symbol-name name) :keyword) - name)) + (values (keywordicate name) name)) `(append (and ,supplied-p (list ',key ,var)) ,(grovel state (cdr lambda-list)))))) (&rest diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ae11f5d..5752d6e 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1126,7 +1126,7 @@ (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg)) (defun make-keyword-for-arg (symbol vars keywordify) (let ((key (if (and keywordify (not (keywordp symbol))) - (intern (symbol-name symbol) "KEYWORD") + (keywordicate symbol) symbol))) (when (eq key :allow-other-keys) (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS.")) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 91a013b..6fe6325 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -284,7 +284,6 @@ ;;; The second value is a list of all the arguments bound. We make the ;;; variables IGNORABLE so that we don't have to manually declare them ;;; Ignore if their only purpose is to make the syntax work. -(declaim (ftype (function (list list symbol t) list) parse-deftransform)) (defun parse-deftransform (lambda-list body args error-form) (multiple-value-bind (req opt restp rest keyp keys allowp) (parse-lambda-list lambda-list) @@ -313,7 +312,7 @@ (dolist (spec keys) (if (or (atom spec) (atom (first spec))) (let* ((var (if (atom spec) spec (first spec))) - (key (intern (symbol-name var) "KEYWORD"))) + (key (keywordicate var))) (vars var) (binds `(,var (find-keyword-continuation ,n-keys ,key))) (keywords key)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 4c72075..4e2b10d 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -1070,10 +1070,11 @@ (nm (car next-methods)) (nms (cdr next-methods)) (nmc (when nm - (make-method-call :function (if (std-instance-p nm) - (method-function nm) - nm) - :call-method-args (list nms))))) + (make-method-call + :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) (if restp (let* ((rest (nthcdr nreq method-args)) (args (ldiff method-args rest))) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index e5d62ac..f4382e3 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -13,18 +13,30 @@ (cl:in-package :cl-user) -(let ((+ifni single-float-positive-infinity) - (-ifni single-float-negative-infinity)) - (assert (= (* +ifni 1) +ifni)) - (assert (= (* +ifni -0.1) -ifni)) - (assert (= (+ +ifni -0.1) +ifni)) - (assert (= (- +ifni -0.1) +ifni)) - (assert (= (sqrt +ifni) +ifni)) - (assert (= (* -ifni -14) +ifni)) - (assert (= (/ -ifni 0.1) -ifni)) - (assert (= (/ -ifni 100/3) -ifni)) - (assert (< -ifni +ifni)) - ;; FIXME: Reenable this when bug 92 is fixed. - ;; (assert (not (< +ifni 100))) - (assert (not (< +ifni 100.0))) - (assert (not (< +ifni -ifni)))) +(dolist (ifnis (list (cons single-float-positive-infinity + single-float-negative-infinity) + (cons double-float-positive-infinity + double-float-negative-infinity))) + (destructuring-bind (+ifni . -ifni) ifnis + (assert (= (* +ifni 1) +ifni)) + (assert (= (* +ifni -0.1) -ifni)) + (assert (= (+ +ifni -0.1) +ifni)) + (assert (= (- +ifni -0.1) +ifni)) + (assert (= (sqrt +ifni) +ifni)) + (assert (= (* -ifni -14) +ifni)) + (assert (= (/ -ifni 0.1) -ifni)) + (assert (= (/ -ifni 100/3) -ifni)) + (assert (not (= +ifni -ifni))) + (assert (= -ifni -ifni)) + (assert (not (= +ifni 100/3))) + (assert (not (= -ifni -1.0 -ifni))) + (assert (not (= -ifni -17/02 -ifni))) + (assert (< -ifni +ifni)) + (assert (not (< +ifni 100))) + (assert (not (< +ifni 100.0))) + (assert (not (< +ifni -ifni))) + (assert (< 100 +ifni)) + (assert (< 100.0 +ifni)) + (assert (>= 100 -ifni)) + (assert (not (<= 6/7 (* 3 -ifni)))) + (assert (not (> +ifni +ifni))))) diff --git a/version.lisp-expr b/version.lisp-expr index 77c9375..86e55f7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.28" +"0.6.11.29" -- 1.7.10.4