45:
a slew of floating-point-related errors reported by Peter Van Eynde
on July 25, 2000:
- a: (fixed in sbcl-0.6.11.25)
b: SBCL's value for LEAST-POSITIVE-SHORT-FLOAT is bogus, and
should probably be 1.4012985e-45. In SBCL,
(/ LEAST-POSITIVE-SHORT-FLOAT 2) returns a number smaller
than LEAST-POSITIVE-SHORT-FLOAT. Similar problems
exist for LEAST-NEGATIVE-SHORT-FLOAT, LEAST-POSITIVE-LONG-FLOAT,
and LEAST-NEGATIVE-LONG-FLOAT.
- c: Many expressions generate floating infinity:
+ c: Many expressions generate floating infinity on x86/Linux:
(/ 1 0.0)
(/ 1 0.0d0)
(EXPT 10.0 1000)
(EXPT 10.0d0 1000)
- PVE's regression tests want them to raise errors. SBCL
- generates the infinities instead, which may or may not be
- conforming behavior.
+ PVE's regression tests want them to raise errors. sbcl-0.7.0.5
+ on x86/Linux generates the infinities instead. That might or
+ might not be conforming behavior, but it's also inconsistent,
+ which is almost certainly wrong. (Inconsistency: (/ 1 0.0)
+ should give the same result as (/ 1.0 0.0), but instead (/ 1 0.0)
+ generates SINGLE-FLOAT-POSITIVE-INFINITY and (/ 1.0 0.0)
+ signals an error.
d: (in section12.erg) various forms a la
(FLOAT 1 DOUBLE-FLOAT-EPSILON)
don't give the right behavior.
d: In general, the system doesn't like '(INTEGER (0) (0)) -- it
blows up at the level of SPECIFIER-TYPE with
"Lower bound (0) is greater than upper bound (0)." Probably
- SPECIFIER-TYPE should return NIL instead.
+ SPECIFIER-TYPE should return the NIL type instead.
g: The type system isn't all that smart about relationships
between hairy types, as shown in the type.erg test results,
e.g. (SUBTYPEP 'CONS '(NOT ATOM)) => NIL, NIL.
type declarations are supposed to be treated as assertions unless
SAFETY 0, so we should be getting a TYPE-ERROR.
-111:
- reported by Martin Atzmueller 2001-06-25; originally from CMU CL bugs
- collection:
- (in-package :cl-user)
- ;;; Produces an assertion failures when compiled.
- (defun foo (z)
- (declare (type (or (function (t) t) null) z))
- (let ((z (or z #'identity)))
- (declare (type (function (t) t) z))
- (funcall z 1)))
- The error in sbcl-0.6.12.42 is
- internal error, failed AVER:
- "(COMMON-LISP:NOT (COMMON-LISP:EQ SB!C::CHECK COMMON-LISP:T))"
-
112:
reported by Martin Atzmueller 2001-06-25; taken from CMU CL bugs
collection; apparently originally reported by Bruno Haible
* The fasl file version number changed again, for dozens of reasons,
some of which are apparent above.
-changes in sbcl-0.7.0 relative to sbcl-0.6.13:
-* various bug fixes, notably:
- ** DEFGENERIC is now choosier about the methods it redefines, so
- reLOADing a previously-LOADed file containing DEFGENERICs does
- the right thing now, so now the Lispy edit/reLOAD-a-little/test
- cycle works as it should. (thanks to APD)
+changes in sbcl-0.7.1 relative to sbcl-0.7.0:
+* SB-ALIEN:LOAD-FOREIGN and SB-ALIEN:LOAD-1-FOREIGN are set
+ up properly again. (There was a packaging bug in 0.7.0 which
+ left their definitions in SB-SYS::LOAD-FOREIGN and
+ SB-SYS::LOAD-1-FOREIGN.)
+* DEFGENERIC is now choosier about the methods it redefines, so that
+ reLOADing a previously-LOADed file containing DEFGENERICs does
+ the right thing now. Thus, the Lispy edit/reLOAD-a-little/test
+ cycle now works as it should. (thanks to Alexey Dejneka)
+* Bug 106 (types (COMPLEX FOO) where FOO is an obscure type) was
+ fixed by Christophe Rhodes. (He actually submitted this patch
+ months ago, and I delayed until after 0.7.0.)
+* Bug 111 (internal compiler confusion about runtime checks on
+ FUNCTION types) was fixed by Alexey Dejneka.
planned incompatible changes in 0.7.x:
* When the profiling interface settles down, maybe in 0.7.x, maybe
for early 0.7.x:
-* patches postponed until after 0.7.0:
- ** CSR "rough patch to fix bug 106" 2001-10-28
- ** Alexey Dejneka "bug 111" 2001-12-30
* building with CLISP (or explaining why not). This will likely involve
a rearrangement of the build system so that it never renames
the output from COMPILE-FILE, because CLISP's COMPILE-FILE
besides CLISPiosyncrasies, I'm reasonably motivated to do it.
* urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
** made inlining DEFUN inside MACROLET work again
- ** (also, while working on INLINE anyway, it should be easy
+ ** (also, while working on INLINE anyway, it might be easy
to flush the old MAYBE-INLINE cruft entirely,
including e.g. on the man page)
** fixed bug 137 (more)
;;; lambda-list variables since any other arguments will be in the
;;; &REST arg's list of values.
(defun print-frame-call-1 (frame)
- (let* ((d-fun (sb!di:frame-debug-fun frame))
- (loc (sb!di:frame-code-location frame))
- (results (list (sb!di:debug-fun-name d-fun))))
+ (let ((debug-fun (sb!di:frame-debug-fun frame))
+ (loc (sb!di:frame-code-location frame))
+ (reversed-args nil))
+
+ ;; Construct function arguments in REVERSED-ARGS.
(handler-case
- (dolist (ele (sb!di:debug-fun-lambda-list d-fun))
+ (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
(lambda-list-element-dispatch ele
- :required ((push (frame-call-arg ele loc frame) results))
- :optional ((push (frame-call-arg (second ele) loc frame) results))
- :keyword ((push (second ele) results)
- (push (frame-call-arg (third ele) loc frame) results))
- :deleted ((push (frame-call-arg ele loc frame) results))
+ :required ((push (frame-call-arg ele loc frame) reversed-args))
+ :optional ((push (frame-call-arg (second ele) loc frame)
+ reversed-args))
+ :keyword ((push (second ele) reversed-args)
+ (push (frame-call-arg (third ele) loc frame)
+ reversed-args))
+ :deleted ((push (frame-call-arg ele loc frame) reversed-args))
:rest ((lambda-var-dispatch (second ele) loc
nil
(progn
- (setf results
+ (setf reversed-args
(append (reverse (sb!di:debug-var-value
(second ele) frame))
- results))
+ reversed-args))
(return))
(push (make-unprintable-object
"unavailable &REST argument")
- results)))))
+ reversed-args)))))
(sb!di:lambda-list-unavailable
()
- (push (make-unprintable-object "lambda list unavailable") results)))
- (pprint-logical-block (*standard-output* nil)
- (let ((x (nreverse (mapcar #'ensure-printable-object results))))
- (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x))))
- (when (sb!di:debug-fun-kind d-fun)
+ (push (make-unprintable-object "lambda list unavailable")
+ reversed-args)))
+
+ (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
+ (let ((args (nreverse (mapcar #'ensure-printable-object reversed-args))))
+ ;; Since we go to some trouble to make nice informative function
+ ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
+ ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
+ (let ((*print-length* nil)
+ (*print-level* nil))
+ (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
+ ;; For the function arguments, we can just print normally.
+ (format t "~{ ~_~S~}" args)))
+
+ (when (sb!di:debug-fun-kind debug-fun)
(write-char #\[)
- (prin1 (sb!di:debug-fun-kind d-fun))
+ (prin1 (sb!di:debug-fun-kind debug-fun))
(write-char #\]))))
(defun ensure-printable-object (object)
;;; except that the value of NAME is passed to the compiler for use in
;;; creation of debug information for the resulting function.
;;;
-;;; Eventually we might use this for NAME values other than legal
-;;; function names, e.g.
+;;; NAME can be a legal function name or some arbitrary other thing.
+;;;
+;;; If NAME is a legal function name, then the caller should be
+;;; planning to set (FDEFINITION NAME) to the created function.
+;;; (Otherwise the debug names will be inconsistent and thus
+;;; unnecessarily confusing.)
+;;;
+;;; Arbitrary other things are appropriate for naming things which are
+;;; not the FDEFINITION of NAME. E.g.
;;; NAME = (:FLET FOO BAR)
;;; for the FLET function in
;;; (DEFUN BAR (X)
;;; (FLET ((FOO (Y) (+ X Y)))
;;; FOO))
;;; or
-;;; NAME = (:METHOD PRINT-OBJECT (STARSHIP T))
+;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T))
;;; for the function used to implement
-;;; (DEFMETHOD PRINT-OBJECT ((SS STARSHIP) STREAM) ...).
-;;; However, as of this writing (while defining/implementing it in
-;;; sbcl-0.pre7.108) NAME is always a legal function name.
-;;;
-;;; If NAME is a legal function name, then the caller should be
-;;; planning to set (FDEFINITION NAME) to the created function.
-;;; (Otherwise the debug names will be inconsistent and thus
-;;; unnecessarily confusing.)
+;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
(def-ir1-translator named-lambda ((name &rest rest) start cont)
(reference-leaf start
cont
- (ir1-convert-lambda `(lambda ,@rest)
- :source-name name)))
+ (if (legal-fun-name-p name)
+ (ir1-convert-lambda `(lambda ,@rest)
+ :source-name name)
+ (ir1-convert-lambda `(lambda ,@rest)
+ :debug-name name))))
\f
;;;; FUNCALL
(node-derived-type (continuation-use cont)))))
;;; Our best guess for the type of this continuation's value. Note
-;;; that this may be Values or Function type, which cannot be passed
+;;; that this may be VALUES or FUNCTION type, which cannot be passed
;;; as an argument to the normal type operations. See
-;;; Continuation-Type. This may be called on deleted continuations,
+;;; CONTINUATION-TYPE. This may be called on deleted continuations,
;;; always returning *.
;;;
;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the
(cond ((values-subtypep proven asserted)
(setf (continuation-%type-check cont) nil)
(setf (continuation-%derived-type cont) proven))
+ ((and (values-subtypep proven (specifier-type 'function))
+ (values-subtypep asserted (specifier-type 'function)))
+ ;; It's physically impossible for a runtime type check to
+ ;; distinguish between the various subtypes of FUNCTION, so
+ ;; it'd be pointless to do more type checks here.
+ (setf (continuation-%type-check cont) nil)
+ (setf (continuation-%derived-type cont)
+ ;; FIXME: This should depend on optimization
+ ;; policy. This is for SPEED > SAFETY:
+ #+nil (values-type-intersection asserted proven)
+ ;; and this is for SAFETY >= SPEED:
+ #-nil proven))
(t
(unless (or (continuation-%type-check cont)
(not (continuation-dest cont))
,,(cadr specializer))
`',specializer))
specializers))
- unspecialized-lambda-list method-class-name
+ unspecialized-lambda-list
+ method-class-name
initargs-form
pv-table-symbol))))
(extract-declarations body env)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
- (declare (%method-name ,(list name qualifiers specializers)))
+ ;; (Old PCL code used a somewhat different style of
+ ;; list for %METHOD-NAME values. Our names use
+ ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
+ ;; method names look more like what you see in a
+ ;; DEFMETHOD form.)
+ ;;
+ ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
+ ;; least the code to set up named BLOCKs around the
+ ;; bodies of methods, depends on the function's base
+ ;; name being the first element of the %METHOD-NAME
+ ;; list. It would be good to remove this dependency,
+ ;; perhaps by building the BLOCK here, or by using
+ ;; another declaration (e.g. %BLOCK-NAME), so that
+ ;; our method debug names are free to have any format,
+ ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
+ (declare (%method-name (,name
+ ,@qualifiers
+ ,specializers)))
(declare (%method-lambda-list ,@lambda-list))
,@declarations
,@real-body)
(defun real-make-method-initargs-form (proto-gf proto-method
method-lambda initargs env)
(declare (ignore proto-gf proto-method))
- (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+ (unless (and (consp method-lambda)
+ (eq (car method-lambda) 'lambda))
(error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~
is not a lambda form."
method-lambda))
(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
&body body)
`(macrolet ((call-next-method-bind (&body body)
- `(let () ,@body))
+ `(let () ,@body))
(call-next-method-body (cnm-args)
- `(if ,',next-method-call
- ,(if (and (null ',rest-arg)
- (consp cnm-args)
- (eq (car cnm-args) 'list))
- `(invoke-effective-method-function
- ,',next-method-call nil
- ,@(cdr cnm-args))
- (let ((call `(invoke-effective-method-function
- ,',next-method-call
- ,',(not (null rest-arg))
- ,@',args
- ,@',(when rest-arg `(,rest-arg)))))
- `(if ,cnm-args
- (bind-args ((,@',args
- ,@',(when rest-arg
- `(&rest ,rest-arg)))
- ,cnm-args)
- ,call)
- ,call)))
- (error "no next method")))
+ `(if ,',next-method-call
+ ,(locally
+ ;; This declaration suppresses a "deleting
+ ;; unreachable code" note for the following IF when
+ ;; REST-ARG is NIL. It is not nice for debugging
+ ;; SBCL itself, but at least it keeps us from
+ ;; annoying users.
+ (declare (optimize (inhibit-warnings 3)))
+ (if (and (null ',rest-arg)
+ (consp cnm-args)
+ (eq (car cnm-args) 'list))
+ `(invoke-effective-method-function
+ ,',next-method-call nil
+ ,@(cdr cnm-args))
+ (let ((call `(invoke-effective-method-function
+ ,',next-method-call
+ ,',(not (null rest-arg))
+ ,@',args
+ ,@',(when rest-arg `(,rest-arg)))))
+ `(if ,cnm-args
+ (bind-args ((,@',args
+ ,@',(when rest-arg
+ `(&rest ,rest-arg)))
+ ,cnm-args)
+ ,call)
+ ,call))))
+ (error "no next method")))
(next-method-p-body ()
- `(not (null ,',next-method-call))))
- ,@body))
+ `(not (null ,',next-method-call))))
+ ,@body))
(defmacro bind-lexical-method-functions
((&key call-next-method-p next-method-p-p closurep applyp)
;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do
;;; we need it both here and there? Why? -- WHN 19991203
(eval-when (:load-toplevel)
- (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32)
- (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2)))
+ (dolist (n-size '((1 513) (3 257) (3 129) (14 128) (6 65)
+ (2 64) (7 33) (16 32) (16 17) (32 16)
+ (64 9) (64 8) (6 5) (128 4) (35 2)))
(let ((n (car n-size))
(size (cadr n-size)))
(mapcar #'free-cache-vector
(defun expand-make-instance-form (form)
(let ((class (cadr form)) (initargs (cddr form))
- (keys nil)(allow-other-keys-p nil) key value)
+ (keys nil) (allow-other-keys-p nil) key value)
(when (and (constant-symbol-p class)
(let ((initargs-tail initargs))
(loop (when (null initargs-tail) (return t))
(/show "starting pcl/macros.lisp")
(declaim (declaration
- ;; These three nonstandard declarations seem to be used
- ;; privately within PCL itself to pass information around,
- ;; so we can't just delete them.
- %class
+ ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration
+ ;; to propagate information needed to set up nice debug
+ ;; names (as seen e.g. in BACKTRACE) for method functions.
%method-name
+ ;; These nonstandard declarations seem to be used privately
+ ;; within PCL itself to pass information around, so we can't
+ ;; just delete them.
+ %class
%method-lambda-list
;; This declaration may also be used within PCL to pass
;; information around, I'm not sure. -- WHN 2000-12-30
(slot-name-lists (pv-table-slot-name-lists pv-table))
(pv-size (pv-table-pv-size pv-table))
(pv-map (make-array pv-size :initial-element nil)))
- (let ((map-index 1)(param-index 0))
+ (let ((map-index 1) (param-index 0))
(dolist (slot-name-list slot-name-lists)
(dolist (slot-name (cdr slot-name-list))
(let ((a (assoc slot-name new-values)))
;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
;; SBCL doesn't have 'em, VALUES should probably be removed from
;; this list.
- '(values %method-name %method-lambda-list
- optimize ftype inline notinline))
+ '(values
+ %method-name
+ %method-lambda-list
+ optimize
+ ftype
+ inline
+ notinline))
(defvar *var-declarations-with-arg*
'(%class
(if (member var args)
;; Quietly remove IGNORE declarations on
;; args when a next-method is involved, to
- ;; prevent compiler warns about ignored
+ ;; prevent compiler warnings about ignored
;; args being read.
(unless (and calls-next-method-p
(eq (car dname) 'ignore))
(setq body (cdr body)))
(values outer-decls inner-decls body)))
+;;; Pull a name out of the %METHOD-NAME declaration in the function
+;;; body given, or return NIL if no %METHOD-NAME declaration is found.
+(defun body-method-name (body)
+ (multiple-value-bind (documentation declarations real-body)
+ (extract-declarations body nil)
+ (declare (ignore documentation real-body))
+ (let ((name-decl (get-declaration '%method-name declarations)))
+ (and name-decl
+ (destructuring-bind (name) name-decl
+ name)))))
+
+;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
+;;; declaration (which is a naming style internal to PCL) into an
+;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
+;;; throughout SBCL, understood by the main compiler); or if there's
+;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
+;;; lambda expression.
+(defun name-method-lambda (method-lambda)
+ (let ((method-name (body-method-name (cddr method-lambda))))
+ (if method-name
+ `(named-lambda ,method-name ,(rest method-lambda))
+ method-lambda)))
+
(defun make-method-initargs-form-internal (method-lambda initargs env)
(declare (ignore env))
- (let (method-lambda-args lmf lmf-params)
+ (let (method-lambda-args
+ lmf ; becomes body of function
+ lmf-params)
(if (not (and (= 3 (length method-lambda))
(= 2 (length (setq method-lambda-args (cadr method-lambda))))
(consp (setq lmf (third method-lambda)))
(cadr (setq lmf-params (cadr lmf))))
(eq (cadr method-lambda-args)
(caddr lmf-params))))
- `(list* :function #',method-lambda
+ `(list* :function ,(name-method-lambda method-lambda)
',initargs)
(let* ((lambda-list (car lmf-params))
- (nreq 0)(restp nil)(args nil))
+ (nreq 0)
+ (restp nil)
+ (args nil))
(dolist (arg lambda-list)
(when (member arg '(&optional &rest &key))
- (setq restp t)(return nil))
- (when (eq arg '&aux) (return nil))
- (incf nreq)(push arg args))
+ (setq restp t)
+ (return nil))
+ (when (eq arg '&aux)
+ (return nil))
+ (incf nreq)
+ (push arg args))
(setq args (nreverse args))
(setf (getf (getf initargs :plist) :arg-info) (cons nreq restp))
(make-method-initargs-form-internal1
(defun make-method-initargs-form-internal1
(initargs body req-args lmf-params restp)
- (multiple-value-bind (outer-decls inner-decls body)
+ (multiple-value-bind (outer-decls inner-decls body-sans-decls)
(split-declarations
body req-args (getf (cdr lmf-params) :call-next-method-p))
(let* ((rest-arg (when restp '.rest-arg.))
(args+rest-arg (if restp
(append req-args (list rest-arg))
req-args)))
- `(list* :fast-function
- (lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
- (declare (ignorable .pv-cell. .next-method-call.))
- ,@outer-decls
- (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
- &rest forms)
- (declare (ignore pv-table-symbol pv-parameters))
- `(let ((,pv (car .pv-cell.))
- (,calls (cdr .pv-cell.)))
- (declare ,(make-pv-type-declaration pv)
- ,(make-calls-type-declaration calls))
- ,pv ,calls
- ,@forms)))
- (fast-lexical-method-functions
- (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
- ,@(cdddr lmf-params))
- ,@inner-decls
- ,@body)))
+ `(list*
+ :fast-function
+ (named-lambda
+ ,(or (body-method-name body) '.method.) ; function name
+ (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
+ ;; body of the function
+ (declare (ignorable .pv-cell. .next-method-call.))
+ ,@outer-decls
+ (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+ &rest forms)
+ (declare (ignore pv-table-symbol
+ pv-parameters))
+ `(let ((,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv)
+ ,(make-calls-type-declaration calls))
+ ,pv ,calls
+ ,@forms)))
+ (fast-lexical-method-functions
+ (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+ ,@(cdddr lmf-params))
+ ,@inner-decls
+ ,@body-sans-decls)))
',initargs))))
;;; Use arrays and hash tables and the fngen stuff to make this much
walked-arglist
walked-body))))
-(defun walk-named-lambda (form context old-env)
- (walker-environment-bind (new-env old-env)
- (let* ((name (cadr form))
- (arglist (caddr form))
- (body (cdddr form))
- (walked-arglist (walk-arglist arglist context new-env))
- (walked-body
- (walk-declarations body #'walk-repeat-eval new-env)))
- (relist* form
- (car form)
- name
- walked-arglist
- walked-body))))
-
(defun walk-setq (form context env)
(if (cdddr form)
(let* ((expanded (let ((rforms nil)
:ALLTEST-LEGACY-1613
:ALLTEST-LEGACY-1715
:ALLTEST-LEGACY-1723
+
+ ;; bug 45c
+ #+(and linux x86) :ALLTEST-LEGACY-1814
+ #+(and linux x86) :ALLTEST-LEGACY-1818
+ #+(and linux x86) :ALLTEST-LEGACY-1822
+ #+(and linux x86) :ALLTEST-LEGACY-1826
+ #+(and linux x86) :ALLTEST-LEGACY-1830
+ #+(and linux x86) :ALLTEST-LEGACY-1834
+ #+(and linux x86) :ALLTEST-LEGACY-1838
+ #+(and linux x86) :ALLTEST-LEGACY-1842
+
:ALLTEST-LEGACY-2204
:CLOS-LEGACY-170
:CMUCL-BUGS-LEGACY-292
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.0.5"
+"0.7.0.6"
projects / sbcl.git / commitdiff