1 /*
2 * Package Management for CLISP
3 * Bruno Haible 1990-2005, 2017
4 * Sam Steingold 1999-2011, 2016
5 * German comments translated into English: Stefan Kain 2002-02-20
6 */
7
8 #include "lispbibl.c"
9 #include "arilev0.c" /* for hashcode calculation */
10
11 #ifdef MULTITHREAD
12 /* mutex for guarding access to O(all_packages) */
13 global xmutex_t all_packages_lock;
14 #endif
15
16 /* MT changes
17 There is global mutex for O(all_packages) and per package recursive lisp
18 mutex. If both of them should be obtained (for any package) - the order
19 O(all_packages_lock) --> package lock should be preserved. Otherwise deadlocks
20 are possible. Also if multiple package locks should be obtained at the same
21 time - first all_package_lock should be obtained - such cases are use-package,
22 unuse-package.
23
24 Symbol lookups are not guarded but are safe due to the way symtab_insert and
25 rehash_symtab work. On MT rehash_symtab always returns newly allocated symtab
26 that does not share nor modifies the old one - thus any thread that may perform
27 lookups on the old one will not be "surprised" by modified internals (and
28 intern (e.g. symtab_insert) is guarded by package mutex).
29 This copy semantic on rehashing is slower than previous cons cell reuse but is
30 better than obtaining lock on symbol lookup.
31
32 The use of WITH_xxx macros for locking makes debugging harder but is clean way
33 to handle stack unwind and release acquired locks.*/
34
35 /* data structure of the symbols: see LISPBIBL.D
36 data structure of the symbol table:
37 a vector with 3 Slots:
38 size Fixnum >0, <2^24, = length of the table
39 table vector of length size,
40 contains single symbols (/= NIL) and symbol-lists
41 count number of symbols in the table, Fixnum >=0 */
42 #define Symtab_size(symtab) (TheSvector(symtab)->data[0])
43 #define Symtab_table(symtab) (TheSvector(symtab)->data[1])
44 #define Symtab_count(symtab) (TheSvector(symtab)->data[2])
45 /* consistency rule: for each string there is in the table
46 at most one symbol with this printname. */
47
48 /* UP: Creates a new empty symbol-table.
49 make_symtab(size)
50 > size: the desired size of the table (odd number, >0, <2^24)
51 < result: new symbol-table of this size
52 can trigger GC */
make_symtab(uintL size)53 local maygc object make_symtab (uintL size) {
54 var object table = allocate_vector(size); /* vector with size NIL-entries */
55 pushSTACK(table);
56 var object symtab = allocate_vector(3); /* vector of length 3 */
57 Symtab_table(symtab) = popSTACK(); /* insert table */
58 Symtab_size(symtab) = fixnum(size); /* insert size */
59 Symtab_count(symtab) = Fixnum_0; /* insert count := 0 */
60 return symtab;
61 }
62
63 /* UP: Calculates the hashcode of a string. This is a 24-bit-number.
64 string_hashcode(string,invert)
65 > string: a string
66 > invert: whether to implicitly case-invert the string
67 < result: the hashcode of the string */
string_hashcode(object string,bool invert)68 local uint32 string_hashcode (object string, bool invert) {
69 var uintL len;
70 var uintL offset;
71 string = unpack_string_ro(string,&len,&offset);
72 var uint32 hashcode = 0; /* hashcode, only the lower 24 Bit count */
73 if (len > 0) {
74 SstringDispatch(string,X, {
75 var const cintX* charptr = &((SstringX)TheVarobject(string))->data[offset];
76 /* there are len characters, starting at charptr */
77 /* Look at all len characters, not just at the first min(len,16)
78 characters, as we did earlier, because a bad hash function quasi
79 turns the hash table into a few long linear lists. */
80 var uintC count;
81 dotimesC(count, len, {
82 /* rotate hashcode by 5 bits to the left: */
83 hashcode = hashcode << 5; hashcode = hashcode + (hashcode >> 24);
84 /* 'add' next byte via XOR: */
85 var cintX c = *charptr++;
86 hashcode = hashcode ^ (uint32)(invert ? as_cint(invert_case(as_chart(c))) : c);
87 });
88 });
89 }
90 return hashcode & 0x00FFFFFF;
91 }
92
93 /* UP: Reorganizes a symbol-table, after it has grown, and
94 tries to save Conses.
95 rehash_symtab(symtab)
96 > symtab: symbol-table
97 < result: reorganized symbol-table (EQ to the first).
98 call only, if BREAK_SEM_2 is set
99 can trigger GC */
100 local maygc object rehash_symtab (object symtab);
101
102 /* auxiliary functions: */
103
104 /* takes a Cons from free-conses or returns a fresh one.
105 new_cons()
106 < result: new Cons.
107 stack layout: free-conses, newtable, listr, symbol, entry.
108 can trigger GC */
new_cons(void)109 local maygc object new_cons (void) {
110 var object free = STACK_4; /* free-conses */
111 if (!nullp(free)) {
112 STACK_4 = Cdr(free); /* shorten free-conses */
113 return free;
114 } else {
115 return allocate_cons(); /* request new Cons from memory-management */
116 }
117 }
118
119 /* inserts an additional symbol into the new table.
120 newinsert(sym,size);
121 > sym: symbol
122 stack layout: tab, oldtable, free-conses, newtable, listr.
123 can trigger GC */
newinsert(object sym,uintL size)124 local maygc void newinsert (object sym, uintL size) {
125 var uintL index = /* Index = Hashcode mod size */
126 string_hashcode(Symbol_name(sym),false) % size;
127 /* entry in the newtable */
128 var object entry = TheSvector(STACK_1)->data[index];
129 if ((!nullp(entry)) || nullp(sym)) {
130 /* if entry=NIL and sym/=NIL, then simply enter sym.
131 else, entry must be extended by cons-ing: */
132 pushSTACK(sym); /* save symbol */
133 pushSTACK(entry); /* save entry */
134 if (!listp(entry)) {
135 /* if entry is not a list, replace with (new-cons entry NIL): */
136 var object new_entry = new_cons();
137 Cdr(new_entry) = NIL; Car(new_entry) = STACK_0;
138 STACK_0 = new_entry;
139 }
140 /* and cons symbol in front of it: */
141 var object new_entry = new_cons();
142 Cdr(new_entry) = popSTACK(); /* enter entry resp. list as CDR */
143 Car(new_entry) = popSTACK(); /* enter symbol as CAR */
144 sym = new_entry; /* and then enter new_entry */
145 }
146 TheSvector(STACK_1)->data[index] = sym; /* enter new entry in newtable */
147 }
148
rehash_symtab(object symtab)149 local maygc object rehash_symtab (object symtab) {
150 pushSTACK(symtab); /* save symbol-table */
151 var uintL oldsize = posfixnum_to_V(Symtab_size(symtab)); /* old size */
152 var uintL newsize; /* new size */
153 var object size; /* new size (as Fixnum) */
154 pushSTACK(Symtab_table(symtab)); /* oldtable = old table-vector */
155 pushSTACK(NIL); /* free-conses := NIL */
156 #ifdef TYPECODES /* Svector_length is limited to max. 2^32-1 */
157 /* new size = min(floor(oldsize*1.6),2^32-1) */
158 { /* multiply oldsize (>0, <2^32) with 1.6*2^31, then divide by 2^31 : */
159 var uint32 prod_hi;
160 var uint32 prod_lo;
161 mulu32(oldsize,3435973888UL, prod_hi=,prod_lo=);
162 newsize =
163 (prod_hi < (1UL<<31) ? (prod_hi << 1) | (prod_lo >> 31) : (1UL<<31)-1 );
164 }
165 #else /* Svector_length is limited to max. 2^24-1 */
166 /* new size = min(floor(oldsize*1.6),2^24-1) */
167 { /* multiply oldsize (>0, <2^24) with 1.6*2^7, then divide by 2^7 : */
168 var uint32 prod = oldsize * 205UL;
169 newsize = (prod < (1UL<<31) ? prod>>7 : (1UL<<24)-1 );
170 } /* newsize is now >= oldsize > 0 and < 2^24 */
171 #endif
172 /* make newsize odd by rounding off: */
173 newsize = (newsize - 1) | 1 ;
174 /* calculate size: */
175 size = fixnum(newsize);
176 /* if newsize <= oldsize , the table does not need to be enlarged: */
177 if (newsize <= oldsize) {
178 skipSTACK(3);
179 return symtab;
180 }
181 { /* new vector with size NILs */
182 var object newtable = allocate_vector(newsize);
183 pushSTACK(newtable); /* save */
184 }
185 /* here we could protect against breaks.
186 stack layout: tab, oldtable, free-conses, newtable.
187 transfer symbols from oldtable to newtable:
188 first process the symbols, that sit in lists
189 (maybe Conses become free): */
190 {
191 var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
192 var uintC count = oldsize;
193 do {
194 var object oldentry = /* entry with number index in oldtable */
195 *(gcv_object_t*)(pointerplus(&TheSvector(STACK_2)->data[0],
196 (aint)offset));
197 if (consp(oldentry)) /* this time process only non-empty symbol-lists */
198 do {
199 pushSTACK(Cdr(oldentry)); /* save rest-list */
200 #ifndef MULTITHREAD
201 /* cons oldentry in front of free-conses */
202 Cdr(oldentry) = STACK_2; STACK_2 = oldentry;
203 #endif
204 /* enter symbol in the new table */
205 newinsert(Car(oldentry),newsize);
206 oldentry = popSTACK(); /* rest-list */
207 } while (consp(oldentry));
208 offset++;
209 } while (--count);
210 }
211 { /* then process symbols, that sit there collision-free: */
212 var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
213 var uintC count;
214 dotimespC(count,oldsize, {
215 var object oldentry = /* entry with number index in oldtable */
216 *(gcv_object_t*)(pointerplus(&TheSvector(STACK_2)->data[0],
217 (aint)offset));
218 if (!listp(oldentry)) { /* this time process only symbols /= NIL */
219 pushSTACK(oldentry); /* dummy, so that the stack is fine */
220 newinsert(oldentry,newsize); /* enter into the new table */
221 skipSTACK(1);
222 }
223 offset++;
224 });
225 }
226 /* stack layout: tab, oldtable, free-conses, newtable. */
227 { /* update tab: */
228 #ifdef MULTITHREAD
229 /* allocate new symtab. other threads may have obtained pointer to
230 the old one for lookup - do not modify it */
231 var object new_symtab = allocate_vector(3); /* vector of length 3 */
232 Symtab_count(new_symtab) = Symtab_count(STACK_3); /* set the count */
233 STACK_3 = new_symtab; /* replace symtab on the stack */
234 #endif
235 var object newtable = popSTACK(); /* newtable */
236 skipSTACK(2);
237 symtab = popSTACK(); /* tab */
238 Symtab_size(symtab) = size;
239 Symtab_table(symtab) = newtable;
240 }
241 /* here, breaks could be allowed again. */
242 return symtab;
243 }
244
245 /* UP: Searches a symbol of given printname in the list.
246 > string: string
247 > invert: whether to implicitly case-invert the string
248 > list: list of symbols
249 < result: true, if found.
250 < sym: the symbol from the list, that has the given printname (if found) */
symbol_list_lookup(object string,bool invert,object list,object * sym_)251 local inline bool symbol_list_lookup(object string, bool invert, object list,
252 object* sym_) {
253 /* traverse list: */
254 var bool (*s_eq)(object,object) = (invert ? &string_eq_inverted : &string_eq);
255 while (consp(list)) {
256 if ((*s_eq)(string,Symbol_name(Car(list))))
257 goto found;
258 list = Cdr(list);
259 }
260 return false; /* not found */
261 found: /* found */
262 if (sym_) { *sym_ = Car(list); }
263 return true;
264 }
265
266 /* UP: Searches a symbol with given print-name in the symbol-table.
267 symtab_lookup(string,invert,symtab,&sym)
268 > string: string
269 > invert: whether to implicitly case-invert the string
270 > symtab: symbol-table
271 < result: true if found, false if not found.
272 if found:
273 < sym: the symbol from the symbol-table, that has the given printname */
symtab_lookup(object string,bool invert,object symtab,object * sym_)274 local bool symtab_lookup (object string, bool invert, object symtab, object* sym_) {
275 var uintL index = /* Index = Hashcode mod size */
276 string_hashcode(string,invert) % (uintL)posfixnum_to_V(Symtab_size(symtab));
277 /* entry in the table */
278 var object entry = TheSvector(Symtab_table(symtab))->data[index];
279 if (!listp(entry)) { /* entry is a single symbol */
280 /* first string and printname of the found symbol are equal ? */
281 if ((invert ? string_eq_inverted : string_eq)
282 (string,Symbol_name(entry))) {
283 if (sym_) { *sym_ = entry; }
284 return true;
285 } else {
286 return false;
287 }
288 } else { /* entry is a symbol-list */
289 return symbol_list_lookup(string,invert,entry,sym_);
290 }
291 }
292
293 /* UP: Searches a given symbol in the symbol-table.
294 symtab_find(sym,symtab)
295 > sym: symbol
296 > symtab: symbol-table
297 < result: true, if found */
symtab_find(object sym,object symtab)298 local bool symtab_find (object sym, object symtab) {
299 var uintL index = /* Index = Hashcode mod size */
300 string_hashcode(Symbol_name(sym),false) % (uintL)posfixnum_to_V(Symtab_size(symtab));
301 /* entry in the table */
302 var object entry = TheSvector(Symtab_table(symtab))->data[index];
303 if (!listp(entry)) { /* entry is a single symbol */
304 /* sym and found symbol are equal ? */
305 if (eq(sym,entry))
306 return true;
307 else
308 return false;
309 } else { /* entry is a symbol-list */
310 if (nullp(memq(sym,entry))) return false; /* not found */
311 else return true; /* found as CAR from entry */
312 }
313 }
314
315 /* UP: Inserts a given symbol into the symbol-table (destructively).
316 symtab_insert(sym,symtab)
317 > sym: symbol
318 > symtab: symbol-table
319 < result: new symbol-table, EQ to the old one
320 call only, if BREAK_SEM_2 is set
321 can trigger GC */
symtab_insert(object sym,object symtab)322 local maygc object symtab_insert (object sym, object symtab) {
323 { /* first test if reorganization is necessary: */
324 var uintL size = posfixnum_to_V(Symtab_size(symtab));
325 var uintL count = posfixnum_to_V(Symtab_count(symtab));
326 /* if count>=2*size , the table must be reorganized: */
327 if (count >= 2*size) {
328 pushSTACK(sym); /* save symbol */
329 symtab = rehash_symtab(symtab);
330 sym = popSTACK();
331 }
332 }
333 /* then insert the symbol: */
334 var uintL index = /* Index = Hashcode mod size */
335 string_hashcode(Symbol_name(sym),false) % (uintL)posfixnum_to_V(Symtab_size(symtab));
336 /* entry in the table */
337 var object entry = TheSvector(Symtab_table(symtab))->data[index];
338 if (!nullp(entry) || nullp(sym)) {
339 /* if entry=NIL and sym/=NIL, then simply enter sym.
340 else, entry must be extended by cons-ing: */
341 pushSTACK(symtab); /* save symtab */
342 pushSTACK(sym); /* save Symbol */
343 pushSTACK(entry); /* save entry */
344 if (!listp(entry)) {
345 /* if entry is not a list, replace with (cons entry NIL): */
346 var object new_entry = allocate_cons();
347 Car(new_entry) = STACK_0;
348 STACK_0 = new_entry;
349 }
350 { /* and cons symbol in front of it: */
351 var object new_entry = allocate_cons();
352 Cdr(new_entry) = popSTACK(); /* enter entry resp. list as CDR */
353 Car(new_entry) = popSTACK(); /* enter symbol as CAR */
354 sym = new_entry; /* and then enter new_entry */
355 }
356 symtab = popSTACK();
357 }
358 TheSvector(Symtab_table(symtab))->data[index] = sym; /* enter new entry */
359 Symtab_count(symtab) = fixnum_inc(Symtab_count(symtab),1); /* (incf count) */
360 return symtab;
361 }
362
363 /* UP: Removes a symbol from a symbol-table.
364 symtab_delete(sym,symtab)
365 > sym: symbol
366 > symtab: symboltable */
symtab_delete(object sym,object symtab)367 local void symtab_delete (object sym, object symtab) {
368 var uintL index = /* Index = Hashcode mod size */
369 string_hashcode(Symbol_name(sym),false) % (uintL)posfixnum_to_V(Symtab_size(symtab));
370 var gcv_object_t* entryptr = &TheSvector(Symtab_table(symtab))->data[index];
371 var object entry = *entryptr; /* entry in the table */
372 if (!listp(entry)) { /* entry is a single symbol */
373 /* sym and found symbol eq ? */
374 if (!eq(sym,entry))
375 goto notfound;
376 /* replace entry with NIL: */
377 *entryptr = NIL;
378 } else { /* entry is a symbol-list */
379 while (consp(entry)) {
380 /* sym and symbol from entry eq ? */
381 if (eq(sym,Car(entry)))
382 goto found;
383 entryptr = &Cdr(entry); entry = *entryptr;
384 }
385 goto notfound; /* not found */
386 found: /* found as CAR of *entryptr = entry */
387 /* -> discard a list-element: */
388 *entryptr = Cdr(entry); /* replace entry with Cdr(entry) */
389 }
390 /* finally decrement the symbol-counter by 1: (decf count) */
391 Symtab_count(symtab) = fixnum_inc(Symtab_count(symtab),-1);
392 return;
393 notfound:
394 pushSTACK(unbound); /* PACKAGE-ERROR slot PACKAGE */
395 pushSTACK(sym);
396 error(package_error,GETTEXT("symbol ~S cannot be deleted from symbol table"));
397 }
398
399 /* lookup the STRING among the EXTernal (resp. INTernal) symbols of PACK */
400 #define package_lookup_ext(string,invert,pack,res_) \
401 symtab_lookup(string,invert,ThePackage(pack)->pack_external_symbols,res_)
402 #define package_lookup_int(string,invert,pack,res_) \
403 symtab_lookup(string,invert,ThePackage(pack)->pack_internal_symbols,res_)
404
405 /* Test whether there is an inherited symbol with the given name.
406 inherited_lookup(string,invert,pack,&sym)
407 Return true if string is found in (package-use-list pack).
408 > string: a Lisp string object
409 > invert: whether to implicitly case-invert the string
410 > pack: is a Lisp package object
411 The symbol found is returned in *SYM_ (if SYM_ is not NULL). */
inherited_lookup(object string,bool invert,object pack,object * sym_)412 local bool inherited_lookup (object string, bool invert, object pack, object* sym_) {
413 var object packlistr = ThePackage(pack)->pack_use_list;
414 while (consp(packlistr)) {
415 var object usedpack = Car(packlistr);
416 if (package_lookup_ext(string,invert,usedpack,sym_))
417 return true;
418 packlistr = Cdr(packlistr);
419 }
420 return false;
421 }
422
423 /* Check whether the symbol is inherited by the package.
424 inherited_find(symbol,pack)
425 SYMBOL is a Lisp symbol object
426 PACK is a Lisp package object */
inherited_find(object symbol,object pack)427 local bool inherited_find (object symbol, object pack) {
428 var object list = ThePackage(pack)->pack_use_list;
429 while (consp(list)) {
430 if (symtab_find(symbol,ThePackage(Car(list))->pack_external_symbols))
431 return true;
432 list = Cdr(list);
433 }
434 return false;
435 }
436
437 /* data structure of package, see LISPBIBL.D.
438 Components:
439 pack_external_symbols symbol-table of the externally present symbols
440 pack_internal_symbols symbol-table of the internally present symbols
441 pack_shadowing_symbols list of the shadowing-symbols
442 pack_use_list use-list, a list of packages
443 pack_used_by_list used-by-list, a list of packages
444 pack_name the name, an immutable simple-string
445 pack_nicknames the nicknames, a list of immutable simple-strings
446 pack_docstring the documentation string or NIL
447
448 consistency rules:
449 1. All packages are listed in ALL_PACKAGES exactly once.
450 2. The union over ALL_PACKAGES of { name } U nicknames is disjoint.
451 3. for any two packages p,q:
452 p in use_list(q) <==> q in used_by_list(q)
453 4. p is a Package.
454 accessible(p) = ISymbols(p) U ESymbols(p) U
455 U { ESymbols(q) | q in use_list(p) }
456 5. For each Package p
457 shadowing_symbols(p) is a subset of ISymbols(p) U ESymbols(p)
458 and therefore also a subset of accessible(p).
459 6. s is a string, p is a package.
460 If more than one element of accessible(p) has print name = s, then
461 exactly one of these symbols is in shadowing_symbols(p).
462 7. s is a string, p is a package.
463 At most one symbol with the print name = s
464 is in ISymbols(p) U ESymbols(p).
465 8. If s is a symbol with the Home Package p /= NIL,
466 then s is in ISymbols(p) U ESymbols(p). */
467
468 /* UP: make sure pack_shortest_name is indeed the shortest */
ensure_pack_shortest_name(object pack)469 local void ensure_pack_shortest_name (object pack) {
470 var object shortest_name = ThePackage(pack)->pack_name;
471 var uintL shortest_len = Sstring_length(shortest_name);
472 var object nick_list = ThePackage(pack)->pack_nicknames;
473 while (consp(nick_list)) {
474 var object nick = Car(nick_list); nick_list = Cdr(nick_list);
475 var uintL nick_len = Sstring_length(nick);
476 if (nick_len < shortest_len) {
477 shortest_len = nick_len;
478 shortest_name = nick;
479 }
480 }
481 ThePackage(pack)->pack_shortest_name = shortest_name;
482 }
483
484 /* UP: Creates a new package, without testing for name-conflicts.
485 make_package(name,nicknames,case_sensitive_p)
486 > name: name (an immutable simple-string)
487 > nicknames: nicknames (a list of immutable simple-strings)
488 > case_sensitive_p: flag, if case-sensitive
489 > case_inverted_p: flag, if case-inverted
490 < result: new package
491 can trigger GC */
make_package(object name,object nicknames,bool case_sensitive_p,bool case_inverted_p)492 local maygc object make_package (object name, object nicknames,
493 bool case_sensitive_p, bool case_inverted_p) {
494 set_break_sem_2();
495 pushSTACK(nicknames); pushSTACK(name); /* save nicknames and names */
496 /* create table for external symbols: */
497 { var object symtab = make_symtab(11); pushSTACK(symtab); }
498 /* create table for internal symbols: */
499 { var object symtab = make_symtab(63); pushSTACK(symtab); }
500 /* create new package: */
501 var object pack = allocate_package();
502 /* and fill: */
503 if (case_sensitive_p) { mark_pack_casesensitive(pack); }
504 if (case_inverted_p) { mark_pack_caseinverted(pack); }
505 ThePackage(pack)->pack_internal_symbols = popSTACK();
506 ThePackage(pack)->pack_external_symbols = popSTACK();
507 ThePackage(pack)->pack_shadowing_symbols = NIL;
508 ThePackage(pack)->pack_use_list = NIL;
509 ThePackage(pack)->pack_used_by_list = NIL;
510 ThePackage(pack)->pack_name = popSTACK();
511 ThePackage(pack)->pack_nicknames = popSTACK();
512 ThePackage(pack)->pack_docstring = NIL;
513 ensure_pack_shortest_name(pack);
514 pushSTACK(pack);
515 #ifdef MULTITHREAD
516 /* allocate the package mutex */
517 /* mutex name is the same as the package name */
518 pushSTACK(S(Kname)); pushSTACK(ThePackage(pack)->pack_name);
519 pushSTACK(S(Krecursive_p)); pushSTACK(T); /* recursive */
520 funcall(L(make_mutex),4);
521 ThePackage(STACK_0)->pack_mutex = value1;
522 #endif
523 /* and insert in ALL_PACKAGES: */
524 pushSTACK(allocate_cons()); /* new_cons */
525 WITH_OS_MUTEX_LOCK(2,&all_packages_lock, {
526 var object new_cons = popSTACK();
527 Car(new_cons) = STACK_0; Cdr(new_cons) = O(all_packages);
528 O(all_packages) = new_cons;
529 });
530 pack=popSTACK();
531 /* finished: */
532 clr_break_sem_2();
533 return pack;
534 }
535
536 /* UP: Searches a symbol of given printname in the shadowing-list
537 of a package.
538 shadowing_lookup(string,invert,pack,&sym)
539 > string: string
540 > invert: whether to implicitly case-invert the string
541 > pack: package
542 < result: true, if found.
543 < sym: the symbol from the shadowing-list, that has the given printname
544 (if found) */
545 #define shadowing_lookup(string,invert,pack,sym_) \
546 symbol_list_lookup(string,invert,ThePackage(pack)->pack_shadowing_symbols,sym_)
547
548 /* UP: Searches a given symbol in the shadowing-list of a package.
549 shadowing_find(sym,pack)
550 > sym: symbol
551 > pack: package
552 < result: true if found. */
553 #define shadowing_find(s,p) (!nullp(memq(s,ThePackage(p)->pack_shadowing_symbols)))
554
555 /* UP: Adds a symbol to the shadowing-list of a package, that does not yet
556 contain a symbol of the same name.
557 shadowing_insert(&sym,&pack)
558 > sym: symbol (in STACK)
559 > pack: package (in STACK)
560 < sym: symbol, EQ to the old one
561 < pack: package, EQ to the old one
562 can trigger GC */
shadowing_insert(const gcv_object_t * sym_,const gcv_object_t * pack_)563 local maygc void shadowing_insert (const gcv_object_t* sym_, const gcv_object_t* pack_) {
564 /* insert a new cons with symbol as CAR in front of the shadowing-symbols: */
565 var object new_cons = allocate_cons();
566 var object pack = *pack_;
567 Car(new_cons) = *sym_;
568 Cdr(new_cons) = ThePackage(pack)->pack_shadowing_symbols;
569 ThePackage(pack)->pack_shadowing_symbols = new_cons;
570 }
571
572 /* UP: Removes a symbol of given name from the shadowing-list
573 of a package.
574 shadowing_delete(string,invert,pack)
575 > string: string
576 > invert: whether to implicitly case-invert the string
577 > pack: package */
shadowing_delete(object string,bool invert,object pack)578 local void shadowing_delete (object string, bool invert, object pack) {
579 var gcv_object_t* listptr = &ThePackage(pack)->pack_shadowing_symbols;
580 var object list = *listptr;
581 /* list = *listptr traverses the shadowing-list */
582 var bool (*s_eq)(object,object) = (invert ? &string_eq_inverted : &string_eq);
583 while (consp(list)) {
584 if ((*s_eq)(string,Symbol_name(Car(list))))
585 goto found;
586 listptr = &Cdr(list); list = *listptr;
587 }
588 /* no symbol with this name found, done. */
589 return;
590 found:
591 /* equality: remove. After that we are done, because there can be only
592 one symbol of the same printname in the shadowing-list. */
593 *listptr = Cdr(list); /* replace list with Cdr(list) */
594 return;
595 }
596
597 /* UP: Tests, if a symbol in a package is accessible and is not
598 shadowed by another symbol of the same name.
599 accessiblep(sym,pack)
600 > sym: symbol
601 > pack: package
602 < result: true if sym is accessible in pack and is not shadowed,
603 else false */
accessiblep(object sym,object pack)604 global bool accessiblep (object sym, object pack) {
605 /* method:
606 First, search a symbol of equal name in the shadowing-list;
607 if not found, search the symbol among the present ones and
608 then among the inherited symbols.
609 Other possible method (not realized here):
610 If the home-package of sym is equal to pack, sym is present in pack,
611 done. Else search a present symbol of equal name.
612 sym found -> finished.
613 Found another one -> sym is not in the shadowing-list and
614 thus not visible.
615 none found -> search sym among the inherited symbols. */
616 var object shadowingsym;
617 /* First, search in the shadowing-list of pack: */
618 if (shadowing_lookup(Symbol_name(sym),false,pack,&shadowingsym)) {
619 /* shadowingsym = symbol, found in the shadowing-list */
620 return (eq(shadowingsym,sym)); /* compare with sym */
621 } else { /* no symbol of equal name in the shadowing-list */
622 /* Search among the internal symbols: */
623 if (symtab_find(sym,ThePackage(pack)->pack_internal_symbols))
624 return true;
625 /* Search among the external symbols: */
626 if (symtab_find(sym,ThePackage(pack)->pack_external_symbols))
627 return true;
628 /* Search among the external symbols of the packages from the use-list: */
629 if (inherited_find(sym,pack))
630 return true;
631 return false;
632 }
633 }
634
635 /* UP: tests, if a symbol is accessible in a package as
636 external symbol.
637 externalp(sym,pack)
638 > sym: symbol
639 > pack: package
640 < result:
641 true if sym is accessible in pack as external symbol,
642 (in this case, sym is not shadowed, because a symbol,
643 possibly shadowing sym, should be listed in shadowing-symbols(pack),
644 according to the consistency-rules 5 and 7 identical with sym),
645 else false */
externalp(object sym,object pack)646 global bool externalp (object sym, object pack) {
647 return symtab_find(sym,ThePackage(pack)->pack_external_symbols);
648 }
649
650 /* UP: locates an external symbol with a given printname in a package.
651 find_external_symbol(string,invert,pack,&sym)
652 > string: string
653 > invert: whether to implicitly case-invert the string
654 > pack: package
655 < result: true, if an external symbol with that printname has been found in pack.
656 < sym: this symbol, if found. */
find_external_symbol(object string,bool invert,object pack,object * sym_)657 global bool find_external_symbol (object string, bool invert, object pack, object* sym_) {
658 return package_lookup_ext(string,invert,pack,sym_);
659 }
660
661 /* UP: searches a package of given name or nickname
662 find_package(string)
663 > string: string
664 < result: package of this name or NIL */
find_package(object string)665 modexp maygc object find_package (object string) {
666 pushSTACK(NIL); /* result */
667 pushSTACK(string);
668 var gcv_object_t *string_ = &STACK_0;
669 var gcv_object_t *pack_ = &STACK_1;
670 WITH_OS_MUTEX_LOCK(0,&all_packages_lock, {
671 var object packlistr = O(all_packages); /* traverse package-list */
672 var object pack;
673 while (nullp(*pack_) && consp(packlistr)) {
674 pack = Car(packlistr); /* Package to be tested */
675 /* test name: */
676 if (string_eq(*string_,ThePackage(pack)->pack_name)) {
677 *pack_ = pack; continue; /* exit */
678 }
679 { /* test nickname: */
680 /* traverse nickname-list */
681 var object nicknamelistr = ThePackage(pack)->pack_nicknames;
682 while (consp(nicknamelistr)) {
683 if (string_eq(*string_,Car(nicknamelistr))) {
684 *pack_ = pack; break; /* exit */
685 }
686 nicknamelistr = Cdr(nicknamelistr);
687 }
688 }
689 packlistr = Cdr(packlistr); /* next package */
690 }
691 });
692 skipSTACK(1); /* string */
693 return popSTACK();
694 }
695
696 /* UP: Searches a symbol of given printname in a package.
697 find_symbol(string,invert,pack,&sym)
698 > string: string
699 > invert: whether to implicitly case-invert the string
700 > pack: package
701 < sym: symbol, if found; else NIL
702 < result: 0, if not found
703 1, if available as external symbol
704 2, if inherited via use-list
705 3, if available as internal symbol
706 + (-4, if available in the shadowing-list) */
find_symbol(object string,bool invert,object pack,object * sym_)707 local sintBWL find_symbol (object string, bool invert, object pack, object* sym_) {
708 /* First search in the shadowing-list of pack: */
709 if (shadowing_lookup(string,invert,pack,sym_)) {
710 /* *sym_ = symbol, found in the shadowing-list */
711 /* Search for it among the internal symbols: */
712 if (symtab_find(*sym_,ThePackage(pack)->pack_internal_symbols))
713 return 3-4; /* found among the internal symbols */
714 /* Search it among the external symbols: */
715 if (symtab_find(*sym_,ThePackage(pack)->pack_external_symbols))
716 return 1-4; /* found among the external symbols */
717 /* contradiction to consistency rule 5. */
718 pushSTACK(*sym_); pushSTACK(pack);
719 error(serious_condition,GETTEXT("~S inconsistent: symbol ~S is a shadowing symbol but not present"));
720 } else { /* symbol not yet found */
721 /* search among the internal symbols: */
722 if (package_lookup_int(string,invert,pack,sym_))
723 return 3; /* found among the internal symbols */
724 /* search among the external symbols: */
725 if (package_lookup_ext(string,invert,pack,sym_))
726 return 1; /* found among the external symbols */
727 /* search among the external packages from the use-list: */
728 if (inherited_lookup(string,invert,pack,sym_))
729 return 2; /* found among the inherited symbols */
730 /* not found */
731 *sym_ = NIL; return 0;
732 }
733 }
734 /* Actually, one has to search in the shadowing-list only after
735 one has searched among the present symbols, because the symbol in the
736 shadowing-list is already present (consistency rule 5). */
737
738 /* raise a continuable error when func(obj) was called on a locked package pack
739 continue means "Ignore the lock and proceed"
740 can trigger GC */
cerror_package_locked(object func,object pack,object obj)741 local maygc void cerror_package_locked (object func, object pack, object obj) {
742 pushSTACK(NIL); /* 7 continue-format-string */
743 pushSTACK(S(package_error)); /* 6 error type */
744 pushSTACK(S(Kpackage)); /* 5 :PACKAGE */
745 if (consp(pack)) pushSTACK(Car(pack)); /* from check-redefinition */
746 else pushSTACK(pack); /* 4 PACKAGE-ERROR slot PACKAGE */
747 pushSTACK(NIL); /* 3 error-format-string */
748 pushSTACK(func); /* 2 */
749 pushSTACK(obj); /* 1 */
750 pushSTACK(pack); /* 0 */
751 /* CLSTEXT "can trigger GC", so it cannot be called until
752 all the arguments have been already pushed on the STACK */
753 STACK_7 = CLSTEXT("Ignore the lock and proceed"); /* continue-format-string */
754 STACK_3 = CLSTEXT("~A(~S): ~S is locked"); /* error-format-string */
755 funcall(L(cerror_of_type),8);
756 }
757 /* check the package lock */
758 #define check_pack_lock(func,pack,obj) \
759 if (pack_locked_p(pack)) cerror_package_locked(func,pack,obj)
760 #define safe_check_pack_lock(func,pack,obj) \
761 do { pushSTACK(pack); pushSTACK(obj); /* save */ \
762 check_pack_lock(func, STACK_1 /*pack*/,STACK_0 /*obj*/); \
763 obj = popSTACK(); pack = popSTACK(); /* restore */ \
764 } while(0)
765
766 /* UP: Inserts a symbol into a package, that has no symbol of the same name yet.
767 Does not check for conflicts.
768 make_present(sym,pack);
769 > sym: symbol
770 > pack: package
771 only call, if BREAK_SEM_2 is set
772 can trigger GC */
make_present(object sym,object pack)773 local maygc void make_present (object sym, object pack) {
774 pushSTACK(pack);
775 if (!eq(pack,O(keyword_package))) {
776 if (nullp(Symbol_package(sym)))
777 Symbol_package(sym) = pack;
778 /* Insert symbol into the internal symbols: */
779 var object symtab =
780 symtab_insert(sym,ThePackage(pack)->pack_internal_symbols);
781 ThePackage(STACK_0)->pack_internal_symbols = symtab;
782 } else {
783 if (nullp(Symbol_package(sym))) {
784 pushSTACK(pack); /* save */
785 sym = check_symbol_not_symbol_macro(sym);
786 Symbol_package(sym) = pack = popSTACK();
787 Symbol_value(sym) = sym; /* sym gets itself as value */
788 set_const_flag(TheSymbol(sym)); /* mark as constant */
789 }
790 /* Insert symbol into the external symbols: */
791 var object symtab =
792 symtab_insert(sym,ThePackage(pack)->pack_external_symbols);
793 ThePackage(STACK_0)->pack_external_symbols = symtab;
794 }
795 skipSTACK(1);
796 }
797
798 /* UP: Interns a symbol with a given printname in a package.
799 intern(string,invert,pack,&sym)
800 > string: string
801 > invert: whether to implicitly case-invert the string
802 > pack: package
803 < sym: symbol
804 < result: 0, if not found, but newly created
805 1, if available as external symbol
806 2, if inherited via use-list
807 3, if available as internal symbol
808 can trigger GC */
intern(object string,bool invert,object pack,object * sym_)809 modexp maygc uintBWL intern
810 (object string, bool invert, object pack, object* sym_) {
811 /* first check without locking */
812 var uintBWL result = find_symbol(string,invert,pack,sym_);
813 if (!(result==0)) {
814 return result & 3; /* found -> finished */
815 }
816 pushSTACK(string);
817 pushSTACK(pack);
818 pushSTACK(NIL); /* place for new symbol */
819 var gcv_object_t *pack_ = &STACK_1;
820 var gcv_object_t *string_ = &STACK_2;
821 var gcv_object_t *newsym_ = &STACK_0;
822 if (pack_locked_p(*pack_)) {
823 /* when STRING comes from READ, it points to a re-usable buffer
824 that will be overwritten during the CERROR i/o
825 therefore we must copy and save it */
826 pushSTACK(coerce_ss(*string_));
827 cerror_package_locked(S(intern),*pack_,STACK_0);
828 *string_ = popSTACK();
829 /* CERROR may do interesting things: it goes through CLCS, i.e., CLOS,
830 and can compute effective methods and thus create symbols, so... */
831 result = find_symbol(*string_,invert,*pack_,sym_);
832 if (!(result==0)) {
833 skipSTACK(3);
834 return result & 3; /* found -> finished */
835 }
836 }
837 /* in single thread - there is no need to check again */
838 #ifndef MULTITHREAD
839 #define UNLESS_FIND_SYMBOL
840 #else
841 #define UNLESS_FIND_SYMBOL \
842 result = find_symbol(*string_,invert,*pack_,sym_); \
843 if (!(result==0)) { \
844 *newsym_ = *sym_; /* store at gc safe location */\
845 result &= 3; /* found -> finished */ \
846 } else
847 #endif
848 /* with locked package */
849 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*pack_)->pack_mutex,{
850 /* MT: search again, while we were waiting the same symbol may have
851 been interned */
852 UNLESS_FIND_SYMBOL
853 {
854 if (invert)
855 *string_ = string_invertcase(*string_);
856 *string_ = coerce_imm_ss(*string_); /* string --> immutable simple-string */
857 *newsym_ = make_symbol(*string_); /* (make-symbol string) */
858 /* enter this new symbol into the package: */
859 set_break_sem_2(); /* protect against breaks */
860 make_present(*newsym_,*pack_); /* intern into this package */
861 clr_break_sem_2(); /* allow breaks */
862 }
863 });
864 *sym_ = *newsym_;
865 skipSTACK(3); /* string, pack & newsym */
866 return result;
867 #undef UNLESS_FIND_SYMBOL
868 }
869
870 /* UP: Interns a symbol of given printname into the keyword-package.
871 intern_keyword(string)
872 > string: string
873 < result: symbol, a keyword
874 can trigger GC */
intern_keyword(object string)875 modexp maygc object intern_keyword (object string) {
876 var object sym;
877 intern(string,false,O(keyword_package),&sym);
878 return sym;
879 }
880
881 /* UP: lookup the string among the internal and, if not found,
882 external symbols of the package PACK
883 tab, if supplied, is the assignment that will set the table in which the
884 STRINNG was found */
885 #define package_lookup(string,invert,pack,res_,tab) \
886 (symtab_lookup(string,invert,tab ThePackage(pack)->pack_internal_symbols,res_) || \
887 symtab_lookup(string,invert,tab ThePackage(pack)->pack_external_symbols,res_))
888
889 /* UP: Imports a symbol into a package and turns it into a shadowing-symbol.
890 Possibly another present symbol in this package
891 of the same name is uninterned.
892 shadowing_import(&sym,&pack);
893 > sym: symbol (in STACK)
894 > pack: package (in STACK)
895 < sym: symbol, EQ to the old one
896 < pack: package, EQ to the old one
897 can trigger GC.
898 MT: no locking - the caller locks */
shadowing_import(const gcv_object_t * sym_,const gcv_object_t * pack_)899 local maygc void shadowing_import (const gcv_object_t* sym_, const gcv_object_t* pack_) {
900 check_pack_lock(S(shadowing_import),*pack_,*sym_);
901 set_break_sem_2(); /* protect against breaks */
902 {
903 var object sym = *sym_;
904 var object pack = *pack_;
905 /* Searches an internal or external symbol of the same name: */
906 var object othersym;
907 var object tab_found;
908 var object string = Symbol_name(sym);
909 pushSTACK(string); /* save string */
910 if (package_lookup(string,false,pack,&othersym,tab_found=)) {
911 /* a symbol othersym of the same name was
912 already present in the package */
913 if (!eq(othersym,sym)) { /* was it the to be imported symbol itself? */
914 /* no -> have to take othersym away from the internal resp. */
915 /* from the external symbols: */
916 symtab_delete(othersym,tab_found);
917 /* Was this symbol taken away from its home-package,
918 its home-package must be set to NIL: */
919 if (eq(Symbol_package(othersym),pack))
920 Symbol_package(othersym) = NIL;
921 /* symbol sym must be added to the package pack. */
922 make_present(sym,pack);
923 }
924 } else { /* symbol sym must be added to the package pack. */
925 make_present(sym,pack);
926 }
927 }
928 /* symbol must be added to the shadowing-list of the package. */
929 shadowing_delete(popSTACK(),false,*pack_); /* remove string from */
930 /* the shadowing-list */
931 shadowing_insert(sym_,pack_); /* add symbol to the shadowing-list */
932 clr_break_sem_2(); /* allow breaks */
933 }
934
935 /* UP: Shadows in a package all symbols accessible from other packages
936 of give name by one symbol present in this package
937 of the same name.
938 shadow(&sym,invert,&pack)
939 > sym: symbol or string (in STACK)
940 > invert: whether to implicitly case-invert the string
941 > pack: package (in STACK)
942 < pack: package, EQ to the old
943 can trigger GC.
944 MT: locks with package mutex */
do_shadow(const gcv_object_t * sym_,bool invert,const gcv_object_t * pack_)945 local maygc void do_shadow (const gcv_object_t* sym_, bool invert, const gcv_object_t* pack_) {
946 check_pack_lock(S(shadow),*pack_,*sym_);
947 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*pack_)->pack_mutex,{
948 set_break_sem_2(); /* protect against breaks */
949 /* Search an internal or external symbol of the same name: */
950 var object string = /* only the name of the symbol counts. */
951 test_stringsymchar_arg(*sym_,invert);
952 var object pack = *pack_;
953 pushSTACK(NIL); /* make room for othersym */
954 pushSTACK(string); /* save string */
955 var object othersym;
956 if (package_lookup(string,invert,pack,&othersym,)) {
957 STACK_1 = othersym;
958 } else {
959 /* not found -> create new symbol of the same name: */
960 if (invert)
961 string = string_invertcase(string);
962 string = coerce_imm_ss(string); /* string --> immutable simple-string */
963 var object othersym = make_symbol(string); /* new symbol */
964 STACK_1 = othersym;
965 make_present(othersym,*pack_); /* enter into the package */
966 /* home-package of the new symbols is pack */
967 Symbol_package(STACK_1) = *pack_;
968 }
969 /* stack-layout: othersym, string
970 In the package, now symbol othersym of the same name is present.
971 remove string from the shadowing-list */
972 shadowing_delete(popSTACK(),invert,*pack_);
973 /* therefore add othersym to the shadowing-list */
974 shadowing_insert(&STACK_0,pack_);
975 skipSTACK(1); /* forget othersym */
976 clr_break_sem_2(); /* allow breaks */
977 });
978 }
shadow(const gcv_object_t * sym_,const gcv_object_t * pack_)979 local maygc void shadow (const gcv_object_t* sym_, const gcv_object_t* pack_) {
980 do_shadow(sym_,false,pack_);
981 }
cs_shadow(const gcv_object_t * sym_,const gcv_object_t * pack_)982 local maygc void cs_shadow (const gcv_object_t* sym_, const gcv_object_t* pack_) {
983 do_shadow(sym_,true,pack_);
984 }
985
986 /* UP: Removes a symbol from the set of present symbols of a package
987 and does conflict resolution if it was in the shadowing-list
988 of this package and a name conflict arises.
989 unintern(&sym,&pack)
990 > sym: symbol (in STACK)
991 > pack: package (in STACK)
992 < sym: symbol, EQ to the old
993 < pack: package, EQ to the old
994 < result: T if found and deleted, NIL if nothing has been done.
995 can trigger GC
996 MT: no locking. caller holds the pack lock */
unintern(const gcv_object_t * sym_,const gcv_object_t * pack_)997 local maygc object unintern (const gcv_object_t* sym_, const gcv_object_t* pack_) {
998 check_pack_lock(S(unintern),*pack_,*sym_);
999 var object sym = *sym_;
1000 var object pack = *pack_;
1001 var object symtab;
1002 /* search sym among the internal and the external symbols: */
1003 if (symtab_find(sym,symtab=ThePackage(pack)->pack_internal_symbols)
1004 || symtab_find(sym,symtab=ThePackage(pack)->pack_external_symbols)) {
1005 /* found symbol sym in the table symtab */
1006 if (shadowing_find(sym,pack)) { /* search in the shadowing-list */
1007 /* possible conflict -> build up selection-list: */
1008 pushSTACK(symtab); /* save symboltable */
1009 pushSTACK(NIL); /* start option-list */
1010 pushSTACK(ThePackage(pack)->pack_use_list); /* traverse use-list */
1011 /* stack-layout: symboltable, OL, use-list-rest */
1012 while (mconsp(STACK_0)) {
1013 var object othersym;
1014 pack = Car(STACK_0); /* package from the use-list */
1015 STACK_0 = Cdr(STACK_0);
1016 /* search inherited symbol of the same name: */
1017 if (package_lookup_ext(Symbol_name(*sym_),false,pack,&othersym)) {
1018 /* check that othersym is not in the option-list yet */
1019 var object temp = STACK_1;
1020 while (mconsp(temp)) {
1021 if (eq(Cdr(Cdr(Car(temp))),othersym))
1022 goto next_package;
1023 temp = Cdr(temp);
1024 }
1025 /* othersym is a symbol of the same name, inherited from pack */
1026 pushSTACK(temp=ThePackage(pack)->pack_name); /* name of pack */
1027 pushSTACK(othersym); /* symbol */
1028 pushSTACK(NIL);
1029 pushSTACK(NIL); /* "symbol ~A from ~A will become a shadowing symbol" */
1030 pushSTACK(Symbol_name(othersym)); /* symbolname */
1031 pushSTACK(pack); /* package */
1032 STACK_2 = CLSTEXT("symbol ~A from ~A will become a shadowing symbol");
1033 /* (FORMAT NIL "..." symbolname packagename) */
1034 funcall(S(format),4);
1035 temp = value1;
1036 pushSTACK(temp); /* total-string */
1037 temp = allocate_cons();
1038 Car(temp) = popSTACK();
1039 Cdr(temp) = popSTACK();
1040 pushSTACK(temp); /* (cons total-string othersym) */
1041 temp = allocate_cons();
1042 Cdr(temp) = popSTACK();
1043 Car(temp) = popSTACK();
1044 /* temp = (list packagename total-string othersym) */
1045 /* STACK is correct, again */
1046 /* push to the option-list: */
1047 pushSTACK(temp);
1048 temp = allocate_cons();
1049 Car(temp) = popSTACK(); Cdr(temp) = STACK_1;
1050 STACK_1 = temp;
1051 }
1052 next_package:;
1053 }
1054 skipSTACK(1);
1055 /* option-list build-up finished.
1056 stack-layout: symboltable, OL
1057 if (length OL) >= 2, there's a conflict: */
1058 if (mconsp(STACK_0) && mconsp(Cdr(STACK_0))) {
1059 /* raise a correctable error, options is STACK_0 already */
1060 pushSTACK(*pack_); /* PACKAGE-ERROR slot PACKAGE */
1061 pushSTACK(*pack_); /* package */
1062 pushSTACK(*sym_); /* symbol */
1063 correctable_error(package_error,GETTEXT("Uninterning ~S from ~S uncovers a name conflict.\nYou may choose the symbol in favour of which to resolve the conflict."));
1064 pushSTACK(value1);
1065 } else
1066 STACK_0 = NIL;
1067 /* STACK_0 is the selection (NIL if no conflict arises) */
1068 /* stack-layout: symboltable, selection */
1069 set_break_sem_3();
1070 {
1071 var object sym = *sym_;
1072 var object pack = *pack_;
1073 /* remove symbol from symboltable: */
1074 symtab_delete(sym,STACK_1);
1075 /* if it was removed from its home-package,
1076 set the home-package to NIL: */
1077 if (eq(Symbol_package(sym),pack))
1078 Symbol_package(sym) = NIL;
1079 /* discard symbol from shadowing-list: */
1080 shadowing_delete(Symbol_name(sym),false,pack);
1081 }
1082 if (!nullp(STACK_0))
1083 /* in case of a conflict: import selected symbol: */
1084 shadowing_import(&STACK_0,pack_);
1085 skipSTACK(2); /* forget symboltable & selection */
1086 clr_break_sem_3();
1087 return T; /* that's it */
1088 } else { /* no conflict */
1089 set_break_sem_2();
1090 symtab_delete(sym,symtab); /* delete symbol */
1091 if (eq(Symbol_package(sym),pack))
1092 Symbol_package(sym) = NIL; /* maybe set home-package to NIL */
1093 clr_break_sem_2();
1094 return T;
1095 }
1096 } else /* not found */
1097 return NIL;
1098 }
1099
1100 /* UP: raise a continuable error and query the user about how to proceed
1101 return true when an abort was requested
1102 dialog_type == 0 or 1 or 2
1103 can trigger GC */
query_intern_conflict(object pack,object sym,object other,int dialog_type)1104 local maygc bool query_intern_conflict (object pack, object sym, object other,
1105 int dialog_type) {
1106 pushSTACK(NIL); /* place for OPTIONS */
1107 pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
1108 pushSTACK(other); pushSTACK(pack); pushSTACK(sym);
1109 switch (dialog_type) { /* fill OPTIONS */
1110 case 0: /* conflict */
1111 STACK_4=CLOTEXT("((IMPORT \"import it and unintern the other symbol\" . T)"
1112 " (IGNORE \"do not import it, leave undone\" . NIL))");
1113 break;
1114 case 1: /* conflict & shadowing */
1115 STACK_4=CLOTEXT("((IMPORT \"import it, unintern one other symbol and shadow the other symbols\" . T)"
1116 " (IGNORE \"do not import it, leave undone\" . NIL))");
1117 break;
1118 case 2: /* shadowing */
1119 STACK_4=CLOTEXT("((IMPORT \"import it and shadow the other symbol\" . T)"
1120 " (IGNORE \"do nothing\" . NIL))");
1121 break;
1122 default: NOTREACHED;
1123 }
1124 correctable_error(package_error,(dialog_type == 1
1125 ? GETTEXT("Importing ~S into ~S produces a name conflict with ~S and other symbols.")
1126 : GETTEXT("Importing ~S into ~S produces a name conflict with ~S.")));
1127 return nullp(value1);
1128 }
1129
1130 /* UP: Imports a symbol into a package and does conflict resolution
1131 in case, that a name conflict arises either with a symbol
1132 inherited from anotherpackage or with an already present symbol
1133 in this package of the same name.
1134 import(&sym,&pack);
1135 > sym: symbol (in STACK)
1136 > pack: package (in STACK)
1137 < pack: package, EQ to the old
1138 can trigger GC
1139 MT: pack is locked by the caller. */
import(const gcv_object_t * sym_,const gcv_object_t * pack_)1140 global maygc void import (const gcv_object_t* sym_, const gcv_object_t* pack_) {
1141 var object sym = *sym_;
1142 var object pack = *pack_;
1143 var object string = Symbol_name(sym);
1144 var object othersym;
1145 var object othersymtab;
1146 /* search symbol of the same name among the internal
1147 and the external symbols: */
1148 if (package_lookup(string,false,pack,&othersym,othersymtab=)) {
1149 /* othersym = symbol of the same name, found in othersymtab */
1150 if (eq(othersym,sym)) /* the same symbol -> nothing to do */
1151 return;
1152 /* not the same symbol was present -> must throw out othersym and
1153 insert the given symbol sym for it.
1154 determine beforehand, if there are additional inherited
1155 symbols there, and then raise Continuable Error. */
1156 pushSTACK(string);
1157 pushSTACK(othersym);
1158 pushSTACK(othersymtab);
1159 /* first calculate inherited-flag: */
1160 var bool inheritedp = inherited_lookup(string,false,pack,NULL);
1161 /* stack-layout: symbol-name, othersym, othersymtab. */
1162 /* raise Continuable Error: */
1163 if (query_intern_conflict(*pack_,*sym_,othersym,inheritedp ? 1 : 0)) {
1164 skipSTACK(3); return; /* yes -> do not import, finished */
1165 }
1166 /* import: */
1167 set_break_sem_2();
1168 pack = *pack_;
1169 { /* remove othersym from pack: */
1170 var object othersym = STACK_1;
1171 symtab_delete(othersym,STACK_0); /* remove othersym from othersymtab */
1172 if (eq(Symbol_package(othersym),pack))
1173 Symbol_package(othersym) = NIL; /* maybe home-package := NIL */
1174 }
1175 /* insert sym in pack: */
1176 make_present(*sym_,pack);
1177 /* remove symbols of the same name from the shadowing-list of pack: */
1178 shadowing_delete(STACK_2,false,*pack_);
1179 /* if inherited-flag, turn sym in pack into a shadowing-symbol: */
1180 if (inheritedp)
1181 shadowing_insert(sym_,pack_);
1182 clr_break_sem_2();
1183 skipSTACK(3); return;
1184 } else {
1185 /* no symbol of the same name was present.
1186 Search a symbol of the same name, that is inherited (there is
1187 at most one, according to the consistency rules 6 and 5): */
1188 var object otherusedsym;
1189 if (!inherited_lookup(string,false,pack,&otherusedsym)
1190 || eq(otherusedsym,sym)) {
1191 /* insert sym simply in pack: */
1192 set_break_sem_2();
1193 make_present(sym,pack);
1194 clr_break_sem_2();
1195 } else {
1196 /* no -> raise Continuable Error and query user: */
1197 if (query_intern_conflict(pack,sym,otherusedsym,2))
1198 return; /* yes -> do not import, finished */
1199 /* import: */
1200 set_break_sem_2();
1201 /* insert sym in pack: */
1202 make_present(*sym_,*pack_);
1203 /* turn sym in pack into a shadowing-symbol: */
1204 shadowing_insert(sym_,pack_);
1205 clr_break_sem_2();
1206 }
1207 }
1208 }
1209
1210 /* UP: Sets a symbol back from external to internal status in
1211 einer package.
1212 unexport(&sym,&pack);
1213 > sym: symbol (in STACK)
1214 > pack: package (in STACK)
1215 < pack: package, EQ to the old
1216 can trigger GC
1217 MT: pack is locked by the caller */
unexport(const gcv_object_t * sym_,const gcv_object_t * pack_)1218 local maygc void unexport (const gcv_object_t* sym_, const gcv_object_t* pack_) {
1219 check_pack_lock(S(unexport),*pack_,*sym_);
1220 var object sym = *sym_;
1221 var object pack = *pack_;
1222 var object symtab;
1223 if (symtab_find(sym,symtab=ThePackage(pack)->pack_external_symbols)) {
1224 /* sym is external in pack */
1225 if (eq(pack,O(keyword_package))) { /* test for keyword-package */
1226 pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
1227 pushSTACK(pack);
1228 error(package_error,GETTEXT("UNEXPORT in ~S is illegal"));
1229 }
1230 set_break_sem_2();
1231 symtab_delete(sym,symtab); /* remove sym from the external symbols */
1232 /* therefor, insert it into the internal symbols */
1233 symtab = symtab_insert(sym,ThePackage(pack)->pack_internal_symbols);
1234 ThePackage(*pack_)->pack_internal_symbols = symtab;
1235 clr_break_sem_2();
1236 } else {
1237 /* Search, if the symbol is accessible at all. */
1238 /* Search among the internal symbols: */
1239 if (symtab_find(sym,ThePackage(pack)->pack_internal_symbols))
1240 return;
1241 /* Search among the external symbols of the packages from the use-list: */
1242 if (inherited_find(sym,pack))
1243 return;
1244 /* not found among the accessible symbols */
1245 pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
1246 pushSTACK(pack); pushSTACK(sym);
1247 error(package_error,GETTEXT("UNEXPORT works only on accessible symbols, not on ~S in ~S"));
1248 }
1249 }
1250
1251 /* UP: Sets a present symbol into external status.
1252 make_external(sym,pack);
1253 > sym: symbol
1254 > pack: package, in which the symbol is present
1255 can trigger GC */
make_external(object sym,object pack)1256 local maygc void make_external (object sym, object pack) {
1257 if (symtab_find(sym,ThePackage(pack)->pack_external_symbols))
1258 return; /* symbol already external -> nothing to do */
1259 set_break_sem_2();
1260 /* remove sym from the internal symbols */
1261 symtab_delete(sym,ThePackage(pack)->pack_internal_symbols);
1262 /* therefor, insert it into the external symbols */
1263 pushSTACK(pack);
1264 var object symtab =
1265 symtab_insert(sym,ThePackage(pack)->pack_external_symbols);
1266 pack = popSTACK();
1267 ThePackage(pack)->pack_external_symbols = symtab;
1268 clr_break_sem_2();
1269 }
1270
1271 /* UP: Exports a symbol from a package
1272 export(&sym,&pack);
1273 > sym: symbol (in STACK)
1274 > pack: package (in STACK)
1275 < sym: symbol, EQ to the old
1276 < pack: package, EQ to the old
1277 can trigger GC
1278 MT: pack is locked by the caller. */
export(const gcv_object_t * sym_,const gcv_object_t * pack_)1279 global maygc void export (const gcv_object_t* sym_, const gcv_object_t* pack_) {
1280 check_pack_lock(S(export),*pack_,*sym_);
1281 var object sym = *sym_;
1282 var object pack = *pack_;
1283 /* search sym among the external symbols of pack: */
1284 if (symtab_find(sym,ThePackage(pack)->pack_external_symbols))
1285 return; /* found -> finished */
1286 var bool import_it = false;
1287 /* import_it = flag, if symbol has to be imported first. */
1288 /* search sym among the internal symbols of pack: */
1289 if (!(symtab_find(sym,ThePackage(pack)->pack_internal_symbols))) {
1290 /* symbol sym is not present in package pack */
1291 import_it = true;
1292 /* Search, if it is at least accessible: */
1293 if (!inherited_find(sym,pack)) {
1294 /* symbol sym is not even accessible in the package pack ==>
1295 raise correctable error: */
1296 pushSTACK(NIL); /* place for OPTIONS */
1297 pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
1298 /* "symbol ~S has to be imported in ~S before being exported" */
1299 pushSTACK(pack); pushSTACK(sym); pushSTACK(S(export));
1300 STACK_4 = CLOTEXT("((IMPORT \"import the symbol first\" . T)"
1301 " (IGNORE \"do nothing, do not export the symbol\" . NIL))");
1302 correctable_error(package_error,GETTEXT("~S: Symbol ~S should be imported into ~S before being exported."));
1303 if (nullp(value1)) /* NIL-option selected? */
1304 return; /* yes -> do not export, finished */
1305 }
1306 }
1307 /* Test for name-conflict: */
1308 pushSTACK(NIL); /* conflict-resolver:=NIL */
1309 /* stack-layout: conflict-resolver (a list of pairs (sym . pack),
1310 for which shadowing_import has to be applied).
1311 used-by-list is searched */
1312 pushSTACK(ThePackage(*pack_)->pack_used_by_list);
1313 while (mconsp(STACK_0)) {
1314 var object usingpack = Car(STACK_0); /* USE-ing package */
1315 STACK_0 = Cdr(STACK_0);
1316 var object othersym;
1317 if (find_symbol(Symbol_name(*sym_),false,usingpack,&othersym) > 0)
1318 /* othersym is a symbol of the same name in usingpack */
1319 if (!eq(othersym,*sym_)) {
1320 var gcv_object_t *othersym_, *usingpack_;
1321 /* it is not sym itself -> there is a conflict */
1322 pushSTACK(othersym); othersym_ = &STACK_0;
1323 pushSTACK(usingpack); usingpack_ = &STACK_0;
1324 /* stack-layout: conflict-resolver, used-by-list-rest,
1325 other symbol, USE-ing package. */
1326 pushSTACK(NIL); /* space for OPTIONS */
1327 pushSTACK(*pack_); /* PACKAGE-ERROR slot PACKAGE */
1328 pushSTACK(usingpack); /* USE-ing package */
1329 pushSTACK(usingpack); /* USE-ing package */
1330 pushSTACK(othersym); /* other symbol */
1331 pushSTACK(*pack_); /* package */
1332 pushSTACK(*sym_); /* symbol */
1333 { /* construct options-list: */
1334 var object temp;
1335 pushSTACK(ThePackage(*pack_)->pack_name); /* package name */
1336 pushSTACK(CLSTEXT("the symbol to export, "));
1337 pushSTACK(*sym_); /* symbol */
1338 funcall(L(prin1_to_string),1); /* (prin1-to-string Symbol) */
1339 pushSTACK(value1);
1340 /* (string-concat "The new symbol " (prin1-to-string Symbol)) */
1341 temp = string_concat(2);
1342 pushSTACK(temp);
1343 temp = listof(2); /* (list* symbol (string-concat ...) 'T) */
1344 Cdr(Cdr(temp)) = T;
1345 pushSTACK(temp);
1346 pushSTACK(ThePackage(*usingpack_)->pack_name); /* USE-ing pack */
1347 pushSTACK(CLSTEXT("the old symbol, "));
1348 pushSTACK(*othersym_); /* other symbol */
1349 /* (prin1-to-string anderesSymbol) */
1350 funcall(L(prin1_to_string),1);
1351 pushSTACK(value1);
1352 /* (string-concat "The old symbol " (prin1-to-string old-symbol)) */
1353 temp = string_concat(2);
1354 pushSTACK(temp);
1355 temp = listof(2); /* (list* other-symbol (string-concat ...) 'NIL) */
1356 /* Cdr(Cdr(temp)) = NIL; not needed */
1357 pushSTACK(temp);
1358 temp = listof(2); /* (list (list s1 ... 'T) (list s2 ... 'NIL)) */
1359 STACK_6 = temp; /* options */
1360 }
1361 correctable_error(package_error,GETTEXT("Exporting ~S from ~S produces a name conflict with ~S from ~S.\nYou may choose which symbol should be accessible in ~S."));
1362 pushSTACK(nullp(value1)?STACK_1/*other symbol*/:*sym_);/*solvingsym*/
1363 { /* extend conflict-resolver with (solvingsym . usingpack) : */
1364 var object new_cons = allocate_cons();
1365 Car(new_cons) = popSTACK(); /* solvingsym */
1366 Cdr(new_cons) = popSTACK(); /* usingpack */
1367 /* new_cons = (cons solvingsym usingpack) */
1368 /* cons in front of conflict-resolver: */
1369 STACK_0 = new_cons;
1370 new_cons = allocate_cons();
1371 Car(new_cons) = popSTACK(); /* (solvingsym . usingpack) */
1372 Cdr(new_cons) = STACK_1;
1373 STACK_1 = new_cons;
1374 }
1375 /* stack-layout: conflict-resolver, used-by-list-rest. */
1376 }
1377 }
1378 skipSTACK(1);
1379 /* stack-layout: conflict-resolver. */
1380 /* Now maybe import symbol sym: */
1381 if (import_it) {
1382 /* import sym in pack: */
1383 import(sym_,pack_);
1384 /* This importing can be aborted by CERROR.
1385 An abort is not dangerous at this point, because up to now
1386 the symbol is only internal in the package (except if it is
1387 the KEYWORD package, that can not be USE-ed). */
1388 }
1389 set_break_sem_3(); /* protect against breaks */
1390 /* now resolve the conflicts: */
1391 while (mconsp(STACK_0)) {
1392 var object cons_sym_pack = Car(STACK_0);
1393 STACK_0 = Cdr(STACK_0);
1394 pushSTACK(Car(cons_sym_pack)); /* solvingsym */
1395 pushSTACK(Cdr(cons_sym_pack)); /* usingpack */
1396 shadowing_import(&STACK_1,&STACK_0); /* import and shadow */
1397 skipSTACK(2);
1398 }
1399 skipSTACK(1);
1400 make_external(*sym_,*pack_); /* make sym in pack external */
1401 clr_break_sem_3(); /* allow breaks */
1402 }
1403
1404 /* UP: Applies a function to all symbols in a symboltable.
1405 (In the worst case, this function may delete the symbol via symtab_delete
1406 from the table.)
1407 map_symtab(fun,symtab);
1408 > fun: function with one argument
1409 > symtab: symboltable
1410 can trigger GC */
map_symtab(object fun,object symtab)1411 local maygc void map_symtab (object fun, object symtab) {
1412 pushSTACK(fun); /* function */
1413 pushSTACK(Symtab_table(symtab)); /* table vector */
1414 /* number of entries */
1415 var uintL size = posfixnum_to_V(Symtab_size(symtab));
1416 var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
1417 var uintC count;
1418 dotimespC(count,size, {
1419 var object entry = /* entry with number index in table */
1420 *(gcv_object_t*)(pointerplus(&TheSvector(STACK_0)->data[0],(aint)offset));
1421 if (atomp(entry)) {
1422 if (!nullp(entry)) {
1423 /* entry is a symbol /= NIL */
1424 pushSTACK(entry); funcall(STACK_2,1); /* apply function */
1425 }
1426 } else {
1427 /* process non-empty symbol list */
1428 pushSTACK(entry);
1429 do {
1430 var object listr = STACK_0;
1431 STACK_0 = Cdr(listr);
1432 /* apply function to symbol */
1433 pushSTACK(Car(listr)); funcall(STACK_3,1);
1434 } while (!matomp(STACK_0));
1435 skipSTACK(1);
1436 }
1437 offset++;
1438 });
1439 skipSTACK(2);
1440 }
1441
1442 /* UP: Applies a C-function to all symbols of a symbol table.
1443 (In the worst case, this function may delete the symbol via symtab_delete
1444 from the table.)
1445 map_symtab_c(fun,data,symtab);
1446 > fun: function with two arguments, may trigger GC
1447 > data: first argument for the function
1448 > symtab: symbol table
1449 can trigger GC */
1450 typedef maygc void one_sym_function_t (void* data, object sym);
map_symtab_c(one_sym_function_t * fun,void * data,object symtab)1451 local maygc void map_symtab_c (one_sym_function_t* fun, void* data, object symtab) {
1452 pushSTACK(Symtab_table(symtab)); /* table vector */
1453 /* number of entries */
1454 var uintL size = posfixnum_to_V(Symtab_size(symtab));
1455 var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
1456 var uintC count;
1457 dotimespC(count,size, {
1458 var object entry = /* entry with number index in table */
1459 *(gcv_object_t*)(pointerplus(&TheSvector(STACK_0)->data[0],(aint)offset));
1460 if (atomp(entry)) {
1461 if (!nullp(entry)) { /* entry is a symbol /= NIL */
1462 (*fun)(data,entry); /* apply function */
1463 }
1464 } else { /* process non-empty symbol list */
1465 pushSTACK(entry);
1466 do {
1467 var object listr = STACK_0;
1468 STACK_0 = Cdr(listr);
1469 (*fun)(data,Car(listr)); /* apply function to symbol */
1470 } while (!matomp(STACK_0));
1471 skipSTACK(1);
1472 }
1473 offset++;
1474 });
1475 skipSTACK(1);
1476 }
1477
1478 /* define macro for locking mutexes of list of packages */
1479 #ifdef MULTITHREAD
1480 /* TODO: following is not interrupt-safe. If the thread is interrupted in the
1481 middle of the loop below with non-local exit - we are going release locks
1482 that were not required (in most cases this will result in an error,
1483 but in case of already held recursive mutex we will release it). */
1484 #define PACKAGE_LIST_MUTEX_LOCK_HELP_(packlist_) do { \
1485 pushSTACK(*packlist_); \
1486 while (mconsp(STACK_0)) { \
1487 pushSTACK(ThePackage(Car(STACK_0))->pack_mutex); \
1488 funcall(L(mutex_lock),1); \
1489 STACK_0 = Cdr(STACK_0); \
1490 } \
1491 skipSTACK(1); \
1492 } while(0)
1493 #define PACKAGE_LIST_MUTEX_UNLOCK_HELP_(packlist_,keep_mv_space) \
1494 do { \
1495 var uintC cnt=mv_count; \
1496 if (keep_mv_space) mv_to_STACK(); \
1497 pushSTACK(*packlist_); \
1498 while (mconsp(STACK_0)) { \
1499 pushSTACK(ThePackage(Car(STACK_0))->pack_mutex); \
1500 funcall(L(mutex_unlock),1); \
1501 STACK_0 = Cdr(STACK_0); \
1502 } \
1503 skipSTACK(1); \
1504 if (keep_mv_space) STACK_to_mv(cnt); \
1505 } while(0)
1506 /* packlist_ should be pointer to GC safe location. */
1507 #define WITH_PACKAGE_LIST_MUTEX_LOCK(stack_count,keep_mv_space,packlist_,body) \
1508 WITH_MUTEX_LOCK_HELP_(stack_count,keep_mv_space,packlist_,,PACKAGE_LIST_MUTEX_LOCK_HELP_,PACKAGE_LIST_MUTEX_UNLOCK_HELP_,body)
1509 #else /* no MT */
1510 #define WITH_PACKAGE_LIST_MUTEX_LOCK(stack_count,keep_mv_space,packlist_,body) body
1511 #endif
1512
1513 /* UP: Effectuates, that all external symbols of a given list of packages
1514 become implicitly accessible in a given package.
1515 use_package(packlist,pack);
1516 > packlist: list of packages, that are to be USE-ed
1517 > pack: package
1518 the list packlist is thereby destroyed!
1519 can trigger GC */
1520 local one_sym_function_t use_package_aux;
use_package(object packlist,object pack)1521 local maygc void use_package (object packlist, object pack) {
1522 safe_check_pack_lock(S(use_package),pack,packlist);
1523 { /* packlist := (delete-duplicates packlist :test #'eq) : */
1524 var object packlist1 = packlist;
1525 while (consp(packlist1)) {
1526 var object to_delete = Car(packlist1);
1527 /* remove to_delete destructively from (cdr packlist1) : */
1528 var object packlist2 = packlist1; /* starts at packlist1 */
1529 var object packlist3; /* always = (cdr packlist2) */
1530 while (consp(packlist3=Cdr(packlist2))) {
1531 if (eq(Car(packlist3),to_delete)) {
1532 /* remove (car packlist3) destructively from the list: */
1533 Cdr(packlist2) = Cdr(packlist3);
1534 } else { /* advance: */
1535 packlist2 = packlist3;
1536 }
1537 }
1538 packlist1 = Cdr(packlist1);
1539 }
1540 }
1541 /* Remove all the packages from packlist, that are equal to pack
1542 or that already occur in the use-list of pack: */
1543 pushSTACK(pack); /* save package pack */
1544 pushSTACK(packlist); /* save list of packages to be USE-ed */
1545 {
1546 var gcv_object_t* packlistr_ = &STACK_0;
1547 var object packlistr = *packlistr_;
1548 /* packlistr loops over packlist, packlistr = *packlistr_ */
1549 while (consp(packlistr)) {
1550 /* test, if (car packlistr) must be discarded: */
1551 var object pack_to_test = Car(packlistr);
1552 if (eq(pack_to_test,pack))
1553 goto delete_pack_to_test;
1554 if (!nullp(memq(pack_to_test,ThePackage(pack)->pack_use_list)))
1555 goto delete_pack_to_test;
1556 if (true) { /* do not discard, advance: */
1557 packlistr_ = &Cdr(packlistr); packlistr = *packlistr_;
1558 } else { /* discard (car packlistr) : */
1559 delete_pack_to_test:
1560 packlistr = *packlistr_ = Cdr(packlistr);
1561 }
1562 }
1563 }
1564 var gcv_object_t *packlist_lock_ = &STACK_0;
1565 var gcv_object_t *pack_lock_ = &STACK_1;
1566 WITH_PACKAGE_LIST_MUTEX_LOCK(2,false,packlist_lock_, {
1567 /* build conflict list.
1568 A conflict is an at least two-element list
1569 of symbols of the same printname, together with the package,
1570 from which this symbol is taken:
1571 ((pack1 . sym1) ...) means, that on execution of the USE-PACKAGE
1572 the symbole sym1,... (from pack1 etc.) would compete for
1573 the visibility in package pack.
1574 The conflict list is the list of all occurring conflicts. */
1575 {
1576 var gcv_object_t *pack_ = &STACK_1;
1577 var gcv_object_t *packlist_ = &STACK_0;
1578 var gcv_object_t *conflicts_;
1579 var gcv_object_t *conflict_resolver_;
1580 pushSTACK(NIL); /* (so far empty) conflict list */
1581 conflicts_ = &STACK_0;
1582 /* stack-layout: pack, packlist, conflicts. */
1583 { /* peruse package list: */
1584 pushSTACK(*packlist_);
1585 while (mconsp(STACK_0)) {
1586 var object pack_to_use = Car(STACK_0);
1587 STACK_0 = Cdr(STACK_0);
1588 /* apply use_package_aux to all external symbols of pack_to_use: */
1589 map_symtab_c(&use_package_aux,conflicts_,
1590 ThePackage(pack_to_use)->pack_external_symbols);
1591 }
1592 skipSTACK(1);
1593 }
1594 { /* reconstruct conflict list: Each conflict ((pack1 . sym1) ...) is
1595 transformed into ((packname1 pack1 . sym1) ...). */
1596 pushSTACK(*conflicts_); /* traverse conflict list */
1597 while (mconsp(STACK_0)) {
1598 var object conflict = Car(STACK_0);
1599 STACK_0 = Cdr(STACK_0);
1600 pushSTACK(conflict); /* process conflict */
1601 while (mconsp(STACK_0)) {
1602 var object new_cons = allocate_cons(); /* new cons */
1603 var object old_cons = Car(STACK_0); /* (pack . sym) */
1604 /* replace pack by its name */
1605 Car(new_cons) = ThePackage(Car(old_cons))->pack_name;
1606 /* insert new-cons */
1607 Cdr(new_cons) = old_cons; Car(STACK_0) = new_cons;
1608 STACK_0 = Cdr(STACK_0);
1609 }
1610 skipSTACK(1);
1611 }
1612 skipSTACK(1);
1613 }
1614 /* conflict-list finished. */
1615 pushSTACK(NIL); /* conflict-resolver := NIL */
1616 conflict_resolver_ = &STACK_0;
1617 /* stack-layout: pack, packlist, conflicts, conflict-resolver. */
1618 /* treat conflicts with user-queries: */
1619 while (!nullp(*conflicts_)) { /* only necessary for conflicts/=NIL */
1620 /* raise correctable error: */
1621 pushSTACK(Car(*conflicts_)); /* OPTIONS */
1622 pushSTACK(*pack_); /* PACKAGE-ERROR slot PACKAGE */
1623 pushSTACK(*pack_);
1624 pushSTACK(Symbol_name(Cdr(Cdr(Car(Car(*conflicts_)))))); /* name */
1625 pushSTACK(fixnum(llength(*conflicts_))); /* (length conflicts) */
1626 pushSTACK(*pack_); pushSTACK(*packlist_); pushSTACK(S(use_package));
1627 correctable_error(package_error,GETTEXT("(~S ~S ~S): ~S name conflicts remain\nWhich symbol with name ~S should be accessible in ~S?"));
1628 pushSTACK(value1); /* sym */
1629 {
1630 var object new_cons = allocate_cons();
1631 Car(new_cons) = popSTACK(); /* sym */
1632 Cdr(new_cons) = *conflict_resolver_;
1633 /* conflict-resolver := (cons sym conflict-resolver) */
1634 *conflict_resolver_ = new_cons;
1635 }
1636 *conflicts_ = Cdr(*conflicts_);
1637 }
1638 /* stack-layout: pack, packlist, conflicts, conflict-resolver. */
1639 { /* resolve conflicts: */
1640 set_break_sem_3();
1641 /* traverse conflict-resolver: */
1642 while (mconsp(STACK_0)) {
1643 pushSTACK(Car(STACK_0)); /* symbol from conflict-resolver */
1644 /* make it into a shadowing-symbol in pack */
1645 shadowing_import(&STACK_0,&STACK_4);
1646 skipSTACK(1);
1647 STACK_0 = Cdr(STACK_0);
1648 }
1649 skipSTACK(2); /* forget conflicts and conflict-resolver */
1650 /* stack-layout: pack, packlist. */
1651 /* traverse packlist: */
1652 while (mconsp(STACK_0)) {
1653 pushSTACK(Car(STACK_0)); /* pack_to_use */
1654 { /* (push pack_to_use (package-use-list pack)) */
1655 var object new_cons = allocate_cons();
1656 var object pack = STACK_2;
1657 Car(new_cons) = STACK_0; /* pack_to_use */
1658 Cdr(new_cons) = ThePackage(pack)->pack_use_list;
1659 ThePackage(pack)->pack_use_list = new_cons;
1660 }
1661 { /* (push pack (package-used-by-list pack_to_use)) */
1662 var object new_cons = allocate_cons();
1663 var object pack_to_use = popSTACK();
1664 Car(new_cons) = STACK_1; /* pack */
1665 Cdr(new_cons) = ThePackage(pack_to_use)->pack_used_by_list;
1666 ThePackage(pack_to_use)->pack_used_by_list = new_cons;
1667 }
1668 STACK_0 = Cdr(STACK_0);
1669 }
1670 skipSTACK(2); /* forget pack and packlist */
1671 clr_break_sem_3();
1672 }
1673 }
1674 });
1675 }
1676
1677
1678 /* UP: Auxiliary function for use_package:
1679 Test the argument (an external symbol from one of the packages of
1680 packlist), if it creates a conflict. If yes, extend conflicts.
1681 can trigger GC */
use_package_aux(void * data,object sym)1682 local maygc void use_package_aux (void* data, object sym) {
1683 var gcv_object_t* localptr = (gcv_object_t*)data;
1684 /* Pointer to local variables of use_package:
1685 *(localptr STACKop 2) = pack,
1686 *(localptr STACKop 1) = packlist,
1687 *(localptr STACKop 0) = conflicts. */
1688 var object string = Symbol_name(sym); /* printname of the passed symbol */
1689 /* Is there a conflict between the symbols with printname = string ?
1690 travares conflict list so far (((pack1 . sym1) ...) ...) : */
1691 {
1692 var object conflictsr = *(localptr STACKop 0);
1693 while (consp(conflictsr)) {
1694 /* conflict already treated?
1695 (car conflictsr) = next conflict,
1696 (car (car conflictsr)) = its first cons,
1697 (cdr (car (car conflictsr))) = the symbol therein,
1698 is its printname = string ? */
1699 if (string_eq(Symbol_name(Cdr(Car(Car(conflictsr)))),string))
1700 goto ok;
1701 conflictsr = Cdr(conflictsr);
1702 }
1703 }
1704 pushSTACK(string); /* save string */
1705 /* build new conflict: */
1706 { pushSTACK(NIL); } /* new conflict (still empty) */
1707 { /* test, if a symbol of the same name is already accessible in pack: */
1708 var object othersym;
1709 var sintBWL code = find_symbol(string,false,*(localptr STACKop 2),&othersym);
1710 if (code < 0) {
1711 /* Eponymous symbol in the shadowing-list impedes conflict. */
1712 skipSTACK(2); goto ok;
1713 }
1714 if (code > 0) {
1715 /* accessible, but not shadowing ->
1716 extend conflict by (pack . othersym) : */
1717 pushSTACK(othersym);
1718 {
1719 var object temp = allocate_cons();
1720 Cdr(temp) = popSTACK(); /* othersym */
1721 Car(temp) = *(localptr STACKop 2); /* pack */
1722 pushSTACK(temp); /* (pack . othersym) */
1723 }
1724 {
1725 var object new_cons = allocate_cons();
1726 Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
1727 STACK_0 = new_cons;
1728 }
1729 }
1730 }
1731 /* Test, in which packages from packlist a symbol of the same name
1732 is external: */
1733 {
1734 var object packlistr = *(localptr STACKop 1); /* traverse packlist */
1735 while (consp(packlistr)) {
1736 var object pack_to_use = Car(packlistr);
1737 packlistr = Cdr(packlistr);
1738 var object othersym;
1739 if (package_lookup_ext(STACK_1,false,pack_to_use,&othersym)) {
1740 /* othersym has the printname = string and is
1741 external in pack_to_use.
1742 push (pack_to_use . othersym) on conflict: */
1743 pushSTACK(packlistr); /* save packlistr */
1744 pushSTACK(pack_to_use);
1745 pushSTACK(othersym);
1746 {
1747 var object new_cons = allocate_cons();
1748 Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
1749 pushSTACK(new_cons); /* (cons pack_to_use othersym) */
1750 }
1751 {
1752 var object new_cons = allocate_cons();
1753 Car(new_cons) = popSTACK();
1754 packlistr = popSTACK();
1755 Cdr(new_cons) = STACK_0;
1756 /* conflict := (cons (cons pack_to_use othersym) conflict) */
1757 STACK_0 = new_cons;
1758 }
1759 }
1760 }
1761 }
1762 {
1763 var object conflict = popSTACK(); /* the completed conflict */
1764 /* conflict := (delete-duplicates conflict :key #'cdr :test #'eq): */
1765 {
1766 var object conflict1 = conflict;
1767 while (consp(conflict1)) {
1768 var object to_delete = Cdr(Car(conflict1));
1769 /* Remove all elements with CDR=to_delete
1770 destructively from (cdr conflict1) : */
1771 var object conflict2 = conflict1; /* starts at conflict1 */
1772 var object conflict3; /* always = (cdr conflict2) */
1773 while (consp(conflict3=Cdr(conflict2))) {
1774 if (eq(Cdr(Car(conflict3)),to_delete)) {
1775 /* discard (car conflict3) destructively from the list: */
1776 Cdr(conflict2) = Cdr(conflict3);
1777 } else { /* advance: */
1778 conflict2 = conflict3;
1779 }
1780 }
1781 conflict1 = Cdr(conflict1);
1782 }
1783 }
1784 /* if conflict has a length >=2 , it is consed to conflicts: */
1785 if (consp(conflict) && mconsp(Cdr(conflict))) {
1786 pushSTACK(conflict);
1787 var object new_cons = allocate_cons();
1788 Car(new_cons) = popSTACK(); /* conflict */
1789 Cdr(new_cons) = *(localptr STACKop 0); /* conflicts */
1790 /* conflicts := (cons conflict conflicts) */
1791 *(localptr STACKop 0) = new_cons;
1792 }
1793 }
1794 skipSTACK(1); /* forget string */
1795 ok: ;
1796 }
1797
1798 /* UP: Effectuates, that a given package is not USE-ed anymore
1799 by (another) package.
1800 unuse_1package(pack,qpack);
1801 > pack: package
1802 > qpack: package
1803 Removes qpack from the use-list of pack
1804 and pack from the used-by-list of qpack.
1805 can trigger GC */
unuse_1package(object pack,object qpack)1806 local maygc void unuse_1package (object pack, object qpack) {
1807 safe_check_pack_lock(S(use_package),pack,qpack);
1808 set_break_sem_2();
1809 /* remove qpack from the use-list of pack: */
1810 ThePackage(pack)->pack_use_list =
1811 deleteq(ThePackage(pack)->pack_use_list,qpack);
1812 /* remove pack from the used-by-list of qpack: */
1813 ThePackage(qpack)->pack_used_by_list =
1814 deleteq(ThePackage(qpack)->pack_used_by_list,pack);
1815 clr_break_sem_2();
1816 }
1817
1818 /* UP: Effectuates, that a list of given packages is not USE-ed anymore
1819 by a given package.
1820 unuse_package(packlist,pack);
1821 > packlist: list of packages
1822 > pack: package
1823 Removes all packages from packlist from the use-list of pack
1824 and pack from the used-by-lists of all packages from packlist.
1825 can trigger GC
1826 MT: pack mutex is locked by caller */
unuse_package(object packlist,object pack)1827 local maygc void unuse_package (object packlist, object pack) {
1828 pushSTACK(pack);
1829 pushSTACK(packlist);
1830 pushSTACK(NIL);
1831 var gcv_object_t *pack_ = &STACK_2;
1832 var gcv_object_t *qpack_ = &STACK_0;
1833 set_break_sem_3();
1834 /* traverse packlist: */
1835 while (mconsp(STACK_1)) {
1836 STACK_0 = Car(STACK_1);
1837 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*qpack_)->pack_mutex,{
1838 unuse_1package(*pack_,*qpack_);
1839 });
1840 STACK_1 = Cdr(STACK_1);
1841 }
1842 clr_break_sem_3();
1843 skipSTACK(3);
1844 }
1845
1846 /* UP: returns the current package
1847 get_current_package()
1848 < result: current package
1849 can trigger GC */
get_current_package(void)1850 global maygc object get_current_package (void) {
1851 var object pack = Symbol_value(S(packagestar)); /* value of *PACKAGE* */
1852 if (packagep(pack) && !pack_deletedp(pack)) {
1853 return pack;
1854 } else {
1855 var object newpack = /* reset *PACKAGE* */
1856 Symbol_value(S(packagestar)) = O(default_package);
1857 /* get_current_package() is often called by the reader,
1858 so we need to save and restore the read buffers */
1859 pushSTACK(TLO(token_buff_1)); TLO(token_buff_1) = NIL;
1860 pushSTACK(TLO(token_buff_2)); TLO(token_buff_2) = NIL;
1861 pushSTACK(NIL); /* 8: "Proceed with the new value." */
1862 pushSTACK(S(type_error)); /* 7: error type */
1863 pushSTACK(S(Kdatum)); /* 6: :DATUM */
1864 pushSTACK(pack); /* 5: TYPE-ERROR slot DATUM */
1865 pushSTACK(S(Kexpected_type)); /* 4: :EXPECTED-TYPE */
1866 pushSTACK(S(package)); /* 3: TYPE-ERROR slot EXPECTED-TYPE */
1867 pushSTACK(NIL); /* 2: "The value of ..." */
1868 pushSTACK(pack); /* 1: old name */
1869 pushSTACK(newpack); /* 0: new name */
1870 STACK_2 = CLSTEXT("The value of *PACKAGE* was not a package and was reset. The old value was ~S. The new value is ~S.");
1871 STACK_8 = CLSTEXT("Proceed with the new value.");
1872 funcall(L(cerror_of_type),9);
1873 TLO(token_buff_2) = popSTACK(); /* restore read buffers */
1874 TLO(token_buff_1) = popSTACK();
1875 return Symbol_value(S(packagestar));
1876 }
1877 }
1878
1879 /* UP: checks a package-argument.
1880 Tests, if it is a package or a package name, and returns it as
1881 a package. Else error message.
1882 test_package_arg(obj)
1883 > obj: argument
1884 < result: argument turned into a package
1885 can trigger GC */
test_package_arg(object obj)1886 local maygc object test_package_arg (object obj) {
1887 restart_package_arg:
1888 if (packagep(obj)) { /* package -> mostly OK */
1889 if (!pack_deletedp(obj))
1890 return obj;
1891 pushSTACK(NIL); /* no PLACE */
1892 pushSTACK(obj); /* PACKAGE-ERROR slot PACKAGE */
1893 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1894 check_value(package_error,GETTEXT("~S: Package ~S has been deleted."));
1895 obj = value1;
1896 goto restart_package_arg;
1897 }
1898 if (stringp(obj))
1899 string: { /* string -> search package with name obj: */
1900 pushSTACK(obj);
1901 var object pack = find_package(obj);
1902 obj = popSTACK();
1903 if (!nullp(pack))
1904 return pack;
1905 pushSTACK(NIL); /* no PLACE */
1906 pushSTACK(obj); /* PACKAGE-ERROR slot PACKAGE */
1907 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1908 check_value(package_error,GETTEXT("~S: There is no package with name ~S"));
1909 obj = value1;
1910 goto restart_package_arg;
1911 }
1912 if (symbolp(obj)) { /* symbol -> string */
1913 obj = Symbol_name(obj); goto string; /* use print name, no case-invert */
1914 }
1915 if (charp(obj)) { /* character -> string */
1916 var object new_string = allocate_string(1);
1917 TheSnstring(new_string)->data[0] = char_code(obj);
1918 obj = new_string;
1919 goto string;
1920 }
1921 pushSTACK(NIL); /* no PLACE */
1922 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1923 pushSTACK(O(type_packname)); /* TYPE-ERROR slot EXPECTED-TYPE */
1924 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1925 check_value(type_error,GETTEXT("~S: argument should be a package or a package name, not ~S"));
1926 obj = value1;
1927 goto restart_package_arg;
1928 }
1929
1930 LISPFUNNR(make_symbol,1) { /* (MAKE-SYMBOL printname), CLTL p. 168 */
1931 var object arg = check_string(popSTACK());
1932 VALUES1(make_symbol(coerce_imm_ss(arg)));
1933 }
1934
1935 LISPFUNNR(find_package,1) { /* (FIND-PACKAGE name), CLTL p. 183 */
1936 var object pack = popSTACK();
1937 if (packagep(pack)) VALUES1(pack);
1938 else {
1939 var object name = test_stringsymchar_arg(pack,false);
1940 VALUES1(find_package(name)); /* search package */
1941 }
1942 }
1943
1944 LISPFUNN(pfind_package,1) { /* (SYSTEM::%FIND-PACKAGE name) */
1945 VALUES1(test_package_arg(popSTACK())); /* argument as package */
1946 }
1947
1948 LISPFUNNR(package_name,1) { /* (PACKAGE-NAME package), CLTL p. 184 */
1949 var object pack = popSTACK();
1950 if (packagep(pack) && pack_deletedp(pack)) {
1951 VALUES1(NIL);
1952 } else {
1953 pack = test_package_arg(pack); /* argument as package */
1954 VALUES1(ThePackage(pack)->pack_name); /* the name */
1955 }
1956 }
1957
1958 LISPFUNNR(package_nicknames,1)
1959 { /* (PACKAGE-NICKNAMES package), CLTL p. 184 */
1960 var object pack = popSTACK();
1961 if (packagep(pack) && pack_deletedp(pack)) {
1962 VALUES1(NIL);
1963 } else {
1964 pack = test_package_arg(pack); /* argument as package */
1965 /* copy nicknamelist for safety reasons */
1966 VALUES1(copy_list(ThePackage(pack)->pack_nicknames));
1967 }
1968 }
1969
1970 /* UP: checks name and nicknames -
1971 arguments of RENAME-PACKAGE and MAKE-PACKAGE.
1972 Tests, if STACK_4 is a name, and turns it into a immutable simple-string.
1973 Tests, if STACK_3 is a name or a list of names, and turns it
1974 into a new list of immutable simple-strings.
1975 > subr-self: caller (a SUBR)
1976 can trigger GC */
test_names_args(void)1977 local maygc void test_names_args (void) {
1978 /* check name for string and turn it into a simple-string: */
1979 STACK_4 = coerce_imm_ss(test_stringsymchar_arg(STACK_4,false));
1980 { /* convert nickname-argument into a list: */
1981 var object nicknames = STACK_3;
1982 if (!boundp(nicknames)) {
1983 STACK_3 = NIL; /* no nicknames specified -> default NIL */
1984 } else {
1985 if (!listp(nicknames)) {
1986 /* nicknames not a list -> turn it into a one-element list: */
1987 nicknames = allocate_cons();
1988 Car(nicknames) = STACK_3;
1989 STACK_3 = nicknames;
1990 }
1991 }
1992 }
1993 { /* check nickname(s) for string, turn into simple-strings
1994 and build a new nicknamelist: */
1995 pushSTACK(NIL); /* new nicknamelist := NIL */
1996 while (mconsp(STACK_4)) {
1997 {
1998 var object nickname = Car(STACK_4); /* next nickname */
1999 STACK_4 = Cdr(STACK_4);
2000 /* as simple-string */
2001 nickname = coerce_imm_ss(test_stringsymchar_arg(nickname,false));
2002 /* cons in front of the new nicknamelist: */
2003 pushSTACK(nickname);
2004 }
2005 var object new_cons = allocate_cons();
2006 Car(new_cons) = popSTACK();
2007 Cdr(new_cons) = STACK_0;
2008 STACK_0 = new_cons;
2009 }
2010 var object nicknames = popSTACK();
2011 STACK_3 = nicknames; /* new nicknamelist replaces the old */
2012 }
2013 }
2014
2015 /* (RENAME-PACKAGE pack name [nicknames]), CLTL p. 184 */
2016 LISPFUN(rename_package,seclass_default,2,1,norest,nokey,0,NIL) {
2017 /* Test, if pack is a package: */
2018 STACK_2 = test_package_arg(STACK_2);
2019 check_pack_lock(S(rename_package),STACK_2,STACK_1);
2020 /* check name and nicknames:
2021 name is a package designator here (but not in make-package!) */
2022 if (packagep(STACK_1)) STACK_1 = ThePackage(STACK_1)->pack_name;
2023 pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL); /* dummies on the stack */
2024 test_names_args();
2025 skipSTACK(3);
2026 WITH_OS_MUTEX_LOCK(3,&all_packages_lock, {
2027 var object pack = STACK_2;
2028 { /* test, if a package-name-conflict arises: */
2029 var object name = STACK_1;
2030 var object nicknamelistr = STACK_0;
2031 /* name loops over the names and all nicknames */
2032 while (1) { /* find package with this name: */
2033 pushSTACK(name); pushSTACK(nicknamelistr); /* save (MT) */
2034 var object found = find_package(name);
2035 nicknamelistr = popSTACK(); name = popSTACK(); /* restore */
2036 pack = STACK_2;
2037 if (!(nullp(found) || eq(found,pack))) {
2038 /* found, but another one than the given package: */
2039 pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
2040 pushSTACK(name); pushSTACK(TheSubr(subr_self)->name);
2041 error(package_error,
2042 GETTEXT("~S: there is already a package named ~S"));
2043 }
2044 /* none or only the given package has the Name name ->
2045 no conflict with this (nick)name, continue: */
2046 if (atomp(nicknamelistr))
2047 break;
2048 name = Car(nicknamelistr); /* next nickname */
2049 nicknamelistr = Cdr(nicknamelistr); /* shorten remaining nicknamelist */
2050 }
2051 }
2052 /* There are no conflicts. */
2053 var gcv_object_t *pack_ = &STACK_2;
2054 var gcv_object_t *name_ = &STACK_1;
2055 var gcv_object_t *nicknamelistr_ = &STACK_0;
2056 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*pack_)->pack_mutex, {
2057 set_break_sem_2();
2058 ThePackage(*pack_)->pack_name = *name_;
2059 ThePackage(*pack_)->pack_nicknames = *nicknamelistr_;
2060 clr_break_sem_2();
2061 });
2062 pack = STACK_2; /* restore the pack */
2063 ensure_pack_shortest_name(pack);
2064 skipSTACK(3);
2065 VALUES1(pack); /* pack as value */
2066 });
2067 }
2068
2069 LISPFUNNR(package_use_list,1) { /* (PACKAGE-USE-LIST package), CLTL p. 184 */
2070 var object pack = test_package_arg(popSTACK()); /* argument as package */
2071 /* copy use-list for safety reasons */
2072 VALUES1(copy_list(ThePackage(pack)->pack_use_list));
2073 }
2074
2075 LISPFUNNR(package_used_by_list,1)
2076 { /* (PACKAGE-USED-BY-LIST package), CLTL p. 184 */
2077 var object pack = test_package_arg(popSTACK()); /* argument as package */
2078 /* copy used-by-list for safety reasons */
2079 VALUES1(copy_list(ThePackage(pack)->pack_used_by_list));
2080 }
2081
2082 LISPFUNNR(package_shadowing_symbols,1)
2083 { /* (PACKAGE-SHADOWING-SYMBOLS package), CLTL p. 184 */
2084 var object pack = test_package_arg(popSTACK()); /* argument as package */
2085 /* copy shadowing-list for safety reasons */
2086 VALUES1(copy_list(ThePackage(pack)->pack_shadowing_symbols));
2087 }
2088
2089 /* (EXT:PACKAGE-CASE-SENSITIVE-P package) */
2090 LISPFUNNR(package_case_sensitive_p,1) {
2091 var object pack = test_package_arg(popSTACK());
2092 VALUES_IF(pack_casesensitivep(pack));
2093 }
2094
2095 /* ((SETF EXT:PACKAGE-CASE-SENSITIVE-P) value package) */
2096 LISPFUNN(set_package_case_sensitive_p,2) {
2097 var object pack = test_package_arg(popSTACK());
2098 var bool value = !nullp(popSTACK());
2099 if (value) mark_pack_casesensitive(pack);
2100 else mark_pack_caseinsensitive(pack);
2101 VALUES_IF(value);
2102 }
2103
2104 /* (EXT:PACKAGE-CASE-INVERTED-P package) */
2105 LISPFUNNR(package_case_inverted_p,1) {
2106 var object pack = test_package_arg(popSTACK());
2107 VALUES_IF(pack_caseinvertedp(pack));
2108 }
2109
2110 /* ((SETF EXT:PACKAGE-CASE-INVERTED-P) value package) */
2111 LISPFUNN(set_package_case_inverted_p,2) {
2112 var object pack = test_package_arg(popSTACK());
2113 var bool value = !nullp(popSTACK());
2114 if (value) mark_pack_caseinverted(pack);
2115 else mark_pack_casepreserved(pack);
2116 VALUES_IF(value);
2117 }
2118
2119 /* (SYS::PACKAGE-DOCUMENTATION package) */
2120 LISPFUNNR(package_documentation,1) {
2121 var object pack = test_package_arg(popSTACK());
2122 VALUES1(ThePackage(pack)->pack_docstring);
2123 }
2124
2125 /* ((SETF SYS::PACKAGE-DOCUMENTATION) new-value package)
2126 documentation is either a doc-string or a list (doc-string impnotes-id) */
2127 LISPFUNN(set_package_documentation,2) {
2128 STACK_0 = test_package_arg(STACK_0);
2129 if (!listp(STACK_1)) STACK_1 = check_string(STACK_1);
2130 VALUES1(ThePackage(STACK_0)->pack_docstring = STACK_1);
2131 skipSTACK(2);
2132 }
2133
2134 LISPFUNNR(package_shortest_name,1)
2135 { /* (EXT:PACKAGE-SHORTEST-NAME package) */
2136 var object pack = test_package_arg(popSTACK());
2137 VALUES1(ThePackage(pack)->pack_shortest_name);
2138 }
2139
2140 LISPFUNNR(package_lock,1)
2141 { /* (EXT:PACKAGE-LOCK package) */
2142 var object pack = test_package_arg(popSTACK());
2143 VALUES_IF(pack_locked_p(pack));
2144 }
2145
2146 /* ((SETF EXT:PACKAGE-LOCK) lock package) */
2147 LISPFUNN(set_package_lock,2) {
2148 var bool unlock_p = nullp(STACK_1);
2149 var object pack = STACK_0;
2150 if (mconsp(pack)) {
2151 while (mconsp(STACK_0)) {
2152 var object pa = test_package_arg(Car(STACK_0)); STACK_0 = Cdr(STACK_0);
2153 if (unlock_p) mark_pack_unlocked(pa);
2154 else mark_pack_locked(pa);
2155 }
2156 } else if (nullp(pack)) { /* do nothing - package list was empty */
2157 } else {
2158 pack = test_package_arg(pack);
2159 if (unlock_p) mark_pack_unlocked(pack);
2160 else mark_pack_locked(pack);
2161 }
2162 skipSTACK(2);
2163 VALUES_IF(!unlock_p);
2164 }
2165
2166 /* barf when SYMBOL is an unaccessible special variable
2167 being modified from a non-home package.
2168 See compiler.lisp:set-check-lock.
2169 can trigger GC */
2170 #define SYM_VAL_LOCK(symbol,pack) \
2171 (!nullp(pack) && !eq(pack,Symbol_value(S(packagestar))) /* non-home */ \
2172 && special_var_p(TheSymbol(symbol)) /* special */ \
2173 && !externalp(symbol,pack) /* for IN-PACKAGE forms */ \
2174 && !accessiblep(symbol,Symbol_value(S(packagestar)))) /* accessible */
symbol_value_check_lock(object caller,object symbol)2175 global maygc void symbol_value_check_lock (object caller, object symbol) {
2176 var object pack = Symbol_package(symbol);
2177 if (SYM_VAL_LOCK(symbol,pack))
2178 check_pack_lock(caller,pack,symbol);
2179 }
2180 LISPFUNN(symbol_value_lock,1) { /* SYS::SYMBOL-VALUE-LOCK */
2181 var object symb = check_symbol(popSTACK());
2182 var object pack = Symbol_package(symb);
2183 VALUES_IF(SYM_VAL_LOCK(symb,pack) && pack_locked_p(pack));
2184 }
2185
2186 /* (SYSTEM::CHECK-PACKAGE-LOCK caller package symbol)
2187 when FUNCTION is (P)SETQ, calls symbol_value_check_lock() */
2188 LISPFUNN(check_package_lock,3) {
2189 if (mconsp(STACK_1)) { /* package is actually a list of packages */
2190 var bool locked = true;
2191 var object list = STACK_1;
2192 /* for the package list to be "locked", _all_ members must be locked
2193 non-package members mean that the argument was a defmethod spec like
2194 (eql 1), which means unlocked: you can always redefine such methods */
2195 while (locked && mconsp(list)) {
2196 locked = (packagep(Car(list)) ? pack_locked_p(Car(list)) : false);
2197 list = Cdr(list);
2198 }
2199 if (locked) /* all packages are locked --> error */
2200 cerror_package_locked(STACK_2,STACK_1,STACK_0);
2201 } else if (packagep(STACK_1)) /* just one package - check it */
2202 check_pack_lock(STACK_2,STACK_1,STACK_0);
2203 skipSTACK(3);
2204 mv_count = 0;
2205 }
2206
2207 LISPFUNNR(list_all_packages,0)
2208 { /* (LIST-ALL-PACKAGES) returns a list of all packages, CLTL p. 184 */
2209 WITH_OS_MUTEX_LOCK(0,&all_packages_lock, {
2210 VALUES1(reverse(O(all_packages))); /* (copy of the list, as a precaution) */
2211 });
2212 }
2213
2214 /* UP: check the last argument &optional (pack *package*) of
2215 a LISP-function.
2216 test_optional_package_arg()
2217 > STACK_0: last argument
2218 < STACK_0: argument transformed into a package
2219 can trigger GC */
test_optional_package_arg(void)2220 local maygc void test_optional_package_arg (void) {
2221 var object pack = STACK_0;
2222 if (!boundp(pack)) {
2223 STACK_0 = get_current_package(); /* default is the value of *PACKAGE* */
2224 } else {
2225 STACK_0 = test_package_arg(pack);
2226 }
2227 }
2228
2229 /* UP: Check of the arguments of INTERN and FIND-SYMBOL.
2230 test_intern_args()
2231 can trigger GC */
test_intern_args(void)2232 local maygc void test_intern_args (void) {
2233 STACK_1 = check_string(STACK_1); /* test string */
2234 test_optional_package_arg(); /* test package */
2235 }
2236
2237 /* UP: Transforms a INTERN/FIND-SYMBOL - result into a keyword.
2238 intern_result(code)
2239 > code : flag as for intern and find_symbol
2240 < result : corresponding keyword */
intern_result(uintBWL code)2241 local object intern_result (uintBWL code) {
2242 switch (code) {
2243 case 0: { return NIL; } /* 0 -> NIL */
2244 case 1: { return S(Kexternal); } /* 1 -> :EXTERNAL */
2245 case 2: { return S(Kinherited); } /* 2 -> :INHERITED */
2246 case 3: { return S(Kinternal); } /* 3 -> :INTERNAL */
2247 default: NOTREACHED;
2248 }
2249 }
2250
2251 /* (INTERN string [package]) and its case-inverted variant */
do_intern(bool invert)2252 local maygc Values do_intern (bool invert) {
2253 test_intern_args(); /* test arguments */
2254 var object pack = popSTACK();
2255 var object string = popSTACK();
2256 #if !defined(VALUE1_EXTRA)
2257 var uintBWL code = intern(string,invert,pack,&value1); /* symbol to value1 */
2258 #else
2259 var object value;
2260 var uintBWL code = intern(string,invert,pack,&value); /* Symbol to value */
2261 value1 = value;
2262 #endif
2263 value2 = intern_result(code); mv_count=2; /* two values */
2264 }
2265
2266 /* (INTERN string [package]), CLTL p. 184 */
2267 LISPFUN(intern,seclass_default,1,1,norest,nokey,0,NIL) {
2268 do_intern(false);
2269 }
2270
2271 /* (CS-COMMON-LISP:INTERN string [package]) */
2272 LISPFUN(cs_intern,seclass_default,1,1,norest,nokey,0,NIL) {
2273 do_intern(true);
2274 }
2275
2276 /* (FIND-SYMBOL string [package]) and its case-inverted variant */
do_find_symbol(bool invert)2277 local maygc Values do_find_symbol (bool invert) {
2278 test_intern_args(); /* test arguments */
2279 var object pack = popSTACK();
2280 var object string = popSTACK();
2281 #if !defined(VALUE1_EXTRA)
2282 var uintBWL code = find_symbol(string,invert,pack,&value1) & 3; /* symbol to value1 */
2283 #else
2284 var object value;
2285 var uintBWL code = find_symbol(string,invert,pack,&value) & 3; /* symbol to value */
2286 value1 = value;
2287 #endif
2288 value2 = intern_result(code); mv_count=2; /* two values */
2289 }
2290
2291 /* (FIND-SYMBOL string [package]), CLTL p. 185 */
2292 LISPFUN(find_symbol,seclass_read,1,1,norest,nokey,0,NIL)
2293 {
2294 do_find_symbol(false);
2295 }
2296
2297 /* (CS-COMMON-LISP:FIND-SYMBOL string [package]) */
2298 LISPFUN(cs_find_symbol,seclass_read,1,1,norest,nokey,0,NIL)
2299 {
2300 do_find_symbol(true);
2301 }
2302
2303 /* (UNINTERN symbol [package]), CLTL p. 185 */
2304 LISPFUN(unintern,seclass_default,1,1,norest,nokey,0,NIL) {
2305 /* test symbol: */
2306 STACK_1 = check_symbol(STACK_1);
2307 /* test package: */
2308 test_optional_package_arg();
2309 /* unintern: */
2310 var gcv_object_t *pack_ = &STACK_0;
2311 var gcv_object_t *sym_ = &STACK_1;
2312 WITH_LISP_MUTEX_LOCK(0,true,&ThePackage(*pack_)->pack_mutex,{
2313 VALUES1(unintern(sym_,pack_));
2314 });
2315 skipSTACK(2);
2316 }
2317
2318 /* UP: Dispatcher of a function like EXPORT, UNEXPORT, IMPORT, SHADOWING-IMPORT
2319 or SHADOW. tests, if the first argument is a symbol-list, if
2320 the second argument (default: *PACKAGE*) is a package, and applies the
2321 subroutine to each of the symbols. Return 1 value T.
2322 apply_symbols(&fun);
2323 specification of the subroutine fun:
2324 fun(&sym,&pack);
2325 > sym: symbol (in STACK)
2326 > pack: package (in STACK)
2327 < pack: package, EQ to the old one
2328 can trigger GC
2329 < STACK: cleaned up
2330 can trigger GC */
2331 typedef maygc void sym_pack_function_t (const gcv_object_t* sym_, const gcv_object_t* pack_);
apply_symbols(sym_pack_function_t * fun)2332 local maygc Values apply_symbols (sym_pack_function_t* fun) {
2333 { /* test, if the first argument is a symbol-list or a symbol: */
2334 var object symarg = STACK_1;
2335 /* test for symbol: */
2336 if (symbolp(symarg))
2337 goto ok;
2338 if ((fun == &shadow || fun == &cs_shadow)
2339 && (stringp(symarg) || charp(symarg)))
2340 goto ok;
2341 /* test for symbol-list: */
2342 while (consp(symarg)) { /* symarg loops over STACK_1 */
2343 if (!(symbolp(Car(symarg))
2344 || ((fun == &shadow || fun == &cs_shadow)
2345 && (stringp(Car(symarg)) || charp(Car(symarg))))))
2346 goto not_ok;
2347 symarg = Cdr(symarg);
2348 }
2349 if (!nullp(symarg))
2350 goto not_ok; /* list correctly finished? */
2351 goto ok; /* correct symbol-list */
2352 not_ok:
2353 pushSTACK(STACK_1); pushSTACK(TheSubr(subr_self)->name);
2354 error(error_condition,GETTEXT("~S: argument should be a symbol or a list of symbols, not ~S"));
2355 ok: ;
2356 }
2357 /* test package: */
2358 test_optional_package_arg();
2359 /* stack-layout: symarg, pack. */
2360 /* apply fun to all symbols: */
2361 if (matomp(STACK_1)) {
2362 if (nullp(STACK_1)) {
2363 /* ANSI CL 11.1.1. says
2364 "Where an operator takes an argument that is either a symbol or a list of
2365 symbols, an argument of nil is treated as an empty list of symbols." */
2366 } else {
2367 /* single symbol */
2368 /* stack-layout: sym, pack. */
2369 var gcv_object_t *pack_ = &STACK_0;
2370 var gcv_object_t *sym_ = &STACK_1;
2371 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*pack_)->pack_mutex,{
2372 (*fun)(sym_,pack_);
2373 });
2374 }
2375 skipSTACK(2);
2376 } else {
2377 /* non-empty symbol-list */
2378 var gcv_object_t *pack_ = &STACK_0;
2379 var gcv_object_t *symlist_ = &STACK_1;
2380 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*pack_)->pack_mutex,{
2381 pushSTACK(NIL);
2382 do {
2383 var object symlistr = *symlist_;
2384 *symlist_ = Cdr(symlistr);
2385 STACK_0 = Car(symlistr); /* symbol */
2386 /* stack-layout (single thread) : symlistr, pack, sym. */
2387 /* stack-layout (MT) : symlistr, pack, UNWIND_PROTECT frame ,sym. */
2388 (*fun)(&STACK_0,pack_);
2389 } while (!matomp(*symlist_));
2390 skipSTACK(1);
2391 });
2392 skipSTACK(2); /* pack & symlist */
2393 }
2394 /* finish: */
2395 VALUES1(T);
2396 }
2397
2398 /* (EXPORT symbols [package]), CLTL p. 186 */
2399 LISPFUN(export,seclass_default,1,1,norest,nokey,0,NIL) {
2400 return_Values apply_symbols(&export);
2401 }
2402
2403 /* (UNEXPORT symbols [package]), CLTL p. 186 */
2404 LISPFUN(unexport,seclass_default,1,1,norest,nokey,0,NIL) {
2405 return_Values apply_symbols(&unexport);
2406 }
2407
2408 /* (IMPORT symbols [package]), CLTL p. 186 */
2409 LISPFUN(import,seclass_default,1,1,norest,nokey,0,NIL) {
2410 return_Values apply_symbols(&import);
2411 }
2412
2413 /* (SHADOWING-IMPORT symbols [package]), CLTL p. 186 */
2414 LISPFUN(shadowing_import,seclass_default,1,1,norest,nokey,0,NIL) {
2415 return_Values apply_symbols(&shadowing_import);
2416 }
2417
2418 /* (SHADOW symbols [package]), CLTL p. 186 */
2419 LISPFUN(shadow,seclass_default,1,1,norest,nokey,0,NIL) {
2420 return_Values apply_symbols(&shadow);
2421 }
2422
2423 /* (CS-COMMON-LISP:SHADOW symbols [package]) */
2424 LISPFUN(cs_shadow,seclass_default,1,1,norest,nokey,0,NIL) {
2425 return_Values apply_symbols(&cs_shadow);
2426 }
2427
2428 /* UP: Preparation of the arguments of USE-PACKAGE and UNUSE-PACKAGE.
2429 The first argument STACK_1 is turned into a (newly created)
2430 list of packages, the second argument STACK_0 is checked.
2431 can trigger GC */
prepare_use_package(void)2432 local maygc void prepare_use_package (void) {
2433 /* check second argument (package) : */
2434 test_optional_package_arg();
2435 { /* check first argument (package or package-list) : */
2436 var object packs_to_use = STACK_1;
2437 if (!listp(packs_to_use)) {
2438 /* packs_to_use not a list -> turn it into a one-element list: */
2439 pushSTACK(test_package_arg(packs_to_use)); /* single package */
2440 var object new_cons = allocate_cons();
2441 Car(new_cons) = popSTACK();
2442 STACK_1 = new_cons;
2443 } else { /* packs_to_use a list -> build up new package-list: */
2444 pushSTACK(NIL); /* start with NIL */
2445 while (mconsp(STACK_2)) {
2446 var object packlistr = STACK_2;
2447 STACK_2 = Cdr(packlistr);
2448 pushSTACK(test_package_arg(Car(packlistr))); /* next package */
2449 var object new_cons = allocate_cons();
2450 Car(new_cons) = popSTACK();
2451 Cdr(new_cons) = STACK_0;
2452 STACK_0 = new_cons;
2453 }
2454 var object packlist = popSTACK(); /* new package-list */
2455 STACK_1 = packlist;
2456 }
2457 }
2458 }
2459
2460 /* (USE-PACKAGE packs-to-use [package]), CLTL p. 187 */
2461 LISPFUN(use_package,seclass_default,1,1,norest,nokey,0,NIL) {
2462 prepare_use_package();
2463 var gcv_object_t *pack_ = &STACK_0;
2464 var gcv_object_t *packlist_ = &STACK_1;
2465 WITH_OS_MUTEX_LOCK(2, &all_packages_lock, {
2466 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*pack_)->pack_mutex,{
2467 use_package(*packlist_,*pack_);
2468 });
2469 });
2470 skipSTACK(2); VALUES1(T);
2471 }
2472
2473 /* (UNUSE-PACKAGE packs-to-use [package]), CLTL p. 187 */
2474 LISPFUN(unuse_package,seclass_default,1,1,norest,nokey,0,NIL) {
2475 prepare_use_package();
2476 var gcv_object_t *pack_ = &STACK_0;
2477 var gcv_object_t *packlist_ = &STACK_1;
2478 WITH_OS_MUTEX_LOCK(2, &all_packages_lock, {
2479 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*pack_)->pack_mutex,{
2480 unuse_package(*packlist_,*pack_);
2481 });
2482 });
2483 skipSTACK(2); VALUES1(T);
2484 }
2485
2486 /* UP: Corrects a package(nick)name.
2487 > name: Desired package-name (simple-string)
2488 > nickname_p: is this a name or a nickname
2489 < result: not yet existing package-name
2490 or NIL if CONTINUE restart is selected
2491 can trigger GC */
correct_packname(object name,bool nickname_p)2492 local maygc object correct_packname (object name, bool nickname_p) {
2493 var object pack;
2494 pushSTACK(name);
2495 while (!nullp(pack=find_package(name))) {
2496 name = popSTACK();
2497 /* package with this name already exists */
2498 pushSTACK(NIL); /* OPTIONS */
2499 pushSTACK(pack); /* PACKAGE-ERROR slot package */
2500 pushSTACK(name); pushSTACK(TheSubr(subr_self)->name);
2501 /* fill OPTIONS */
2502 pushSTACK(S(continue)); /* restart name */
2503 pushSTACK(nickname_p ? CLSTEXT("discard this nickname")
2504 : CLSTEXT("return the existing package"));
2505 var object tmp = listof(2);
2506 pushSTACK(tmp);
2507 pushSTACK(S(readL)); /* restart name */
2508 pushSTACK(nickname_p ? CLSTEXT("input another nickname")
2509 : CLSTEXT("input another name"));
2510 pushSTACK(S(prompt_for_new_value)); /* interactive function */
2511 pushSTACK(NIL); /* place */
2512 tmp = listof(4);
2513 pushSTACK(tmp);
2514 tmp = listof(2); STACK_3 = tmp; /* options list */
2515 correctable_error(package_error,GETTEXT("~S: a package with name ~S already exists."));
2516 if (nullp(value1)) return NIL; /* continue */
2517 name = test_stringsymchar_arg(value1,false);
2518 pushSTACK(name);
2519 }
2520 return coerce_imm_ss(popSTACK());
2521 }
2522
2523 /* UP for MAKE-PACKAGE and %IN-PACKAGE:
2524 Builds a new package and returns it as value.
2525 > STACK_4: name-argument
2526 > STACK_3: nicknames-argument
2527 > STACK_2: uselist-argument
2528 > STACK_1: case-sensitive-argument
2529 > STACK_0: case-inverted-argument
2530 removes the 5 STACK elements
2531 can trigger GC */
in_make_package(bool case_inverted)2532 local maygc void in_make_package (bool case_inverted) {
2533 /* transform name into simple-string and
2534 nicknames into a new simple-string-list: */
2535 test_names_args();
2536 var object new_name = correct_packname(STACK_4,false);
2537 if (nullp(new_name)) { /* CONTINUE: re-use the existing package */
2538 VALUES1(find_package(STACK_4));
2539 skipSTACK(5);
2540 return;
2541 } else /* corrected: replace */
2542 STACK_4 = new_name;
2543 /* check nicknames and maybe adjust: */
2544 pushSTACK(STACK_3);
2545 while (mconsp(STACK_0)) {
2546 var object correct_nick = correct_packname(Car(STACK_0),true);
2547 Car(STACK_0) = correct_nick;
2548 STACK_0 = Cdr(STACK_0);
2549 }
2550 skipSTACK(1);
2551 STACK_3 = deleteq(STACK_3,NIL);
2552 /* (DELETE-DUPLICATES NICKNAMES :TEST (FUNCTION STRING=)) */
2553 pushSTACK(STACK_3); pushSTACK(S(Ktest)); pushSTACK(L(string_eq));
2554 funcall(L(delete_duplicates),3);
2555 STACK_3 = value1;
2556 /* create package: */
2557 STACK_4 = make_package(STACK_4,STACK_3,
2558 boundp(STACK_1) ? !nullp(STACK_1) : case_inverted,
2559 boundp(STACK_0) ? !nullp(STACK_0) : case_inverted);
2560 /* stack-layout: pack, nicknames, uselist, case-sensitive, case-inverted. */
2561 /* use default value for use-argument: */
2562 if (!boundp(STACK_2))
2563 STACK_2 = O(use_default);
2564 /* execute (USE-PACKAGE uselist newpackage) : */
2565 pushSTACK(STACK_2); /* uselist */
2566 pushSTACK(STACK_(4+1)); /* package */
2567 funcall(L(use_package),2);
2568 skipSTACK(4);
2569 VALUES1(popSTACK()); /* package as value */
2570 }
2571
2572 /* (MAKE-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]
2573 [:CASE-SENSITIVE sensitivep] [:CASE-INVERTED invertedp]),
2574 CLTL p. 183 */
2575 LISPFUN(make_package,seclass_default,1,0,norest,key,4,
2576 (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) {
2577 WITH_OS_MUTEX_LOCK(5,&all_packages_lock, {
2578 in_make_package(false);
2579 });
2580 }
2581
2582 /* (CS-COMMON-LISP:MAKE-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]
2583 [:CASE-SENSITIVE sensitivep] [:CASE-INVERTED invertedp]) */
2584 LISPFUN(cs_make_package,seclass_default,1,0,norest,key,4,
2585 (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) {
2586 WITH_OS_MUTEX_LOCK(5,&all_packages_lock, {
2587 in_make_package(true);
2588 });
2589 }
2590
2591 /* (SYSTEM::%IN-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]
2592 [:CASE-SENSITIVE sensitivep] [:CASE-INVERTED invertedp])
2593 is like (IN-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]), CLTL p. 183,
2594 except that *PACKAGE* is not modified. */
2595 LISPFUN(pin_package,seclass_default,1,0,norest,key,4,
2596 (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) {
2597 /* check name and turn into string: */
2598 STACK_4 = test_stringsymchar_arg(STACK_4,false);
2599 WITH_OS_MUTEX_LOCK(5,&all_packages_lock, {
2600 /* find package with this name: */
2601 var object temppack = find_package(STACK_4);
2602 if (nullp(temppack)) { /* package not found, must create a new one */
2603 in_make_package(false);
2604 } else { /* package found */
2605 STACK_4 = temppack; /* save pack */
2606 var gcv_object_t *pack_ = &STACK_4;
2607 WITH_LISP_MUTEX_LOCK(5,true,&ThePackage(*pack_)->pack_mutex, {
2608 /* stack-layout: pack, nicknames, uselist, case-sensitive, case-inverted. */
2609 if (boundp(STACK_1)) { /* check the case-sensitivity: */
2610 var bool value = !nullp(STACK_1);
2611 if (!!pack_casesensitivep(*pack_) != value) {
2612 pushSTACK(*pack_); pushSTACK(*pack_);
2613 STACK_1 = CLSTEXT("One should not change the case sensitiveness of ~S.");
2614 funcall(S(warn),2);
2615 }
2616 if (value) mark_pack_casesensitive(*pack_);
2617 else mark_pack_caseinsensitive(*pack_);
2618 }
2619 if (boundp(STACK_0)) { /* check the case-invertedness: */
2620 var bool value = !nullp(STACK_0);
2621 if (!!pack_caseinvertedp(*pack_) != value) {
2622 pushSTACK(*pack_); pushSTACK(*pack_);
2623 STACK_1 = CLSTEXT("One should not change the case inversion of ~S.");
2624 funcall(S(warn),2);
2625 }
2626 if (value) mark_pack_caseinverted(*pack_);
2627 else mark_pack_casepreserved(*pack_);
2628 }
2629 /* adjust the nicknames: */
2630 if (boundp(STACK_3)) {
2631 /* install nicknames with RENAME-PACKAGE: */
2632 pushSTACK(*pack_); /* pack */
2633 pushSTACK(ThePackage(*pack_)->pack_name); /* (package-name pack) */
2634 pushSTACK(STACK_(3+2)); /* nicknames */
2635 /* (RENAME-PACKAGE pack (package-name pack) nicknames) */
2636 funcall(L(rename_package),3);
2637 }
2638 /* adjust the use-list: */
2639 if (boundp(STACK_2)) {
2640 /* extend use-list with USE-PACKAGE
2641 and shorten with UNUSE-PACKAGE: */
2642 STACK_1 = STACK_2; /* use-list as 1. argument for USE-PACKAGE */
2643 STACK_0 = STACK_4; /* pack as 2. argument for USE-PACKAGE */
2644 prepare_use_package(); /* check arguments STACK_1, STACK_0 */
2645 /* stack-layout: pack, nicknames, -, new use-list, pack. */
2646 { /* execute USE-PACKAGE (with copied use-list): */
2647 var object temp = reverse(STACK_1);
2648 use_package(temp,STACK_4);
2649 }
2650 /* All packages, that are still listed in the use-list of pack,
2651 but which do not occur in the uselist located in STACK_1,
2652 are removed with unuse_1package: */
2653 { /* traverse use-list of pack */
2654 pushSTACK(NIL);
2655 var gcv_object_t *qpack_ = &STACK_0;
2656 STACK_1 = ThePackage(*pack_)->pack_use_list;
2657 while (mconsp(STACK_1)) {
2658 *qpack_ = Car(STACK_1);
2659 /* search in uselist: */
2660 if (nullp(memq(*qpack_,STACK_2))) {
2661 /* not found in uselist */
2662 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*qpack_)->pack_mutex, {
2663 unuse_1package(*pack_,*qpack_);
2664 });
2665 }
2666 STACK_1 = Cdr(STACK_1);
2667 }
2668 skipSTACK(1);
2669 }
2670 }
2671 /* the use-list is adjusted correctly. */
2672 skipSTACK(4); /* forget uselist, nicknames etc. */
2673 VALUES1(popSTACK());
2674 });
2675 }
2676 });
2677 }
2678
2679 local one_sym_function_t delete_package_aux;
2680 /* (DELETE-PACKAGE package), CLTL2 p. 265-266 */
2681 LISPFUNN(delete_package,1) {
2682 var object pack = popSTACK();
2683 if (packagep(pack)) {
2684 if (pack_deletedp(pack)) {
2685 VALUES1(NIL); return; /* already deleted -> 1 value NIL */
2686 }
2687 } else if (stringp(pack))
2688 string: { /* string -> find package with this name: */
2689 pushSTACK(pack);
2690 var object found = find_package(pack);
2691 pack = popSTACK();
2692 if (nullp(found)) {
2693 /* raise Continuable Error: */
2694 pushSTACK(NIL); /* "Ignore." */
2695 pushSTACK(S(package_error)); /* PACKAGE-ERROR */
2696 pushSTACK(S(Kpackage)); /* :PACKAGE */
2697 pushSTACK(pack); /* package-name */
2698 pushSTACK(NIL); /* "~S: A package with name ~S does not exist." */
2699 pushSTACK(S(delete_package));
2700 pushSTACK(pack);
2701 STACK_6 = CLSTEXT("Ignore.");
2702 STACK_2 = CLSTEXT("~S: There is no package with name ~S.");
2703 /* (SYS::CERROR-OF-TYPE "..." 'PACKAGE-ERROR :PACKAGE pack "..."
2704 'DELETE-PACKAGE pack) */
2705 funcall(L(cerror_of_type),7);
2706 VALUES1(NIL);
2707 return;
2708 }
2709 pack = found;
2710 } else if (symbolp(pack)) { /* symbol -> string */
2711 pack = Symbol_name(pack); goto string; /* use printname, no case-invert */
2712 } else if (charp(pack)) { /* character -> string */
2713 var object new_string = allocate_string(1);
2714 TheSnstring(new_string)->data[0] = char_code(pack);
2715 pack = new_string;
2716 goto string;
2717 } else
2718 pack = test_package_arg(pack); /* report error */
2719 pushSTACK(pack);
2720 if (!nullp(ThePackage(pack)->pack_used_by_list)) {
2721 /* raise Continuable Error: */
2722 pushSTACK(NIL); /* "~*Delete ~S anyway." */
2723 pushSTACK(S(package_error)); /* PACKAGE-ERROR */
2724 pushSTACK(S(Kpackage)); /* :PACKAGE */
2725 pushSTACK(pack); /* package */
2726 pushSTACK(NIL); /* "~S: ~S is used by ~{~S~^, ~}." */
2727 pushSTACK(S(delete_package));
2728 pushSTACK(pack);
2729 pushSTACK(ThePackage(pack)->pack_used_by_list);
2730 STACK_7 = CLSTEXT("~*Delete ~S anyway.");
2731 STACK_3 = CLSTEXT("~S: ~S is used by ~{~S~^, ~}.");
2732 /* (SYS::CERROR-OF-TYPE "..." 'PACKAGE-ERROR :PACKAGE pack "..."
2733 'DELETE-PACKAGE pack used-by-list) */
2734 funcall(L(cerror_of_type),8);
2735 }
2736 var gcv_object_t *pack_ = &STACK_0;
2737 WITH_OS_MUTEX_LOCK(0, &all_packages_lock, {
2738 WITH_LISP_MUTEX_LOCK(0,true,&ThePackage(*pack_)->pack_mutex,{
2739 /* in MT build package may have been deleted while we were wating */
2740 if (!pack_deletedp(*pack_)) {
2741 /* execute (DOLIST (p used-py-list) (UNUSE-PACKAGE pack p)) : */
2742 set_break_sem_3();
2743 pushSTACK(NIL);
2744 var gcv_object_t *qpack_ = &STACK_0;
2745 while (mconsp(ThePackage(*pack_)->pack_used_by_list)) {
2746 STACK_0 = Car(ThePackage(*pack_)->pack_used_by_list);
2747 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*qpack_)->pack_mutex,{
2748 unuse_1package(*qpack_,*pack_);
2749 });
2750 }
2751 skipSTACK(1);
2752 clr_break_sem_3();
2753 /* execute (UNUSE-PACKAGE (package-use-list pack) pack) : */
2754 unuse_package(ThePackage(*pack_)->pack_use_list,*pack_);
2755 /* apply delete_package_aux to the symbols present in pack: */
2756 map_symtab_c(&delete_package_aux,pack_,
2757 ThePackage(*pack_)->pack_external_symbols);
2758 map_symtab_c(&delete_package_aux,pack_,
2759 ThePackage(*pack_)->pack_internal_symbols);
2760 /* remove pack from the list of all packages and mark as deleted: */
2761 set_break_sem_2();
2762 O(all_packages) = deleteq(O(all_packages),*pack_);
2763 mark_pack_deleted(*pack_);
2764 clr_break_sem_2();
2765 VALUES1(T);
2766 } else
2767 VALUES1(NIL);
2768 });
2769 });
2770 skipSTACK(1);
2771 }
2772
2773 /* UP: Auxiliary function for DELETE-PACKAGE:
2774 Remove the argument (a present symbol) from pack.
2775 can trigger GC */
delete_package_aux(void * data,object sym)2776 local maygc void delete_package_aux (void* data, object sym) {
2777 var gcv_object_t* localptr = (gcv_object_t*)data; /* pointer to pack */
2778 pushSTACK(sym); unintern(&STACK_0,localptr);
2779 #if defined(MULTITHREAD)
2780 /* clear per thread symvalues if any.
2781 FIXME: The symvalue cell pointed from clisp_thread_t will remain
2782 as a memory leak !!! It is possible with exhaustive scan of all
2783 symbols to "compact" the threads symvalues cells. */
2784 clear_per_thread_symvalues(STACK_0);
2785 #endif
2786 skipSTACK(1);
2787 }
2788
2789 /* (FIND-ALL-SYMBOLS name) and its case-inverted variant */
do_find_all_symbols(bool invert)2790 local maygc Values do_find_all_symbols (bool invert) {
2791 STACK_0 = test_stringsymchar_arg(STACK_0,invert); /* name as string */
2792 pushSTACK(NIL); /* (so far empty) symbol-list */
2793 pushSTACK(O(all_packages)); /* traverse list of all packages */
2794 while (mconsp(STACK_0)) {
2795 var object pack = Car(STACK_0); /* next package */
2796 /* search in its internal and external symbols: */
2797 var object sym;
2798 if (package_lookup(STACK_2,invert,pack,&sym,)) {
2799 /* found: symbol sym is present in package pack,
2800 cons with (pushnew sym STACK_1 :test #'eq) on the symbol-list:
2801 Search, if the found symbol sym occurs in STACK_1: */
2802 if (nullp(memq(sym,STACK_1))) { /* not found, must cons: */
2803 pushSTACK(sym);
2804 {
2805 var object new_cons = allocate_cons();
2806 Car(new_cons) = popSTACK();
2807 Cdr(new_cons) = STACK_1;
2808 STACK_1 = new_cons;
2809 }
2810 }
2811 }
2812 STACK_0 = Cdr(STACK_0);
2813 }
2814 skipSTACK(1);
2815 VALUES1(popSTACK()); /* symbol-list as value */
2816 skipSTACK(1);
2817 }
2818
2819 /* (FIND-ALL-SYMBOLS name), CLTL p. 187 */
2820 LISPFUNNR(find_all_symbols,1)
2821 {
2822 WITH_OS_MUTEX_LOCK(1, &all_packages_lock,{
2823 do_find_all_symbols(false);
2824 });
2825 }
2826
2827 /* (CS-COMMON-LISP:FIND-ALL-SYMBOLS name) */
2828 LISPFUNNR(cs_find_all_symbols,1)
2829 {
2830 WITH_OS_MUTEX_LOCK(1, &all_packages_lock,{
2831 do_find_all_symbols(true);
2832 });
2833 }
2834
2835 local one_sym_function_t map_symbols_aux;
2836 /* (SYSTEM::MAP-SYMBOLS fun pack)
2837 applies the function fun to all accessible symbols in pack. Value NIL. */
2838 LISPFUNN(map_symbols,2) {
2839 /* check second argument: */
2840 STACK_0 = test_package_arg(STACK_0);
2841 /* apply fun to all internal symbols: */
2842 map_symtab(STACK_1,ThePackage(STACK_0)->pack_internal_symbols);
2843 /* apply fun to all external symbols: */
2844 map_symtab(STACK_1,ThePackage(STACK_0)->pack_external_symbols);
2845 /* apply fun to all inherited symbols: */
2846 pushSTACK(ThePackage(STACK_0)->pack_use_list); /* traverse use-list */
2847 while (mconsp(STACK_0)) {
2848 var object usedpack = Car(STACK_0); /* next package from the use-list */
2849 STACK_0 = Cdr(STACK_0);
2850 map_symtab_c(&map_symbols_aux,&STACK_1,
2851 ThePackage(usedpack)->pack_external_symbols);
2852 }
2853 skipSTACK(3);
2854 VALUES1(NIL);
2855 }
2856
2857 /* UP: Auxiliary function for map_symbols:
2858 Test, if the argument is not shadowed in the given package, and
2859 then apply the given function.
2860 can trigger GC */
map_symbols_aux(void * data,object sym)2861 local maygc void map_symbols_aux (void* data, object sym) {
2862 var gcv_object_t* localptr = (gcv_object_t*)data;
2863 /* Pointer to local variables of map_symbols:
2864 *(localptr STACKop 1) = fun,
2865 *(localptr STACKop 0) = pack.
2866 The symbol STACK_0 is shadowed, if and only if a different
2867 symbol of the same name is located in the
2868 shadowing-list of pack. */
2869 var object shadowingsym;
2870 if (!(shadowing_lookup(Symbol_name(sym),false,*(localptr STACKop 0),&shadowingsym)
2871 && !eq(shadowingsym,sym))) {
2872 pushSTACK(sym); funcall(*(localptr STACKop 1),1);
2873 } else {
2874 /* symbol is shadowed in pack -> do not call function */
2875 }
2876 }
2877
2878 /* (SYSTEM::MAP-EXTERNAL-SYMBOLS fun pack)
2879 applies the function fun to all external symbols in pack. Value NIL. */
2880 LISPFUNN(map_external_symbols,2) {
2881 /* check second argument: */
2882 var object pack = test_package_arg(popSTACK());
2883 /* apply fun to all external symbols: */
2884 map_symtab(popSTACK(),ThePackage(pack)->pack_external_symbols);
2885 VALUES1(NIL);
2886 }
2887
2888 /* (SYSTEM::MAP-ALL-SYMBOLS fun)
2889 applies the function fun to all symbols present in any package. */
2890 LISPFUNN(map_all_symbols,1)
2891 {
2892 #ifdef MULTITHREAD
2893 {
2894 pushSTACK(NIL);
2895 var gcv_object_t *ap_ = &STACK_0;
2896 WITH_OS_MUTEX_LOCK(0,&all_packages_lock, {
2897 *ap_ = copy_list(O(all_packages)); /* traverse copy of package-list */
2898 });
2899 }
2900 #else
2901 pushSTACK(O(all_packages)); /* traverse package-list */
2902 #endif
2903 while (mconsp(STACK_0)) {
2904 var object pack = Car(STACK_0); /* next package */
2905 STACK_0 = Cdr(STACK_0);
2906 pushSTACK(pack); /* save */
2907 /* apply fun to all internal symbols: */
2908 map_symtab(STACK_2,ThePackage(pack)->pack_internal_symbols);
2909 pack = popSTACK();
2910 /* apply fun to all external symbols: */
2911 map_symtab(STACK_1,ThePackage(pack)->pack_external_symbols);
2912 }
2913 skipSTACK(2);
2914 VALUES1(NIL);
2915 }
2916
2917 /* UP: Subroutine for EXT:RE-EXPORT.
2918 Exports a single symbol from TO-PACK. */
export_symbol_from(void * data,object sym)2919 local void export_symbol_from (void *data, object sym) {
2920 var gcv_object_t* pack_ = (gcv_object_t*)data; /* points into the STACK */
2921 pushSTACK(sym);
2922 export(&STACK_0,pack_);
2923 skipSTACK(1);
2924 }
2925
2926 /* (EXT:RE-EXPORT "FROM-PACK" "TO-PACK")
2927 export all external symbols in FROM-PACK from TO-PACK */
2928 LISPFUNN(re_export,2) {
2929 STACK_1 = test_package_arg(STACK_1); /* FROM-PACK */
2930 STACK_0 = test_package_arg(STACK_0); /* TO-PACK */
2931 /* TO-PACK must be already using FROM-PACK */
2932 var object pack_u_l = ThePackage(STACK_0)->pack_use_list;
2933 if (nullp(memq(STACK_1,ThePackage(STACK_0)->pack_use_list))) {
2934 pushSTACK(STACK_0); /* TO-PACK: PACKAGE slot of PACKAGE-ERROR */
2935 pushSTACK(STACK_2); /* FROM-PACK */
2936 pushSTACK(STACK_1); /* TO-PACK */
2937 pushSTACK(S(re_export));
2938 error(package_error,GETTEXT("~S: ~S is not using ~S"));
2939 }
2940 var gcv_object_t *from_pack_ = &STACK_1;
2941 var gcv_object_t *to_pack_ = &STACK_0;
2942 WITH_LISP_MUTEX_LOCK(0,false,&ThePackage(*to_pack_)->pack_mutex, {
2943 map_symtab_c(&export_symbol_from,to_pack_,
2944 ThePackage(*from_pack_)->pack_external_symbols);
2945 });
2946 VALUES1(NIL);
2947 skipSTACK(2);
2948 }
2949
2950 /* Auxiliary functions for WITH-PACKAGE-ITERATOR, CLtL2 p. 275, and LOOP:
2951 (SYSTEM::PACKAGE-ITERATOR package flags) returns an internal state
2952 for iterating through the package.
2953 (SYSTEM::PACKAGE-ITERATE internal-state) iterates through a package by
2954 one, thereby changes the internal-state and returns: three values
2955 T, symbol, accessibility of the next symbols resp. 1 value NIL at the end.
2956 PIS = Package Iterator State */
2957 #define PIS_SIZE 6
2958 #define PIS_ENTRY 0
2959 #define PIS_INDEX 1
2960 #define PIS_SYMTAB 2
2961 #define PIS_INHPKG 3
2962 #define PIS_PACK 4
2963 #define PIS_FLAGS 5
2964 #define PIS(state,field) TheSvector(state)->data[PIS_##field]
2965
2966 LISPFUNN(package_iterator,2) {
2967 STACK_1 = test_package_arg(STACK_1); /* check package-argument */
2968 /* An internal state consists of a vector
2969 #(entry index symtab inh-packages package flags locked)
2970 locked is the currently MT-locked package
2971 flags is a sub-list of (:INTERNAL :EXTERNAL :INHERITED) ,
2972 package is the original package,
2973 inh-packages is a sub-list of (package-use-list package) ,
2974 symtab is a symbol-table or NIL,
2975 index is an Index in symtab,
2976 entry is the rest of an entry in symtab. */
2977 var object state = allocate_vector(PIS_SIZE);
2978 /* PIS(state,SYMTAB) = NIL; */ /* invalid */
2979 PIS(state,INHPKG) = ThePackage(STACK_1)->pack_use_list;
2980 PIS(state,PACK) = STACK_1;
2981 PIS(state,FLAGS) = STACK_0;
2982 VALUES1(state); skipSTACK(2); /* state as value */
2983 }
2984
2985 LISPFUNN(package_iterate,1) {
2986 var object state = STACK_0; /* internal state */
2987 /* hopefully a PIS-vector */
2988 if (simple_vector_p(state) && (Svector_length(state) == PIS_SIZE)) {
2989 /* state = #(entry index symtab inh-packages package flags) */
2990 var object symtab = PIS(state,SYMTAB);
2991 if (simple_vector_p(symtab)) {
2992 if (false) {
2993 search1:
2994 PIS(state,SYMTAB) = symtab;
2995 PIS(state,INDEX) = Symtab_size(PIS(state,SYMTAB));
2996 PIS(state,ENTRY) = NIL;
2997 }
2998 search2: {
2999 var object entry = PIS(state,ENTRY);
3000 search3: /* continue search within entry: */
3001 if (consp(entry)) {
3002 PIS(state,ENTRY) = Cdr(entry);
3003 value2 = Car(entry); goto found;
3004 } else if (!nullp(entry)) {
3005 PIS(state,ENTRY) = NIL;
3006 value2 = entry; goto found;
3007 }
3008 if (false) {
3009 found:
3010 /* Found a symbol value.
3011 Verify that is it accessible in pack and, if :INHERITED
3012 is requested,
3013 1. not hidden by a different symbol (which must be on the
3014 shadowing-list of pack),
3015 2. itself not already present in pack (because in this case
3016 the accessibility would be :INTERNAL or :EXTERNAL). */
3017 if (!(eq(Car(PIS(state,FLAGS)),S(Kinherited))
3018 && (shadowing_lookup(Symbol_name(value2),false,
3019 PIS(state,PACK),NULL)
3020 || symtab_find(value2,
3021 ThePackage(PIS(state,PACK))->
3022 pack_internal_symbols)
3023 || symtab_find(value2,
3024 ThePackage(PIS(state,PACK))->
3025 pack_external_symbols)))) {
3026 /* Symbol value2 is really accessible. */
3027 value1 = T; value3 = Car(PIS(state,FLAGS));
3028 mv_count=3; skipSTACK(1); return;
3029 }
3030 goto search2;
3031 }
3032 { /* entry became =NIL -> go to next Index */
3033 var uintL index = posfixnum_to_V(PIS(state,INDEX));
3034 if (index > 0) {
3035 PIS(state,INDEX) = fixnum_inc(PIS(state,INDEX),-1);
3036 index--;
3037 /* check index as a precaution */
3038 entry = (index < (uintL)posfixnum_to_V(Symtab_size(symtab))
3039 ? (object)TheSvector(Symtab_table(symtab))->data[index]
3040 : NIL);
3041 goto search3;
3042 }
3043 }
3044 }
3045 /* index became =0 -> go to next table */
3046 if (eq(Car(PIS(state,FLAGS)),S(Kinherited))) {
3047 search4:
3048 if (mconsp(PIS(state,INHPKG))) {
3049 /* go to next element of the list inh-packages */
3050 symtab = ThePackage(Car(PIS(state,INHPKG)))->pack_external_symbols;
3051 PIS(state,INHPKG) = Cdr(PIS(state,INHPKG));
3052 goto search1;
3053 }
3054 }
3055 search5: /* go to next element of flags */
3056 PIS(state,FLAGS) = Cdr(PIS(state,FLAGS));
3057 }
3058 var object flags = PIS(state,FLAGS);
3059 if (consp(flags)) {
3060 var object flag = Car(flags);
3061 if (eq(flag,S(Kinternal))) { /* :INTERNAL */
3062 symtab = ThePackage(PIS(state,PACK))->pack_internal_symbols;
3063 goto search1;
3064 } else if (eq(flag,S(Kexternal))) { /* :EXTERNAL */
3065 symtab = ThePackage(PIS(state,PACK))->pack_external_symbols;
3066 goto search1;
3067 }
3068 else if (eq(flag,S(Kinherited))) /* :INHERITED */
3069 goto search4;
3070 goto search5; /* skip invalid flag */
3071 }
3072 }
3073 VALUES1(NIL); skipSTACK(1);
3074 }
3075
3076 /* UP: initialize the package list
3077 init_packages();
3078 can trigger GC */
init_packages(void)3079 global maygc void init_packages (void) {
3080 O(all_packages) = NIL; /* ALL_PACKAGES := NIL */
3081 { /* #<PACKAGE CS-COMMON-LISP-USER>: */
3082 pushSTACK(coerce_imm_ss(ascii_to_string("CS-COMMON-LISP-USER")));
3083 pushSTACK(coerce_imm_ss(ascii_to_string("CS-CL-USER")));
3084 /* Provide nickname "CS-USER" for similarity with package "COMMON-LISP-USER". */
3085 pushSTACK(coerce_imm_ss(ascii_to_string("CS-USER")));
3086 var object nicks = listof(2); /* ("CS-CL-USER" "CS-USER") */
3087 O(modern_user_package) = make_package(popSTACK(),nicks,true,true); /* "CS-COMMON-LISP-USER" */
3088 }
3089 { /* #<PACKAGE CS-COMMON-LISP>: */
3090 pushSTACK(coerce_imm_ss(ascii_to_string("CS-COMMON-LISP")));
3091 pushSTACK(coerce_imm_ss(ascii_to_string("CS-CL")));
3092 /* Provide nickname "CS-LISP" for similarity with package "COMMON-LISP". */
3093 pushSTACK(coerce_imm_ss(ascii_to_string("CS-LISP")));
3094 var object nicks = listof(2); /* ("CS-CL" "CS-LISP") */
3095 make_package(popSTACK(),nicks,true,true); /* "CS-COMMON-LISP" */
3096 }
3097 /* #<PACKAGE CHARSET>: */
3098 pushSTACK(coerce_imm_ss(ascii_to_string("CHARSET")));
3099 O(charset_package) = make_package(popSTACK(),NIL,false,false); /* "CHARSET",() */
3100 /* #<PACKAGE KEYWORD>: */
3101 pushSTACK(coerce_imm_ss(ascii_to_string("KEYWORD")));
3102 O(keyword_package) = make_package(popSTACK(),NIL,false,false); /* "KEYWORD" */
3103 { /* #<PACKAGE SYSTEM>: */
3104 pushSTACK(coerce_imm_ss(ascii_to_string("SYSTEM")));
3105 pushSTACK(coerce_imm_ss(ascii_to_string("SYS")));
3106 var object nicks = listof(1); /* ("SYS") */
3107 make_package(popSTACK(),nicks,false,false); /* "SYSTEM" */
3108 }
3109 { /* #<PACKAGE COMMON-LISP-USER>: */
3110 pushSTACK(coerce_imm_ss(ascii_to_string("COMMON-LISP-USER")));
3111 pushSTACK(coerce_imm_ss(ascii_to_string("CL-USER")));
3112 pushSTACK(coerce_imm_ss(ascii_to_string("USER")));
3113 var object nicks = listof(2); /* ("CL-USER" "USER") */
3114 make_package(popSTACK(),nicks,false,false); /* "COMMON-LISP-USER" */
3115 }
3116 { /* #<PACKAGE COMMON-LISP>: */
3117 pushSTACK(coerce_imm_ss(ascii_to_string("COMMON-LISP")));
3118 pushSTACK(coerce_imm_ss(ascii_to_string("LISP")));
3119 pushSTACK(coerce_imm_ss(ascii_to_string("CL")));
3120 var object nicks = listof(2); /* ("LISP" "CL") */
3121 O(default_package) = make_package(popSTACK(),nicks,false,false); /* "COMMON-LISP" */
3122 }
3123 /* Created all basic packages.
3124 Now append all further packages to the end of O(all_packages). */
3125 nreverse(O(all_packages));
3126 #define LISPPACK LISPPACK_B
3127 #include "constpack.c"
3128 #undef LISPPACK
3129 nreverse(O(all_packages));
3130 }
3131