From 4ec46046e59ce00abe3e53bce16fdfb2c4c57362 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 21 Jan 2008 14:40:54 +0000 Subject: [PATCH] 1.0.13.46: fixed bug #402 * 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 | 31 ------------ NEWS | 7 ++- src/pcl/defs.lisp | 6 --- src/pcl/vector.lisp | 131 ++++++++++++++----------------------------------- src/pcl/walk.lisp | 37 +++++++++----- tests/bug-414.lisp | 2 +- tests/clos.impure.lisp | 10 ++++ version.lisp-expr | 2 +- 8 files changed, 80 insertions(+), 146 deletions(-) diff --git a/BUGS b/BUGS index 503fdc4e4..887ffbe70 100644 --- 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 923b8a303..a2c51768b 100644 --- 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) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index c781e64a0..985bf5ce9 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -195,12 +195,6 @@ (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) -(pushnew '%class *var-declarations*) -(pushnew '%variable-rebinding *var-declarations*) - -(defun variable-class (var env) - (caddr (var-declaration 'class var env))) - (defvar *standard-method-combination*) (defun plist-value (object name) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 869e86ea1..21874fe60 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -550,104 +550,47 @@ (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 diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 5f4495387..30906c755 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -276,20 +276,35 @@ (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)) @@ -613,7 +628,7 @@ (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) diff --git a/tests/bug-414.lisp b/tests/bug-414.lisp index 2f2ac6013..d57a30d1b 100644 --- a/tests/bug-414.lisp +++ b/tests/bug-414.lisp @@ -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. diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 3fa764a64..9dbd83f6d 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1597,5 +1597,15 @@ (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)))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index b0c2bf9dc..1b3faf997 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".) -"1.0.13.45" +"1.0.13.46" -- 2.11.4.GIT