1.0.13.46: fixed bug #402
authorNikodemus Siivola <nikodemus@random-state.net>
Mon, 21 Jan 2008 14:40:54 +0000 (21 14:40 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Mon, 21 Jan 2008 14:40:54 +0000 (21 14:40 +0000)
 * Rewrite SPLIT-DECLARATIONS to use two (short) constant lists and
   INFO instead of *VAR-DECLARATIONS-WITH|WITHOUT-ARG*.

 * Test-case for #402.

 * While at it, replace the *VAR-DECLARATIONS* from walker as well,
   replacing it with WALKED-VAR-DECLARATION-P, and make VAR-DECLARATION
   use a compiler-macro to check for bogus-declarations when possible.
   (All our whopping 3 calls to it.)

 * Bug #413 was fixed in 1.0.13, remove it from BUGS.

 * Whitespace.

BUGS
NEWS
src/pcl/defs.lisp
src/pcl/vector.lisp
src/pcl/walk.lisp
tests/bug-414.lisp
tests/clos.impure.lisp
version.lisp-expr

diff --git a/BUGS b/BUGS
index 503fdc4..887ffbe 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1612,22 +1612,6 @@ WORKAROUND:
   For some more details see comments for (define-alien-type-method
   (c-string :deport-gen) ...)  in host-c-call.lisp.
 
-402: "DECLAIM DECLARATION does not inform the PCL code-walker"
-  reported by Vincent Arkesteijn:
-
-  (declaim (declaration foo))
-  (defgeneric bar (x))
-  (defmethod bar (x)
-    (declare (foo x))
-    x)
-
-  ==> WARNING: The declaration FOO is not understood by
-      SB-PCL::SPLIT-DECLARATIONS.
-      Please put FOO on one of the lists SB-PCL::*NON-VAR-DECLARATIONS*,
-      SB-PCL::*VAR-DECLARATIONS-WITH-ARG*, or
-      SB-PCL::*VAR-DECLARATIONS-WITHOUT-ARG*.
-      (Assuming it is a variable declaration without argument).
-
 403: FORMAT/PPRINT-LOGICAL-BLOCK of CONDITIONs ignoring *PRINT-CIRCLE*
   In sbcl-0.9.13.34,
     (defparameter *c*
@@ -1785,21 +1769,6 @@ WORKAROUND:
   implementation of read circularity, using a symbol as a marker for
   the previously-referenced object.
 
-413: type-errors in ROOM
-
-  (defvar *a* (make-array (expt 2 27)))
-  (room)
-
-  Causes a type-error on 32bit SBCL, as various byte-counts in ROOM
-  implementation overrun fixnums. 
-
-  This was fixed in 1.0.4.89, but the patch was reverted as it caused
-  ROOM to cons sufficiently to make running it in a loop deadly on
-  GENCGC: newly allocated objects survived to generation 1, where next
-  call to ROOM would see them, and allocate even more...
-
-  Reported by Faré Rideau on sbcl-devel.
-
 415: Issues creating large arrays on x86-64/Linux and x86/Darwin
 
    (make-array (1- array-dimension-limit))
diff --git a/NEWS b/NEWS
index 923b8a3..a2c5176 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,11 @@ changes in sbcl-1.0.14 relative to sbcl-1.0.13:
   * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits
     (see documentation for details.)
   * revived support for OpenBSD (contributed by Josh Elsasser)
+  * partially fixed bug #108: ROOM no longer suffers from occasional
+    (AVER (SAP= CURRENT END)) failures .
+  * fixed bug #402: proclaimed non-standard declarations in DEFMETHOD
+    bodies no longer cause a WARNING to be signalled. (reported by
+    Vincent Arkesteijn)
   * bug fix: (TRUNCATE X 0) when X is a bignum now correctly signals
     DIVISION-BY-ZERO. Similarly for MOD and REM (which suffered due to
     the bug in TRUNCATE.) (reported by Michael Weber)
@@ -10,8 +15,6 @@ changes in sbcl-1.0.14 relative to sbcl-1.0.13:
     no samples. (reported by Andy Hefner)
   * bug fix: functions compiled using (COMPILE NIL '(LAMBDA ...))
     no longer appear as (NIL ...) frames in backtraces.
-  * bug fix: ROOM no longer suffers from occasional (AVER (SAP=
-    CURRENT END)) failures.
   * bug fix: RESOLVE-CONFLICT (and the other name conflict machinery)
     is now actually exported from SB-EXT as documented.  (reported by
     Maciej Katafiasz)
index c781e64..985bf5c 100644 (file)
         (push (list class-name symbol) *built-in-wrapper-symbols*)
         symbol)))
 \f
