extensions: put ext:package-locked-p in core module.

contrib/package-locks/package-locks.lisp

@@ -26,14 +26,6 @@
                 :one-liner t)
   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."

src/c/package.d

@@ -563,7 +563,7 @@ void
 cl_export2(cl_object s, cl_object p)
 {
   int intern_flag, error;
-  cl_object other_p, name = ecl_symbol_name(s);
+  cl_object other_p = ECL_NIL, name = ecl_symbol_name(s);
   p = si_coerce_to_package(p);
   if (p->pack.locked
       && ECL_SYM_VAL(ecl_process_env(),
@@ -966,6 +966,13 @@ si_package_lock(cl_object p, cl_object t)
   @(return (previous? ECL_T : ECL_NIL));
 }
 
+cl_object
+si_package_locked_p (cl_object p)
+{
+  p = si_coerce_to_package(p);
+  @return (p->pack.locked ? ECL_T : ECL_NIL);
+}
+
 /* --- local nicknames ---------------------------------------------------- */
 cl_object
 si_package_local_nicknames(cl_object p)

src/c/symbols_list.h

@@ -1207,9 +1207,9 @@ cl_symbols[] = {
 /* package extensions */
 {SYS_ "*IGNORE-PACKAGE-LOCKS*", SI_SPECIAL, NULL, -1, ECL_NIL},
 {EXT_ "PACKAGE-LOCK", EXT_ORDINARY, si_package_lock, 2, OBJNULL},
+{EXT_ "PACKAGE-LOCKED-P", EXT_ORDINARY, si_package_locked_p, 1, 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},
 {EXT_ "PACKAGE-LOCAL-NICKNAMES", EXT_ORDINARY, si_package_local_nicknames, 1, OBJNULL},

src/c/symbols_list2.h

@@ -1207,9 +1207,9 @@ cl_symbols[] = {
 /* package extensions */
 {SYS_ "*IGNORE-PACKAGE-LOCKS*",NULL},
 {EXT_ "PACKAGE-LOCK","si_package_lock"},
+{EXT_ "PACKAGE-LOCKED-P","si_package_locked_p"},
 {SYS_ "LOCK-PACKAGE",NULL},
 {SYS_ "UNLOCK-PACKAGE",NULL},
-{SYS_ "PACKAGE-LOCKED-P",NULL},
 {SYS_ "WITHOUT-PACKAGE-LOCKS",NULL},
 {SYS_ "WITH-UNLOCKED-PACKAGES",NULL},
 {EXT_ "PACKAGE-LOCAL-NICKNAMES","si_package_local_nicknames"},

src/cmp/proclamations.lsp

@@ -453,6 +453,7 @@
 (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-locked-p (package-designator) boolean :no-side-effects)
 (proclamation ext:package-local-nicknames
  (package-designator) list :no-side-effects)
 (proclamation ext:package-locally-nicknamed-by-list

src/doc/help.lsp

@@ -2295,6 +2295,14 @@ built-in packages:
         system   system internal symbols.  Has nicknames SYS and SI.
         compiler system internal symbols for the ECL compiler.")
 
+(docfun ext:package-lock function
+        (package-designator lock) "
+Sets package's lock to LOCK. Returns previous lock value.")
+
+(docfun ext:package-locked-p function
+        (package-designator) "
+Returns T when PACKAGE is locked, NIL otherwise.")
+
 (docfun ext:package-local-nicknames function
         (package-designator) "
 Returns an alist of (LOCAL-NICKNAME . ACTUAL-PACKAGE)

src/h/external.h

@@ -1313,6 +1313,7 @@ extern ECL_API cl_object si_remove_package_local_nickname(cl_object n, cl_object
 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);
+extern ECL_API cl_object si_package_locked_p(cl_object p);
 extern ECL_API cl_object cl_delete_package(cl_object p);
 extern ECL_API cl_object cl_make_package _ECL_ARGS((cl_narg narg, cl_object pack_name, ...));
 extern ECL_API cl_object cl_intern _ECL_ARGS((cl_narg narg, cl_object strng, ...));