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
(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
(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)))
@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
@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
@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:
,@@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
"*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"
"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"
(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)
;;; 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
;;; 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*))
(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
(: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) ())
(sb!c::process-decls decls
vars
nil
- :lexenv lexenv))))
+ :lexenv lexenv
+ :context :eval))))
(eval-progn-body body lexenv))))
(defun eval (original-exp)
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)
;; 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))))))
\f
;;; miscellaneous full function definitions of things which are
;;; ordinarily handled magically by the compiler
(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))
(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"
(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)
(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)
;;; 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)
;;; 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
;;; 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
;;; 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)
: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)))
;;;
;;; 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))
(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
(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)
(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))
(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."
;;; 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
(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
(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))
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.
(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))
;;;; 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.
;;; 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"
projects / sbcl.git / commitdiff