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
-------------------------------------------------------
This SF.Net email sponsored by Black Hat Briefings & Training.
Attend Black Hat Briefings & Training, Las Vegas July 24-29 -
digital self defense, top technical experts, no vendor pitches,
unmatched networking opportunities. Visit www.blackhat.com
|