-(pushnew '%class *var-declarations*)
-(pushnew '%variable-rebinding *var-declarations*)
-
-(defun variable-class (var env)
-  (caddr (var-declaration 'class var env)))
-
 (defvar *standard-method-combination*)
 \f
 (defun plist-value (object name)
index 869e86e..21874fe 100644 (file)
         (declare ,(make-pv-type-declaration '.pv.))
         ,@forms)))
 
-(defvar *non-var-declarations*
-  ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
-  ;; 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
-    muffle-conditions
-    inline
-    notinline))
-
-(defvar *var-declarations-with-arg*
-  '(%class
-    type))
-
-(defvar *var-declarations-without-arg*
-  '(ignore
-    ignorable special dynamic-extent
-    ;; FIXME: Possibly this entire list and variable could go away.
-    ;; If not, certainly we should remove all these built-in typenames
-    ;; from the list, and replace them with a test for "is it a type
-    ;; name?" (CLTL1 allowed only built-in type names as declarations,
-    ;; but ANSI CL allows any type name as a declaration.)
-    array atom base-char bignum bit bit-vector character compiled-function
-    complex cons double-float extended-char
-    fixnum float function hash-table integer
-    keyword list long-float nil null number package pathname random-state ratio
-    rational readtable sequence short-float signed-byte simple-array
-    simple-bit-vector simple-string simple-vector single-float standard-char
-    stream string symbol t unsigned-byte vector))
-
 (defun split-declarations (body args maybe-reads-params-p)
   (let ((inner-decls nil)
         (outer-decls nil)
         decl)
-    (loop (when (null body) (return nil))
-          (setq decl (car body))
-          (unless (and (consp decl)
-                       (eq (car decl) 'declare))
-            (return nil))
-          (dolist (form (cdr decl))
-            (when (consp form)
-              (let ((declaration-name (car form)))
-                (if (member declaration-name *non-var-declarations*)
-                    (push `(declare ,form) outer-decls)
-                    (let ((arg-p
-                           (member declaration-name
-                                   *var-declarations-with-arg*))
-                          (non-arg-p
-                           (member declaration-name
-                                   *var-declarations-without-arg*))
-                          (dname (list (pop form)))
-                          (inners nil) (outers nil))
-                      (unless (or arg-p non-arg-p)
-                        ;; FIXME: This warning, and perhaps the
-                        ;; various *VAR-DECLARATIONS-FOO* and/or
-                        ;; *NON-VAR-DECLARATIONS* variables,
-                        ;; could probably go away now that we're not
-                        ;; trying to be portable between different
-                        ;; CLTL1 hosts the way PCL was. (Note that to
-                        ;; do this right, we need to be able to handle
-                        ;; user-defined (DECLAIM (DECLARATION FOO))
-                        ;; stuff.)
-                        (warn "The declaration ~S is not understood by ~S.~@
-                               Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
-                        (Assuming it is a variable declaration without argument)."
-                              declaration-name 'split-declarations
-                              declaration-name
-                              '*non-var-declarations*
-                              '*var-declarations-with-arg*
-                              '*var-declarations-without-arg*)
-                        (push declaration-name *var-declarations-without-arg*))
-                      (when arg-p
-                        (setq dname (append dname (list (pop form)))))
-                      (case (car dname)
-                        (%class (push `(declare (,@dname ,@form)) inner-decls))
-                        (t
-                         (dolist (var form)
-                           (if (member var args)
-                               ;; Quietly remove IGNORE declarations
-                               ;; on args when a next-method is
-                               ;; involved, to prevent compiler
-                               ;; warnings about ignored args being
-                               ;; read.
-                               (unless (and maybe-reads-params-p
-                                            (eq (car dname) 'ignore))
-                                 (push var outers))
-                               (push var inners)))
-                         (when outers
-                           (push `(declare (,@dname ,@outers)) outer-decls))
-                         (when inners
-                           (push
-                            `(declare (,@dname ,@inners))
-                            inner-decls)))))))))
-          (setq body (cdr body)))
+    (loop
+      (when (null body)
+        (return nil))
+      (setq decl (car body))
+      (unless (and (consp decl) (eq (car decl) 'declare))
+        (return nil))
+      (dolist (form (cdr decl))
+        (when (consp form)
+          (let* ((name (car form)))
+            (cond ((eq '%class name)
+                   (push `(declare ,form) inner-decls))
+                  ((or (member name '(ignore ignorable special dynamic-extent type))
+                       (info :type :kind name))
+                   (let* ((inners nil)
+                          (outers nil)
+                          (tail (cdr form))
+                          (head (if (eq 'type name)
+                                    (list name (pop tail))
+                                    (list name))))
+                     (dolist (var tail)
+                       (if (member var args)
+                           ;; Quietly remove IGNORE declarations on
+                           ;; args when a next-method is involved, to
+                           ;; prevent compiler warnings about ignored
+                           ;; args being read.
+                           (unless (and (eq 'ignore name) maybe-reads-params-p)
+                             (push var outers))
+                           (push var inners)))
+                     (when outers
+                       (push `(declare (,@head ,@outers)) outer-decls))
+                     (when inners
+                       (push `(declare (,@head ,@inners)) inner-decls))))
+                  (t
+                   ;; All other declarations are not variable declarations,
+                   ;; so they become outer declarations.
+                   (push `(declare ,form) outer-decls))))))
+      (setq body (cdr body)))
     (values outer-decls inner-decls body)))
 
 ;;; Pull a name out of the %METHOD-NAME declaration in the function
index 5f44953..30906c7 100644 (file)
     (when (eq (cadar entry) 'sb!sys:macro)
       entry)))
 
-(defvar *var-declarations* '(special))
+(defun walked-var-declaration-p (declaration)
+  (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special)))
+
+(defun %var-declaration (declaration var env)
+  (let ((id (or (var-lexical-p var env) var)))
+    (dolist (decl (env-declarations env))
+      (when (and (eq (car decl) declaration)
+                 (eq (cadr decl) id))
+        (return decl)))))
 
 (defun var-declaration (declaration var env)
-  (if (not (member declaration *var-declarations*))
-      (error "~S is not a recognized variable declaration." declaration)
-      (let ((id (or (var-lexical-p var env) var)))
-        (dolist (decl (env-declarations env))
-          (when (and (eq (car decl) declaration)
-                     (eq (cadr decl) id))
-            (return decl))))))
+  (if (walked-var-declaration-p declaration)
+      (%var-declaration declaration var env)
+      (error "Not a variable declaration the walker cares about: ~S" declaration)))
+
+#-sb-xc-host
+(define-compiler-macro var-declaration (&whole form declaration var env
+                                        &environment lexenv)
+  (if (sb!xc:constantp declaration lexenv)
+      (let ((decl (constant-form-value declaration lexenv)))
+        (if (walked-var-declaration-p decl)
+            `(%var-declaration ,declaration ,var ,env)
+            form))
+      form))
 
 (defun var-special-p (var env)
-  (or (not (null (var-declaration 'special var env)))
-      (var-globally-special-p var)))
+  (and (or (var-declaration 'special var env)
+           (var-globally-special-p var))
+       t))
 
 (defun var-globally-special-p (symbol)
   (eq (info :variable :kind symbol) :special))
            (let ((type (car declaration))
                  (name (cadr declaration))
                  (args (cddr declaration)))
-             (if (member type *var-declarations*)
+             (if (walked-var-declaration-p type)
                  (note-declaration `(,type
                                      ,(or (var-lexical-p name env) name)
                                      ,.args)
index 2f2ac60..d57a30d 100644 (file)
@@ -1,6 +1,6 @@
 ;;; compiling and disassembling this used to give
 ;;;
-;;;    WARNING: bogus form-number in form!  The source file has probably 
+;;;    WARNING: bogus form-number in form!  The source file has probably
 ;;;    been changed too much to cope with.
 ;;;
 ;;; but the symptoms have disappeared.
index 3fa764a..9dbd83f 100644 (file)
 (assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'warning))))
 (assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'hash-table))))
 (assert (eq t (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'standard-object))))
+
+;;;; bug 402: PCL used to warn about non-standard declarations
+(declaim (declaration bug-402-d))
+(defgeneric bug-402-gf (x))
+(with-test (:name :bug-402)
+  (handler-bind ((warning #'error))
+    (eval '(defmethod bug-402-gf (x)
+            (declare (bug-402-d x))
+            x))))
+
 \f
 ;;;; success
index b0c2bf9..1b3faf9 100644 (file)
@@ -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".)
-"1.0.13.45"
+"1.0.13.46"