From 9c2aef559936cc37f3d66b437adcc301c0db9975 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Sun, 30 Apr 2017 12:35:00 +0200 Subject: [PATCH] packages: add local-nicknames to the internal structure adjust internal functions to accept the argument. --- src/c/main.d | 33 ++++++++++++++++++++++----------- src/c/package.d | 36 ++++++++++++++++++++++++++++-------- src/c/symbols_list.h | 1 + src/c/symbols_list2.h | 1 + src/h/external.h | 2 +- src/h/object.h | 11 ++++++----- src/lsp/defpackage.lsp | 2 +- 7 files changed, 60 insertions(+), 26 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index aaf10be7c..f5a75d35c 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -556,43 +556,54 @@ cl_boot(int argc, char **argv) cl_core.lisp_package = ecl_make_package(str_common_lisp, cl_list(2, str_cl, str_LISP), + ECL_NIL, ECL_NIL); cl_core.user_package = ecl_make_package(str_common_lisp_user, cl_list(2, str_cl_user, str_user), - ecl_list1(cl_core.lisp_package)); + ecl_list1(cl_core.lisp_package), + ECL_NIL); cl_core.keyword_package = - ecl_make_package(str_keyword, ECL_NIL, ECL_NIL); + ecl_make_package(str_keyword, ECL_NIL, ECL_NIL, ECL_NIL); cl_core.ext_package = - ecl_make_package(str_ext, ECL_NIL, - ecl_list1(cl_core.lisp_package)); + ecl_make_package(str_ext, + ECL_NIL, + ecl_list1(cl_core.lisp_package), + ECL_NIL); cl_core.system_package = ecl_make_package(str_si, cl_list(2,str_system,str_sys), cl_list(2,cl_core.ext_package, - cl_core.lisp_package)); + cl_core.lisp_package), + ECL_NIL); cl_core.c_package = ecl_make_package(str_c, ecl_list1(str_compiler), - ecl_list1(cl_core.lisp_package)); + ecl_list1(cl_core.lisp_package), + ECL_NIL); cl_core.clos_package = ecl_make_package(str_clos, ecl_list1(str_mop), - ecl_list1(cl_core.lisp_package)); + ecl_list1(cl_core.lisp_package), + ECL_NIL); cl_core.mp_package = ecl_make_package(str_mp, ecl_list1(str_multiprocessing), - ecl_list1(cl_core.lisp_package)); + ecl_list1(cl_core.lisp_package), + ECL_NIL); #ifdef ECL_CLOS_STREAMS - cl_core.gray_package = ecl_make_package(str_gray, ECL_NIL, - CONS(cl_core.lisp_package, ECL_NIL)); + cl_core.gray_package = ecl_make_package(str_gray, + ECL_NIL, + ecl_list1(cl_core.lisp_package), + ECL_NIL); #endif cl_core.ffi_package = ecl_make_package(str_ffi, ECL_NIL, cl_list(3,cl_core.lisp_package, cl_core.system_package, - cl_core.ext_package)); + cl_core.ext_package), + ECL_NIL); ECL_NIL_SYMBOL->symbol.hpack = cl_core.lisp_package; cl_import2(ECL_NIL, cl_core.lisp_package); diff --git a/src/c/package.d b/src/c/package.d index 7147af414..d72203f57 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -95,11 +95,12 @@ symbol_add_package(cl_object s, cl_object p) } /* - ecl_make_package(n, ns, ul) makes a package with name n, - which must be a string or a symbol, - and nicknames ns, which must be a list of strings or symbols, - and uses packages in list ul, which must be a list of packages - or package names i.e. strings or symbols. + ecl_make_package(n, ns, ul, lns) makes a package with name n, which + must be a string or a symbol, and nicknames ns, which must be a list + of strings or symbols, and uses packages in list ul, which must be a + list of packages or package names i.e. strings or symbols. lns is an + alist (local-nickname . package) which is used for having private + nicknames for other packages. */ static cl_object make_package_hashtable() @@ -118,6 +119,7 @@ alloc_package(cl_object name) p->pack.external = make_package_hashtable(); p->pack.name = name; p->pack.nicknames = ECL_NIL; + p->pack.local_nicknames = ECL_NIL; p->pack.shadowings = ECL_NIL; p->pack.uses = ECL_NIL; p->pack.usedby = ECL_NIL; @@ -184,8 +186,21 @@ process_package_list(cl_object packages) return packages; } +static cl_object +process_local_nicknames_list(cl_object local_nicknames) +{ + cl_object l; + local_nicknames = cl_copy_list(local_nicknames); + for (l = local_nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + ECL_RPLACA(l, si_coerce_to_package(ECL_CONS_CAR(l))); + ECL_RPLACD(l, si_coerce_to_package(ECL_CONS_CDR(l))); + } + return local_nicknames; +} + cl_object -ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) +ecl_make_package(cl_object name, cl_object nicknames, + cl_object use_list, cl_object local_nicknames) { const cl_env_ptr env = ecl_process_env(); cl_object x, other = ECL_NIL; @@ -195,6 +210,7 @@ ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) name = cl_string(name); nicknames = process_nicknames(nicknames); use_list = process_package_list(use_list); + local_nicknames = process_local_nicknames_list(local_nicknames); ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) { /* Find a similarly named package in the list of @@ -223,6 +239,7 @@ ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) x->pack.uses = CONS(y, x->pack.uses); y->pack.usedby = CONS(x, y->pack.usedby); } end_loop_for_in; + x->pack.local_nicknames = local_nicknames; /* Finally, add it to the list of packages */ cl_core.packages = CONS(x, cl_core.packages); OUTPUT: @@ -850,10 +867,13 @@ ecl_unuse_package(cl_object x, cl_object p) } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } -@(defun make_package (pack_name &key nicknames (use CONS(cl_core.lisp_package, ECL_NIL))) +@(defun make_package (pack_name &key + nicknames + (use CONS(cl_core.lisp_package, ECL_NIL)) + local_nicknames) @ /* INV: ecl_make_package() performs type checking */ - @(return ecl_make_package(pack_name, nicknames, use)); + @(return ecl_make_package(pack_name, nicknames, use, local_nicknames)); @) cl_object diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index affa59ddc..a87f91732 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1388,6 +1388,7 @@ cl_symbols[] = { {KEY_ "LINK", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "LIST-ALL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "LOCAL",KEYWORD,NULL,-1,OBJNULL}, +{KEY_ "LOCAL-NICKNAMES",KEYWORD,NULL,-1,OBJNULL}, {KEY_ "LOCKABLE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "LOAD-TOPLEVEL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "MASK", KEYWORD, NULL, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 36a33dd49..5ba4f51a3 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1388,6 +1388,7 @@ cl_symbols[] = { {KEY_ "LINK",NULL}, {KEY_ "LIST-ALL",NULL}, {KEY_ "LOCAL",NULL}, +{KEY_ "LOCAL-NICKNAMES",NULL}, {KEY_ "LOCKABLE",NULL}, {KEY_ "LOAD-TOPLEVEL",NULL}, {KEY_ "MASK",NULL}, diff --git a/src/h/external.h b/src/h/external.h index df0a80f39..c73e29b17 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1300,7 +1300,7 @@ extern ECL_API cl_object cl_shadow _ECL_ARGS((cl_narg narg, cl_object symbols, . extern ECL_API cl_object cl_use_package _ECL_ARGS((cl_narg narg, cl_object pack, ...)); extern ECL_API cl_object cl_unuse_package _ECL_ARGS((cl_narg narg, cl_object pack, ...)); -extern ECL_API cl_object ecl_make_package(cl_object n, cl_object ns, cl_object ul); +extern ECL_API cl_object ecl_make_package(cl_object n, cl_object ns, cl_object ul, cl_object lns); extern ECL_API cl_object ecl_rename_package(cl_object x, cl_object n, cl_object ns); extern ECL_API cl_object ecl_find_package_nolock(cl_object n); extern ECL_API cl_object ecl_find_package(const char *p); diff --git a/src/h/object.h b/src/h/object.h index ebc31e816..5dd9fc6c2 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -272,11 +272,12 @@ struct ecl_symbol { struct ecl_package { _ECL_HDR1(locked); - cl_object name; /* package name, a string */ - cl_object nicknames; /* nicknames, list of strings */ - cl_object shadowings; /* shadowing symbol list */ - cl_object uses; /* use-list of packages */ - cl_object usedby; /* used-by-list of packages */ + cl_object name; /* package name, a string */ + cl_object nicknames; /* nicknames, list of strings */ + cl_object local_nicknames; /* local nicknames, assoc list */ + cl_object shadowings; /* shadowing symbol list */ + cl_object uses; /* use-list of packages */ + cl_object usedby; /* used-by-list of packages */ cl_object internal; /* hashtable for internal symbols */ cl_object external; /* hashtable for external symbols */ }; diff --git a/src/lsp/defpackage.lsp b/src/lsp/defpackage.lsp index 0c88d2d5f..7550cb22f 100644 --- a/src/lsp/defpackage.lsp +++ b/src/lsp/defpackage.lsp @@ -204,7 +204,7 @@ (rename-package name name nicknames)) (when use (unuse-package (package-use-list (find-package name)) name))) - (make-package name :use nil :nicknames nicknames)) + (make-package name :use nil :nicknames nicknames :local-nicknames local-nicknames)) (let ((*package* (find-package name))) (when documentation (setf (documentation *package* t) documentation))