Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler assem.lisp,1.23,1.24 compiler-deftype.lisp,1.5,1.6 early-c.lisp,1.29,1.30 fndb.lisp,1.92,1.93 info-functions.lisp,1.23,1.24 ir1-translators.lisp,1.58,1.59 ir1tran.lisp,1.121,1.122 ir1util.lisp,1.93,1.94 lexenv.lisp,1.18,1.19 main.lisp,1.88,1.89 policy.lisp,1.13,1.14 proclaim.lisp,1.28,1.29 target-main.lisp,1.15,1.16
|
From: Nikodemus S. <de...@us...> - 2004-06-29 08:51:14
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27385/src/compiler Modified Files: assem.lisp compiler-deftype.lisp early-c.lisp fndb.lisp info-functions.lisp ir1-translators.lisp ir1tran.lisp ir1util.lisp lexenv.lisp main.lisp policy.lisp proclaim.lisp target-main.lisp Log Message: 0.8.12.7: Merge package locks, AKA "what can go wrong with a 3783 line patch?" ... Controlled by the presence of :sb-package-locks in target features. ... This builds both with and without package locks on both x86 Linux and SunOS Sparc, with both CMUCL and SBCL as host -- so chances are it should build elsewhere as well. ... Remaining TODO: turn package locking errors from lexical constructs to program errors in the produced code, fix the bits in SBCL that hit host's SBCL-tyle package locks (relevant FIXME is in src/cold/shared.lisp). Index: assem.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/assem.lisp,v retrieving revision 1.23 retrieving revision 1.24 diff -u -d -r1.23 -r1.24 --- assem.lisp 5 Apr 2004 23:16:29 -0000 1.23 +++ assem.lisp 29 Jun 2004 08:51:00 -0000 1.24 @@ -1163,16 +1163,24 @@ ,@(mapcar (lambda (name) `(,name (gen-label))) new-labels)) - (declare (ignorable ,vop-var ,seg-var)) + (declare (ignorable ,vop-var ,seg-var) + ;; Must be done so that contribs and user code doing + ;; low-level stuff don't need to worry about this. + (disable-package-locks %%current-segment%% %%current-vop%%)) (macrolet ((%%current-segment%% () '**current-segment**) (%%current-vop%% () '**current-vop**)) - (symbol-macrolet (,@(when (or inherited-labels nested-labels) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar (lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body))))))) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host. + ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%% %%current-vop%%)) + (symbol-macrolet (,@(when (or inherited-labels nested-labels) + `((..inherited-labels.. ,nested-labels)))) + ,@(mapcar (lambda (form) + (if (label-name-p form) + `(emit-label ,form) + form)) + body))))))) #+sb-xc-host (sb!xc:defmacro assemble ((&optional segment vop &key labels) &body body @@ -1209,13 +1217,13 @@ (declare (ignorable ,vop-var ,seg-var)) (macrolet ((%%current-segment%% () '**current-segment**) (%%current-vop%% () '**current-vop**)) - (symbol-macrolet (,@(when (or inherited-labels nested-labels) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar (lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body))))))) + (symbol-macrolet (,@(when (or inherited-labels nested-labels) + `((..inherited-labels.. ,nested-labels)))) + ,@(mapcar (lambda (form) + (if (label-name-p form) + `(emit-label ,form) + form)) + body))))))) (defmacro inst (&whole whole instruction &rest args &environment env) #!+sb-doc @@ -1636,10 +1644,19 @@ ,@(when decls `((declare ,@decls))) (let ((,postits (segment-postits ,segment-name))) + ;; Must be done so that contribs and user code doing + ;; low-level stuff don't need to worry about this. + (declare (disable-package-locks %%current-segment%%)) (setf (segment-postits ,segment-name) nil) (macrolet ((%%current-segment%% () (error "You can't use INST without an ~ ASSEMBLE inside emitters."))) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host + ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%% + ;; declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%%)) ,@emitter)) (values)) (eval-when (:compile-toplevel :load-toplevel :execute) Index: compiler-deftype.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/compiler-deftype.lisp,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- compiler-deftype.lisp 24 Mar 2003 18:39:03 -0000 1.5 +++ compiler-deftype.lisp 29 Jun 2004 08:51:00 -0000 1.6 @@ -14,6 +14,8 @@ (/show0 "compiler-deftype.lisp 14") (defun %compiler-deftype (name expander &optional doc) + (with-single-package-locked-error + (:symbol name "defining ~A as a type specifier")) (ecase (info :type :kind name) (:primitive (when *type-system-initialized* Index: early-c.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/early-c.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- early-c.lisp 17 May 2004 16:17:58 -0000 1.29 +++ early-c.lisp 29 Jun 2004 08:51:00 -0000 1.30 @@ -102,6 +102,7 @@ (defvar *current-component*) (defvar *delayed-ir1-transforms*) (defvar *handled-conditions*) +(defvar *disabled-package-locks*) (defvar *policy*) (defvar *dynamic-counts-tn*) (defvar *elsewhere*) Index: fndb.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v retrieving revision 1.92 retrieving revision 1.93 diff -u -d -r1.92 -r1.93 --- fndb.lisp 8 Jun 2004 11:38:42 -0000 1.92 +++ fndb.lisp 29 Jun 2004 08:51:00 -0000 1.93 @@ -1482,3 +1482,4 @@ (values) ()) (defknown style-warn (string &rest t) null ()) + Index: info-functions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/info-functions.lisp,v retrieving revision 1.23 retrieving revision 1.24 diff -u -d -r1.23 -r1.24 --- info-functions.lisp 17 Jul 2003 08:14:30 -0000 1.23 +++ info-functions.lisp 29 Jun 2004 08:51:00 -0000 1.24 @@ -209,8 +209,10 @@ (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL")) (when (eq (info :function :kind name) :special-form) (error "~S names a special form." name)) - (setf (info :function :compiler-macro-function name) function) - function) + (with-single-package-locked-error + (:symbol name "setting the compiler-macro-function of ~A") + (setf (info :function :compiler-macro-function name) function) + function)) ;;;; a subset of DOCUMENTATION functionality for bootstrapping Index: ir1-translators.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v retrieving revision 1.58 retrieving revision 1.59 diff -u -d -r1.58 -r1.59 --- ir1-translators.lisp 10 Jun 2004 16:32:46 -0000 1.58 +++ ir1-translators.lisp 29 Jun 2004 08:51:00 -0000 1.59 @@ -255,6 +255,8 @@ (compiler-style-warn "duplicate definitions in ~S" definitions)) (let* ((processed-definitions (mapcar definitionize-fun definitions)) (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) + ;; I wonder how much of an compiler performance penalty this + ;; non-constant keyword is. (funcall fun definitionize-keyword processed-definitions))) ;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then @@ -278,6 +280,9 @@ (destructuring-bind (name arglist &body body) definition (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) + (when (fboundp name) + (with-single-package-locked-error + (:symbol name "binding ~A as a local macro"))) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -326,10 +331,14 @@ (destructuring-bind (name expansion) definition (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) + (when (or (boundp name) (eq (info :variable :kind name) :macro)) + (with-single-package-locked-error + (:symbol name "binding ~A as a local symbol-macro"))) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) + ;; A magical cons that MACROEXPAND-1 understands. `(,name . (MACRO . ,expansion)))))) (defun funcall-in-symbol-macrolet-lexenv (definitions fun context) @@ -523,7 +532,10 @@ (vars var) (names name) (vals (second spec))))))) - + (dolist (name (names)) + (when (eq (info :variable :kind name) :macro) + (with-single-package-locked-error + (:symbol name "lexically binding symbol-macro ~A")))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) @@ -542,9 +554,10 @@ ((next result) (processing-decls (decls vars nil next result) (let ((fun (ir1-convert-lambda-body - forms vars - :debug-name (debug-namify "LET " - bindings)))) + forms + vars + :debug-name (debug-namify "LET S" + bindings)))) (reference-leaf start ctran fun-lvar fun)) (values next result)))) (ir1-convert-combination-args fun-lvar ctran next result values)))))) @@ -559,7 +572,12 @@ (parse-body body :doc-string-allowed nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) (processing-decls (decls vars nil start next) - (ir1-convert-aux-bindings start next result forms vars values))))) + (ir1-convert-aux-bindings start + next + result + forms + vars + values))))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET @@ -601,6 +619,9 @@ (let ((name (first def))) (check-fun-name name) + (when (fboundp name) + (with-single-package-locked-error + (:symbol name "binding ~A as a local function"))) (names name) (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) @@ -619,7 +640,7 @@ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-vars definitions 'flet) + (extract-flet-vars definitions 'flet) (let ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n @@ -629,7 +650,10 @@ names defs))) (processing-decls (decls nil fvars next result) (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) - (ir1-convert-progn-body start next result forms))))))) + (ir1-convert-progn-body start + next + result + forms))))))) (def-ir1-translator labels ((definitions &body body) start next result) #!+sb-doc @@ -639,46 +663,50 @@ each other." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-vars definitions 'labels) - (let* ( ;; dummy LABELS functions, to be used as placeholders + (extract-flet-vars definitions 'labels) + (let* (;; dummy LABELS functions, to be used as placeholders ;; during construction of real LABELS functions - (placeholder-funs (mapcar (lambda (name) - (make-functional - :%source-name name - :%debug-name (debug-namify - "LABELS placeholder " - name))) - names)) - ;; (like PAIRLIS but guaranteed to preserve ordering:) - (placeholder-fenv (mapcar #'cons names placeholder-funs)) + (placeholder-funs (mapcar (lambda (name) + (make-functional + :%source-name name + :%debug-name (debug-namify + "LABELS placeholder " + name))) + names)) + ;; (like PAIRLIS but guaranteed to preserve ordering:) + (placeholder-fenv (mapcar #'cons names placeholder-funs)) ;; the real LABELS functions, compiled in a LEXENV which ;; includes the dummy LABELS functions - (real-funs - (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) - (mapcar (lambda (name def) - (ir1-convert-lambda def - :source-name name - :debug-name (debug-namify - "LABELS " name) - :allow-debug-catch-tag t)) - names defs)))) - + (real-funs + (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) + (mapcar (lambda (name def) + (ir1-convert-lambda def + :source-name name + :debug-name (debug-namify + "LABELS " name) + :allow-debug-catch-tag t)) + names defs)))) + ;; Modify all the references to the dummy function leaves so ;; that they point to the real function leaves. - (loop for real-fun in real-funs and - placeholder-cons in placeholder-fenv do - (substitute-leaf real-fun (cdr placeholder-cons)) - (setf (cdr placeholder-cons) real-fun)) - + (loop for real-fun in real-funs and + placeholder-cons in placeholder-fenv do + (substitute-leaf real-fun (cdr placeholder-cons)) + (setf (cdr placeholder-cons) real-fun)) + ;; Voila. - (processing-decls (decls nil real-funs next result) + (processing-decls (decls nil real-funs next result) (let ((*lexenv* (make-lexenv ;; Use a proper FENV here (not the ;; placeholder used earlier) so that if the ;; lexical environment is used for inline ;; expansion we'll get the right functions. :funs (pairlis names real-funs)))) - (ir1-convert-progn-body start next result forms))))))) + (ir1-convert-progn-body start + next + result + forms))))))) + ;;;; the THE special operator, and friends @@ -860,9 +888,8 @@ (with-unique-names (exit-block) `(block ,exit-block (%within-cleanup - :catch - (%catch (%escape-fun ,exit-block) ,tag) - ,@body))))) + :catch (%catch (%escape-fun ,exit-block) ,tag) + ,@body))))) (def-ir1-translator unwind-protect ((protected &body cleanup) start next result) Index: ir1tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v retrieving revision 1.121 retrieving revision 1.122 diff -u -d -r1.121 -r1.122 --- ir1tran.lisp 27 May 2004 16:06:50 -0000 1.121 +++ ir1tran.lisp 29 Jun 2004 08:51:00 -0000 1.122 @@ -922,6 +922,9 @@ (collect ((restr nil cons) (new-vars nil cons)) (dolist (var-name (rest decl)) + (when (boundp var-name) + (with-single-package-locked-error + (:symbol var-name "declaring the type of ~A"))) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var (lexenv-find var-name vars) @@ -982,6 +985,9 @@ (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) + (when (fboundp name) + (with-single-package-locked-error + (:symbol name "declaring the ftype of ~A"))) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) @@ -1006,6 +1012,8 @@ (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) + (with-single-package-locked-error + (:symbol name "declaring ~A special")) (let ((var (find-in-bindings vars name))) (etypecase var (cons @@ -1202,6 +1210,11 @@ (dynamic-extent (process-dx-decl (cdr spec) vars) res) + ((disable-package-locks enable-package-locks) + (make-lexenv + :default res + :disabled-package-locks (process-package-lock-decl + spec (lexenv-disabled-package-locks res)))) (t (unless (info :declaration :recognized (first spec)) (compiler-warn "unrecognized declaration ~S" raw-spec)) Index: ir1util.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v retrieving revision 1.93 retrieving revision 1.94 diff -u -d -r1.93 -r1.94 --- ir1util.lisp 27 May 2004 16:07:04 -0000 1.93 +++ ir1util.lisp 29 Jun 2004 08:51:00 -0000 1.94 @@ -539,6 +539,8 @@ (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (handled-conditions (lexenv-handled-conditions default)) + (disabled-package-locks + (lexenv-disabled-package-locks default)) (policy (lexenv-policy default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) @@ -551,7 +553,8 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup handled-conditions policy))) + lambda cleanup handled-conditions + disabled-package-locks policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -581,6 +584,7 @@ nil nil (lexenv-handled-conditions lexenv) + (lexenv-disabled-package-locks lexenv) (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery Index: lexenv.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/lexenv.lisp,v retrieving revision 1.18 retrieving revision 1.19 diff -u -d -r1.18 -r1.19 --- lexenv.lisp 17 May 2004 16:17:58 -0000 1.18 +++ lexenv.lisp 29 Jun 2004 08:51:00 -0000 1.19 @@ -27,7 +27,7 @@ (funs vars blocks tags type-restrictions lambda cleanup handled-conditions - policy))) + disabled-package-locks policy))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an ;; INLINE/NOTINLINE declaration, or a list (MACRO . <function>) (a @@ -64,6 +64,8 @@ (cleanup nil) ;; condition types we handle with a handler around the compiler (handled-conditions *handled-conditions*) + ;; lexically disabled package locks (list of symbols) + (disabled-package-locks *disabled-package-locks*) ;; the current OPTIMIZE policy (policy *policy* :type policy)) Index: main.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v retrieving revision 1.88 retrieving revision 1.89 diff -u -d -r1.88 -r1.89 --- main.lisp 17 May 2004 16:17:58 -0000 1.88 +++ main.lisp 29 Jun 2004 08:51:00 -0000 1.89 @@ -806,7 +806,8 @@ (defun convert-and-maybe-compile (form path) (declare (list path)) (let* ((*lexenv* (make-lexenv :policy *policy* - :handled-conditions *handled-conditions*)) + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) (tll (ir1-toplevel form path nil))) (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*)) (t (compile-toplevel (list tll) nil))))) @@ -853,7 +854,9 @@ ;; issue a warning instead of silently screwing up. (*policy* (lexenv-policy *lexenv*)) ;; This is probably also a hack - (*handled-conditions* (lexenv-handled-conditions *lexenv*))) + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))) (process-toplevel-progn forms path compile-time-too)))) ;;; Parse an EVAL-WHEN situations list, returning three flags, @@ -952,7 +955,8 @@ (when name (legal-fun-name-or-type-error name)) (let* ((*lexenv* (make-lexenv :policy *policy* - :handled-conditions *handled-conditions*)) + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -1175,8 +1179,9 @@ ((macrolet) (funcall-in-macrolet-lexenv magic - (lambda (&key funs) + (lambda (&key funs prepend) (declare (ignore funs)) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too)) @@ -1184,7 +1189,8 @@ ((symbol-macrolet) (funcall-in-symbol-macrolet-lexenv magic - (lambda (&key vars) + (lambda (&key vars prepend) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too @@ -1392,6 +1398,7 @@ (*policy* *policy*) (*handled-conditions* *handled-conditions*) + (*disabled-package-locks* *disabled-package-locks*) (*lexenv* (make-null-lexenv)) (*block-compile* *block-compile-arg*) (*source-info* info) Index: policy.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/policy.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- policy.lisp 17 May 2004 16:17:58 -0000 1.13 +++ policy.lisp 29 Jun 2004 08:51:01 -0000 1.14 @@ -73,8 +73,9 @@ (cons name 1)) *policy-qualities*)) ;; not actually POLICY, but very similar - (setf *handled-conditions* nil)) - + (setf *handled-conditions* nil + *disabled-package-locks* nil)) + ;;; On the cross-compilation host, we initialize immediately (not ;;; waiting for "cold init", since cold init doesn't exist on ;;; cross-compilation host). Index: proclaim.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/proclaim.lisp,v retrieving revision 1.28 retrieving revision 1.29 diff -u -d -r1.28 -r1.29 --- proclaim.lisp 17 May 2004 16:17:58 -0000 1.28 +++ proclaim.lisp 29 Jun 2004 08:51:01 -0000 1.29 @@ -119,6 +119,17 @@ (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) list)) +(declaim (ftype (function (list list) list) + process-package-lock-decl)) +(defun process-package-lock-decl (spec old) + (let ((decl (car spec)) + (list (cdr spec))) + (ecase decl + (disable-package-locks + (union old list :test #'equal)) + (enable-package-locks + (set-difference old list :test #'equal))))) + ;;; ANSI defines the declaration (FOO X Y) to be equivalent to ;;; (TYPE FOO X Y) when FOO is a type specifier. This function ;;; implements that by converting (FOO X Y) to (TYPE FOO X Y). @@ -157,6 +168,8 @@ (error "can't declare a non-symbol as SPECIAL: ~S" name)) (when (constantp name) (error "can't declare a constant as SPECIAL: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaraing ~A special")) (clear-info :variable :constant-value name) (setf (info :variable :kind name) :special))) (type @@ -165,6 +178,8 @@ (dolist (name (rest args)) (unless (symbolp name) (error "can't declare TYPE of a non-symbol: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaring the type of ~A")) (when (eq (info :variable :where-from name) :declared) (let ((old-type (info :variable :type name))) (when (type/= type old-type) @@ -181,6 +196,8 @@ (unless (csubtypep ctype (specifier-type 'function)) (error "not a function type: ~S" (first args))) (dolist (name (rest args)) + (with-single-package-locked-error + (:symbol name "globally declaring the ftype of ~A")) (when (eq (info :function :where-from name) :declared) (let ((old-type (info :function :type name))) (when (type/= ctype old-type) @@ -222,6 +239,9 @@ (unmuffle-conditions (setq *handled-conditions* (process-unmuffle-conditions-decl form *handled-conditions*))) + ((disable-package-locks enable-package-locks) + (setq *disabled-package-locks* + (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) (proclaim-as-fun-name name) ; since implicitly it is a function @@ -236,6 +256,8 @@ (error "In~% ~S~%the declaration to be recognized is not a ~ symbol:~% ~S" form decl)) + (with-single-package-locked-error + (:symbol decl "globally declaring ~A as a declaration proclamation")) (setf (info :declaration :recognized decl) t))) (t (unless (info :declaration :recognized kind) Index: target-main.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/target-main.lisp,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- target-main.lisp 17 May 2004 16:17:58 -0000 1.15 +++ target-main.lisp 29 Jun 2004 08:51:01 -0000 1.16 @@ -72,6 +72,8 @@ (*policy* (lexenv-policy *lexenv*)) ;; see above (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) ;; FIXME: ANSI doesn't say anything about CL:COMPILE ;; interacting with these variables, so we shouldn't. As ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by |