From 36b1b1d3ccb357d33ee3e4cfefc0a6d8edf2c14a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 9 Nov 2016 16:44:51 +0100 Subject: [PATCH] add package-locks abstraction We follow the protocol proposed by SBCL. --- src/c/assignment.d | 10 ++++++++-- src/c/package.d | 45 ++++++++++++++++++++++++++++++++----------- src/c/symbols_list.h | 8 ++++++++ src/c/symbols_list2.h | 8 ++++++++ src/lsp/packlib.lsp | 45 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 103 insertions(+), 13 deletions(-) diff --git a/src/c/assignment.d b/src/c/assignment.d index 148be9d7f..6b1b22041 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -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); } diff --git a/src/c/package.d b/src/c/package.d index 51efa524c..7147af414 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -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); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index b3313de2b..fe3c73656 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 32cee48ce..719962b5b 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -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"}, diff --git a/src/lsp/packlib.lsp b/src/lsp/packlib.lsp index 9622d9bba..3d9df2306 100644 --- a/src/lsp/packlib.lsp +++ b/src/lsp/packlib.lsp @@ -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)))))))