pointers. (reported by Sean Ross)
* bug fix: PROFILE output is printed nicely even for large numerical
values. (thanks to Zach Beane)
+ * bug fix: streams with element-type (SIGNED-BYTE <N>) for <N>
+ greater than 32 handle EOF correctly.
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
(define-condition nil-array-accessed-error (type-error)
()
(:report (lambda (condition stream)
+ (declare (ignore condition))
(format stream
"An attempt to access an array of element-type ~
NIL was made. Congratulations!"))))
;;; objects
(defun just-dump-it-normally (object &optional (env nil env-p))
(declare (type structure!object object))
- (declare (ignorable env env-p))
+ (declare (ignorable env env-p object))
;; KLUDGE: we require essentially three different behaviours of
;; JUST-DUMP-IT-NORMALLY, two of which (host compiler's
;; MAKE-LOAD-FORM, cross-compiler's MAKE-LOAD-FORM) are handled by
(let ((,element-var
(catch 'eof-input-catcher
(input-at-least ,stream-var ,bytes)
- ,@read-forms)))
+ (locally ,@read-forms))))
(cond (,element-var
(incf (fd-stream-ibuf-head ,stream-var) ,bytes)
,element-var)
do (return-from pick-input-routine
(values
(lambda (stream eof-error eof-value)
- (let ((sap (fd-stream-ibuf-sap stream))
- (head (fd-stream-ibuf-head stream)))
- (loop for j from 0 below (/ i 8)
- with result = 0
- do (setf result
- (+ (* 256 result)
- (sap-ref-8 sap (+ head j))))
- finally (return (dpb result (byte i 0) -1)))))
+ (input-wrapper (stream (/ i 8) eof-error eof-value)
+ (let ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream)))
+ (loop for j from 0 below (/ i 8)
+ with result = 0
+ do (setf result
+ (+ (* 256 result)
+ (sap-ref-8 sap (+ head j))))
+ finally (return (dpb result (byte i 0) -1))))))
`(signed-byte ,i)
(/ i 8)))))
:IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
See the manual for details."
+ (declare (ignore external-format)) ; FIXME: CHECK-TYPE? WARN-if-not?
+
;; Calculate useful stuff.
(multiple-value-bind (input output mask)
(case direction
;;; Signal the appropriate condition when we get a floating-point error.
(defun sigfpe-handler (signal info context)
- (declare (ignore signal info context))
+ (declare (ignore signal info))
(declare (type system-area-pointer context))
(let* ((modes (context-floating-point-modes
(sb!alien:sap-alien context (* os-context-t))))
;; corresponding argument was a list.
(t (values 1 1 remaining))))))
(walk-conditional (conditional directives args)
- (declare (ignore args))
(let ((*default-format-error-offset*
(1- (format-directive-end conditional))))
(multiple-value-bind (sublists last-semi-with-colon-p remaining)
(parse-conditional-directive directives)
(declare (ignore last-semi-with-colon-p))
- (let ((sub-max (loop for s in sublists
- maximize (nth-value 1 (walk-directive-list s args)))))
+ (let ((sub-max
+ (loop for s in sublists
+ maximize (nth-value
+ 1 (walk-directive-list s args)))))
(cond
((format-directive-atsignp conditional)
(values 1 (max 1 sub-max) remaining))
((csubtypep type1 (specifier-type 'function)) nil)
(t :call-other-method)))
(!define-type-method (function :complex-union2) (type1 type2)
+ (declare (ignore type2))
+ ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming
+ ;; FUNCTION, then it is the union of the two; otherwise, there is no
+ ;; special union.
(cond
((type= type1 (specifier-type 'function)) type1)
(t nil)))
(bin #'concatenated-bin)
(n-bin #'concatenated-n-bin)
(misc #'concatenated-misc))
- (:constructor %make-concatenated-stream
- (&rest streams &aux (current streams)))
+ (:constructor %make-concatenated-stream (&rest streams))
(:copier nil))
;; The car of this is the substream we are reading from now.
(streams nil :type list))
dst-end))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
- (declare (ignore arg1 arg2))
+ (declare (ignore arg2))
(case operation
(:file-position
(let ((buffer (fill-pointer-output-stream-string stream)))
#!+sb-doc
"Load the file given by FILESPEC into the Lisp environment, returning
T on success."
-
+ (declare (ignore external-format))
(let ((*load-depth* (1+ *load-depth*))
;; KLUDGE: I can't find in the ANSI spec where it says that
;; DECLAIM/PROCLAIM of optimization policy should have file
;;;; queues, locks
;; spinlocks use 0 as "free" value: higher-level locks use NIL
-(defun get-spinlock (lock offset new-value) )
+(defun get-spinlock (lock offset new-value)
+ (declare (ignore lock offset new-value)))
(defmacro with-spinlock ((queue) &body body)
+ (declare (ignore queue))
`(progn ,@body))
;;;; the higher-level locking operations are based on waitqueues
;;;; job control
(defun init-job-control () t)
-(defun debugger-wait-until-foreground-thread (stream) t)
+(defun debugger-wait-until-foreground-thread (stream)
+ (declare (ignore stream))
+ t)
(defun get-foreground () t)
-(defun release-foreground (&optional next) t)
+(defun release-foreground (&optional next)
+ (declare (ignore next))
+ t)
(defun terminate-session ())
(in-package "SB!THREAD")
(sb!xc:defmacro with-recursive-lock ((mutex) &body body)
+ (declare (ignore #!-sb-thread mutex))
#!+sb-thread
(with-unique-names (cfp)
`(let ((,cfp (sb!kernel:current-fp)))
(if (< unix-time (ash 1 31))
unix-time
(multiple-value-bind (year offset) (years-since-mar-2000 utime)
+ (declare (ignore year))
(+ +mar-1-2035+ (- unix-to-universal-time) offset)))))
(defun decode-universal-time (universal-time &optional time-zone)
(declaim (inline adjust-fixup-array))
(defun adjust-fixup-array (array size)
- (let ((length (length array))
- (new (make-array size :element-type '(unsigned-byte 32))))
+ (let ((new (make-array size :element-type '(unsigned-byte 32))))
(replace new array)
new))
(ctran (node-next node))
(tail (component-tail (block-component block)))
(succ (first (block-succ block))))
+ (declare (ignore lvar))
(unless (or (and (eq node (block-last block)) (eq succ tail))
(block-delete-p block))
(when (eq (node-derived-type node) *empty-type*)
;;; whereas NEXT is a variable naming a CTRAN in the body. -- CSR,
;;; 2004-03-30.
(defmacro with-dynamic-extent ((start body-start next kind) &body body)
+ (declare (ignore kind))
(with-unique-names (cleanup next-ctran)
`(progn
(ctran-starts-block ,body-start)
(source-name '.anonymous.)
debug-name
allow-debug-catch-tag)
+ (declare (ignore allow-debug-catch-tag))
(destructuring-bind (decls macros symbol-macros &rest body)
(if (eq (car fun) 'lambda-with-lexenv)
(cdr fun)
(when (lambda-var-ignorep var)
;; (ANSI's specification for the IGNORE declaration requires
;; that this be a STYLE-WARNING, not a full WARNING.)
- (compiler-style-warn "reading an ignored variable: ~S" name)))
+ #-sb-xc-host
+ (compiler-style-warn "reading an ignored variable: ~S" name)
+ ;; there's no need for us to accept ANSI's lameness when
+ ;; processing our own code, though.
+ #+sb-xc-host
+ (compiler-warn "reading an ignored variable: ~S" name)))
(reference-leaf start next result var))
(cons
(aver (eq (car var) 'MACRO))
(unless (policy *compiler-error-context* (= inhibit-warnings 3))
;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
;; requires this to be no more than a STYLE-WARNING.
+ #-sb-xc-host
(compiler-style-warn "The variable ~S is defined but never used."
- (leaf-debug-name var)))
+ (leaf-debug-name var))
+ ;; There's no reason to accept this kind of equivocation
+ ;; when compiling our own code, though.
+ #+sb-xc-host
+ (compiler-warn "The variable ~S is defined but never used."
+ (leaf-debug-name var)))
(setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
(values))
;;; exits to CONT in that entry, then return it, otherwise return NIL.
(defun find-nlx-info (exit)
(declare (type exit exit))
- (let* ((entry (exit-entry exit))
- (entry-cleanup (entry-cleanup entry)))
+ (let ((entry (exit-entry exit)))
(dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
(when (eq (nlx-info-exit nlx) exit)
(return nlx)))))
(defun find-template-result-types (call template rtypes)
(declare (type combination call)
(type template template) (list rtypes))
+ (declare (ignore template))
(let* ((dtype (node-derived-type call))
(type dtype)
(types (mapcar #'primitive-type
;;; lvar LOC.
;;; -- We don't know what it is.
(defun fun-lvar-tn (node block lvar)
+ (declare (ignore node block))
(declare (type lvar lvar))
(let ((2lvar (lvar-info lvar)))
(if (eq (ir2-lvar-kind 2lvar) :delayed)
(defun template-args-ok (template call safe-p)
(declare (type template template)
(type combination call))
+ (declare (ignore safe-p))
(let ((mtype (template-more-args-type template)))
(do ((args (basic-combination-args call) (cdr args))
(types (template-arg-types template) (cdr types)))
`(progn
(declaim (ftype (function (ctran ctran (or lvar null) t) (values))
,fn-name))
- (defun ,fn-name (,start-var ,next-var ,result-var ,n-form)
- (let ((,n-env *lexenv*))
- ,@decls
- ,body
- (values)))
+ (defun ,fn-name (,start-var ,next-var ,result-var ,n-form
+ &aux (,n-env *lexenv*))
+ (declare (ignorable ,start-var ,next-var ,result-var))
+ ,@decls
+ ,body
+ (values))
,@(when doc
`((setf (fdocumentation ',name 'function) ,doc)))
;; FIXME: Evidently "there can only be one!" -- we overwrite any
(let ((n-args (gensym)))
`(progn
(defun ,name (,n-node ,@vars)
+ (declare (ignorable ,@vars))
(let ((,n-args (basic-combination-args ,n-node)))
,(parse-deftransform lambda-list body n-args
`(return-from ,name nil))))
(values nil t t)))
(defun logand-derive-type-aux (x y &optional same-leaf)
- (declare (ignore same-leaf))
+ (when same-leaf
+ (return-from logand-derive-type-aux x))
(multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
(declare (ignore x-pos))
(multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
(specifier-type 'integer)))))))
(defun logior-derive-type-aux (x y &optional same-leaf)
- (declare (ignore same-leaf))
+ (when same-leaf
+ (return-from logior-derive-type-aux x))
(multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
(multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
(cond
(specifier-type 'integer))))))))
(defun logxor-derive-type-aux (x y &optional same-leaf)
- (declare (ignore same-leaf))
+ (when same-leaf
+ (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
(multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
(multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
(cond
(defoptimizer (logeqv derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf)
(lognot-derive-type-aux
- (logxor-derive-type-aux x y same-leaf)))
+ (logxor-derive-type-aux x y same-leaf)))
#'logeqv))
(defoptimizer (lognand derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf)
(lognot-derive-type-aux
(logior-derive-type-aux x y same-leaf)))
#'lognor))
+;;; FIXME: use SAME-LEAF instead of ignoring it.
(defoptimizer (logandc1 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf)
- (logand-derive-type-aux
- (lognot-derive-type-aux x) y nil))
+ (if same-leaf
+ (specifier-type '(eql 0))
+ (logand-derive-type-aux
+ (lognot-derive-type-aux x) y nil)))
#'logandc1))
(defoptimizer (logandc2 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf)
- (logand-derive-type-aux
- x (lognot-derive-type-aux y) nil))
+ (if same-leaf
+ (specifier-type '(eql 0))
+ (logand-derive-type-aux
+ x (lognot-derive-type-aux y) nil)))
#'logandc2))
(defoptimizer (logorc1 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf)
- (logior-derive-type-aux
- (lognot-derive-type-aux x) y nil))
+ (if same-leaf
+ (specifier-type '(eql -1))
+ (logior-derive-type-aux
+ (lognot-derive-type-aux x) y nil)))
#'logorc1))
(defoptimizer (logorc2 derive-type) ((x y))
(two-arg-derive-type x y (lambda (x y same-leaf)
- (logior-derive-type-aux
- x (lognot-derive-type-aux y) nil))
+ (if same-leaf
+ (specifier-type '(eql -1))
+ (logior-derive-type-aux
+ x (lognot-derive-type-aux y) nil)))
#'logorc2))
\f
;;;; miscellaneous derive-type methods
(new-end end)
(cleanup (block-end-cleanup block))
(found-similar-p nil))
+ (declare (ignore #-nil cleanup))
(dolist (succ (block-succ block))
#+nil
(when (and (< block succ)
;;; Do source transformation for TYPEP of a known union type. If a
;;; union type contains LIST, then we pull that out and make it into a
-;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
-;;; will be a subtype even without there being any (member NIL). We
-;;; just drop through to the general code in this case, rather than
-;;; trying to optimize it.
+;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
+;;; will be a subtype even without there being any (member NIL). We
+;;; currently just drop through to the general code in this case,
+;;; rather than trying to optimize it (but FIXME CSR 2004-04-05: it
+;;; wouldn't be hard to optimize it after all).
(defun source-transform-union-typep (object type)
(let* ((types (union-type-types type))
- (type-list (specifier-type 'list))
(type-cons (specifier-type 'cons))
(mtype (find-if #'member-type-p types))
(members (when mtype (member-type-members mtype))))
;;; this is the right thing to do anyway; omitting them can lead to
;;; system corruption on conforming code. -- CSR
(defun maybe-fp-wait (node &optional note-next-instruction)
+ (declare (ignore node))
#+nil
(when (policy node (or (= debug 3) (> safety speed))))
(when note-next-instruction
`(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
(let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
slot-vars pv-parameters))
- ,@body)))
+ (declare (ignorable ,@(mapcar #'identity slot-vars)))
+ ,@body)))
;;; This gets used only when the default MAKE-METHOD-LAMBDA is
;;; overridden.
;;; the end of string and the string is adjustable the string will be
;;; implicitly extended, otherwise an error will be signalled. The
;;; latter case is provided for in the code, but not currently
-;;; excercised since SBCL fill-pointer arrays are always (currently) adjustable.
+;;; excercised since SBCL fill-pointer arrays are always (currently)
+;;; adjustable.
;;;
;;; * END will refer to the ARRAY-TOTAL-SIZE of string, not
;;; FILL-POINTER, since by definition the FILE-POSITION will always be
;;; a FILL-POINTER, so that would be of limited use.
;;;
-;;; * Rewinding the stream works with owerwriting semantics.
+;;; * Rewinding the stream works with overwriting semantics.
;;;
#+nil (let ((str (make-array 0
:element-type 'character
(frob 'character)
(frob 'base-char)
(frob 'nil))
+
+(with-open-file (s "/dev/null" :element-type '(signed-byte 48))
+ (assert (eq :eof (read-byte s nil :eof))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.9.35"
+"0.8.9.36"
projects / sbcl.git / commitdiff