From 25d4ea4f108159b9782f21212374a1631cfe9a56 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 14 Apr 2006 08:18:20 +0000 Subject: [PATCH] 0.9.11.35: better package locking and more cleaning up after .31 * package lock violations from lexical operations always cause runtime PROGRAM-ERRORs * better EXTRA_CFLAGS handling in SB-GROVEL --- NEWS | 3 + contrib/sb-grovel/def-to-lisp.lisp | 13 +- doc/manual/package-locks-extended.texinfo | 62 +++---- package-data-list.lisp-expr | 6 +- src/code/cross-misc.lisp | 4 +- src/code/early-fasl.lisp | 3 +- src/code/early-package.lisp | 22 +-- src/code/error.lisp | 13 +- src/code/eval.lisp | 258 +++++++++++++++-------------- src/compiler/ir1-translators.lisp | 16 +- src/compiler/ir1tran.lisp | 31 ++-- tests/package-locks.impure.lisp | 151 ++++++++--------- version.lisp-expr | 2 +- 13 files changed, 314 insertions(+), 270 deletions(-) diff --git a/NEWS b/NEWS index 8100381..cc670d7 100644 --- a/NEWS +++ b/NEWS @@ -18,6 +18,9 @@ changes in sbcl-0.9.12 relative to sbcl-0.9.11: for sending data through UDP sockets (thanks to François-René Rideau) * minor incompatible change: SIGPIPE is ignored and "Broken pipe" error is signalled instead (thanks to François-René Rideau) + * minor incompatible change: Error signalling behaviour of lexical + operations violating package locks has changed slightly. Refer to + documentation on package locks for details. * bug fix: LISTEN sometimes returned T even in cases where no data was immediately available from the stream * fixed bug: types of the last two arguments to SET-SYNTAX-FROM-CHAR diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index e091d59..1356609 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -5,6 +5,15 @@ (defun escape-for-string (string) (c-escape string)) +(defun split-cflags (string) + (remove-if (lambda (flag) + (zerop (length flag))) + (loop + for start = 0 then (if end (1+ end) nil) + for end = (and start (position #\Space string :start start)) + while start + collect (subseq string start end)))) + (defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\)) "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR." (coerce (loop for c across string @@ -178,9 +187,7 @@ code: (sb-ext:run-program "gcc" (append - (let ((cf (sb-ext:posix-getenv "EXTRA_CFLAGS"))) - (when (plusp (length cf)) - (list cf))) + (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS")) (list "-o" (namestring tmp-a-dot-out) (namestring tmp-c-source))) diff --git a/doc/manual/package-locks-extended.texinfo b/doc/manual/package-locks-extended.texinfo index 8cb8a74..f993888 100644 --- a/doc/manual/package-locks-extended.texinfo +++ b/doc/manual/package-locks-extended.texinfo @@ -4,7 +4,7 @@ @cindex Packages, locked None of the following sections apply to SBCL built without package -locksing support. +locking support. The interface described here is experimental: incompatible changes in future SBCL releases are possible, even expected: the concept of @@ -72,22 +72,7 @@ Unless explicitly altered by @code{defpackage}, @tindex symbol-package-locked-error @tindex package-error -If an operation violates a package lock, a continuable error that is -of a subtype of @code{sb-ext:package-lock-violation} (subtype of -@code{package-error}) is signalled when the operation is attempted. - -Additional restarts may be established for continuable package lock -violations for interactive use. - -The actual type of the error depends on circumstances that caused the -violation: operations on packages signal errors of type -@code{sb-ext:package-locked-error}, and operations on symbols signal -errors of type @code{sb-ext:symbol-package-locked-error}. - -@node Package Locks in Compiled Code -@subsection Package Locks in Compiled Code - -@subsubsection Lexical bindings and declarations +@subsubsection Lexical Bindings and Declarations @findex let @findex let* @findex flet @@ -101,17 +86,17 @@ errors of type @code{sb-ext:symbol-package-locked-error}. @findex disable-package-locks @findex enable-package-locks -Compiling lexical binding constructs or lexical declarations that -violate package locks causes a compile-time package-lock violation. A -complete listing of operators affect by this is: @code{let}, +Lexical bindings or declarations that violate package locks cause +result in a @code{program-error} being signalled at when the form that +violates package locks would be executed. + +A complete listing of operators affect by this is: @code{let}, @code{let*}, @code{flet}, @code{labels}, @code{macrolet}, and @code{symbol-macrolet}, @code{declare}. Package locks affecting both lexical bindings and declarations can be -disabled at compile-time with @code{sb-ext:disable-package-locks} -declaration, and re-enabled with @code{sb-ext:enable-package-locks} -declaration. Constructs compiled with package locks thusly disabled -are guaranteed not to signal package lock violation errors at runtime. +disabled locally with @code{sb-ext:disable-package-locks} declaration, +and re-enabled with @code{sb-ext:enable-package-locks} declaration. Example: @@ -127,17 +112,36 @@ Example: ,@@body))) @end lisp -@subsubsection Interned symbols +@subsubsection Other Operations + +If an non-lexical operation violates a package lock, a continuable +error that is of a subtype of @code{sb-ext:package-lock-violation} +(subtype of @code{package-error}) is signalled when the operation is +attempted. + +Additional restarts may be established for continuable package lock +violations for interactive use. + +The actual type of the error depends on circumstances that caused the +violation: operations on packages signal errors of type +@code{sb-ext:package-locked-error}, and operations on symbols signal +errors of type @code{sb-ext:symbol-package-locked-error}. + + +@node Package Locks in Compiled Code +@subsection Package Locks in Compiled Code + +@subsubsection Interned Symbols If file-compiled code contains interned symbols, then loading that code into an image without the said symbols will not cause a package lock violation, even if the packages in question are locked. -@subsubsection Other limitations on compiled code +@subsubsection Other Limitations on Compiled Code -With the exception of the aforementioned contructs, and interned -symbols, behaviour is unspecified if package locks affecting compiled -code are not the same during loading of the code or execution. +With the exception of interned symbols, behaviour is unspecified if +package locks affecting compiled code are not the same during loading +of the code or execution. Specifically, code compiled with packages unlocked may or may not fail to signal package-lock-violations even if the packages are locked at diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 189d891..3db5059 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -821,7 +821,9 @@ retained, possibly temporariliy, because it might be used internally." "*SETF-FDEFINITION-HOOK*" ;; error-reporting facilities - "ENCAPSULATED-CONDITION" "COMPILED-PROGRAM-ERROR" + "COMPILED-PROGRAM-ERROR" + "ENCAPSULATED-CONDITION" + "INTERPRETED-PROGRAM-ERROR" "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR" "SIMPLE-STREAM-ERROR" "SIMPLE-STORAGE-CONDITION" @@ -1177,7 +1179,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" "ALLOCATE-VECTOR" "ALLOCATE-STATIC-VECTOR" "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" - "COMPILER-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" + "PROGRAM-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" "DISABLED-PACKAGE-LOCKS" "WITH-SINGLE-PACKAGE-LOCKED-ERROR" "PACKAGE-ERROR-FORMAT-ARGUMENTS" diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index a2545b0..67e730b 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -155,8 +155,8 @@ (declare (ignore kind thing format)) `(progn ,@body)) -(defun compiler-assert-symbol-home-package-unlocked (symbol control) - (declare (ignore control)) +(defun program-assert-symbol-home-package-unlocked (context symbol control) + (declare (ignore context control)) symbol) (defun assert-package-unlocked (package &optional control &rest args) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 68eee80..da1abb0 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -76,7 +76,7 @@ ;;; versions which break binary compatibility. But it certainly should ;;; be incremented for release versions which break binary ;;; compatibility. -(def!constant +fasl-file-version+ 64) +(def!constant +fasl-file-version+ 65) ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so) ;;; 38: (2003-01-05) changed names of internal SORT machinery ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to @@ -134,6 +134,7 @@ ;;; trap information size on RISCy platforms. ;;; 64: (2006-03-24) New calling convention for unknown-values on x86 and ;;; x86-64. Also (belatedly) PPC/gencgc, including :gencgc on FPAFF. +;;; 65: (2006-04-11) Package locking interface changed. ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/code/early-package.lisp b/src/code/early-package.lisp index 25c73ff..fb2e1d2 100644 --- a/src/code/early-package.lisp +++ b/src/code/early-package.lisp @@ -53,18 +53,20 @@ (when ,topmost (setf *ignored-package-locks* :invalid))))))) -(defun compiler-assert-symbol-home-package-unlocked (symbol control) +(defun program-assert-symbol-home-package-unlocked (context symbol control) #!-sb-package-locks - (declare (ignore symbol control)) + (declare (ignore context symbol control)) #!+sb-package-locks - (flet ((resignal (condition) - ;; Signal the condition to give user defined handlers a chance, - ;; if they decline convert to compiler-error. - (signal condition) - (sb!c:compiler-error condition))) - (handler-bind ((package-lock-violation #'resignal)) - (with-single-package-locked-error () - (assert-symbol-home-package-unlocked symbol control))))) + (handler-bind ((package-lock-violation + (lambda (condition) + (ecase context + (:compile + (warn "Compile-time package lock violation:~% ~A" + condition) + (sb!c:compiler-error condition)) + (:eval + (eval-error condition)))))) + (with-single-package-locked-error (:symbol symbol control)))) (defmacro without-package-locks (&body body) #!+sb-doc diff --git a/src/code/error.lisp b/src/code/error.lisp index 522df87..3a02c24 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -77,10 +77,21 @@ (:report (lambda (condition stream) (format stream "Execution of a form compiled with errors.~%~ Form:~% ~A~%~ - Compile-time-error:~% ~A" + Compile-time error:~% ~A" (program-error-source condition) (program-error-message condition))))) +(define-condition interpreted-program-error + (program-error encapsulated-condition) + ;; Unlike COMPILED-PROGRAM-ERROR, we don't need to dump these, so + ;; storing the original condition and form is OK. + ((form :initarg :form :reader program-error-form)) + (:report (lambda (condition stream) + (format stream "~&Evaluation of~% ~S~%~ + caused error:~% ~A~%" + (program-error-form condition) + (encapsulated-condition condition))))) + (define-condition simple-control-error (simple-condition control-error) ()) (define-condition simple-file-error (simple-condition file-error) ()) (define-condition simple-program-error (simple-condition program-error) ()) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 3e4c729..8e67686 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -70,7 +70,8 @@ (sb!c::process-decls decls vars nil - :lexenv lexenv)))) + :lexenv lexenv + :context :eval)))) (eval-progn-body body lexenv)))) (defun eval (original-exp) @@ -79,6 +80,16 @@ result or results." (eval-in-lexenv original-exp (make-null-lexenv))) +;;;; EVAL-ERROR +;;;; +;;;; Analogous to COMPILER-ERROR, but simpler. + +(define-condition eval-error (encapsulated-condition) ()) + +(defun eval-error (condition) + (signal 'eval-error :condition condition) + (bug "Unhandled EVAL-ERROR")) + ;;; Pick off a few easy cases, and the various top level EVAL-WHEN ;;; magical cases, and call %EVAL for the rest. (defun eval-in-lexenv (original-exp lexenv) @@ -98,125 +109,132 @@ ;; error straight away. (invoke-restart 'sb!c::signal-error))))) (let ((exp (macroexpand original-exp lexenv))) - (typecase exp - (symbol - (ecase (info :variable :kind exp) - (:constant - (values (info :variable :constant-value exp))) - ((:special :global) - (symbol-value exp)) - ;; FIXME: This special case here is a symptom of non-ANSI - ;; weirdness in SBCL's ALIEN implementation, which could - ;; cause problems for e.g. code walkers. It'd probably be - ;; good to ANSIfy it by making alien variable accessors - ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF - ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain - ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to - ;; be retained for compatibility, it can be implemented - ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers - ;; happy. - (:alien - (%eval original-exp lexenv)))) - (list - (let ((name (first exp)) - (n-args (1- (length exp)))) - (case name - ((function) - (unless (= n-args 1) - (error "wrong number of args to FUNCTION:~% ~S" exp)) - (let ((name (second exp))) - (if (and (legal-fun-name-p name) - (not (consp (let ((sb!c:*lexenv* lexenv)) - (sb!c:lexenv-find name funs))))) - (%coerce-name-to-fun name) - (%eval original-exp lexenv)))) - ((quote) - (unless (= n-args 1) - (error "wrong number of args to QUOTE:~% ~S" exp)) - (second exp)) - (setq - (unless (evenp n-args) - (error "odd number of args to SETQ:~% ~S" exp)) - (unless (zerop n-args) - (do ((name (cdr exp) (cddr name))) - ((null name) - (do ((args (cdr exp) (cddr args))) - ((null (cddr args)) - ;; We duplicate the call to SET so that the - ;; correct value gets returned. - (set (first args) (eval-in-lexenv (second args) lexenv))) - (set (first args) (eval-in-lexenv (second args) lexenv)))) - (let ((symbol (first name))) - (case (info :variable :kind symbol) - (:special) - (t (return (%eval original-exp lexenv)))) - (unless (type= (info :variable :type symbol) - *universal-type*) - ;; let the compiler deal with type checking - (return (%eval original-exp lexenv))))))) - ((progn) - (eval-progn-body (rest exp) lexenv)) - ((eval-when) - ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR - ;; instead of PROGRAM-ERROR when there's something wrong - ;; with the syntax here (e.g. missing SITUATIONS). This - ;; could be fixed by hand-crafting clauses to catch and - ;; report each possibility, but it would probably be - ;; cleaner to write a new macro - ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does - ;; DESTRUCTURING-BIND and promotes any mismatch to - ;; PROGRAM-ERROR, then to use it here and in (probably - ;; dozens of) other places where the same problem - ;; arises. - (destructuring-bind (eval-when situations &rest body) exp - (declare (ignore eval-when)) - (multiple-value-bind (ct lt e) - (sb!c:parse-eval-when-situations situations) - ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of - ;; the situation :EXECUTE (or EVAL) controls whether - ;; evaluation occurs for other EVAL-WHEN forms; that - ;; is, those that are not top level forms, or those - ;; in code processed by EVAL or COMPILE. If the - ;; :EXECUTE situation is specified in such a form, - ;; then the body forms are processed as an implicit - ;; PROGN; otherwise, the EVAL-WHEN form returns NIL. - (declare (ignore ct lt)) - (when e - (eval-progn-body body lexenv))))) - ((locally) - (eval-locally exp lexenv)) - ((macrolet) - (destructuring-bind (definitions &rest body) - (rest exp) - (let ((lexenv - (let ((sb!c:*lexenv* lexenv)) - (sb!c::funcall-in-macrolet-lexenv - definitions - (lambda (&key funs) - (declare (ignore funs)) - sb!c:*lexenv*) - :eval)))) - (eval-locally `(locally ,@body) lexenv)))) - ((symbol-macrolet) - (destructuring-bind (definitions &rest body) (rest exp) - (multiple-value-bind (lexenv vars) - (let ((sb!c:*lexenv* lexenv)) - (sb!c::funcall-in-symbol-macrolet-lexenv - definitions - (lambda (&key vars) - (values sb!c:*lexenv* vars)) - :eval)) - (eval-locally `(locally ,@body) lexenv :vars vars)))) - (t - (if (and (symbolp name) - (eq (info :function :kind name) :function)) - (collect ((args)) - (dolist (arg (rest exp)) - (args (eval-in-lexenv arg lexenv))) - (apply (symbol-function name) (args))) - (%eval exp lexenv)))))) - (t - exp))))) + (handler-bind ((eval-error + (lambda (condition) + (error 'interpreted-program-error + :condition (encapsulated-condition condition) + :form exp)))) + (typecase exp + (symbol + (ecase (info :variable :kind exp) + (:constant + (values (info :variable :constant-value exp))) + ((:special :global) + (symbol-value exp)) + ;; FIXME: This special case here is a symptom of non-ANSI + ;; weirdness in SBCL's ALIEN implementation, which could + ;; cause problems for e.g. code walkers. It'd probably be + ;; good to ANSIfy it by making alien variable accessors + ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF + ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain + ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to + ;; be retained for compatibility, it can be implemented + ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers + ;; happy. + (:alien + (%eval original-exp lexenv)))) + (list + (let ((name (first exp)) + (n-args (1- (length exp)))) + (case name + ((function) + (unless (= n-args 1) + (error "wrong number of args to FUNCTION:~% ~S" exp)) + (let ((name (second exp))) + (if (and (legal-fun-name-p name) + (not (consp (let ((sb!c:*lexenv* lexenv)) + (sb!c:lexenv-find name funs))))) + (%coerce-name-to-fun name) + (%eval original-exp lexenv)))) + ((quote) + (unless (= n-args 1) + (error "wrong number of args to QUOTE:~% ~S" exp)) + (second exp)) + (setq + (unless (evenp n-args) + (error "odd number of args to SETQ:~% ~S" exp)) + (unless (zerop n-args) + (do ((name (cdr exp) (cddr name))) + ((null name) + (do ((args (cdr exp) (cddr args))) + ((null (cddr args)) + ;; We duplicate the call to SET so that the + ;; correct value gets returned. + (set (first args) + (eval-in-lexenv (second args) lexenv))) + (set (first args) + (eval-in-lexenv (second args) lexenv)))) + (let ((symbol (first name))) + (case (info :variable :kind symbol) + (:special) + (t (return (%eval original-exp lexenv)))) + (unless (type= (info :variable :type symbol) + *universal-type*) + ;; let the compiler deal with type checking + (return (%eval original-exp lexenv))))))) + ((progn) + (eval-progn-body (rest exp) lexenv)) + ((eval-when) + ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR + ;; instead of PROGRAM-ERROR when there's something wrong + ;; with the syntax here (e.g. missing SITUATIONS). This + ;; could be fixed by hand-crafting clauses to catch and + ;; report each possibility, but it would probably be + ;; cleaner to write a new macro + ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does + ;; DESTRUCTURING-BIND and promotes any mismatch to + ;; PROGRAM-ERROR, then to use it here and in (probably + ;; dozens of) other places where the same problem + ;; arises. + (destructuring-bind (eval-when situations &rest body) exp + (declare (ignore eval-when)) + (multiple-value-bind (ct lt e) + (sb!c:parse-eval-when-situations situations) + ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of + ;; the situation :EXECUTE (or EVAL) controls whether + ;; evaluation occurs for other EVAL-WHEN forms; that + ;; is, those that are not top level forms, or those + ;; in code processed by EVAL or COMPILE. If the + ;; :EXECUTE situation is specified in such a form, + ;; then the body forms are processed as an implicit + ;; PROGN; otherwise, the EVAL-WHEN form returns NIL. + (declare (ignore ct lt)) + (when e + (eval-progn-body body lexenv))))) + ((locally) + (eval-locally exp lexenv)) + ((macrolet) + (destructuring-bind (definitions &rest body) + (rest exp) + (let ((lexenv + (let ((sb!c:*lexenv* lexenv)) + (sb!c::funcall-in-macrolet-lexenv + definitions + (lambda (&key funs) + (declare (ignore funs)) + sb!c:*lexenv*) + :eval)))) + (eval-locally `(locally ,@body) lexenv)))) + ((symbol-macrolet) + (destructuring-bind (definitions &rest body) (rest exp) + (multiple-value-bind (lexenv vars) + (let ((sb!c:*lexenv* lexenv)) + (sb!c::funcall-in-symbol-macrolet-lexenv + definitions + (lambda (&key vars) + (values sb!c:*lexenv* vars)) + :eval)) + (eval-locally `(locally ,@body) lexenv :vars vars)))) + (t + (if (and (symbolp name) + (eq (info :function :kind name) :function)) + (collect ((args)) + (dolist (arg (rest exp)) + (args (eval-in-lexenv arg lexenv))) + (apply (symbol-function name) (args))) + (%eval exp lexenv)))))) + (t + exp)))))) ;;; miscellaneous full function definitions of things which are ;;; ordinarily handled magically by the compiler diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 70fdcfd..aa92588 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -284,8 +284,8 @@ (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local macro")) + (program-assert-symbol-home-package-unlocked + context name "binding ~A as a local macro")) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -335,8 +335,8 @@ (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)) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local symbol-macro")) + (program-assert-symbol-home-package-unlocked + context 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" @@ -590,8 +590,8 @@ (vals (second spec))))))) (dolist (name (names)) (when (eq (info :variable :kind name) :macro) - (compiler-assert-symbol-home-package-unlocked - name "lexically binding symbol-macro ~A"))) + (program-assert-symbol-home-package-unlocked + :compile name "lexically binding symbol-macro ~A"))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) @@ -683,8 +683,8 @@ (let ((name (first def))) (check-fun-name name) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local function")) + (program-assert-symbol-home-package-unlocked + :compile name "binding ~A as a local function")) (names name) (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 68cac62..8026ab7 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -929,15 +929,15 @@ ;;; If a LAMBDA-VAR being bound, we intersect the type with the var's ;;; type, otherwise we add a type restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. -(defun process-type-decl (decl res vars) +(defun process-type-decl (decl res vars context) (declare (list decl vars) (type lexenv res)) (let ((type (compiler-specifier-type (first decl)))) (collect ((restr nil cons) (new-vars nil cons)) (dolist (var-name (rest decl)) (when (boundp var-name) - (compiler-assert-symbol-home-package-unlocked - var-name "declaring the type of ~A")) + (program-assert-symbol-home-package-unlocked + context 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) @@ -992,15 +992,15 @@ ;;; declarations for functions being bound, we must also deal with ;;; declarations that constrain the type of lexically apparent ;;; functions. -(defun process-ftype-decl (spec res names fvars) +(defun process-ftype-decl (spec res names fvars context) (declare (type list names fvars) (type lexenv res)) (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "declaring the ftype of ~A")) + (program-assert-symbol-home-package-unlocked + context name "declaring the ftype of ~A")) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) (cond (found @@ -1020,11 +1020,12 @@ ;;; special declaration is instantiated by throwing a special variable ;;; into the variables if BINDING-FORM-P is NIL, or otherwise into ;;; *POST-BINDING-VARIABLE-LEXENV*. -(defun process-special-decl (spec res vars binding-form-p) +(defun process-special-decl (spec res vars binding-form-p context) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) - (compiler-assert-symbol-home-package-unlocked name "declaring ~A special") + (program-assert-symbol-home-package-unlocked + context name "declaring ~A special") (let ((var (find-in-bindings vars name))) (etypecase var (cons @@ -1201,18 +1202,18 @@ ;;; Process a single declaration spec, augmenting the specified LEXENV ;;; RES. Return RES and result type. VARS and FVARS are as described ;;; PROCESS-DECLS. -(defun process-1-decl (raw-spec res vars fvars binding-form-p) +(defun process-1-decl (raw-spec res vars fvars binding-form-p context) (declare (type list raw-spec vars fvars)) (declare (type lexenv res)) (let ((spec (canonized-decl-spec raw-spec)) (result-type *wild-type*)) (values (case (first spec) - (special (process-special-decl spec res vars binding-form-p)) + (special (process-special-decl spec res vars binding-form-p context)) (ftype (unless (cdr spec) (compiler-error "no type specified in FTYPE declaration: ~S" spec)) - (process-ftype-decl (second spec) res (cddr spec) fvars)) + (process-ftype-decl (second spec) res (cddr spec) fvars context)) ((inline notinline maybe-inline) (process-inline-decl spec res fvars)) ((ignore ignorable) @@ -1233,7 +1234,7 @@ :handled-conditions (process-unmuffle-conditions-decl spec (lexenv-handled-conditions res)))) (type - (process-type-decl (cdr spec) res vars)) + (process-type-decl (cdr spec) res vars context)) (values (unless *suppress-values-declaration* (let ((types (cdr spec))) @@ -1268,8 +1269,8 @@ ;;; ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. -(defun process-decls (decls vars fvars &key (lexenv *lexenv*) - (binding-form-p nil)) +(defun process-decls (decls vars fvars &key + (lexenv *lexenv*) (binding-form-p nil) (context :compile)) (declare (list decls vars fvars)) (let ((result-type *wild-type*) (*post-binding-variable-lexenv* nil)) @@ -1278,7 +1279,7 @@ (unless (consp spec) (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) (multiple-value-bind (new-env new-result-type) - (process-1-decl spec lexenv vars fvars binding-form-p) + (process-1-decl spec lexenv vars fvars binding-form-p context) (setq lexenv new-env) (unless (eq new-result-type *wild-type*) (setq result-type diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 77b2a9e..6781308 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -16,9 +16,6 @@ (load "assertoid.lisp") (use-package "ASSERTOID") -#-sb-package-locks -(sb-ext:quit :unix-status 104) - ;;;; Our little labrats and a few utilities (defpackage :test-used) @@ -71,7 +68,7 @@ (sb-ext:lock-package p) (sb-ext:unlock-package p))))) -(defun reset-test () +(defun reset-test (lock) "Reset TEST package to a known state, ensure that TEST-DELETE exists." (unless (find-package :test-delete) (make-package :test-delete)) @@ -106,7 +103,8 @@ (defun test:numfun (n) n) (defun test:car (cons) (cl:car cons)) (defun (setf test:cdr) (obj cons) (setf (cl:cdr cons) obj)) - (assert (not (find-symbol *uninterned* :test))))) + (assert (not (find-symbol *uninterned* :test)))) + (set-test-locks lock)) (defun tmp-fmakunbound (x) "FMAKUNDBOUND x, then restore the original binding." @@ -271,7 +269,7 @@ ;;; violations on TEST, and will not signal an error on LOAD if first ;;; compiled by COMPILE-FILE with test unlocked. CAR is the affected ;;; symbol, CDR the form affecting it. -(defvar *illegal-compile-time-forms-alist* +(defvar *illegal-lexical-forms-alist* '(;; binding ;; binding as a function @@ -315,68 +313,74 @@ (declare (ftype (function (fixnum) fixnum) test:numfun)) (cons t t))))) -(defvar *illegal-compile-time-forms* (mapcar #'cdr *illegal-compile-time-forms-alist*)) +(defvar *illegal-lexical-forms* + (mapcar #'cdr *illegal-lexical-forms-alist*)) (defvar *illegal-forms* (append *illegal-runtime-forms* - *illegal-compile-time-forms* + *illegal-lexical-forms* *illegal-double-forms*)) ;;;; Running the tests ;;; Unlocked. No errors nowhere. -(reset-test) -(set-test-locks nil) +(reset-test nil) + (dolist (form (append *legal-forms* *illegal-forms*)) (with-error-info ("~Unlocked form: ~S~%" form) (eval form))) ;;; Locked. Errors for all illegal forms, none for legal. -(reset-test) -(set-test-locks t) +(reset-test t) + (dolist (form *legal-forms*) (with-error-info ("locked legal form: ~S~%" form) (eval form))) -(reset-test) -(set-test-locks t) + (dolist (form (append *illegal-runtime-forms* *illegal-double-forms*)) (with-error-info ("locked illegal runtime form: ~S~%" form) (let ((fun (compile nil `(lambda () ,form)))) - (assert (raises-error? (funcall fun) sb-ext:package-lock-violation))))) -(dolist (pair *illegal-compile-time-forms-alist*) + (assert (raises-error? (funcall fun) sb-ext:package-lock-violation))) + (assert (raises-error? (eval form) sb-ext:package-lock-violation)))) + +(dolist (pair *illegal-lexical-forms-alist*) (let ((form (cdr pair))) - (with-error-info ("locked illegal compile-time form: ~S~%" form) - (assert (raises-error? (compile nil `(lambda () ,form)) sb-ext:package-lock-violation))))) + (with-error-info ("compile locked illegal lexical form: ~S~%" form) + (let ((fun (compile nil `(lambda () ,form)))) + (assert (raises-error? (funcall fun) program-error))) + (assert (raises-error? (eval form) program-error))))) + +;;; Locked, WITHOUT-PACKAGE-LOCKS +(reset-test t) -;;; Locked, WITHOUT-PACKAGE-LOCKS for runtime errors. -(reset-test) -(set-test-locks t) (dolist (form *illegal-runtime-forms*) (with-error-info ("without-package-locks illegal runtime form: ~S~%" form) (funcall (compile nil `(lambda () (without-package-locks ,form)))))) -;;; Locked, WITHOUT-PACKAGE-LOCKS & DISABLE-PACKAGE-LOCKS for compile-time errors. -(reset-test) -(set-test-locks t) -(dolist (pair *illegal-compile-time-forms-alist*) - (destructuring-bind (sym . form) pair - (with-error-info ("without-package-locks illegal compile-time form: ~S~%" form) - (let ((fun (without-package-locks (compile nil `(lambda () ,form))))) - (funcall fun))))) -(reset-test) -(set-test-locks t) -(dolist (pair *illegal-compile-time-forms-alist*) +(dolist (form *illegal-lexical-forms*) + (let ((fun (without-package-locks (compile nil `(lambda () ,form))))) + (funcall fun)) + (without-package-locks (eval form))) + +;;; Locked, DISABLE-PACKAGE-LOCKS +(reset-test t) + +(dolist (pair *illegal-lexical-forms-alist*) (destructuring-bind (sym . form) pair - (with-error-info ("disable-package-locks illegal compile-time form: ~S~%" form) + (with-error-info ("disable-package-locks on illegal form: ~S~%" + form) (funcall (compile nil `(lambda () (declare (disable-package-locks ,sym)) - ,form)))))) + ,form))) + (eval `(locally + (declare (disable-package-locks ,sym)) + ,form))))) ;;; Locked, one error per "lexically apparent violated package", also ;;; test restarts. -(reset-test) -(set-test-locks t) -(dolist (form (append *illegal-runtime-forms* *illegal-compile-time-forms*)) - (with-error-info ("one error per form: ~S~%" form) +(reset-test t) + +(dolist (form *illegal-runtime-forms*) + (with-error-info ("one error per form ~S~%" form) (let ((errorp nil)) (handler-bind ((package-lock-violation (lambda (e) (when errorp @@ -384,6 +388,7 @@ (setf errorp t) (continue e)))) (eval form))))) + (dolist (form *illegal-double-forms*) (with-error-info ("two errors per form: ~S~%" form) (let ((error-count 0)) @@ -398,55 +403,43 @@ error-count form)))))) ;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only +;;; +;;; This is not part of the interface, but it is the behaviour we want (let* ((tmp "package-locks.tmp.lisp") (fasl (compile-file-pathname tmp)) (n 0)) (dolist (form *illegal-runtime-forms*) (unwind-protect (with-simple-restart (next "~S failed, continue with next test" form) - (reset-test) - (set-test-locks nil) + (reset-test nil) (with-open-file (f tmp :direction :output) (prin1 form f)) (multiple-value-bind (file warnings failure-p) (compile-file tmp) (set-test-locks t) - (assert (raises-error? (load fasl) sb-ext:package-lock-violation)))) + (assert (raises-error? (load fasl) + sb-ext:package-lock-violation)))) (when (probe-file tmp) (delete-file tmp)) (when (probe-file fasl) (delete-file fasl))))) ;;;; Tests for enable-package-locks declarations -(reset-test) -(set-test-locks t) -(dolist (pair *illegal-compile-time-forms-alist*) +(reset-test t) + +(dolist (pair *illegal-lexical-forms-alist*) (destructuring-bind (sym . form) pair - (assert (raises-error? - (compile nil `(lambda () - (declare (disable-package-locks ,sym)) - ,form - (locally (declare (enable-package-locks ,sym)) - ,form))) - package-lock-violation)) + (let ((fun (compile nil `(lambda () + (declare (disable-package-locks ,sym)) + ,form + (locally (declare (enable-package-locks ,sym)) + ,form))))) + (assert (raises-error? (funcall fun) program-error))) (assert (raises-error? (eval `(locally (declare (disable-package-locks ,sym)) - ,form - (locally (declare (enable-package-locks ,sym)) - ,form))) - package-lock-violation)))) - -;;;; Program-errors from lexical violations -;;;; In addition to that, this is also testing for bug 387 -(with-test (:name :program-error - :fails-on :sbcl) - (reset-test) - (set-test-locks t) - (dolist (pair *illegal-compile-time-forms-alist*) - (destructuring-bind (sym . form) pair - (declare (ignore sym)) - (let ((fun (compile nil `(lambda () - ,form)))) - (assert (raises-error? (funcall fun) program-error)))))) + ,form + (locally (declare (enable-package-locks ,sym)) + ,form))) + program-error)))) ;;;; See that trace on functions in locked packages doesn't break ;;;; anything. @@ -457,10 +450,11 @@ (assert (package-locked-p :sb-gray)) (multiple-value-bind (fun compile-errors) (ignore-errors - (compile nil - '(lambda () - (defclass fare-class () - ((line-column :initform 0 :reader sb-gray:stream-line-column)))))) + (compile + nil + '(lambda () + (defclass fare-class () + ((line-column :initform 0 :reader sb-gray:stream-line-column)))))) (assert (not compile-errors)) (assert fun) (multiple-value-bind (class run-errors) (ignore-errors (funcall fun)) @@ -469,15 +463,16 @@ ;;;; No bogus violations from DECLARE's done by PCL behind the ;;;; scenes. Reported by David Wragg on sbcl-help. -(reset-test) -(set-test-locks t) +(reset-test t) + (defmethod pcl-type-declaration-method-bug ((test:*special* stream)) test:*special*) (assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*))) (assert (raises-error? - (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) - (declare (type stream test:*special*)) - test:*special*)) - package-lock-violation)) + (eval + '(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) + (declare (type stream test:*special*)) + test:*special*)) + program-error)) ;;; WOOT! Done. diff --git a/version.lisp-expr b/version.lisp-expr index cb58d2c..a9faa11 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".) -"0.9.11.34" +"0.9.11.35" -- 1.7.10.4