b. For the example above, the compiler does not issue a note.
+279: type propagation error -- correctly inferred type goes astray?
+ In sbcl-0.8.3 and sbcl-0.8.1.47, the warning
+ The binding of ABS-FOO is a (VALUES (INTEGER 0 0)
+ &OPTIONAL), not a (INTEGER 1 536870911)
+ is emitted when compiling this file:
+ (declaim (ftype (function ((integer 0 #.most-positive-fixnum))
+ (integer #.most-negative-fixnum 0))
+ foo))
+ (defun foo (x)
+ (- x))
+ (defun bar (x)
+ (let* (;; Uncomment this for a type mismatch warning indicating
+ ;; that the type of (FOO X) is correctly understood.
+ #+nil (fs-foo (float-sign (foo x)))
+ ;; Uncomment this for a type mismatch warning
+ ;; indicating that the type of (ABS (FOO X)) is
+ ;; correctly understood.
+ #+nil (fs-abs-foo (float-sign (abs (foo x))))
+ ;; something wrong with this one though
+ (abs-foo (abs (foo x))))
+ (declare (type (integer 1 100) abs-foo))
+ (print abs-foo)))
+
+280: bogus WARNING about duplicate function definition
+ In sbcl-0.8.3 and sbcl-0.8.1.47, if BS.MIN is defined inline,
+ e.g. by
+ (declaim (inline bs.min))
+ (defun bs.min (bases) nil)
+ before compiling the file below, the compiler warns
+ Duplicate definition for BS.MIN found in one static
+ unit (usually a file).
+ when compiling
+ (declaim (special *minus* *plus* *stagnant*))
+ (defun b.*.min (&optional (x () xp) (y () yp) &rest rest)
+ (bs.min avec))
+ (define-compiler-macro b.*.min (&rest rest)
+ `(bs.min ,@rest))
+ (defun afish-d-rbd (pd)
+ (if *stagnant*
+ (b.*.min (foo-d-rbd *stagnant*))
+ (multiple-value-bind (reduce-fn initial-value)
+ (etypecase pd
+ (list (values #'bs.min 0))
+ (vector (values #'bs.min *plus*)))
+ (let ((cv-ks (cv (kpd.ks pd))))
+ (funcall reduce-fn d-rbds)))))
+ (defun bfish-d-rbd (pd)
+ (if *stagnant*
+ (b.*.min (foo-d-rbd *stagnant*))
+ (multiple-value-bind (reduce-fn initial-value)
+ (etypecase pd
+ (list (values #'bs.min *minus*))
+ (vector (values #'bs.min 0)))
+ (let ((cv-ks (cv (kpd.ks pd))))
+ (funcall reduce-fn d-rbds)))))
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
\f
;;;; various sequencing constructs
-(defmacro-mundanely prog (varlist &body body-decls)
- (multiple-value-bind (body decls) (parse-body body-decls nil)
- `(block nil
- (let ,varlist
- ,@decls
- (tagbody ,@body)))))
-
-(defmacro-mundanely prog* (varlist &body body-decls)
- (multiple-value-bind (body decls) (parse-body body-decls nil)
- `(block nil
- (let* ,varlist
- ,@decls
- (tagbody ,@body)))))
+(flet ((prog-expansion-from-let (varlist body-decls let)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
+ `(block nil
+ (,let ,varlist
+ ,@decls
+ (tagbody ,@body))))))
+ (defmacro-mundanely prog (varlist &body body-decls)
+ (prog-expansion-from-let varlist body-decls 'let))
+ (defmacro-mundanely prog* (varlist &body body-decls)
+ (prog-expansion-from-let varlist body-decls 'let*)))
(defmacro-mundanely prog1 (result &body body)
(let ((n-result (gensym)))
;; environment. We spuriously reference the gratuitous variable,
;; since we don't want to use IGNORABLE on what might be a special
;; var.
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let ((n-list (gensym)))
`(do* ((,n-list ,list (cdr ,n-list)))
((endp ,n-list)
;;; Iterate over the entries in a HASH-TABLE.
(defmacro dohash ((key-var value-var table &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let ((gen (gensym))
(n-more (gensym)))
`(with-hash-table-iterator (,gen ,table)
(return (eval-in-lexenv (first i) lexenv)))))
(defun eval-locally (exp lexenv &optional vars)
- (multiple-value-bind (body decls) (parse-body (rest exp) nil)
+ (multiple-value-bind (body decls)
+ (parse-body (rest exp) :doc-string-allowed nil)
(let ((lexenv
;; KLUDGE: Uh, yeah. I'm not anticipating
;; winning any prizes for this code, which was
;;;; WITH-FOO i/o-related macros
(defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(let ((abortp (gensym)))
`(let ((,var ,stream)
(,abortp t))
(defmacro-mundanely with-input-from-string ((var string &key index start end)
&body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
;; The ONCE-ONLY inhibits compiler note for unreachable code when
;; END is true.
(once-only ((string string))
(defmacro-mundanely with-output-to-string
((var &optional string &key (element-type ''character))
&body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(if string
`(let ((,var (make-fill-pointer-output-stream ,string)))
,@decls
"DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
Executes the FORMs at least once for each symbol accessible in the given
PACKAGE with VAR bound to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
"DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
Executes the FORMs once for each external symbol in the given PACKAGE with
VAR bound to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
"DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
Executes the FORMs once for each symbol in every package with VAR bound
to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
;;;
;;; If DOC-STRING-ALLOWED is NIL, then no forms will be treated as
;;; documentation strings.
-(defun parse-body (body &optional (doc-string-allowed t))
+(defun parse-body (body &key (doc-string-allowed t) (toplevel nil))
(let ((reversed-decls nil)
(forms body)
(doc nil))
- ;; Since we don't have macros like AND, OR, and NOT yet, it's
- ;; hard to express these tests clearly. Giving them names
- ;; seems to help a little bit.
+ ;; Since we don't have macros like AND, OR, and NOT yet, it's hard
+ ;; to express these tests clearly. Giving them names seems to help
+ ;; a little bit.
(flet ((doc-string-p (x remaining-forms)
(if (stringp x)
- (if doc-string-allowed
- ;; ANSI 3.4.11 explicitly requires that a doc
- ;; string be followed by another form (either an
- ;; ordinary form or a declaration). Hence:
- (if remaining-forms
- (if doc
- ;; ANSI 3.4.11 says that the consequences of
- ;; duplicate doc strings are unspecified.
- ;; That's probably not something the
- ;; programmer intends. We raise an error so
- ;; that this won't pass unnoticed.
- (error "duplicate doc string ~S" x)
- t)))))
+ (if doc-string-allowed
+ ;; ANSI 3.4.11 explicitly requires that a doc
+ ;; string be followed by another form (either an
+ ;; ordinary form or a declaration). Hence:
+ (if remaining-forms
+ (if doc
+ ;; ANSI 3.4.11 says that the consequences of
+ ;; duplicate doc strings are unspecified.
+ ;; That's probably not something the
+ ;; programmer intends. We raise an error so
+ ;; that this won't pass unnoticed.
+ (error "duplicate doc string ~S" x)
+ t)))))
(declaration-p (x)
(if (consp x)
(let ((name (car x)))
- (if (eq name 'declaim)
- ;; technically legal, but rather unlikely to
- ;; be what the user intended...
- (progn
- (style-warn
- "DECLAIM where DECLARE was probably intended")
- nil)
- (eq name 'declare))))))
+ (case name
+ ((declare) t)
+ ((declaim)
+ (unless toplevel
+ ;; technically legal, but rather unlikely to
+ ;; be what the user meant to do...
+ (style-warn
+ "DECLAIM where DECLARE was probably intended")
+ nil))
+ (t nil))))))
(tagbody
:again
(if forms
- (let ((form1 (first forms)))
- ;; Note: The (IF (IF ..) ..) stuff is because we don't
- ;; have the macro AND yet.:-|
- (if (doc-string-p form1 (rest forms))
- (setq doc form1)
- (if (declaration-p form1)
- (setq reversed-decls
- (cons form1 reversed-decls))
- (go :done)))
- (setq forms (rest forms))
- (go :again)))
+ (let ((form1 (first forms)))
+ ;; Note: The (IF (IF ..) ..) stuff is because we don't
+ ;; have the macro AND yet.:-|
+ (if (doc-string-p form1 (rest forms))
+ (setq doc form1)
+ (if (declaration-p form1)
+ (setq reversed-decls
+ (cons form1 reversed-decls))
+ (go :done)))
+ (setq forms (rest forms))
+ (go :again)))
:done)
(values forms
(nreverse reversed-decls)
(defvar *ignorable-vars*)
(declaim (type list *ignorable-vars*))
-;;; Return, as multiple values, a body, possibly a declare form to put
+;;; Return, as multiple values, a body, possibly a DECLARE form to put
;;; where this code is inserted, the documentation for the parsed
;;; body, and bounds on the number of arguments.
(defun parse-defmacro (lambda-list arg-list-name body name error-kind
(error-fun 'error)
(wrap-block t))
(multiple-value-bind (forms declarations documentation)
- (parse-body body doc-string-allowed)
+ (parse-body body :doc-string-allowed doc-string-allowed)
(let ((*arg-tests* ())
(*user-lets* ())
(*system-lets* ())
(t (illegal-varlist)))))
(t (illegal-varlist)))))
;; Construct the new form.
- (multiple-value-bind (code decls) (parse-body decls-and-code nil)
+ (multiple-value-bind (code decls)
+ (parse-body decls-and-code :doc-string-allowed nil)
`(block ,block
(,bind ,(nreverse r-inits)
,@decls
(sb!xc:defmacro define-sequence-traverser (name args &body body)
(multiple-value-bind (body declarations docstring)
- (parse-body body t)
+ (parse-body body :doc-string-allowed t)
(collect ((new-args) (new-declarations) (adjustments))
(dolist (arg args)
(case arg
(if (eq '&whole (car arglist))
(values (cadr arglist) (cddr arglist))
(values (gensym) arglist))
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
`(progn
(!cold-init-forms
(setf (info :type :translator ',name)
evaluated."
(if (null bindings)
(ir1-translate-locally body start cont)
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let)
(let* ((fun-cont (make-continuation))
(cont (processing-decls (decls vars nil cont)
"LET* ({(Var [Value]) | Var}*) Declaration* Form*
Similar to LET, but the variables are bound sequentially, allowing each Value
form to reference any of the previous Vars."
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
(multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
(processing-decls (decls vars nil cont)
(ir1-convert-aux-bindings start cont forms vars values)))))
;;; forms before we hit the IR1 transform level.
(defun ir1-translate-locally (body start cont &key vars funs)
(declare (type list body) (type continuation start cont))
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(processing-decls (decls vars funs cont)
(ir1-convert-progn-body start cont forms))))
Evaluate the Body-Forms with some local function definitions. The bindings
do not enclose the definitions; any use of Name in the Forms will refer to
the lexically apparent function definition in the enclosing environment."
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'flet)
(let ((fvars (mapcar (lambda (n d)
Evaluate the Body-Forms with some local function definitions. The bindings
enclose the new definitions, so the defined functions can call themselves or
each other."
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(multiple-value-bind (names defs)
(extract-flet-vars definitions 'labels)
(let* ( ;; dummy LABELS functions, to be used as placeholders
;;; We parse declarations and then recursively process the body.
(defun process-toplevel-locally (body path compile-time-too &key vars funs)
(declare (list path))
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil :toplevel t)
(let* ((*lexenv* (process-decls decls vars funs))
;; FIXME: VALUES declaration
;;
;;; a function.
;;;
;;; Given the continuation ARG, derive the resulting type using the
-;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some
+;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
;;; "atomic" continuation type like numeric-type or member-type
;;; (containing just one element). It should return the resulting
;;; type, which can be a list of types.
;;;
-;;; For the case of member types, if a member-fcn is given it is
+;;; For the case of member types, if a MEMBER-FUN is given it is
;;; called to compute the result otherwise the member type is first
-;;; converted to a numeric type and the derive-fcn is call.
-(defun one-arg-derive-type (arg derive-fcn member-fcn
+;;; converted to a numeric type and the DERIVE-FUN is called.
+(defun one-arg-derive-type (arg derive-fun member-fun
&optional (convert-type t))
- (declare (type function derive-fcn)
- (type (or null function) member-fcn))
+ (declare (type function derive-fun)
+ (type (or null function) member-fun))
(let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
(when arg-list
(flet ((deriver (x)
(typecase x
(member-type
- (if member-fcn
+ (if member-fun
(with-float-traps-masked
(:underflow :overflow :divide-by-zero)
(make-member-type
:members (list
- (funcall member-fcn
+ (funcall member-fun
(first (member-type-members x))))))
;; Otherwise convert to a numeric type.
(let ((result-type-list
- (funcall derive-fcn (convert-member-type x))))
+ (funcall derive-fun (convert-member-type x))))
(if convert-type
(convert-back-numeric-type-list result-type-list)
result-type-list))))
(numeric-type
(if convert-type
(convert-back-numeric-type-list
- (funcall derive-fcn (convert-numeric-type x)))
- (funcall derive-fcn x)))
+ (funcall derive-fun (convert-numeric-type x)))
+ (funcall derive-fun x)))
(t
*universal-type*))))
;; Run down the list of args and derive the type of each one,
(first results)))))))
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
-;;; two arguments. DERIVE-FCN takes 3 args in this case: the two
+;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
;;; original args and a third which is T to indicate if the two args
;;; really represent the same continuation. This is useful for
;;; deriving the type of things like (* x x), which should always be
;;; positive. If we didn't do this, we wouldn't be able to tell.
-(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
+(defun two-arg-derive-type (arg1 arg2 derive-fun fun
&optional (convert-type t))
- (declare (type function derive-fcn fcn))
+ (declare (type function derive-fun fun))
(flet ((deriver (x y same-arg)
(cond ((and (member-type-p x) (member-type-p y))
(let* ((x (first (member-type-members x)))
(result (with-float-traps-masked
(:underflow :overflow :divide-by-zero
:invalid)
- (funcall fcn x y))))
+ (funcall fun x y))))
(cond ((null result))
((and (floatp result) (float-nan-p result))
(make-numeric-type :class 'float
((and (member-type-p x) (numeric-type-p y))
(let* ((x (convert-member-type x))
(y (if convert-type (convert-numeric-type y) y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
((and (numeric-type-p x) (member-type-p y))
(let* ((x (if convert-type (convert-numeric-type x) x))
(y (convert-member-type y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
((and (numeric-type-p x) (numeric-type-p y))
(let* ((x (if convert-type (convert-numeric-type x) x))
(y (if convert-type (convert-numeric-type y) y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
(t
(specifier-type 'integer))))))
-(macrolet ((deffrob (logfcn)
- (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
- `(defoptimizer (,logfcn derive-type) ((x y))
- (two-arg-derive-type x y #',fcn-aux #',logfcn)))))
+(macrolet ((deffrob (logfun)
+ (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
+ `(defoptimizer (,logfun derive-type) ((x y))
+ (two-arg-derive-type x y #',fun-aux #',logfun)))))
(deffrob logand)
(deffrob logior)
(deffrob logxor))
env))))
(defun add-method-declarations (name qualifiers lambda-list body env)
+ (declare (ignore env))
(multiple-value-bind (parameters unspecialized-lambda-list specializers)
(parse-specialized-lambda-list lambda-list)
(declare (ignore parameters))
(multiple-value-bind (real-body declarations documentation)
- (parse-body body env)
+ (parse-body body)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
;; (Old PCL code used a somewhat different style of
is not a lambda form."
method-lambda))
(multiple-value-bind (real-body declarations documentation)
- (parse-body (cddr method-lambda) env)
+ (parse-body (cddr method-lambda))
(let* ((name-decl (get-declaration '%method-name declarations))
(sll-decl (get-declaration '%method-lambda-list declarations))
(method-name (when (consp name-decl) (car name-decl)))
(multiple-value-bind (walked-lambda-body
walked-declarations
walked-documentation)
- (parse-body (cddr walked-lambda) env)
+ (parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
(when (or next-method-p-p call-next-method-p)
(setq plist (list* :needs-next-methods-p t plist)))
;;; body given, or return NIL if no %METHOD-NAME declaration is found.
(defun body-method-name (body)
(multiple-value-bind (real-body declarations documentation)
- (parse-body body nil)
- (declare (ignore documentation real-body))
+ (parse-body body)
+ (declare (ignore real-body documentation))
(let ((name-decl (get-declaration '%method-name declarations)))
(and name-decl
(destructuring-bind (name) name-decl
;;; with something arbitrary in the fourth field, is used for CVS
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
-"0.8.3.2"
+"0.8.3.3"
projects / sbcl.git / commitdiff