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
(: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
;;; 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=))
(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*))
\f
;;;; 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)
(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)
(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*))
(return frame)))))))
(print-frame-call *current-frame*))
-(def-debug-command-alias "F" "FRAME")
+(!def-debug-command-alias "F" "FRAME")
\f
;;;; commands for entering and leaving the debugger
;;; 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*)
\f
;;;; 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
*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*)
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)))
;;; 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*)
;;; 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)))
: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)
(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)))
(setf *breakpoints* nil)
(format t "all breakpoints deleted~%")))))
-(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
+(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
\f
;;; 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)))
(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
(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)
\f
;;;; 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
(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))
(((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))))
(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)
(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
(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."))
;;; 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)
(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))
(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)))
(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)))))
;;; 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"
projects / sbcl.git / commitdiff