5
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
6
Copyright (c) 1990, Giuseppe Attardi.
7
Copyright (c) 2001, Juan Jose Garcia Ripoll.
9
ECL is free software; you can redistribute it and/or
10
modify it under the terms of the GNU Library General Public
11
License as published by the Free Software Foundation; either
12
version 2 of the License, or (at your option) any later version.
14
See file '../Copyright' for full details.
18
#include <ecl/internal.h>
20
/******************************* ------- ******************************/
22
* NOTE 1: we only need to use the package locks when reading/writing the hash
23
* tables, or changing the fields of a package. We do not need the locks to
24
* read lists from the packages (i.e. list of shadowing symbols, used
25
* packages, etc), or from the global environment (cl_core.packages_list) if
26
* we do not destructively modify them (For instance, use ecl_remove_eq
27
* instead of ecl_delete_eq).
30
* NOTE 2: Operations between locks must be guaranteed not fail, or, if
31
* they signal an error, they should undo all locks they had before.
39
FEpackage_error(const char *message, cl_object package, int narg, ...)
42
cl_va_start(args, narg, narg, 0);
43
si_signal_simple_error(6,
45
Cnil, /* not correctable */
46
make_constant_string(message), /* format control */
47
narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */
48
@':package', package); /* extra arguments */
52
CEpackage_error(const char *message, const char *continue_message, cl_object package, int narg, ...)
55
cl_va_start(args, narg, narg, 0);
56
si_signal_simple_error(6,
58
make_constant_string(continue_message),
59
make_constant_string(message), /* format control */
60
narg? cl_grab_rest_args(args) : cl_list(1,package),
61
@':package', package);
65
member_string_eq(cl_object x, cl_object l)
67
/* INV: l is a proper list */
68
for (; CONSP(l); l = CDR(l))
69
if (string_eq(x, CAR(l)))
75
Make_package(n, ns, ul) makes a package with name n,
76
which must be a string or a symbol,
77
and nicknames ns, which must be a list of strings or symbols,
78
and uses packages in list ul, which must be a list of packages
79
or package names i.e. strings or symbols.
82
make_package_hashtable()
87
h = cl_alloc_object(t_hashtable);
89
h->hash.test = htt_pack;
91
h->hash.rehash_size = make_shortfloat(1.5f);
92
h->hash.threshold = make_shortfloat(0.75f);
95
h->hash.data = NULL; /* for GC sake */
96
h->hash.data = (struct ecl_hashtable_entry *)cl_alloc(hsize * sizeof(struct ecl_hashtable_entry));
101
make_package(cl_object name, cl_object nicknames, cl_object use_list)
103
cl_object x, y, other;
105
name = cl_string(name);
106
assert_type_proper_list(nicknames);
107
assert_type_proper_list(use_list);
109
/* 1) Find a similarly named package in the list of packages to be
110
* created and use it.
113
if (cl_core.packages_to_be_created != OBJNULL) {
114
cl_object *p = &cl_core.packages_to_be_created;
115
for (x = *p; x != Cnil; ) {
116
if (equal(CAAR(x), name)) {
121
/* FIXME! We should also check the nicknames */
127
/* 2) Otherwise, try to build a new package */
128
if ((other = ecl_find_package_nolock(name)) != Cnil) {
129
ERROR: PACKAGE_OP_UNLOCK();
130
CEpackage_error("A package with the name ~A already exists.",
131
"Return existing package",
135
x = cl_alloc_object(t_package);
136
x->pack.internal = make_package_hashtable();
137
x->pack.external = make_package_hashtable();
140
#if defined(_MSC_VER) || defined(mingw32)
141
x->pack.lock = CreateMutex(NULL, FALSE, NULL);
144
pthread_mutexattr_t attr;
145
pthread_mutexattr_init(&attr);
146
pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK_NP);
147
pthread_mutex_init(&x->pack.lock, &attr);
148
pthread_mutexattr_destroy(&attr);
150
#endif /* _MSC_VER */
153
x->pack.nicknames = Cnil;
154
x->pack.shadowings = Cnil;
156
x->pack.usedby = Cnil;
157
x->pack.locked = FALSE;
158
for (; !endp(nicknames); nicknames = CDR(nicknames)) {
159
cl_object nick = cl_string(CAR(nicknames));
160
if ((other = ecl_find_package_nolock(nick)) != Cnil) {
164
x->pack.nicknames = CONS(nick, x->pack.nicknames);
166
for (; !endp(use_list); use_list = CDR(use_list)) {
167
y = si_coerce_to_package(CAR(use_list));
168
x->pack.uses = CONS(y, x->pack.uses);
169
y->pack.usedby = CONS(x, y->pack.usedby);
172
/* 3) Finally, add it to the list of packages */
173
cl_core.packages = CONS(x, cl_core.packages);
179
rename_package(cl_object x, cl_object name, cl_object nicknames)
183
name = cl_string(name);
184
x = si_coerce_to_package(x);
186
CEpackage_error("Cannot rename locked package ~S.",
187
"Ignore lock and proceed", x, 0);
190
y = ecl_find_package_nolock(name);
191
if ((y != Cnil) && (y != x)) {
192
ERROR: PACKAGE_OP_UNLOCK();
193
FEpackage_error("A package with name ~S already exists.", x,
198
x->pack.nicknames = Cnil;
199
assert_type_proper_list(nicknames);
200
for (; !endp(nicknames); nicknames = CDR(nicknames)) {
201
cl_object nick = CAR(nicknames);
202
y = ecl_find_package_nolock(nick);
209
x->pack.nicknames = CONS(cl_string(nick), x->pack.nicknames);
216
ecl_find_package_nolock(n) seaches for a package with name n, where n is
217
a valid string designator, or simply outputs n if it is a
220
This is not a locking routine and someone may replace the list of
221
packages while we are scanning it. Nevertheless, the list IS NOT
222
be destructively modified, which means that we are on the safe side.
223
Routines which need to ensure that the package list remains constant
224
should enforce a global lock with PACKAGE_OP_LOCK().
227
ecl_find_package_nolock(cl_object name)
231
if (type_of(name) == t_package)
233
name = cl_string(name);
234
/* INV: cl_core.packages is a proper list */
235
for (l = cl_core.packages; CONSP(l); l = CDR(l)) {
237
if (string_eq(name, p->pack.name))
239
if (member_string_eq(name, p->pack.nicknames))
246
si_coerce_to_package(cl_object p)
248
/* INV: ecl_find_package_nolock() signals an error if "p" is neither a package
250
cl_object pp = ecl_find_package_nolock(p);
252
FEpackage_error("There exists no package with name ~S", p, 0);
258
current_package(void)
262
x = symbol_value(@'*package*');
263
if (type_of(x) != t_package) {
264
ECL_SETQ(@'*package*', cl_core.user_package);
265
FEerror("The value of *PACKAGE*, ~S, was not a package",
272
Intern(st, p) interns string st in package p.
275
_intern(const char *s, cl_object p)
278
cl_object str = make_constant_string(s);
279
return intern(str, p, &intern_flag);
283
intern(cl_object name, cl_object p, int *intern_flag)
287
assert_type_string(name);
288
p = si_coerce_to_package(p);
291
s = gethash_safe(name, p->pack.external, OBJNULL);
293
*intern_flag = EXTERNAL;
296
/* Keyword package has no intern section nor can it be used */
297
if (p == cl_core.keyword_package) goto INTERN;
298
s = gethash_safe(name, p->pack.internal, OBJNULL);
300
*intern_flag = INTERNAL;
303
for (ul=p->pack.uses; CONSP(ul); ul = CDR(ul)) {
304
s = gethash_safe(name, CAR(ul)->pack.external, OBJNULL);
306
*intern_flag = INHERITED;
311
if (p->pack.locked) {
313
CEpackage_error("Cannot intern symbol ~S in locked package ~S.",
314
"Ignore lock and proceed", p, 2, name, p);
315
goto TRY_AGAIN_LABEL;
317
s = make_symbol(name);
320
if (p == cl_core.keyword_package) {
321
s->symbol.stype = stp_constant;
323
sethash(name, p->pack.external, s);
325
sethash(name, p->pack.internal, s);
333
ecl_find_symbol_nolock(st, len, p) searches for string st of length
337
ecl_find_symbol_nolock(cl_object name, cl_object p, int *intern_flag)
341
assert_type_string(name);
342
s = gethash_safe(name, p->pack.external, OBJNULL);
344
*intern_flag = EXTERNAL;
347
if (p == cl_core.keyword_package)
349
s = gethash_safe(name, p->pack.internal, OBJNULL);
351
*intern_flag = INTERNAL;
354
for (ul=p->pack.uses; CONSP(ul); ul = CDR(ul)) {
355
s = gethash_safe(name, CAR(ul)->pack.external, OBJNULL);
357
*intern_flag = INHERITED;
369
ecl_find_symbol(cl_object n, cl_object p, int *intern_flag)
372
p = si_coerce_to_package(p);
374
n = ecl_find_symbol_nolock(n, p, intern_flag);
380
unintern(cl_object s, cl_object p)
382
cl_object x, y, l, hash;
385
assert_type_symbol(s);
386
p = si_coerce_to_package(p);
390
hash = p->pack.internal;
391
x = gethash_safe(s->symbol.name, hash, OBJNULL);
394
hash = p->pack.external;
395
x = gethash_safe(s->symbol.name, hash, OBJNULL);
399
if (p->pack.locked) {
401
CEpackage_error("Cannot unintern symbol ~S from locked package ~S.",
402
"Ignore lock and proceed", p, 2, s, p);
403
goto TRY_AGAIN_LABEL;
405
if (!member_eq(s, p->pack.shadowings))
408
for (l = p->pack.uses; CONSP(l); l = CDR(l)) {
409
y = gethash_safe(s->symbol.name, CAR(l)->pack.external, OBJNULL);
415
FEpackage_error("Cannot unintern the shadowing symbol ~S~%"
417
"because ~S and ~S will cause~%"
418
"a name conflict.", p, 4, s, p, x, y);
422
p->pack.shadowings = ecl_remove_eq(s, p->pack.shadowings);
424
remhash(s->symbol.name, hash);
425
if (s->symbol.hpack == p)
426
s->symbol.hpack = Cnil;
434
cl_export2(cl_object s, cl_object p)
436
cl_object x, l, hash = OBJNULL;
439
assert_type_symbol(s);
440
p = si_coerce_to_package(p);
443
CEpackage_error("Cannot export symbol ~S from locked package ~S.",
444
"Ignore lock and proceed", p, 2, s, p);
446
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
449
CEpackage_error("The symbol ~S is not accessible from ~S and cannot be exported.",
450
"Import the symbol in the package and proceed.",
455
FEpackage_error("Cannot export the symbol ~S from ~S,~%"
456
"because there is already a symbol with the same name~%"
457
"in the package.", p, 2, s, p);
459
if (intern_flag == EXTERNAL)
461
if (intern_flag == INTERNAL)
462
hash = p->pack.internal;
463
for (l = p->pack.usedby; CONSP(l); l = CDR(l)) {
464
x = ecl_find_symbol_nolock(s->symbol.name, CAR(l), &intern_flag);
465
if (intern_flag && s != x &&
466
!member_eq(x, CAR(l)->pack.shadowings)) {
468
FEpackage_error("Cannot export the symbol ~S~%"
470
"because it will cause a name conflict~%"
471
"in ~S.", p, 3, s, p, CAR(l));
475
remhash(s->symbol.name, hash);
476
sethash(s->symbol.name, p->pack.external, s);
482
cl_delete_package(cl_object p)
484
cl_object hash, list;
487
/* 1) Try to remove the package from the global list */
488
p = ecl_find_package_nolock(p);
490
CEpackage_error("Package ~S not found. Cannot delete it.",
491
"Ignore error and continue", p, 0);
495
CEpackage_error("Cannot delete locked package ~S.",
496
"Ignore lock and proceed", p, 0);
497
if (p == cl_core.lisp_package || p == cl_core.keyword_package) {
498
FEpackage_error("Cannot remove package ~S", p, 0);
501
/* 2) Now remove the package from the other packages that use it
502
* and empty the package.
504
if (Null(p->pack.name)) {
507
for (list = p->pack.uses; !endp(list); list = CDR(list))
508
unuse_package(CAR(list), p);
509
for (list = p->pack.usedby; !endp(list); list = CDR(list))
510
unuse_package(p, CAR(list));
512
for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++)
513
if (hash->hash.data[i].key != OBJNULL) {
514
cl_object s = hash->hash.data[i].value;
515
if (s->symbol.hpack == p)
516
s->symbol.hpack = Cnil;
518
cl_clrhash(p->pack.internal);
519
for (hash = p->pack.external, i = 0; i < hash->hash.size; i++)
520
if (hash->hash.data[i].key != OBJNULL) {
521
cl_object s = hash->hash.data[i].value;
522
if (s->symbol.hpack == p)
523
s->symbol.hpack = Cnil;
525
cl_clrhash(p->pack.external);
526
p->pack.shadowings = Cnil;
530
/* 2) Only at the end, remove the package from the list of packages. */
532
cl_core.packages = ecl_remove_eq(p, cl_core.packages);
538
cl_unexport2(cl_object s, cl_object p)
543
assert_type_symbol(s);
544
p = si_coerce_to_package(p);
545
if (p == cl_core.keyword_package)
546
FEpackage_error("Cannot unexport a symbol from the keyword package.",
547
cl_core.keyword_package, 0);
549
CEpackage_error("Cannot unexport symbol ~S from locked package ~S.",
550
"Ignore lock and proceed", p, 2, s, p);
552
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
553
if (intern_flag == 0) {
555
FEpackage_error("Cannot unexport ~S because it does not belong to package ~S.",
558
if (intern_flag != EXTERNAL) {
559
/* According to ANSI & Cltl, internal symbols are
560
ignored in unexport */
563
remhash(s->symbol.name, p->pack.external);
564
sethash(s->symbol.name, p->pack.internal, s);
570
cl_import2(cl_object s, cl_object p)
575
assert_type_symbol(s);
576
p = si_coerce_to_package(p);
578
CEpackage_error("Cannot import symbol ~S into locked package ~S.",
579
"Ignore lock and proceed", p, 2, s, p);
581
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
585
CEpackage_error("Cannot import the symbol ~S "
587
"because there is already a symbol with the same name~%"
589
"Ignore conflict and proceed", p, 2, s, p);
591
if (intern_flag == INTERNAL || intern_flag == EXTERNAL)
594
sethash(s->symbol.name, p->pack.internal, s);
595
if (Null(s->symbol.hpack))
602
shadowing_import(cl_object s, cl_object p)
607
assert_type_symbol(s);
608
p = si_coerce_to_package(p);
610
CEpackage_error("Cannot shadowing-import symbol ~S into locked package ~S.",
611
"Ignore lock and proceed", p, 2, s, p);
614
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
615
if (intern_flag && intern_flag != INHERITED) {
617
if (!member_eq(x, p->pack.shadowings))
619
= CONS(x, p->pack.shadowings);
622
if(member_eq(x, p->pack.shadowings))
623
p->pack.shadowings = ecl_remove_eq(x, p->pack.shadowings);
624
if (intern_flag == INTERNAL)
625
remhash(x->symbol.name, p->pack.internal);
627
remhash(x->symbol.name, p->pack.external);
628
if (x->symbol.hpack == p)
629
x->symbol.hpack = Cnil;
631
p->pack.shadowings = CONS(s, p->pack.shadowings);
632
sethash(s->symbol.name, p->pack.internal, s);
638
shadow(cl_object s, cl_object p)
643
/* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */
645
p = si_coerce_to_package(p);
647
CEpackage_error("Cannot shadow symbol ~S in locked package ~S.",
648
"Ignore lock and proceed", p, 2, s, p);
650
x = ecl_find_symbol_nolock(s, p, &intern_flag);
651
if (intern_flag != INTERNAL && intern_flag != EXTERNAL) {
653
sethash(x->symbol.name, p->pack.internal, x);
656
p->pack.shadowings = CONS(x, p->pack.shadowings);
661
use_package(cl_object x, cl_object p)
663
struct ecl_hashtable_entry *hash_entries;
664
cl_index i, hash_length;
667
x = si_coerce_to_package(x);
668
if (x == cl_core.keyword_package)
669
FEpackage_error("Cannot use keyword package.", cl_core.keyword_package, 0);
670
p = si_coerce_to_package(p);
672
CEpackage_error("Cannot use package ~S in locked package ~S.",
673
"Ignore lock and proceed",
675
if (p == cl_core.keyword_package)
676
FEpackage_error("Cannot use in keyword package.", cl_core.keyword_package, 0);
679
if (member_eq(x, p->pack.uses))
684
hash_entries = x->pack.external->hash.data;
685
hash_length = x->pack.external->hash.size;
686
for (i = 0; i < hash_length; i++)
687
if (hash_entries[i].key != OBJNULL) {
688
cl_object here = hash_entries[i].value;
689
cl_object there = ecl_find_symbol_nolock(here->symbol.name, p, &intern_flag);
690
if (intern_flag && here != there
691
&& ! member_eq(there, p->pack.shadowings)) {
694
FEpackage_error("Cannot use ~S~%"
696
"because ~S and ~S will cause~%"
697
"a name conflict.", p, 4, x, p, here, there);
700
p->pack.uses = CONS(x, p->pack.uses);
701
x->pack.usedby = CONS(p, x->pack.usedby);
707
unuse_package(cl_object x, cl_object p)
709
x = si_coerce_to_package(x);
710
p = si_coerce_to_package(p);
712
CEpackage_error("Cannot unuse package ~S from locked package ~S.",
713
"Ignore lock and proceed",
717
p->pack.uses = ecl_remove_eq(x, p->pack.uses);
718
x->pack.usedby = ecl_remove_eq(p, x->pack.usedby);
723
@(defun make_package (pack_name &key nicknames (use CONS(cl_core.lisp_package, Cnil)))
725
/* INV: make_package() performs type checking */
726
@(return make_package(pack_name, nicknames, use))
730
si_select_package(cl_object pack_name)
732
cl_object p = si_coerce_to_package(pack_name);
733
@(return (ECL_SETQ(@'*package*', p)))
737
cl_find_package(cl_object p)
739
@(return ecl_find_package_nolock(p))
743
cl_package_name(cl_object p)
745
/* FIXME: name should be a fresh one */
746
p = si_coerce_to_package(p);
747
@(return p->pack.name)
751
cl_package_nicknames(cl_object p)
753
/* FIXME: list should be a fresh one */
754
p = si_coerce_to_package(p);
755
@(return p->pack.nicknames)
758
@(defun rename_package (pack new_name &o new_nicknames)
760
/* INV: rename_package() type checks and coerces pack to package */
761
@(return rename_package(pack, new_name, new_nicknames))
765
cl_package_use_list(cl_object p)
767
return cl_copy_list(si_coerce_to_package(p)->pack.uses);
771
cl_package_used_by_list(cl_object p)
773
return cl_copy_list(si_coerce_to_package(p)->pack.usedby);
777
cl_package_shadowing_symbols(cl_object p)
779
return cl_copy_list(si_coerce_to_package(p)->pack.shadowings);
783
si_package_lock(cl_object p, cl_object t)
785
p = si_coerce_to_package(p);
786
p->pack.locked = (t != Cnil);
791
cl_list_all_packages()
793
return cl_copy_list(cl_core.packages);
796
@(defun intern (strng &optional (p current_package()) &aux sym)
799
sym = intern(strng, p, &intern_flag);
800
if (intern_flag == INTERNAL)
801
@(return sym @':internal')
802
if (intern_flag == EXTERNAL)
803
@(return sym @':external')
804
if (intern_flag == INHERITED)
805
@(return sym @':inherited')
809
@(defun find_symbol (strng &optional (p current_package()))
813
x = ecl_find_symbol(strng, p, &intern_flag);
814
if (intern_flag == INTERNAL)
815
@(return x @':internal')
816
if (intern_flag == EXTERNAL)
817
@(return x @':external')
818
if (intern_flag == INHERITED)
819
@(return x @':inherited')
823
@(defun unintern (symbl &optional (p current_package()))
825
@(return (unintern(symbl, p) ? Ct : Cnil))
828
@(defun export (symbols &o (pack current_package()))
832
switch (type_of(symbols)) {
836
cl_export2(symbols, pack);
840
pack = si_coerce_to_package(pack);
841
for (l = symbols; !endp(l); l = CDR(l))
842
cl_export2(CAR(l), pack);
846
assert_type_symbol(symbols);
852
@(defun unexport (symbols &o (pack current_package()))
856
switch (type_of(symbols)) {
860
cl_unexport2(symbols, pack);
864
pack = si_coerce_to_package(pack);
865
for (l = symbols; !endp(l); l = CDR(l))
866
cl_unexport2(CAR(l), pack);
870
assert_type_symbol(symbols);
876
@(defun import (symbols &o (pack current_package()))
880
switch (type_of(symbols)) {
884
cl_import2(symbols, pack);
888
pack = si_coerce_to_package(pack);
889
for (l = symbols; !endp(l); l = CDR(l))
890
cl_import2(CAR(l), pack);
894
assert_type_symbol(symbols);
900
@(defun shadowing_import (symbols &o (pack current_package()))
904
switch (type_of(symbols)) {
908
shadowing_import(symbols, pack);
912
pack = si_coerce_to_package(pack);
913
for (l = symbols; !endp(l); l = CDR(l))
914
shadowing_import(CAR(l), pack);
918
assert_type_symbol(symbols);
924
@(defun shadow (symbols &o (pack current_package()))
928
switch (type_of(symbols)) {
932
/* Arguments to SHADOW may be: string designators ... */
935
shadow(symbols, pack);
938
/* ... or lists of string designators */
939
pack = si_coerce_to_package(pack);
940
for (l = symbols; !endp(l); l = CDR(l))
941
shadow(CAR(l), pack);
944
assert_type_string(symbols);
950
@(defun use_package (pack &o (pa current_package()))
954
switch (type_of(pack)) {
961
use_package(pack, pa);
965
pa = si_coerce_to_package(pa);
966
for (l = pack; !endp(l); l = CDR(l))
967
use_package(CAR(l), pa);
971
assert_type_package(pack);
977
@(defun unuse_package (pack &o (pa current_package()))
981
switch (type_of(pack)) {
988
unuse_package(pack, pa);
992
pa = si_coerce_to_package(pa);
993
for (l = pack; !endp(l); l = CDR(l))
994
unuse_package(CAR(l), pa);
998
assert_type_package(pack);
1005
si_package_hash_tables(cl_object p)
1007
cl_object he, hi, u;
1008
assert_type_package(p);
1010
he = si_copy_hash_table(p->pack.external);
1011
hi = si_copy_hash_table(p->pack.internal);
1012
u = cl_copy_list(p->pack.uses);
added
removed
src/c/package.d
