Menu
▾
▴
[Sbcl-commits] master: Deal with 3000 lines of warning output during make-target-2
|
From: Douglas K. <sn...@us...> - 2014-04-18 22:33:16
|
The branch "master" has been updated in SBCL:
via 2f2aff3a45d0eb7aeeebf2c58c113b126e70409a (commit)
from 9d1a7ca200a21dd6c7813323a4e04f15a3d40ad1 (commit)
- Log -----------------------------------------------------------------
commit 2f2aff3a45d0eb7aeeebf2c58c113b126e70409a
Author: Douglas Katzman <do...@go...>
Date: Fri Apr 18 18:22:16 2014 -0400
Deal with 3000 lines of warning output during make-target-2
---
src/cold/warm.lisp | 5 ++++-
src/pcl/boot.lisp | 12 +++++++-----
src/pcl/braid.lisp | 3 +--
src/pcl/compiler-support.lisp | 2 ++
src/pcl/defs.lisp | 16 ++++++----------
src/pcl/dfun.lisp | 1 +
src/pcl/fixup.lisp | 1 +
src/pcl/init.lisp | 1 +
src/pcl/low.lisp | 3 ++-
src/pcl/macros.lisp | 3 +++
src/pcl/methods.lisp | 5 ++++-
src/pcl/slots-boot.lisp | 2 --
src/pcl/std-class.lisp | 14 ++++++++------
src/pcl/vector.lisp | 10 ++--------
14 files changed, 42 insertions(+), 36 deletions(-)
diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp
index bab0527..f9bf542 100644
--- a/src/cold/warm.lisp
+++ b/src/cold/warm.lisp
@@ -198,7 +198,10 @@
(format t "~&deleted ~S~%" output-truename))))
;; Otherwise: success, just fall through.
(t nil))
- (unless (load output-truename)
+ (unless (handler-bind
+ ((sb-kernel:redefinition-with-defgeneric
+ #'muffle-warning))
+ (load output-truename))
(error "LOAD of ~S failed." output-truename))
(sb-int:/show "done loading" output-truename))))))
diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 6a8cc46..741525a 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -459,6 +459,7 @@ bootstrapping.
(defun make-defmethod-form
(name qualifiers specializers unspecialized-lambda-list
method-class-name initargs-form)
+ (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
(let (fn
fn-lambda)
(if (and (interned-symbol-p (fun-name-block-name name))
@@ -966,6 +967,7 @@ bootstrapping.
parameters-setqd closurep applyp method-cell))
&body body
&environment env)
+ (declare (ignore parameters-setqd))
(if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
`(locally
,@body)
@@ -1731,11 +1733,11 @@ bootstrapping.
(defvar *!early-generic-functions* ())
-(defun ensure-generic-function (fun-name
- &rest all-keys
- &key environment definition-source
- &allow-other-keys)
- (declare (ignore environment))
+;; CLHS doesn't specify &allow-other-keys here but I guess the supposition
+;; is that they'll be checked by ENSURE-GENERIC-FUNCTION-USING-CLASS.
+;; Except we don't do that either, so I think the blame, if any, lies there
+;; for not catching errant keywords.
+(defun ensure-generic-function (fun-name &rest all-keys)
(let ((existing (and (fboundp fun-name)
(gdefinition fun-name))))
(cond ((and existing
diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 1fde5e2..3565b52 100644
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -640,8 +640,7 @@
;;; installs the class in the Lisp type system.
(defun %update-lisp-class-layout (class layout)
;; Protected by *world-lock* in callers.
- (let ((classoid (layout-classoid layout))
- (olayout (class-wrapper class)))
+ (let ((classoid (layout-classoid layout)))
(unless (eq (classoid-layout classoid) layout)
(setf (layout-inherits layout)
(order-layout-inherits
diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp
index 6db8a5d..abc9466 100644
--- a/src/pcl/compiler-support.lisp
+++ b/src/pcl/compiler-support.lisp
@@ -52,6 +52,7 @@
(policy (lexenv-policy lexenv)))
(eql (cdr (assoc 'safety policy)) 3)))
+(declaim (ftype function sb-pcl::parse-specialized-lambda-list))
(define-source-context defmethod (name &rest stuff)
(let ((arg-pos (position-if #'listp stuff)))
(if arg-pos
@@ -83,6 +84,7 @@
(define-internal-pcl-function-name-syntax sb-pcl::slow-method (list)
(valid-function-name-p (cadr list)))
+(declaim (ftype function sb-pcl::std-instance-p sb-pcl::fsc-instance-p))
(define-internal-pcl-function-name-syntax sb-pcl::ctor (list)
(let ((class-or-name (cadr list)))
(cond
diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 6ac72de..3d3d2c2 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -509,16 +509,12 @@
;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
;;; these functions can access the SLOT-INFO directly, avoiding the overhead
;;; of accessing a standard-instance.
-(defstruct (slot-info (:constructor make-slot-info
- (&key slotd
- typecheck
- (type t)
- (reader
- (uninitialized-accessor-function :reader slotd))
- (writer
- (uninitialized-accessor-function :writer slotd))
- (boundp
- (uninitialized-accessor-function :boundp slotd)))))
+(defstruct (slot-info
+ (:constructor make-slot-info
+ (&key slotd typecheck
+ (reader (uninitialized-accessor-function :reader slotd))
+ (writer (uninitialized-accessor-function :writer slotd))
+ (boundp (uninitialized-accessor-function :boundp slotd)))))
(typecheck nil :type (or null function))
(reader (missing-arg) :type function)
(writer (missing-arg) :type function)
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 7fe8491..fbb6f7f 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -662,6 +662,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28
(declaim (inline make-callable))
(defun make-callable (gf methods generator method-alist wrappers)
+ (declare (ignore gf))
(let* ((*applicable-methods* methods)
(callable (function-funcall generator method-alist wrappers)))
callable))
diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp
index 3ba1153..40f90b2 100644
--- a/src/pcl/fixup.lisp
+++ b/src/pcl/fixup.lisp
@@ -28,6 +28,7 @@
(compute-standard-slot-locations)
(dolist (s '(condition function structure-object))
(dohash ((k v) (classoid-subclasses (find-classoid s)))
+ (declare (ignore v))
(find-class (classoid-name k))))
(setq **boot-state** 'complete)
diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 14475ea..439cace 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -137,6 +137,7 @@
(allocation nil allocationp)
(initargs nil initargsp)
(documentation nil docp))
+ (declare (ignore initform initfunction type))
(unless namep
(error 'slotd-initialization-error :initarg :name :kind :missing))
(unless (symbolp name)
diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index 9abb13b..2ae0b49 100644
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -178,6 +178,7 @@ comparison.")
;;; In all cases, SET-FUN-NAME must return the new (or same)
;;; function. (Unlike other functions to set stuff, it does not return
;;; the new value.)
+(declaim (ftype function class-of))
(defun set-fun-name (fun new-name)
#+sb-doc
"Set the name of a compiled function object. Return the function."
@@ -190,7 +191,7 @@ comparison.")
(setf (sb-eval:interpreted-function-name fun) new-name))
(funcallable-instance ;; KLUDGE: probably a generic function...
(cond ((if (eq **boot-state** 'complete)
- (typep fun 'generic-function)
+ (typep fun 'generic-function) ; FIXME: inefficient forward-ref
(eq (class-of fun) *the-class-standard-generic-function*))
(setf (%funcallable-instance-info fun 2) new-name))
(t
diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index 437e802..a7bfd58 100644
--- a/src/pcl/macros.lisp
+++ b/src/pcl/macros.lisp
@@ -71,6 +71,7 @@
(defvar *create-classes-from-internal-structure-definitions-p* t)
+(declaim (ftype function ensure-non-standard-class))
(defun find-class-from-cell (symbol cell &optional (errorp t))
(or (when cell
(or (classoid-cell-pcl-class cell)
@@ -119,10 +120,12 @@
(find-class-from-cell ',symbol ,cell nil))))))
form))
+(declaim (ftype function class-wrapper))
(declaim (inline class-classoid))
(defun class-classoid (class)
(layout-classoid (class-wrapper class)))
+(declaim (ftype function %set-class-type-translation update-ctors))
(defun (setf find-class) (new-value name &optional errorp environment)
(declare (ignore errorp environment))
(cond ((legal-class-name-p name)
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 40e5883..2ed6c9f 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -80,6 +80,7 @@
(invalid-method-initarg method "~@<~S of ~S is neither ~S nor a ~S.~@:>"
:documentation doc 'null 'string)))
(defun check-lambda-list (method ll)
+ (declare (ignore method ll))
nil)
(defun check-method-function (method fun)
@@ -99,6 +100,7 @@
q :qualifiers qualifiers 'null)))))
(defun check-slot-name (method name)
+ (declare (ignore method))
(unless (symbolp name)
(invalid-method-initarg "~@<~S of ~S is not a ~S.~@:>"
:slot-name name 'symbol)))
@@ -575,9 +577,10 @@
;; it would be bad to unwind and leave the gf in an inconsistent
;; state.
(sb-thread::with-recursive-system-lock (lock)
- (let* ((specializers (method-specializers method))
+ (let* ((specializers (method-specializers method)) ; flushable?
(methods (generic-function-methods generic-function))
(new-methods (remove method methods)))
+ (declare (ignore specializers))
(setf (method-generic-function method) nil
(generic-function-methods generic-function) new-methods)
(dolist (specializer (method-specializers method))
diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 8a5993b..1bbb501 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -483,7 +483,6 @@
(find-class class-or-name nil))))
(defun make-std-reader-method-function (class-or-name slot-name)
- (declare (ignore class-or-name))
(ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'reader t)
(:standard
(let* ((initargs (copy-tree
@@ -544,7 +543,6 @@
initargs)))))
(defun make-std-boundp-method-function (class-or-name slot-name)
- (declare (ignore class-or-name))
(ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'boundp t)
(:standard
(let ((initargs (copy-tree
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index af97d32..8189300 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -73,8 +73,9 @@
(defmethod initialize-internal-slot-functions
((slotd effective-slot-definition))
- (let* ((name (slot-value slotd 'name))
+ (let* ((name (slot-value slotd 'name)) ; flushable? (is it ever unbound?)
(class (slot-value slotd '%class)))
+ (declare (ignore name))
(dolist (type '(reader writer boundp))
(let* ((gf-name (ecase type
(reader 'slot-value-using-class)
@@ -87,9 +88,7 @@
;; computed this early in class finalization; however, we need
;; this bit as early as possible. -- CSR, 2009-11-05
(setf (slot-accessor-std-p slotd type)
- (let* ((std-method (standard-svuc-method type))
- (str-method (structure-svuc-method type))
- (types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
+ (let* ((types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
(types (if (eq type 'writer) `(t ,@types1) types1))
(methods (compute-applicable-methods-using-types gf types)))
(null (cdr methods))))
@@ -126,8 +125,9 @@
;;; or some such.
(defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
type gf)
- (let* ((name (slot-value slotd 'name))
+ (let* ((name (slot-value slotd 'name)) ; flushable?
(class (slot-value slotd '%class)))
+ (declare (ignore name))
(multiple-value-bind (function std-p)
(if (eq **boot-state** 'complete)
(get-accessor-method-function gf type class slotd)
@@ -510,7 +510,8 @@
(with-world-lock ()
(without-package-locks
(unless (class-finalized-p class)
- (let ((name (class-name class)))
+ (let ((name (class-name class))) ; flushable?
+ (declare (ignore name))
;; KLUDGE: This is fairly horrible. We need to make a
;; full-fledged CLASSOID here, not just tell the compiler that
;; some class is forthcoming, because there are legitimate
@@ -1559,6 +1560,7 @@
(safe (safe-p new-class)))
(multiple-value-bind (new-instance-slots new-class-slots)
(classify-slotds (layout-slot-list new-wrapper))
+ (declare (ignore new-class-slots))
(multiple-value-bind (old-instance-slots old-class-slots)
(classify-slotds (layout-slot-list old-wrapper))
diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 7ce3f34..eebc4c6 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -819,10 +819,7 @@
(let* ((method-function nil)
(snl (getf plist :slot-name-lists))
(pv-table (when snl
- (intern-pv-table :slot-name-lists snl)))
- (arg-info (getf plist :arg-info))
- (nreq (car arg-info))
- (restp (cdr arg-info)))
+ (intern-pv-table :slot-name-lists snl))))
(setq method-function
(lambda (method-args next-methods)
(let* ((pv (when pv-table
@@ -848,10 +845,7 @@
;;; over the actual PV-CELL in this case.
(defun method-function-from-fast-method-call (fmc)
(let* ((fmf (fast-method-call-function fmc))
- (pv (fast-method-call-pv fmc))
- (arg-info (fast-method-call-arg-info fmc))
- (nreq (car arg-info))
- (restp (cdr arg-info)))
+ (pv (fast-method-call-pv fmc)))
(lambda (method-args next-methods)
(let* ((nm (car next-methods))
(nms (cdr next-methods))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|