mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-24 21:41:29 -08:00
Code Issues Projects Releases Packages Wiki Activity

add package-locks abstraction

Browse source 
We follow the protocol proposed by SBCL.
This commit is contained in:
Daniel Kochmański 2016-11-09 16:44:51 +01:00
parent 861b286f40
commit 36b1b1d3cc
5 changed files with 103 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

10
src/c/assignment.d
View file

@ -116,7 +116,10 @@ ecl_rem_setf_definition(cl_object sym)
if (Null(cl_functionp(def)))
FEinvalid_function(def);
pack = ecl_symbol_package(sym);
if (pack != ECL_NIL && pack->pack.locked) {
if (pack != ECL_NIL
&& pack->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Attempt to redefine function ~S in locked package.",
"Ignore lock and proceed", pack, 1, fname);
}
@ -167,7 +170,10 @@ cl_fmakunbound(cl_object fname)
{
cl_object sym = si_function_block_name(fname);
cl_object pack = ecl_symbol_package(sym);
if (pack != ECL_NIL && pack->pack.locked) {
if (pack != ECL_NIL
&& pack->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Attempt to redefine function ~S in locked package.",
"Ignore lock and proceed", pack, 1, fname);
}

45
src/c/package.d
View file

@ -245,7 +245,9 @@ ecl_rename_package(cl_object x, cl_object name, cl_object nicknames)
name = cl_string(name);
nicknames = process_nicknames(nicknames);
x = si_coerce_to_package(x);
if (x->pack.locked) {
if (x->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Cannot rename locked package ~S.",
"Ignore lock and proceed", x, 0);
}
@ -369,7 +371,10 @@ ecl_intern(cl_object name, cl_object p, int *intern_flag)
s = find_symbol_inner(name, p, intern_flag);
if (*intern_flag) {
error = 0;
} else if (p->pack.locked && !ignore_error) {
} else if (p->pack.locked
&& !ignore_error
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
error = 1;
} else {
s = cl_make_symbol(name);
@ -472,7 +477,9 @@ ecl_unintern(cl_object s, cl_object p)
cl_object name = ecl_symbol_name(s);
p = si_coerce_to_package(p);
if (p->pack.locked) {
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Cannot unintern symbol ~S from locked package ~S.",
"Ignore lock and proceed", p, 2, s, p);
}
@ -531,7 +538,9 @@ cl_export2(cl_object s, cl_object p)
int intern_flag, error;
cl_object other_p, name = ecl_symbol_name(s);
p = si_coerce_to_package(p);
if (p->pack.locked)
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL)
CEpackage_error("Cannot export symbol ~S from locked package ~S.",
"Ignore lock and proceed", p, 2, s, p);
AGAIN:
@ -584,7 +593,9 @@ cl_delete_package(cl_object p)
"Ignore error and continue", p, 0);
@(return ECL_NIL);
}
if (p->pack.locked)
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL)
CEpackage_error("Cannot delete locked package ~S.",
"Ignore lock and proceed", p, 0);
if (p == cl_core.lisp_package || p == cl_core.keyword_package) {
@ -635,7 +646,9 @@ cl_unexport2(cl_object s, cl_object p)
FEpackage_error("Cannot unexport a symbol from the keyword package.",
cl_core.keyword_package, 0);
}
if (p->pack.locked) {
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Cannot unexport symbol ~S from locked package ~S.",
"Ignore lock and proceed", p, 2, s, p);
}
@ -667,7 +680,9 @@ cl_import2(cl_object s, cl_object p)
int intern_flag, error, ignore_error = 0;
cl_object name = ecl_symbol_name(s);
p = si_coerce_to_package(p);
if (p->pack.locked) {
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Cannot import symbol ~S into locked package ~S.",
"Ignore lock and proceed", p, 2, s, p);
}
@ -706,7 +721,9 @@ ecl_shadowing_import(cl_object s, cl_object p)
cl_object x;
cl_object name = ecl_symbol_name(s);
p = si_coerce_to_package(p);
if (p->pack.locked)
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL)
CEpackage_error("Cannot shadowing-import symbol ~S into "
"locked package ~S.",
"Ignore lock and proceed", p, 2, s, p);
@ -745,7 +762,9 @@ ecl_shadow(cl_object s, cl_object p)
/* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */
s = cl_string(s);
p = si_coerce_to_package(p);
if (p->pack.locked)
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL)
CEpackage_error("Cannot shadow symbol ~S in locked package ~S.",
"Ignore lock and proceed", p, 2, s, p);
ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) {
@ -779,7 +798,9 @@ ecl_use_package(cl_object x, cl_object p)
if (p == cl_core.keyword_package)
FEpackage_error("Cannot apply USE-PACKAGE on keyword package.",
cl_core.keyword_package, 0);
if (p->pack.locked)
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL)
CEpackage_error("Cannot use package ~S in locked package ~S.",
"Ignore lock and proceed",
p, 2, x, p);
@ -817,7 +838,9 @@ ecl_unuse_package(cl_object x, cl_object p)
{
x = si_coerce_to_package(x);
p = si_coerce_to_package(p);
if (p->pack.locked)
if (p->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL)
CEpackage_error("Cannot unuse package ~S from locked package ~S.",
"Ignore lock and proceed",
p, 2, x, p);

8
src/c/symbols_list.h
View file

@ -1207,7 +1207,15 @@ cl_symbols[] = {
{EXT_ "MKSTEMP", EXT_ORDINARY, si_mkstemp, 1, OBJNULL},
{SYS_ "RMDIR", SI_ORDINARY, si_rmdir, 1, OBJNULL},
{EXT_ "MAKE-PIPE", EXT_ORDINARY, si_make_pipe, 0, OBJNULL},
/* PACKAGE_LOCKS */
{SYS_ "*IGNORE-PACKAGE-LOCKS*", SI_SPECIAL, NULL, -1, ECL_NIL},
{EXT_ "PACKAGE-LOCK", EXT_ORDINARY, si_package_lock, 2, OBJNULL},
{SYS_ "LOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "UNLOCK-PACKAGE", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "PACKAGE-LOCKED-P", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "WITHOUT-PACKAGE-LOCKS", EXT_ORDINARY, NULL, 1, OBJNULL},
{SYS_ "WITH-UNLOCKED-PACKAGES", EXT_ORDINARY, NULL, 1, OBJNULL},
/* ~PACKAGE_LOCKS */
{SYS_ "PACKAGE-HASH-TABLES", SI_ORDINARY, si_package_hash_tables, 1, OBJNULL},
{SYS_ "PATHNAME-TRANSLATIONS", SI_ORDINARY, si_pathname_translations, -1, OBJNULL},
{SYS_ "POINTER", SI_ORDINARY, si_pointer, 1, OBJNULL},

8
src/c/symbols_list2.h
View file

@ -1207,7 +1207,15 @@ cl_symbols[] = {
{EXT_ "MKSTEMP","si_mkstemp"},
{SYS_ "RMDIR","si_rmdir"},
{EXT_ "MAKE-PIPE","si_make_pipe"},
/* PACKAGE_LOCKS */
{SYS_ "*IGNORE-PACKAGE-LOCKS*",NULL},
{EXT_ "PACKAGE-LOCK","si_package_lock"},
{SYS_ "LOCK-PACKAGE",NULL},
{SYS_ "UNLOCK-PACKAGE",NULL},
{SYS_ "PACKAGE-LOCKED-P",NULL},
{SYS_ "WITHOUT-PACKAGE-LOCKS",NULL},
{SYS_ "WITH-UNLOCKED-PACKAGES",NULL},
/* ~PACKAGE_LOCKS */
{SYS_ "PACKAGE-HASH-TABLES","si_package_hash_tables"},
{SYS_ "PATHNAME-TRANSLATIONS","si_pathname_translations"},
{SYS_ "POINTER","si_pointer"},

45
src/lsp/packlib.lsp
View file

@ -284,3 +284,48 @@ If PACKAGE is non-NIL, then only the specified PACKAGE is searched."
(prefix (string-prefix-p parent-prefix package-name)))
(when (and prefix (or recurse (not (find #\. package-name :start prefix))))
(pushnew package res)))))))
;;; Package locks
(pushnew :package-locks *features*)
(defun lock-package (package &aux (package (si:coerce-to-package package)))
(ffi:c-inline (package) (:object) :void
"(#0)->pack.locked = 1"
:side-effects t
:one-liner t))
(defun unlock-package (package &aux (package (si:coerce-to-package package)))
(ffi:c-inline (package) (:object) :void
"(#0)->pack.locked = 0"
:side-effects t
:one-liner t))
(defun package-locked-p (package &aux (package (si:coerce-to-package package)))
"Returns T when PACKAGE is locked, NIL otherwise. Signals an error
if PACKAGE doesn't designate a valid package."
(ffi:c-inline (package) (:object) :object
"(#0)->pack.locked ? ECL_T : ECL_NIL"
:side-effects nil
:one-liner t))
(defmacro without-package-locks (&body body)
"Ignores all runtime package lock violations during the execution of
body. Body can begin with declarations."
`(let ((si::*ignore-package-locks* t)) ,@body))
(defmacro with-unlocked-packages ((&rest packages) &body forms)
"Unlocks PACKAGES for the dynamic scope of the body. Signals an
error if any of PACKAGES is not a valid package designator."
(with-unique-names (unlocked-packages)
`(let (,unlocked-packages)
(unwind-protect
(progn
(dolist (p ',packages)
(when (package-locked-p p)
(push p ,unlocked-packages)
(unlock-package p)))
,@forms)
(dolist (p ,unlocked-packages)
(when (find-package p)
(lock-package p)))))))