Commit e7295182 authored by Daniel Kochmański's avatar Daniel Kochmański
Browse files

local package nicknames: add missing functions

parent 8047148c
......@@ -953,6 +953,7 @@ si_package_lock(cl_object p, cl_object t)
@(return (previous? ECL_T : ECL_NIL));
}
/* --- local nicknames ---------------------------------------------------- */
cl_object
si_package_local_nicknames(cl_object p)
{
......@@ -967,6 +968,78 @@ si_package_locally_nicknamed_by_list(cl_object p)
return cl_copy_list(p->pack.nicknamedby);
}
cl_object
si_add_package_local_nickname(cl_object local_nickname,
cl_object actual_package,
cl_object target_package) {
local_nickname = cl_string(local_nickname);
actual_package = si_coerce_to_package(actual_package);
target_package = si_coerce_to_package(target_package);
cl_object existing = target_package->pack.local_nicknames;
cl_object cell = ecl_assoc(local_nickname, existing);
if (target_package->pack.locked
&& ECL_SYM_VAL(ecl_process_env(), @'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Cannot nickname package ~S from locked package ~S.",
"Ignore lock and proceed.",
target_package, 2, actual_package, target_package);
}
if (!Null(cell)) {
cl_object old_package = ECL_CONS_CDR(cell);
if (old_package != actual_package) {
FEpackage_error("Cannot add ~A as local nickname for ~A:~%"
"already a nickname for ~A.",
target_package, 3,
local_nickname, actual_package, old_package);
}
return target_package;
}
ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) {
cl_object nickname_cons = CONS(local_nickname, actual_package);
target_package->pack.local_nicknames
= CONS(nickname_cons, target_package->pack.local_nicknames);
actual_package->pack.nicknamedby
= CONS(target_package, actual_package->pack.nicknamedby);
} ECL_WITH_GLOBAL_ENV_WRLOCK_END;
return target_package;
}
cl_object
si_remove_package_local_nickname(cl_object old_nickname,
cl_object target_package) {
old_nickname = cl_string(old_nickname);
target_package = si_coerce_to_package(target_package);
if (target_package->pack.locked
&& ECL_SYM_VAL(ecl_process_env(),
@'si::*ignore-package-locks*') == ECL_NIL) {
CEpackage_error("Cannot remove local package nickname ~S from locked package ~S.",
"Ignore lock and proceed.",
target_package, 2, old_nickname, target_package);
}
cl_object actual_package = ECL_NIL;
ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) {
cl_object cell = ecl_assoc(old_nickname, target_package->pack.local_nicknames);
if (!Null(cell)) {
actual_package = ECL_CONS_CDR(cell);
target_package->pack.local_nicknames
= ecl_delete_eq(cell, target_package->pack.local_nicknames);
actual_package->pack.nicknamedby
= ecl_delete_eq(target_package, actual_package->pack.nicknamedby);
}
} ECL_WITH_GLOBAL_ENV_WRLOCK_END;
return Null(actual_package) ? ECL_NIL : ECL_T;
}
/* ------------------------------------------------------------------------ */
cl_object
cl_list_all_packages()
{
......
......@@ -1217,6 +1217,8 @@ cl_symbols[] = {
{SYS_ "WITH-UNLOCKED-PACKAGES", EXT_ORDINARY, NULL, 1, OBJNULL},
{EXT_ "PACKAGE-LOCAL-NICKNAMES", EXT_ORDINARY, si_package_local_nicknames, 1, OBJNULL},
{EXT_ "PACKAGE-LOCALLY-NICKNAMED-BY-LIST", EXT_ORDINARY, si_package_locally_nicknamed_by_list, 1, OBJNULL},
{EXT_ "ADD-PACKAGE-LOCAL-NICKNAME", EXT_ORDINARY, si_add_package_local_nickname, 3, OBJNULL},
{EXT_ "REMOVE-PACKAGE-LOCAL-NICKNAME", EXT_ORDINARY, si_remove_package_local_nickname, 2, OBJNULL},
/* ~ */
{SYS_ "PACKAGE-HASH-TABLES", SI_ORDINARY, si_package_hash_tables, 1, OBJNULL},
{SYS_ "PATHNAME-TRANSLATIONS", SI_ORDINARY, si_pathname_translations, -1, OBJNULL},
......
......@@ -1217,7 +1217,9 @@ cl_symbols[] = {
{SYS_ "WITH-UNLOCKED-PACKAGES",NULL},
{EXT_ "PACKAGE-LOCAL-NICKNAMES","si_package_local_nicknames"},
{EXT_ "PACKAGE-LOCALLY-NICKNAMED-BY-LIST","si_package_locally_nicknamed_by_list"},
{EXT_ "ADD-PACKAGE-LOCAL-NICKNAME","si_add_package_local_nickname"},
{EXT_ "REMOVE-PACKAGE-LOCAL-NICKNAME","si_remove_package_local_nickname"},
/* ~ */
{SYS_ "PACKAGE-HASH-TABLES","si_package_hash_tables"},
{SYS_ "PATHNAME-TRANSLATIONS","si_pathname_translations"},
{SYS_ "POINTER","si_pointer"},
......
......@@ -443,6 +443,14 @@
(proclamation si:package-hash-tables (package-designator)
(values hash-table hash-table list) :reader)
(proclamation ext:package-lock (package-designator gen-bool) package)
(proclamation ext:package-local-nicknames
(package-designator) list :no-side-effects)
(proclamation ext:package-locally-nicknamed-by-list
(package-designator) list :no-side-effects)
(proclamation ext:add-package-local-nickname
(string-designator package-designator package-designator) package)
(proclamation ext:remove-package-local-nickname
(string-designator package-designator) list)
;;;
;;; 12. NUMBERS
......
......@@ -1285,6 +1285,8 @@ extern ECL_API cl_object cl_package_used_by_list(cl_object p);
extern ECL_API cl_object cl_package_shadowing_symbols(cl_object p);
extern ECL_API cl_object si_package_local_nicknames(cl_object p);
extern ECL_API cl_object si_package_locally_nicknamed_by_list(cl_object p);
extern ECL_API cl_object si_add_package_local_nickname(cl_object n, cl_object p1, cl_object p2);
extern ECL_API cl_object si_remove_package_local_nickname(cl_object n, cl_object p);
extern ECL_API cl_object cl_list_all_packages(void);
extern ECL_API cl_object si_package_hash_tables(cl_object p);
extern ECL_API cl_object si_package_lock(cl_object p, cl_object t);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment