From: Christophe Rhodes Date: Tue, 13 Apr 2004 10:30:37 +0000 (+0000) Subject: 0.8.9.36: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=15e14ef1ccd3ab6f4711632435a40493dc4cdd9d;p=sbcl.git 0.8.9.36: Commit "ignore during cross-compilation" patch (CSR sbcl-devel 2004-04-05) ... bad treatment of IGNORE now gets a full WARNING during cross-compilation; ... fix all the badness this reveals; ... implement SAME-ARG checking in LOGFOO type derivers; ... also add one more IGNORABLE in PCL (from Marcus Pearce); ... test for bad (signed-byte ) bug. --- diff --git a/NEWS b/NEWS index 2c100d6..d87a4a0 100644 --- a/NEWS +++ b/NEWS @@ -2381,6 +2381,8 @@ changes in sbcl-0.8.10 relative to sbcl-0.8.9: 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 ) for + greater than 32 handle EOF correctly. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/condition.lisp b/src/code/condition.lisp index a441310..7f66431 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -781,6 +781,7 @@ (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!")))) diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index 9ba54be..c16b0fc 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -75,7 +75,7 @@ ;;; 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 diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index fe180be..564f53b 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -574,7 +574,7 @@ (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) @@ -663,14 +663,15 @@ 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))))) @@ -1185,6 +1186,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 diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index fcb29d0..8aaae61 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -137,7 +137,7 @@ ;;; 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)))) diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 77597af..bd61b58 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -1245,14 +1245,15 @@ ;; 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)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 0c920c7..6992712 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -307,6 +307,10 @@ ((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))) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 5a256a3..2c008ba 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -789,8 +789,7 @@ (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)) @@ -1255,7 +1254,7 @@ 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))) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 07703d9..560ba0e 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -165,7 +165,7 @@ #!+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 diff --git a/src/code/target-unithread.lisp b/src/code/target-unithread.lisp index 651573d..6eb1df2 100644 --- a/src/code/target-unithread.lisp +++ b/src/code/target-unithread.lisp @@ -14,9 +14,11 @@ ;;;; 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 @@ -128,7 +130,11 @@ time we reacquire LOCK and return to the caller." ;;;; 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 ()) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index e1e0417..1f2ddcc 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -1,6 +1,7 @@ (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))) diff --git a/src/code/time.lisp b/src/code/time.lisp index 667a0ce..95fe90b 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -162,6 +162,7 @@ (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) diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index bd1935f..d49f487 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -69,8 +69,7 @@ (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)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index f630293..9bf0a58 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -740,6 +740,7 @@ (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*) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 3fcf355..88d3429 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -261,6 +261,7 @@ ;;; 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) @@ -966,6 +967,7 @@ (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) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 64f1f7d..a583be1 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -619,7 +619,12 @@ (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)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 538e95a..95f2e3f 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1149,8 +1149,14 @@ (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)) @@ -1466,8 +1472,7 @@ ;;; 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))))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index f54563c..2d27fa2 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -559,6 +559,7 @@ (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 @@ -857,6 +858,7 @@ ;;; 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) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 794e135..552f50d 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -434,6 +434,7 @@ (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))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index dbb41f9..835f5a3 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -58,11 +58,12 @@ `(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 @@ -513,6 +514,7 @@ (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)))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 71a2313..83fcba2 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2121,7 +2121,8 @@ (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) @@ -2153,7 +2154,8 @@ (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 @@ -2192,7 +2194,8 @@ (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 @@ -2230,7 +2233,7 @@ (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) @@ -2242,25 +2245,34 @@ (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)) ;;;; miscellaneous derive-type methods diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index 02839bf..65b51e6 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -65,6 +65,7 @@ (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) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 3956ca8..976b54a 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -243,13 +243,13 @@ ;;; 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)))) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index d3fd720..3eb240f 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -68,6 +68,7 @@ ;;; 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 diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 02bbe28..f75acf6 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -907,7 +907,8 @@ `(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. diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index 127333b..94da3af 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -160,13 +160,14 @@ ;;; 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 @@ -238,3 +239,6 @@ (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)))) diff --git a/version.lisp-expr b/version.lisp-expr index c6f28d8..0c2184a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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"