/src/package.d

/*
 * Package Management for CLISP
 * Bruno Haible 1990-2005
 * Sam Steingold 1999-2008
 * German comments translated into English: Stefan Kain 2002-02-20
 */

#include "lispbibl.c"
#include "arilev0.c" /* for hashcode calculation */

/* data structure of the symbols: see LISPBIBL.D
 data structure of the symbol table:
 a vector with 3 Slots:
   size    Fixnum >0, <2^24, = length of the table
   table   vector of length size,
             contains single symbols (/= NIL) and symbol-lists
   count   number of symbols in the table, Fixnum >=0 */
#define Symtab_size(symtab)  (TheSvector(symtab)->data[0])
#define Symtab_table(symtab)  (TheSvector(symtab)->data[1])
#define Symtab_count(symtab)  (TheSvector(symtab)->data[2])
/* consistency rule: for each string there is in the table
   at most one symbol with this printname. */

/* UP: Creates a new empty symbol-table.
 make_symtab(size)
 > size: the desired size of the table (odd number, >0, <2^24)
 < result: new symbol-table of this size
 can trigger GC */
local maygc object make_symtab (uintL size) {
  var object table = allocate_vector(size); /* vector with size NIL-entries */
  pushSTACK(table);
  var object symtab = allocate_vector(3); /* vector of length 3 */
  Symtab_table(symtab) = popSTACK(); /* insert table */
  Symtab_size(symtab) = fixnum(size); /* insert size */
  Symtab_count(symtab) = Fixnum_0; /* insert count := 0 */
  return symtab;
}

/* UP: Calculates the hashcode of a string. This is a 24-bit-number.
 string_hashcode(string,invert)
 > string: a string
 > invert: whether to implicitly case-invert the string
 < result: the hashcode of the string */
local uint32 string_hashcode (object string, bool invert) {
  var uintL len;
  var uintL offset;
  string = unpack_string_ro(string,&len,&offset);
  var uint32 hashcode = 0; /* hashcode, only the lower 24 Bit count */
  if (len > 0) {
    SstringDispatch(string,X, {
      var const cintX* charptr = &((SstringX)TheVarobject(string))->data[offset];
      /* there are len characters, starting at charptr */
      /* Look at all len characters, not just at the first min(len,16)
         characters, as we did earlier, because a bad hash function quasi
         turns the hash table into a few long linear lists. */
      var uintC count;
      dotimesC(count, len, {
        /* rotate hashcode by 5 bits to the left: */
        hashcode = hashcode << 5; hashcode = hashcode + (hashcode >> 24);
        /* 'add' next byte via XOR: */
        var cintX c = *charptr++;
        hashcode = hashcode ^ (uint32)(invert ? as_cint(invert_case(as_chart(c))) : c);
      });
    });
  }
  return hashcode & 0x00FFFFFF;
}

/* UP: Reorganizes a symbol-table, after it has grown, and
 tries to save Conses.
 rehash_symtab(symtab)
 > symtab: symbol-table
 < result: reorganized symbol-table (EQ to the first).
 call only, if BREAK_SEM_2 is set
 can trigger GC */
local maygc object rehash_symtab (object symtab);

/* auxiliary functions: */

/* takes a Cons from free-conses or returns a fresh one.
 new_cons()
 < result: new Cons.
 stack layout: free-conses, newtable, listr, symbol, entry.
 can trigger GC */
local maygc object new_cons (void) {
  var object free = STACK_4; /* free-conses */
  if (!nullp(free)) {
    STACK_4 = Cdr(free); /* shorten free-conses */
    return free;
  } else {
    return allocate_cons(); /* request new Cons from memory-management */
  }
}

/* inserts an additional symbol into the new table.
 newinsert(sym,size);
 > sym: symbol
 stack layout: tab, oldtable, free-conses, newtable, listr.
 can trigger GC */
local maygc void newinsert (object sym, uintL size) {
  var uintL index = /* Index = Hashcode mod size */
    string_hashcode(Symbol_name(sym),false) % size;
  /* entry in the newtable */
  var object entry = TheSvector(STACK_1)->data[index];
  if ((!nullp(entry)) || nullp(sym)) {
    /* if entry=NIL and sym/=NIL, then simply enter sym.
       else, entry must be extended by cons-ing: */
    pushSTACK(sym); /* save symbol */
    pushSTACK(entry); /* save entry */
    if (!listp(entry)) {
      /* if entry is not a list, replace with (new-cons entry NIL): */
      var object new_entry = new_cons();
      Cdr(new_entry) = NIL; Car(new_entry) = STACK_0;
      STACK_0 = new_entry;
    }
    /* and cons symbol in front of it: */
    var object new_entry = new_cons();
    Cdr(new_entry) = popSTACK(); /* enter entry resp. list as CDR */
    Car(new_entry) = popSTACK(); /* enter symbol as CAR */
    sym = new_entry; /* and then enter new_entry */
  }
  TheSvector(STACK_1)->data[index] = sym; /* enter new entry in newtable */
}

local object rehash_symtab (object symtab) {
  pushSTACK(symtab); /* save symbol-table */
  var uintL oldsize = posfixnum_to_V(Symtab_size(symtab)); /* old size */
  var uintL newsize; /* new size */
  var object size; /* new size (as Fixnum) */
  pushSTACK(Symtab_table(symtab)); /* oldtable = old table-vector */
  pushSTACK(NIL); /* free-conses := NIL */
 #ifdef TYPECODES /* Svector_length is limited to max. 2^32-1 */
  /* new size = min(floor(oldsize*1.6),2^32-1) */
  { /* multiply oldsize (>0, <2^32) with 1.6*2^31, then divide by 2^31 : */
    var uint32 prod_hi;
    var uint32 prod_lo;
    mulu32(oldsize,3435973888UL, prod_hi=,prod_lo=);
    newsize =
      (prod_hi < (1UL<<31) ? (prod_hi << 1) | (prod_lo >> 31) : (1UL<<31)-1 );
  }
 #else /* Svector_length is limited to max. 2^24-1 */
  /* new size = min(floor(oldsize*1.6),2^24-1) */
  { /* multiply oldsize (>0, <2^24) with 1.6*2^7, then divide by 2^7 : */
    var uint32 prod = oldsize * 205UL;
    newsize = (prod < (1UL<<31) ? prod>>7 : (1UL<<24)-1 );
  } /* newsize is now >= oldsize > 0 and < 2^24 */
 #endif
  /* make newsize odd by rounding off: */
  newsize = (newsize - 1) | 1 ;
  /* calculate size: */
  size = fixnum(newsize);
  /* if newsize <= oldsize , the table does not need to be enlarged: */
  if (newsize <= oldsize) {
    skipSTACK(3);
    return symtab;
  }
  { /* new vector with size NILs */
    var object newtable = allocate_vector(newsize);
    pushSTACK(newtable); /* save */
  }
  /* here we could protect against breaks.
     stack layout: tab, oldtable, free-conses, newtable.
     transfer symbols from oldtable to newtable:
     first process the symbols, that sit in lists
     (maybe Conses become free): */
  {
    var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
    var uintC count;
    dotimespC(count,oldsize, {
      var object oldentry = /* entry with number index in oldtable */
        *(gcv_object_t*)(pointerplus(&TheSvector(STACK_2)->data[0],
                                     (aint)offset));
      if (consp(oldentry)) /* this time process only non-empty symbol-lists */
        do {
          pushSTACK(Cdr(oldentry)); /* save rest-list */
          /* cons oldentry in front of free-conses */
          Cdr(oldentry) = STACK_2; STACK_2 = oldentry;
          /* enter symbol in the new table */
          newinsert(Car(oldentry),newsize);
          oldentry = popSTACK(); /* rest-list */
        } while (consp(oldentry));
      offset++;
    });
  }
  { /* then process symbols, that sit there collision-free: */
    var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
    var uintC count;
    dotimespC(count,oldsize, {
      var object oldentry = /* entry with number index in oldtable */
        *(gcv_object_t*)(pointerplus(&TheSvector(STACK_2)->data[0],
                                     (aint)offset));
      if (!listp(oldentry)) { /* this time process only symbols /= NIL */
        pushSTACK(oldentry); /* dummy, so that the stack is fine */
        newinsert(oldentry,newsize); /* enter into the new table */
        skipSTACK(1);
      }
      offset++;
    });
  }
  /* stack layout: tab, oldtable, free-conses, newtable. */
  { /* update tab: */
    var object newtable = popSTACK(); /* newtable */
    skipSTACK(2);
    symtab = popSTACK(); /* tab */
    Symtab_size(symtab) = size;
    Symtab_table(symtab) = newtable;
  }
  /* here, breaks could be allowed again. */
  return symtab;
}

/* UP: Searches a symbol with given print-name in the symbol-table.
 symtab_lookup(string,invert,symtab,&sym)
 > string: string
 > invert: whether to implicitly case-invert the string
 > symtab: symbol-table
 < result: true if found, false if not found.
 if found:
   < sym: the symbol from the symbol-table, that has the given printname */
local bool symtab_lookup (object string, bool invert, object symtab, object* sym_) {
  var uintL index = /* Index = Hashcode mod size */
    string_hashcode(string,invert) % (uintL)posfixnum_to_V(Symtab_size(symtab));
  /* entry in the table */
  var object entry = TheSvector(Symtab_table(symtab))->data[index];
  if (!listp(entry)) { /* entry is a single symbol */
    /* first string and printname of the found symbol are equal ? */
    if ((invert ? string_eq_inverted : string_eq)
        (string,Symbol_name(entry))) {
      if (sym_) { *sym_ = entry; }
      return true;
    } else {
      return false;
    }
  } else { /* entry is a symbol-list */
    while (consp(entry)) {
      /* first string and printname of the symbol are equal ? */
      if ((invert ? string_eq_inverted : string_eq)
          (string,Symbol_name(Car(entry))))
        goto found;
      entry = Cdr(entry);
    }
    return false; /* not found */
  found: /* found as CAR of entry */
    if (sym_) { *sym_ = Car(entry); }
    return true;
  }
}

/* UP: Searches a given symbol in the symbol-table.
 symtab_find(sym,symtab)
 > sym: symbol
 > symtab: symbol-table
 < result: true, if found */
local bool symtab_find (object sym, object symtab) {
  var uintL index = /* Index = Hashcode mod size */
    string_hashcode(Symbol_name(sym),false) % (uintL)posfixnum_to_V(Symtab_size(symtab));
  /* entry in the table */
  var object entry = TheSvector(Symtab_table(symtab))->data[index];
  if (!listp(entry)) { /* entry is a single symbol */
    /* sym and found symbol are equal ? */
    if (eq(sym,entry))
      return true;
    else
      return false;
  } else { /* entry is a symbol-list */
    if (nullp(memq(sym,entry))) return false; /* not found */
    else return true; /* found as CAR from entry */
  }
}

/* UP: Inserts a given symbol into the symbol-table (destructively).
 symtab_insert(sym,symtab)
 > sym: symbol
 > symtab: symbol-table
 < result: new symbol-table, EQ to the old one
 call only, if BREAK_SEM_2 is set
 can trigger GC */
local maygc object symtab_insert (object sym, object symtab) {
  { /* first test if reorganization is necessary: */
    var uintL size = posfixnum_to_V(Symtab_size(symtab));
    var uintL count = posfixnum_to_V(Symtab_count(symtab));
    /* if count>=2*size , the table must be reorganized: */
    if (count >= 2*size) {
      pushSTACK(sym); /* save symbol */
      symtab = rehash_symtab(symtab);
      sym = popSTACK();
    }
  }
  /* then insert the symbol: */
  var uintL index = /* Index = Hashcode mod size */
    string_hashcode(Symbol_name(sym),false) % (uintL)posfixnum_to_V(Symtab_size(symtab));
  /* entry in the table */
  var object entry = TheSvector(Symtab_table(symtab))->data[index];
  if (!nullp(entry) || nullp(sym)) {
    /* if entry=NIL and sym/=NIL, then simply enter sym.
       else, entry must be extended by cons-ing: */
    pushSTACK(symtab); /* save symtab */
    pushSTACK(sym); /* save Symbol */
    pushSTACK(entry); /* save entry */
    if (!listp(entry)) {
      /* if entry is not a list, replace with (cons entry NIL): */
      var object new_entry = allocate_cons();
      Car(new_entry) = STACK_0;
      STACK_0 = new_entry;
    }
    { /* and cons symbol in front of it: */
      var object new_entry = allocate_cons();
      Cdr(new_entry) = popSTACK(); /* enter entry resp. list as CDR */
      Car(new_entry) = popSTACK(); /* enter symbol as CAR */
      sym = new_entry; /* and then enter new_entry */
    }
    symtab = popSTACK();
  }
  TheSvector(Symtab_table(symtab))->data[index] = sym; /* enter new entry */
  Symtab_count(symtab) = fixnum_inc(Symtab_count(symtab),1); /* (incf count) */
  return symtab;
}

/* UP: Removes a symbol from a symbol-table.
 symtab_delete(sym,symtab)
 > sym: symbol
 > symtab: symboltable */
local void symtab_delete (object sym, object symtab) {
  var uintL index = /* Index = Hashcode mod size */
    string_hashcode(Symbol_name(sym),false) % (uintL)posfixnum_to_V(Symtab_size(symtab));
  var gcv_object_t* entryptr = &TheSvector(Symtab_table(symtab))->data[index];
  var object entry = *entryptr; /* entry in the table */
  if (!listp(entry)) { /* entry is a single symbol */
    /* sym and found symbol eq ? */
    if (!eq(sym,entry))
      goto notfound;
    /* replace entry with NIL: */
    *entryptr = NIL;
  } else { /* entry is a symbol-list */
    while (consp(entry)) {
      /* sym and symbol from entry eq ? */
      if (eq(sym,Car(entry)))
        goto found;
      entryptr = &Cdr(entry); entry = *entryptr;
    }
    goto notfound; /* not found */
  found: /* found as CAR of *entryptr = entry */
    /* -> discard a list-element: */
    *entryptr = Cdr(entry); /* replace entry with Cdr(entry) */
  }
  /* finally decrement the symbol-counter by 1: (decf count) */
  { Symtab_count(symtab) = fixnum_inc(Symtab_count(symtab),-1); }
  return;
 notfound:
  pushSTACK(unbound); /* PACKAGE-ERROR slot PACKAGE */
  pushSTACK(sym);
  error(package_error,
         GETTEXT("symbol ~S cannot be deleted from symbol table"));
}

/* lookup the STRING among the EXTernal (resp. INTernal) symbols of PACK */
#define package_lookup_ext(string,invert,pack,res_)                         \
  symtab_lookup(string,invert,ThePackage(pack)->pack_external_symbols,res_)
#define package_lookup_int(string,invert,pack,res_)                         \
  symtab_lookup(string,invert,ThePackage(pack)->pack_internal_symbols,res_)

/* Test whether there is an inherited symbol with the given name.
 inherited_lookup(string,invert,pack,&sym)
 Return true if string is found in (package-use-list pack).
 > string: a Lisp string object
 > invert: whether to implicitly case-invert the string
 > pack: is a Lisp package object
 The symbol found is returned in *SYM_ (if SYM_ is not NULL). */
local bool inherited_lookup (object string, bool invert, object pack, object* sym_) {
  var object packlistr = ThePackage(pack)->pack_use_list;
  while (consp(packlistr)) {
    var object usedpack = Car(packlistr);
    if (package_lookup_ext(string,invert,usedpack,sym_))
      return true;
    packlistr = Cdr(packlistr);
  }
  return false;
}

/* Check whether the symbol is inherited by the package.
 inherited_find(symbol,pack)
 SYMBOL is a Lisp symbol object
 PACK is a Lisp package object */
local bool inherited_find (object symbol, object pack) {
  var object list = ThePackage(pack)->pack_use_list;
  while (consp(list)) {
    if (symtab_find(symbol,ThePackage(Car(list))->pack_external_symbols))
      return true;
    list = Cdr(list);
  }
  return false;
}

/* data structure of package, see LISPBIBL.D.
 Components:
 pack_external_symbols   symbol-table of the externally present symbols
 pack_internal_symbols   symbol-table of the internally present symbols
 pack_shadowing_symbols  list of the shadowing-symbols
 pack_use_list           use-list, a list of packages
 pack_used_by_list       used-by-list, a list of packages
 pack_name               the name, an immutable simple-string
 pack_nicknames          the nicknames, a list of immutable simple-strings
 pack_docstring          the documentation string or NIL

 consistency rules:
 1. All packages are listed in ALL_PACKAGES exactly once.
 2. The union over ALL_PACKAGES of { name } U nicknames is disjoint.
 3. for any two packages p,q:
    p in use_list(q) <==> q in used_by_list(q)
 4. p is a Package.
    accessible(p) = ISymbols(p) U ESymbols(p) U
                    U { ESymbols(q) | q in use_list(p) }
 5. For each Package p
    shadowing_symbols(p) is a subset of ISymbols(p) U ESymbols(p)
    and therefore also      a subset of accessible(p).
 6. s is a string, p is a package.
    If more than one element of accessible(p) has print name = s, then
    exactly one of these symbols is in shadowing_symbols(p).
 7. s is a string, p is a package.
    At most one symbol with the print name = s
    is in ISymbols(p) U ESymbols(p).
 8. If s is a symbol with the Home Package p /= NIL,
    then s is in ISymbols(p) U ESymbols(p). */

/* UP: make sure pack_shortest_name is indeed the shortest */
local void ensure_pack_shortest_name (object pack) {
  var object shortest_name = ThePackage(pack)->pack_name;
  var uintL shortest_len = Sstring_length(shortest_name);
  var object nick_list = ThePackage(pack)->pack_nicknames;
  while (consp(nick_list)) {
    var object nick = Car(nick_list); nick_list = Cdr(nick_list);
    var uintL nick_len = Sstring_length(nick);
    if (nick_len < shortest_len) {
      shortest_len = nick_len;
      shortest_name = nick;
    }
  }
  ThePackage(pack)->pack_shortest_name = shortest_name;
}

/* UP: Creates a new package, without testing for name-conflicts.
 make_package(name,nicknames,case_sensitive_p)
 > name: name (an immutable simple-string)
 > nicknames: nicknames (a list of immutable simple-strings)
 > case_sensitive_p: flag, if case-sensitive
 > case_inverted_p: flag, if case-inverted
 < result: new package
 can trigger GC */
local maygc object make_package (object name, object nicknames,
                                 bool case_sensitive_p, bool case_inverted_p) {
  set_break_sem_2();
  pushSTACK(nicknames); pushSTACK(name); /* save nicknames and names */
  /* create table for external symbols: */
  { var object symtab = make_symtab(11); pushSTACK(symtab); }
  /* create table for internal symbols: */
  { var object symtab = make_symtab(63); pushSTACK(symtab); }
  /* create new package: */
  var object pack = allocate_package();
  /* and fill: */
  if (case_sensitive_p) { mark_pack_casesensitive(pack); }
  if (case_inverted_p) { mark_pack_caseinverted(pack); }
  ThePackage(pack)->pack_internal_symbols = popSTACK();
  ThePackage(pack)->pack_external_symbols = popSTACK();
  ThePackage(pack)->pack_shadowing_symbols = NIL;
  ThePackage(pack)->pack_use_list = NIL;
  ThePackage(pack)->pack_used_by_list = NIL;
  ThePackage(pack)->pack_name = popSTACK();
  ThePackage(pack)->pack_nicknames = popSTACK();
  ThePackage(pack)->pack_docstring = NIL;
  ensure_pack_shortest_name(pack);
  /* and insert in ALL_PACKAGES: */
  pushSTACK(pack);
  var object new_cons = allocate_cons();
  pack = popSTACK();
  Car(new_cons) = pack; Cdr(new_cons) = O(all_packages);
  O(all_packages) = new_cons;
  /* finished: */
  clr_break_sem_2();
  return pack;
}

/* UP: Searches a symbol of given printname in the shadowing-list
 of a package.
 shadowing_lookup(string,invert,pack,&sym)
 > string: string
 > invert: whether to implicitly case-invert the string
 > pack: package
 < result: true, if found.
 < sym: the symbol from the shadowing-list, that has the given printname
        (if found) */
local bool shadowing_lookup (object string, bool invert, object pack, object* sym_) {
  var object list = ThePackage(pack)->pack_shadowing_symbols;
  /* traverse shadowing-list: */
  while (consp(list)) {
    if ((invert ? string_eq_inverted : string_eq)
        (string,Symbol_name(Car(list))))
      goto found;
    list = Cdr(list);
  }
  return false; /* not found */
 found: /* found */
  if (sym_) { *sym_ = Car(list); }
  return true;
}

/* UP: Searches a given symbol in the shadowing-list of a package.
 shadowing_find(sym,pack)
 > sym: symbol
 > pack: package
 < result: true if found. */
#define shadowing_find(s,p) (!nullp(memq(s,ThePackage(p)->pack_shadowing_symbols)))

/* UP: Adds a symbol to the shadowing-list of a package, that does not yet
 contain a symbol of the same name.
 shadowing_insert(&sym,&pack)
 > sym: symbol (in STACK)
 > pack: package (in STACK)
 < sym: symbol, EQ to the old one
 < pack: package, EQ to the old one
 can trigger GC */
local maygc void shadowing_insert (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  /* insert a new cons with symbol as CAR in front of the shadowing-symbols: */
  var object new_cons = allocate_cons();
  var object pack = *pack_;
  Car(new_cons) = *sym_;
  Cdr(new_cons) = ThePackage(pack)->pack_shadowing_symbols;
  ThePackage(pack)->pack_shadowing_symbols = new_cons;
}

/* UP: Removes a symbol of given name from the shadowing-list
 of a package.
 shadowing_delete(string,invert,pack)
 > string: string
 > invert: whether to implicitly case-invert the string
 > pack: package */
local void shadowing_delete (object string, bool invert, object pack) {
  var gcv_object_t* listptr = &ThePackage(pack)->pack_shadowing_symbols;
  var object list = *listptr;
  /* list = *listptr traverses the shadowing-list */
  while (consp(list)) {
    if ((invert ? string_eq_inverted : string_eq)
        (string,Symbol_name(Car(list))))
      goto found;
    listptr = &Cdr(list); list = *listptr;
  }
  /* no symbol with this name found, done. */
  return;
 found:
  /* equality: remove. After that we are done, because there can be only
     one symbol of the same printname in the shadowing-list. */
  *listptr = Cdr(list); /* replace list with Cdr(list) */
  return;
}

/* UP: Tests, if a symbol in a package is accessible and is not
 shadowed by another symbol of the same name.
 accessiblep(sym,pack)
 > sym: symbol
 > pack: package
 < result: true if sym is accessible in pack and is not shadowed,
             else false */
global bool accessiblep (object sym, object pack) {
  /* method:
     First, search a symbol of equal name in the shadowing-list;
     if not found, search the symbol among the present ones and
     then among the inherited symbols.
     Other possible method (not realized here):
     If the home-package of sym is equal to pack, sym is present in pack,
     done. Else search a present symbol of equal name.
     sym found -> finished.
     Found another one -> sym is not in the shadowing-list and
     thus not visible.
     none found -> search sym among the inherited symbols. */
  var object shadowingsym;
  /* First, search in the shadowing-list of pack: */
  if (shadowing_lookup(Symbol_name(sym),false,pack,&shadowingsym)) {
    /* shadowingsym = symbol, found in the shadowing-list */
    return (eq(shadowingsym,sym)); /* compare with sym */
  } else { /* no symbol of equal name in the shadowing-list */
    /* Search among the internal symbols: */
    if (symtab_find(sym,ThePackage(pack)->pack_internal_symbols))
      return true;
    /* Search among the external symbols: */
    if (symtab_find(sym,ThePackage(pack)->pack_external_symbols))
      return true;
    /* Search among the external symbols of the packages from the use-list: */
    if (inherited_find(sym,pack))
      return true;
    return false;
  }
}

/* UP: tests, if a symbol is accessible in a package as
 external symbol.
 externalp(sym,pack)
 > sym: symbol
 > pack: package
 < result:
     true if sym is accessible in pack as external symbol,
     (in this case, sym is not shadowed, because a symbol,
      possibly shadowing sym, should be listed in shadowing-symbols(pack),
      according to the consistency-rules 5 and 7 identical with sym),
     else false */
global bool externalp (object sym, object pack) {
  return symtab_find(sym,ThePackage(pack)->pack_external_symbols);
}

/* UP: locates an external symbol with a given printname in a package.
 find_external_symbol(string,invert,pack,&sym)
 > string: string
 > invert: whether to implicitly case-invert the string
 > pack: package
 < result: true, if an external symbol with that printname has been found in pack.
 < sym: this symbol, if found. */
global bool find_external_symbol (object string, bool invert, object pack, object* sym_) {
  return package_lookup_ext(string,invert,pack,sym_);
}

/* UP: searches a package of given name or nickname
 find_package(string)
 > string: string
 < result: package of this name or NIL */
global object find_package (object string) {
  var object packlistr = O(all_packages); /* traverse package-list */
  var object pack;
  while (consp(packlistr)) {
    pack = Car(packlistr); /* Package to be tested */
    /* test name: */
    if (string_eq(string,ThePackage(pack)->pack_name))
      return pack;
    { /* test nickname: */
      /* traverse nickname-list */
      var object nicknamelistr = ThePackage(pack)->pack_nicknames;
      while (consp(nicknamelistr)) {
        if (string_eq(string,Car(nicknamelistr)))
          return pack;
        nicknamelistr = Cdr(nicknamelistr);
      }
    }
    packlistr = Cdr(packlistr); /* next package */
  }
  /* not found */
  return NIL;
}

/* UP: Searches a symbol of given printname in a package.
 find_symbol(string,invert,pack,&sym)
 > string: string
 > invert: whether to implicitly case-invert the string
 > pack: package
 < sym: symbol, if found; else NIL
 < result:   0, if not found
             1, if available as external symbol
             2, if inherited via use-list
             3, if available as internal symbol
         + (-4, if available in the shadowing-list) */
local sintBWL find_symbol (object string, bool invert, object pack, object* sym_) {
  /* First search in the shadowing-list of pack: */
  if (shadowing_lookup(string,invert,pack,sym_)) {
    /* *sym_ = symbol, found in the shadowing-list */
    /* Search for it among the internal symbols: */
    if (symtab_find(*sym_,ThePackage(pack)->pack_internal_symbols))
      return 3-4; /* found among the internal symbols */
    /* Search it among the external symbols: */
    if (symtab_find(*sym_,ThePackage(pack)->pack_external_symbols))
      return 1-4; /* found among the external symbols */
    /* contradiction to consistency rule 5. */
    pushSTACK(*sym_); pushSTACK(pack);
    error(serious_condition,GETTEXT("~S inconsistent: symbol ~S is a shadowing symbol but not present"));
  } else { /* symbol not yet found */
    /* search among the internal symbols: */
    if (package_lookup_int(string,invert,pack,sym_))
      return 3; /* found among the internal symbols */
    /* search among the external symbols: */
    if (package_lookup_ext(string,invert,pack,sym_))
      return 1; /* found among the external symbols */
    /* search among the external packages from the use-list: */
    if (inherited_lookup(string,invert,pack,sym_))
      return 2; /* found among the inherited symbols */
    /* not found */
    *sym_ = NIL; return 0;
  }
}
/* Actually, one has to search in the shadowing-list only after
   one has searched among the present symbols, because the symbol in the
   shadowing-list is already present (consistency rule 5). */

/* raise a continuable error when func(obj) was called on a locked package pack
 continue means "Ignore the lock and proceed"
 can trigger GC */
local maygc void cerror_package_locked (object func, object pack, object obj) {
  pushSTACK(NIL);              /* 7 continue-format-string */
  pushSTACK(S(package_error)); /* 6 error type */
  pushSTACK(S(Kpackage));      /* 5 :PACKAGE */
  if (consp(pack)) pushSTACK(Car(pack)); /* from check-redefinition */
  else pushSTACK(pack);        /* 4 PACKAGE-ERROR slot PACKAGE */
  pushSTACK(NIL);              /* 3 error-format-string */
  pushSTACK(func);             /* 2 */
  pushSTACK(obj);              /* 1 */
  pushSTACK(pack);             /* 0 */
  /* CLSTEXT "can trigger GC", so it cannot be called until
     all the arguments have been already pushed on the STACK */
  STACK_7 = CLSTEXT("Ignore the lock and proceed"); /* continue-format-string */
  STACK_3 = CLSTEXT("~A(~S): ~S is locked"); /* error-format-string */
  funcall(L(cerror_of_type),8);
}
/* check the package lock */
#define check_pack_lock(func,pack,obj)                          \
  if (pack_locked_p(pack)) cerror_package_locked(func,pack,obj)
#define safe_check_pack_lock(func,pack,obj)                     \
  do { pushSTACK(pack); pushSTACK(obj); /* save */              \
       check_pack_lock(func, STACK_1 /*pack*/,STACK_0 /*obj*/); \
       obj = popSTACK(); pack = popSTACK(); /* restore */       \
  } while(0)

/* UP: Inserts a symbol into a package, that has no symbol of the same name yet.
   Does not check for conflicts.
 make_present(sym,pack);
 > sym: symbol
 > pack: package
 only call, if BREAK_SEM_2 is set
 can trigger GC */
local maygc void make_present (object sym, object pack) {
  if (!eq(pack,O(keyword_package))) {
    if (nullp(Symbol_package(sym)))
      Symbol_package(sym) = pack;
    /* Insert symbol into the internal symbols: */
    symtab_insert(sym,ThePackage(pack)->pack_internal_symbols);
  } else {
    if (nullp(Symbol_package(sym))) {
      pushSTACK(pack);          /* save */
      sym = check_symbol_not_symbol_macro(sym);
      Symbol_package(sym) = pack = popSTACK();
      Symbol_value(sym) = sym; /* sym gets itself as value */
      set_const_flag(TheSymbol(sym)); /* mark as constant */
    }
    /* Insert symbol into the external symbols: */
    symtab_insert(sym,ThePackage(pack)->pack_external_symbols);
  }
}

/* UP: Interns a symbol with a given printname in a package.
 intern(string,invert,pack,&sym)
 > string: string
 > invert: whether to implicitly case-invert the string
 > pack: package
 < sym: symbol
 < result: 0, if not found, but newly created
           1, if available as external symbol
           2, if inherited via use-list
           3, if available as internal symbol
 can trigger GC */
global maygc uintBWL intern (object string, bool invert, object pack, object* sym_) {
  {
    var sintBWL result = find_symbol(string,invert,pack,sym_); /* search */
    if (!(result==0))
      return result & 3; /* found -> finished */
  }
  pushSTACK(pack); /* save package */
  if (pack_locked_p(pack)) {
    /* when STRING comes from READ, it points to a re-usable buffer
       that will be overwritten during the CERROR i/o
       therefore we must copy and save it */
    pushSTACK(coerce_ss(string));
    cerror_package_locked(S(intern),STACK_1/*pack*/,STACK_0/*string*/);
    string = popSTACK();
  }
  if (invert)
    string = string_invertcase(string);
  string = coerce_imm_ss(string); /* string --> immutable simple-string */
  var object sym = make_symbol(string); /* (make-symbol string) */
  pack = popSTACK();
  /* enter this new symbol into the package: */
  set_break_sem_2(); /* protect against breaks */
  pushSTACK(sym); /* save symbol */
  make_present(sym,pack); /* intern into this package */
  *sym_ = popSTACK();
  clr_break_sem_2(); /* allow breaks */
  return 0;
}

/* UP: Interns a symbol of given printname into the keyword-package.
 intern_keyword(string)
 > string: string
 < result: symbol, a keyword
 can trigger GC */
global maygc object intern_keyword (object string) {
  var object sym;
  intern(string,false,O(keyword_package),&sym);
  return sym;
}

/* UP: lookup the string among the internal and, if not found,
 external symbols of the package PACK
 tab, if supplied, is the assignment that will set the table in which the
 STRINNG was found */
#define package_lookup(string,invert,pack,res_,tab)  \
  (symtab_lookup(string,invert,tab ThePackage(pack)->pack_internal_symbols,res_) || \
   symtab_lookup(string,invert,tab ThePackage(pack)->pack_external_symbols,res_))

/* UP: Imports a symbol into a package and turns it into a shadowing-symbol.
 Possibly another present symbol in this package
 of the same name is uninterned.
 shadowing_import(&sym,&pack);
 > sym: symbol (in STACK)
 > pack: package (in STACK)
 < sym: symbol, EQ to the old one
 < pack: package, EQ to the old one
 can trigger GC */
local maygc void shadowing_import (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  check_pack_lock(S(shadowing_import),*pack_,*sym_);
  set_break_sem_2(); /* protect against breaks */
  {
    var object sym = *sym_;
    var object pack = *pack_;
    /* Searches an internal or external symbol of the same name: */
    var object othersym;
    var object tab_found;
    var object string = Symbol_name(sym);
    pushSTACK(string); /* save string */
    if (package_lookup(string,false,pack,&othersym,tab_found=)) {
      /* a symbol othersym of the same name was
         already present in the package */
      if (!eq(othersym,sym)) { /* was it the to be imported symbol itself? */
        /* no -> have to take othersym away from the internal resp. */
        /* from the external symbols: */
        symtab_delete(othersym,tab_found);
        /* Was this symbol taken away from its home-package,
           its home-package must be set to NIL: */
        if (eq(Symbol_package(othersym),pack))
          Symbol_package(othersym) = NIL;
        /* symbol sym must be added to the package pack. */
        make_present(sym,pack);
      }
    } else { /* symbol sym must be added to the package pack. */
      make_present(sym,pack);
    }
  }
  /* symbol must be added to the shadowing-list of the package. */
  shadowing_delete(popSTACK(),false,*pack_); /* remove string from */
  /* the shadowing-list */
  shadowing_insert(sym_,pack_); /* add symbol to the shadowing-list */
  clr_break_sem_2(); /* allow breaks */
}

/* UP: Shadows in a package all symbols accessible from other packages
 of give name by one symbol present in this package
 of the same name.
 shadow(&sym,invert,&pack)
 > sym: symbol or string (in STACK)
 > invert: whether to implicitly case-invert the string
 > pack: package (in STACK)
 < pack: package, EQ to the old
 can trigger GC */
local maygc void do_shadow (const gcv_object_t* sym_, bool invert, const gcv_object_t* pack_) {
  check_pack_lock(S(shadow),*pack_,*sym_);
  set_break_sem_2(); /* protect against breaks */
  /* Search an internal or external symbol of the same name: */
  var object string = /* only the name of the symbol counts. */
    test_stringsymchar_arg(*sym_,invert);
  var object pack = *pack_;
  pushSTACK(NIL); /* make room for othersym */
  pushSTACK(string); /* save string */
  var object othersym;
  if (package_lookup(string,invert,pack,&othersym,)) {
    STACK_1 = othersym;
  } else {
    /* not found -> create new symbol of the same name: */
    if (invert)
      string = string_invertcase(string);
    string = coerce_imm_ss(string); /* string --> immutable simple-string */
    var object othersym = make_symbol(string); /* new symbol */
    STACK_1 = othersym;
    make_present(othersym,*pack_); /* enter into the package */
    /* home-package of the new symbols is pack */
    Symbol_package(STACK_1) = *pack_;
  }
  /* stack-layout: othersym, string
     In the package, now symbol othersym of the same name is present.
     remove string from the shadowing-list */
  shadowing_delete(popSTACK(),invert,*pack_);
  /* therefore add othersym to the shadowing-list */
  shadowing_insert(&STACK_0,pack_);
  skipSTACK(1); /* forget othersym */
  clr_break_sem_2(); /* allow breaks */
}
local maygc void shadow (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  do_shadow(sym_,false,pack_);
}
local maygc void cs_shadow (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  do_shadow(sym_,true,pack_);
}

/* UP: Removes a symbol from the set of present symbols of a package
 and does conflict resolution if it was in the shadowing-list
 of this package and a name conflict arises.
 unintern(&sym,&pack)
 > sym: symbol (in STACK)
 > pack: package (in STACK)
 < sym: symbol, EQ to the old
 < pack: package, EQ to the old
 < result: T if found and deleted, NIL if nothing has been done.
 can trigger GC */
local maygc object unintern (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  check_pack_lock(S(unintern),*pack_,*sym_);
  var object sym = *sym_;
  var object pack = *pack_;
  var object symtab;
  /* search sym among the internal and the external symbols: */
  if (symtab_find(sym,symtab=ThePackage(pack)->pack_internal_symbols)
      || symtab_find(sym,symtab=ThePackage(pack)->pack_external_symbols)) {
    /* found symbol sym in the table symtab */
    if (shadowing_find(sym,pack)) { /* search in the shadowing-list */
      /* possible conflict -> build up selection-list: */
      pushSTACK(symtab); /* save symboltable */
      pushSTACK(NIL); /* start option-list */
      pushSTACK(ThePackage(pack)->pack_use_list); /* traverse use-list */
      /* stack-layout: symboltable, OL, use-list-rest */
      while (mconsp(STACK_0)) {
        var object othersym;
        pack = Car(STACK_0); /* package from the use-list */
        STACK_0 = Cdr(STACK_0);
        /* search inherited symbol of the same name: */
        if (package_lookup_ext(Symbol_name(*sym_),false,pack,&othersym)) {
          /* check that othersym is not in the option-list yet */
          var object temp = STACK_1;
          while (mconsp(temp)) {
            if (eq(Cdr(Cdr(Car(temp))),othersym))
              goto next_package;
            temp = Cdr(temp);
          }
          /* othersym is a symbol of the same name, inherited from pack */
          pushSTACK(temp=ThePackage(pack)->pack_name); /* name of pack */
          pushSTACK(othersym); /* symbol */
          pushSTACK(NIL);
          pushSTACK(NIL); /* "symbol ~A from ~A will become a shadowing symbol" */
          pushSTACK(Symbol_name(othersym)); /* symbolname */
          pushSTACK(pack); /* package */
          STACK_2 = CLSTEXT("symbol ~A from ~A will become a shadowing symbol");
          /* (FORMAT NIL "..." symbolname packagename) */
          funcall(S(format),4);
          temp = value1;
          pushSTACK(temp); /* total-string */
          temp = allocate_cons();
          Car(temp) = popSTACK();
          Cdr(temp) = popSTACK();
          pushSTACK(temp); /* (cons total-string othersym) */
          temp = allocate_cons();
          Cdr(temp) = popSTACK();
          Car(temp) = popSTACK();
          /* temp = (list packagename total-string othersym) */
          /* STACK is correct, again */
          /* push to the option-list: */
          pushSTACK(temp);
          temp = allocate_cons();
          Car(temp) = popSTACK(); Cdr(temp) = STACK_1;
          STACK_1 = temp;
        }
       next_package:;
      }
      skipSTACK(1);
      /* option-list build-up finished.
         stack-layout: symboltable, OL
         if (length OL) >= 2, there's a conflict: */
      if (mconsp(STACK_0) && mconsp(Cdr(STACK_0))) {
        /* raise a correctable error, options is STACK_0 already */
        pushSTACK(*pack_); /* PACKAGE-ERROR slot PACKAGE */
        pushSTACK(*pack_); /* package */
        pushSTACK(*sym_); /* symbol */
        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."));
        pushSTACK(value1);
      } else
        STACK_0 = NIL;
      /* STACK_0 is the selection (NIL if no conflict arises) */
      /* stack-layout: symboltable, selection */
      set_break_sem_3();
      {
        var object sym = *sym_;
        var object pack = *pack_;
        /* remove symbol from symboltable: */
        symtab_delete(sym,STACK_1);
        /* if it was removed from its home-package,
           set the home-package to NIL: */
        if (eq(Symbol_package(sym),pack))
          Symbol_package(sym) = NIL;
        /* discard symbol from shadowing-list: */
        shadowing_delete(Symbol_name(sym),false,pack);
      }
      if (!nullp(STACK_0))
        /* in case of a conflict: import selected symbol: */
        shadowing_import(&STACK_0,pack_);
      skipSTACK(2); /* forget symboltable & selection */
      clr_break_sem_3();
      return T; /* that's it */
    } else { /* no conflict */
      set_break_sem_2();
      symtab_delete(sym,symtab); /* delete symbol */
      if (eq(Symbol_package(sym),pack))
        Symbol_package(sym) = NIL; /* maybe set home-package to NIL */
      clr_break_sem_2();
      return T;
    }
  } else /* not found */
    return NIL;
}

/* UP: raise a continuable error and query the user about how to proceed
 return true when an abort was requested
 dialog_type == 0 or 1 or 2
 can trigger GC */
local maygc bool query_intern_conflict (object pack, object sym, object other,
                                        int dialog_type) {
  pushSTACK(NIL); /* place for OPTIONS */
  pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
  pushSTACK(other); pushSTACK(pack); pushSTACK(sym);
  switch (dialog_type) {        /* fill OPTIONS */
    case 0: /* conflict */
      STACK_4=CLOTEXT("((IMPORT \"import it and unintern the other symbol\" . T)"
                      " (IGNORE \"do not import it, leave undone\" . NIL))");
      break;
    case 1: /* conflict & shadowing */
      STACK_4=CLOTEXT("((IMPORT \"import it, unintern one other symbol and shadow the other symbols\" . T)"
                      " (IGNORE \"do not import it, leave undone\" . NIL))");
      break;
    case 2: /* shadowing */
      STACK_4=CLOTEXT("((IMPORT \"import it and shadow the other symbol\" . T)"
                      " (IGNORE \"do nothing\" . NIL))");
      break;
    default: NOTREACHED;
  }
  correctable_error(package_error,(dialog_type == 1
                                   ? GETTEXT("Importing ~S into ~S produces a name conflict with ~S and other symbols.")
                                   : GETTEXT("Importing ~S into ~S produces a name conflict with ~S.")));
  return nullp(value1);
}

/* UP: Imports a symbol into a package and does conflict resolution
 in case, that a name conflict arises either with a symbol
 inherited from anotherpackage or with an already present symbol
 in this package of the same name.
 import(&sym,&pack);
 > sym: symbol (in STACK)
 > pack: package (in STACK)
 < pack: package, EQ to the old
 can trigger GC */
global maygc void import (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  var object sym = *sym_;
  var object pack = *pack_;
  var object string = Symbol_name(sym);
  var object othersym;
  var object othersymtab;
  /* search symbol of the same name among the internal
     and the external symbols: */
  if (package_lookup(string,false,pack,&othersym,othersymtab=)) {
    /* othersym = symbol of the same name, found in othersymtab */
    if (eq(othersym,sym)) /* the same symbol -> nothing to do */
      return;
    /* not the same symbol was present -> must throw out othersym and
       insert the given symbol sym for it.
       determine beforehand, if there are additional inherited
       symbols there, and then raise Continuable Error. */
    pushSTACK(string);
    pushSTACK(othersym);
    pushSTACK(othersymtab);
    /* first calculate inherited-flag: */
    var bool inheritedp = inherited_lookup(string,false,pack,NULL);
    /* stack-layout: symbol-name, othersym, othersymtab. */
    /* raise Continuable Error: */
    if (query_intern_conflict(*pack_,*sym_,othersym,inheritedp ? 1 : 0)) {
      skipSTACK(3); return; /* yes -> do not import, finished */
    }
    /* import: */
    set_break_sem_2();
    pack = *pack_;
    { /* remove othersym from pack: */
      var object othersym = STACK_1;
      symtab_delete(othersym,STACK_0); /* remove othersym from othersymtab */
      if (eq(Symbol_package(othersym),pack))
        Symbol_package(othersym) = NIL; /* maybe home-package := NIL */
    }
    /* insert sym in pack: */
    make_present(*sym_,pack);
    /* remove symbols of the same name from the shadowing-list of pack: */
    shadowing_delete(STACK_2,false,*pack_);
    /* if inherited-flag, turn sym in pack into a shadowing-symbol: */
    if (inheritedp)
      shadowing_insert(sym_,pack_);
    clr_break_sem_2();
    skipSTACK(3); return;
  } else {
    /* no symbol of the same name was present.
       Search a symbol of the same name, that is inherited (there is
       at most one, according to the consistency rules 6 and 5): */
    var object otherusedsym;
    if (!inherited_lookup(string,false,pack,&otherusedsym)
        || eq(otherusedsym,sym)) {
      /* insert sym simply in pack: */
      set_break_sem_2();
      make_present(sym,pack);
      clr_break_sem_2();
    } else {
      /* no -> raise Continuable Error and query user: */
      if (query_intern_conflict(pack,sym,otherusedsym,2))
        return; /* yes -> do not import, finished */
      /* import: */
      set_break_sem_2();
      /* insert sym in pack: */
      make_present(*sym_,*pack_);
      /* turn sym in pack into a shadowing-symbol: */
      shadowing_insert(sym_,pack_);
      clr_break_sem_2();
    }
  }
}

/* UP: Sets a symbol back from external to internal status in
 einer package.
 unexport(&sym,&pack);
 > sym: symbol (in STACK)
 > pack: package (in STACK)
 < pack: package, EQ to the old
 can trigger GC */
local maygc void unexport (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  check_pack_lock(S(unexport),*pack_,*sym_);
  var object sym = *sym_;
  var object pack = *pack_;
  var object symtab;
  if (symtab_find(sym,symtab=ThePackage(pack)->pack_external_symbols)) {
    /* sym is external in pack */
    if (eq(pack,O(keyword_package))) { /* test for keyword-package */
      pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
      pushSTACK(pack);
      error(package_error,GETTEXT("UNEXPORT in ~S is illegal"));
    }
    set_break_sem_2();
    symtab_delete(sym,symtab); /* remove sym from the external symbols */
    /* therefor, insert it into the internal symbols */
    symtab_insert(sym,ThePackage(pack)->pack_internal_symbols);
    clr_break_sem_2();
  } else {
    /* Search, if the symbol is accessible at all. */
    /* Search among the internal symbols: */
    if (symtab_find(sym,ThePackage(pack)->pack_internal_symbols))
      return;
    /* Search among the external symbols of the packages from the use-list: */
    if (inherited_find(sym,pack))
      return;
    /* not found among the accessible symbols */
    pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
    pushSTACK(pack); pushSTACK(sym);
    error(package_error,
           GETTEXT("UNEXPORT works only on accessible symbols, not on ~S in ~S"));
  }
}

/* UP: Sets a present symbol into external status.
 make_external(sym,pack);
 > sym: symbol
 > pack: package, in which the symbol is present
 can trigger GC */
local maygc void make_external (object sym, object pack) {
  if (symtab_find(sym,ThePackage(pack)->pack_external_symbols))
    return; /* symbol already external -> nothing to do */
  set_break_sem_2();
  /* remove sym from the internal symbols */
  symtab_delete(sym,ThePackage(pack)->pack_internal_symbols);
  /* therefor, insert it into the external symbols */
  symtab_insert(sym,ThePackage(pack)->pack_external_symbols);
  clr_break_sem_2();
}

/* UP: Exports a symbol from a package
 export(&sym,&pack);
 > sym: symbol (in STACK)
 > pack: package (in STACK)
 < sym: symbol, EQ to the old
 < pack: package, EQ to the old
 can trigger GC */
global maygc void export (const gcv_object_t* sym_, const gcv_object_t* pack_) {
  check_pack_lock(S(export),*pack_,*sym_);
  var object sym = *sym_;
  var object pack = *pack_;
  /* search sym among the external symbols of pack: */
  if (symtab_find(sym,ThePackage(pack)->pack_external_symbols))
    return; /* found -> finished */
  var bool import_it = false;
  /* import_it = flag, if symbol has to be imported first. */
  /* search sym among the internal symbols of pack: */
  if (!(symtab_find(sym,ThePackage(pack)->pack_internal_symbols))) {
    /* symbol sym is not present in package pack */
    import_it = true;
    /* Search, if it is at least accessible: */
    if (!inherited_find(sym,pack)) {
      /* symbol sym is not even accessible in the package pack ==>
         raise correctable error: */
      pushSTACK(NIL); /* place for OPTIONS */
      pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
      /* "symbol ~S has to be imported in ~S before being exported" */
      pushSTACK(pack); pushSTACK(sym); pushSTACK(S(export));
      STACK_4 = CLOTEXT("((IMPORT \"import the symbol first\" . T)"
                        " (IGNORE \"do nothing, do not export the symbol\" . NIL))");
      correctable_error(package_error,GETTEXT("~S: Symbol ~S should be imported into ~S before being exported."));
      if (nullp(value1)) /* NIL-option selected? */
        return; /* yes -> do not export, finished */
    }
  }
  /* Test for name-conflict: */
  pushSTACK(NIL); /* conflict-resolver:=NIL */
  /* stack-layout: conflict-resolver (a list of pairs (sym . pack),
                   for which shadowing_import has to be applied).
  used-by-list is searched */
  pushSTACK(ThePackage(*pack_)->pack_used_by_list);
  while (mconsp(STACK_0)) {
    var object usingpack = Car(STACK_0); /* USE-ing package */
    STACK_0 = Cdr(STACK_0);
    var object othersym;
    if (find_symbol(Symbol_name(*sym_),false,usingpack,&othersym) > 0)
      /* othersym is a symbol of the same name in usingpack */
      if (!eq(othersym,*sym_)) {
        var gcv_object_t *othersym_, *usingpack_;
        /* it is not sym itself -> there is a conflict */
        pushSTACK(othersym); othersym_ = &STACK_0;
        pushSTACK(usingpack); usingpack_ = &STACK_0;
        /* stack-layout: conflict-resolver, used-by-list-rest,
                         other symbol, USE-ing package. */
        pushSTACK(NIL);         /* space for OPTIONS */
        pushSTACK(*pack_);      /* PACKAGE-ERROR slot PACKAGE */
        pushSTACK(usingpack);   /* USE-ing package */
        pushSTACK(usingpack);   /* USE-ing package */
        pushSTACK(othersym);    /* other symbol */
        pushSTACK(*pack_);      /* package */
        pushSTACK(*sym_);       /* symbol */
        { /* construct options-list: */
          var object temp;
          pushSTACK(ThePackage(*pack_)->pack_name); /* package name */
          pushSTACK(CLSTEXT("the symbol to export, "));
          pushSTACK(*sym_); /* symbol */
          funcall(L(prin1_to_string),1); /* (prin1-to-string Symbol) */
          pushSTACK(value1);
          /* (string-concat "The new symbol " (prin1-to-string Symbol)) */
          temp = string_concat(2);
          pushSTACK(temp);
          temp = listof(2); /* (list* symbol (string-concat ...) 'T) */
          Cdr(Cdr(temp)) = T;
          pushSTACK(temp);
          pushSTACK(ThePackage(*usingpack_)->pack_name); /* USE-ing pack */
          pushSTACK(CLSTEXT("the old symbol, "));
          pushSTACK(*othersym_); /* other symbol */
          /* (prin1-to-string anderesSymbol) */
          funcall(L(prin1_to_string),1);
          pushSTACK(value1);
          /* (string-concat "The old symbol " (prin1-to-string old-symbol)) */
          temp = string_concat(2);
          pushSTACK(temp);
          temp = listof(2); /* (list* other-symbol (string-concat ...) 'NIL) */
          /* Cdr(Cdr(temp)) = NIL; not needed */
          pushSTACK(temp);
          temp = listof(2); /* (list (list s1 ... 'T) (list s2 ... 'NIL)) */
          STACK_6 = temp; /* options */
        }
        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."));
        pushSTACK(nullp(value1)?STACK_1/*other symbol*/:*sym_);/*solvingsym*/
        { /* extend conflict-resolver with (solvingsym . usingpack) : */
          var object new_cons = allocate_cons();
          Car(new_cons) = popSTACK(); /* solvingsym */
          Cdr(new_cons) = popSTACK(); /* usingpack */
          /* new_cons = (cons solvingsym usingpack) */
          /* cons in front of conflict-resolver: */
          STACK_0 = new_cons;
          new_cons = allocate_cons();
          Car(new_cons) = popSTACK(); /* (solvingsym . usingpack) */
          Cdr(new_cons) = STACK_1;
          STACK_1 = new_cons;
        }
        /* stack-layout: conflict-resolver, used-by-list-rest. */
      }
  }
  skipSTACK(1);
  /* stack-layout: conflict-resolver. */
  /* Now maybe import symbol sym: */
  if (import_it) {
    /* import sym in pack: */
    import(sym_,pack_);
    /* This importing can be aborted by CERROR.
       An abort is not dangerous at this point, because up to now
       the symbol is only internal in the package (except if it is
       the KEYWORD package, that can not be USE-ed). */
  }
  set_break_sem_3(); /* protect against breaks */
  /* now resolve the conflicts: */
  while (mconsp(STACK_0)) {
    var object cons_sym_pack = Car(STACK_0);
    STACK_0 = Cdr(STACK_0);
    pushSTACK(Car(cons_sym_pack)); /* solvingsym */
    pushSTACK(Cdr(cons_sym_pack)); /* usingpack */
    shadowing_import(&STACK_1,&STACK_0); /* import and shadow */
    skipSTACK(2);
  }
  skipSTACK(1);
  make_external(*sym_,*pack_); /* make sym in pack external */
  clr_break_sem_3(); /* allow breaks */
}

/* UP: Applies a function to all symbols in a symboltable.
 (In the worst case, this function may delete the symbol via symtab_delete
 from the table.)
 map_symtab(fun,symtab);
 > fun: function with one argument
 > symtab: symboltable
 can trigger GC */
local maygc void map_symtab (object fun, object symtab) {
  pushSTACK(fun); /* function */
  pushSTACK(Symtab_table(symtab)); /* table vector */
  /* number of entries */
  var uintL size = posfixnum_to_V(Symtab_size(symtab));
  var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
  var uintC count;
  dotimespC(count,size, {
    var object entry = /* entry with number index in table */
      *(gcv_object_t*)(pointerplus(&TheSvector(STACK_0)->data[0],(aint)offset));
    if (atomp(entry)) {
      if (!nullp(entry)) {
        /* entry is a symbol /= NIL */
        pushSTACK(entry); funcall(STACK_2,1); /* apply function */
      }
    } else {
      /* process non-empty symbol list */
      pushSTACK(entry);
      do {
        var object listr = STACK_0;
        STACK_0 = Cdr(listr);
        /* apply function to symbol */
        pushSTACK(Car(listr)); funcall(STACK_3,1);
      } while (!matomp(STACK_0));
      skipSTACK(1);
    }
    offset++;
  });
  skipSTACK(2);
}

/* UP: Applies a C-function to all symbols of a symbol table.
 (In the worst case, this function may delete the symbol via symtab_delete
 from the table.)
 map_symtab_c(fun,data,symtab);
 > fun: function with two arguments, may trigger GC
 > data: first argument for the function
 > symtab: symbol table
 can trigger GC */
typedef maygc void one_sym_function_t (void* data, object sym);
local maygc void map_symtab_c (one_sym_function_t* fun, void* data, object symtab) {
  pushSTACK(Symtab_table(symtab)); /* table vector */
  /* number of entries */
  var uintL size = posfixnum_to_V(Symtab_size(symtab));
  var gcv_object_t* offset = 0; /* offset = sizeof(gcv_object_t)*index */
  var uintC count;
  dotimespC(count,size, {
    var object entry = /* entry with number index in table */
      *(gcv_object_t*)(pointerplus(&TheSvector(STACK_0)->data[0],(aint)offset));
    if (atomp(entry)) {
      if (!nullp(entry)) { /* entry is a symbol /= NIL */
        (*fun)(data,entry); /* apply function */
      }
    } else { /* process non-empty symbol list */
      pushSTACK(entry);
      do {
        var object listr = STACK_0;
        STACK_0 = Cdr(listr);
        (*fun)(data,Car(listr)); /* apply function to symbol */
      } while (!matomp(STACK_0));
      skipSTACK(1);
    }
    offset++;
  });
  skipSTACK(1);
}

/* UP: Effectuates, that all external symbols of a given list of packages
 become implicitly accessible in a given package.
 use_package(packlist,pack);
 > packlist: list of packages, that are to be USE-ed
 > pack: package
 the list packlist is thereby destroyed!
 can trigger GC */
local one_sym_function_t use_package_aux;
local maygc void use_package (object packlist, object pack) {
  safe_check_pack_lock(S(use_package),pack,packlist);
  { /* packlist := (delete-duplicates packlist :test #'eq) : */
    var object packlist1 = packlist;
    while (consp(packlist1)) {
      var object to_delete = Car(packlist1);
      /* remove to_delete destructively from (cdr packlist1) : */
      var object packlist2 = packlist1; /* starts at packlist1 */
      var object packlist3; /* always = (cdr packlist2) */
      while (consp(packlist3=Cdr(packlist2))) {
        if (eq(Car(packlist3),to_delete)) {
          /* remove (car packlist3) destructively from the list: */
          Cdr(packlist2) = Cdr(packlist3);
        } else { /* advance: */
          packlist2 = packlist3;
        }
      }
      packlist1 = Cdr(packlist1);
    }
  }
  /* Remove all the packages from packlist, that are equal to pack
     or that already occur in the use-list of pack: */
  pushSTACK(pack); /* save package pack */
  pushSTACK(packlist); /* save list of packages to be USE-ed */
  {
    var gcv_object_t* packlistr_ = &STACK_0;
    var object packlistr = *packlistr_;
    /* packlistr loops over packlist, packlistr = *packlistr_ */
    while (consp(packlistr)) {
      /* test, if (car packlistr) must be discarded: */
      var object pack_to_test = Car(packlistr);
      if (eq(pack_to_test,pack))
        goto delete_pack_to_test;
      if (!nullp(memq(pack_to_test,ThePackage(pack)->pack_use_list)))
        goto delete_pack_to_test;
      if (true) { /* do not discard, advance: */
        packlistr_ = &Cdr(packlistr); packlistr = *packlistr_;
      } else {    /* discard (car packlistr) : */
       delete_pack_to_test:
        packlistr = *packlistr_ = Cdr(packlistr);
      }
    }
  }
  /* build conflict list.
     A conflict is an at least two-element list
     of symbols of the same printname, together with the package,
     from which this symbol is taken:
     ((pack1 . sym1) ...) means, that on execution of the USE-PACKAGE
     the symbole sym1,... (from pack1 etc.) would compete for
     the visibility in package pack.
     The conflict list is the list of all occurring conflicts. */
  {
    var gcv_object_t *pack_ = &STACK_1;
    var gcv_object_t *packlist_ = &STACK_0;
    var gcv_object_t *conflicts_, *conflict_resolver_;
    pushSTACK(NIL); /* (so far empty) conflict list */
    conflicts_ = &STACK_0;
    /* stack-layout: pack, packlist, conflicts. */
    { /* peruse package list: */
      pushSTACK(*packlist_);
      while (mconsp(STACK_0)) {
        var object pack_to_use = Car(STACK_0);
        STACK_0 = Cdr(STACK_0);
        /* apply use_package_aux to all external symbols of pack_to_use: */
        map_symtab_c(&use_package_aux,conflicts_,
                     ThePackage(pack_to_use)->pack_external_symbols);
      }
      skipSTACK(1);
    }
    { /* reconstruct conflict list: Each conflict ((pack1 . sym1) ...) is
       transformed into ((packname1 pack1 . sym1) ...). */
      pushSTACK(*conflicts_); /* traverse conflict list */
      while (mconsp(STACK_0)) {
        var object conflict = Car(STACK_0);
        STACK_0 = Cdr(STACK_0);
        pushSTACK(conflict); /* process conflict */
        while (mconsp(STACK_0)) {
          var object new_cons = allocate_cons(); /* new cons */
          var object old_cons = Car(STACK_0); /* (pack . sym) */
          /* replace pack by its name */
          Car(new_cons) = ThePackage(Car(old_cons))->pack_name;
          /* insert new-cons */
          Cdr(new_cons) = old_cons; Car(STACK_0) = new_cons;
          STACK_0 = Cdr(STACK_0);
        }
        skipSTACK(1);
      }
      skipSTACK(1);
    }
    /* conflict-list finished. */
    pushSTACK(NIL); /* conflict-resolver := NIL */
    conflict_resolver_ = &STACK_0;
    /* stack-layout: pack, packlist, conflicts, conflict-resolver. */
    /* treat conflicts with user-queries: */
    while (!nullp(*conflicts_)) { /* only necessary for conflicts/=NIL */
      /* raise correctable error: */
      pushSTACK(Car(*conflicts_));           /* OPTIONS */
      pushSTACK(*pack_);        /* PACKAGE-ERROR slot PACKAGE */
      pushSTACK(*pack_);
      pushSTACK(Symbol_name(Cdr(Cdr(Car(Car(*conflicts_)))))); /* name */
      pushSTACK(fixnum(llength(*conflicts_))); /* (length conflicts) */
      pushSTACK(*pack_); pushSTACK(*packlist_); pushSTACK(S(use_package));
      correctable_error(package_error,GETTEXT("(~S ~S ~S): ~S name conflicts remain\nWhich symbol with name ~S should be accessible in ~S?"));
      pushSTACK(value1); /* sym */
      {
        var object new_cons = allocate_cons();
        Car(new_cons) = popSTACK(); /* sym */
        Cdr(new_cons) = *conflict_resolver_;
        /* conflict-resolver := (cons sym conflict-resolver) */
        *conflict_resolver_ = new_cons;
      }
      *conflicts_ = Cdr(*conflicts_);
    }
    /* stack-layout: pack, packlist, conflicts, conflict-resolver. */
    { /* resolve conflicts: */
      set_break_sem_3();
      /* traverse conflict-resolver: */
      while (mconsp(STACK_0)) {
        pushSTACK(Car(STACK_0)); /* symbol from conflict-resolver */
        /* make it into a shadowing-symbol in pack */
        shadowing_import(&STACK_0,&STACK_4);
        skipSTACK(1);
        STACK_0 = Cdr(STACK_0);
      }
      skipSTACK(2); /* forget conflicts and conflict-resolver */
      /* stack-layout: pack, packlist. */
      /* traverse packlist: */
      while (mconsp(STACK_0)) {
        pushSTACK(Car(STACK_0)); /* pack_to_use */
        { /* (push pack_to_use (package-use-list pack)) */
          var object new_cons = allocate_cons();
          var object pack = STACK_2;
          Car(new_cons) = STACK_0; /* pack_to_use */
          Cdr(new_cons) = ThePackage(pack)->pack_use_list;
          ThePackage(pack)->pack_use_list = new_cons;
        }
        { /* (push pack (package-used-by-list pack_to_use)) */
          var object new_cons = allocate_cons();
          var object pack_to_use = popSTACK();
          Car(new_cons) = STACK_1; /* pack */
          Cdr(new_cons) = ThePackage(pack_to_use)->pack_used_by_list;
          ThePackage(pack_to_use)->pack_used_by_list = new_cons;
        }
        STACK_0 = Cdr(STACK_0);
      }
      skipSTACK(2); /* forget pack and packlist */
      clr_break_sem_3();
    }
  }
}

/* UP: Auxiliary function for use_package:
 Test the argument (an external symbol from one of the packages of
 packlist), if it creates a conflict. If yes, extend conflicts.
 can trigger GC */
local maygc void use_package_aux (void* data, object sym) {
  var gcv_object_t* localptr = (gcv_object_t*)data;
  /* Pointer to local variables of use_package:
     *(localptr STACKop 2) = pack,
     *(localptr STACKop 1) = packlist,
     *(localptr STACKop 0) = conflicts. */
  var object string = Symbol_name(sym); /* printname of the passed symbol */
  /* Is there a conflict between the symbols with printname = string ?
     travares conflict list so far (((pack1 . sym1) ...) ...) : */
  {
    var object conflictsr = *(localptr STACKop 0);
    while (consp(conflictsr)) {
      /* conflict already treated?
         (car conflictsr) = next conflict,
         (car (car conflictsr)) = its first cons,
         (cdr (car (car conflictsr))) = the symbol therein,
         is its printname = string ? */
      if (string_eq(Symbol_name(Cdr(Car(Car(conflictsr)))),string))
        goto ok;
      conflictsr = Cdr(conflictsr);
    }
  }
  pushSTACK(string); /* save string */
  /* build new conflict: */
  { pushSTACK(NIL); } /* new conflict (still empty) */
  { /* test, if a symbol of the same name is already accessible in pack: */
    var object othersym;
    var sintBWL code = find_symbol(string,false,*(localptr STACKop 2),&othersym);
    if (code < 0) {
      /* Eponymous symbol in the shadowing-list impedes conflict. */
      skipSTACK(2); goto ok;
    }
    if (code > 0) {
      /* accessible, but not shadowing ->
         extend conflict by (pack . othersym) : */
      pushSTACK(othersym);
      {
        var object temp = allocate_cons();
        Cdr(temp) = popSTACK(); /* othersym */
        Car(temp) = *(localptr STACKop 2); /* pack */
        pushSTACK(temp); /* (pack . othersym) */
      }
      {
        var object new_cons = allocate_cons();
        Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
        STACK_0 = new_cons;
      }
    }
  }
  /* Test, in which packages from packlist a symbol of the same name
     is external: */
  {
    var object packlistr = *(localptr STACKop 1); /* traverse packlist */
    while (consp(packlistr)) {
      var object pack_to_use = Car(packlistr);
      packlistr = Cdr(packlistr);
      var object othersym;
      if (package_lookup_ext(STACK_1,false,pack_to_use,&othersym)) {
        /* othersym has the printname = string and is
           external in pack_to_use.
           push (pack_to_use . othersym) on conflict: */
        pushSTACK(packlistr); /* save packlistr */
        pushSTACK(pack_to_use);
        pushSTACK(othersym);
        {
          var object new_cons = allocate_cons();
          Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
          pushSTACK(new_cons); /* (cons pack_to_use othersym) */
        }
        {
          var object new_cons = allocate_cons();
          Car(new_cons) = popSTACK();
          packlistr = popSTACK();
          Cdr(new_cons) = STACK_0;
          /* conflict := (cons (cons pack_to_use othersym) conflict) */
          STACK_0 = new_cons;
        }
      }
    }
  }
  {
    var object conflict = popSTACK(); /* the completed conflict */
    /* conflict := (delete-duplicates conflict :key #'cdr :test #'eq): */
    {
      var object conflict1 = conflict;
      while (consp(conflict1)) {
        var object to_delete = Cdr(Car(conflict1));
        /* Remove all elements with CDR=to_delete
           destructively from (cdr conflict1) : */
        var object conflict2 = conflict1; /* starts at conflict1 */
        var object conflict3; /* always = (cdr conflict2) */
        while (consp(conflict3=Cdr(conflict2))) {
          if (eq(Cdr(Car(conflict3)),to_delete)) {
            /* discard (car conflict3) destructively from the list: */
            Cdr(conflict2) = Cdr(conflict3);
          } else { /* advance: */
            conflict2 = conflict3;
          }
        }
        conflict1 = Cdr(conflict1);
      }
    }
    /* if conflict has a length >=2 , it is consed to conflicts: */
    if (consp(conflict) && mconsp(Cdr(conflict))) {
      pushSTACK(conflict);
      var object new_cons = allocate_cons();
      Car(new_cons) = popSTACK(); /* conflict */
      Cdr(new_cons) = *(localptr STACKop 0); /* conflicts */
      /* conflicts := (cons conflict conflicts) */
      *(localptr STACKop 0) = new_cons;
    }
  }
  skipSTACK(1); /* forget string */
 ok: ;
}

/* UP: Effectuates, that a given package is not USE-ed anymore
 by (another) package.
 unuse_1package(pack,qpack);
 > pack: package
 > qpack: package
 Removes qpack from the use-list of pack
 and pack from the used-by-list of qpack.
 can trigger GC */
local maygc void unuse_1package (object pack, object qpack) {
  safe_check_pack_lock(S(use_package),pack,qpack);
  set_break_sem_2();
  /* remove qpack from the use-list of pack: */
  ThePackage(pack)->pack_use_list =
    deleteq(ThePackage(pack)->pack_use_list,qpack);
  /* remove pack from the used-by-list of qpack: */
  ThePackage(qpack)->pack_used_by_list =
    deleteq(ThePackage(qpack)->pack_used_by_list,pack);
  clr_break_sem_2();
}

/* UP: Effectuates, that a list of given packages is not USE-ed anymore
 by a given package.
 unuse_package(packlist,pack);
 > packlist: list of packages
 > pack: package
 Removes all packages from packlist from the use-list of pack
 and pack from the used-by-lists of all packages from packlist.
 can trigger GC */
local maygc void unuse_package (object packlist, object pack) {
  pushSTACK(pack);
  pushSTACK(packlist);
  set_break_sem_3();
  /* traverse packlist: */
  while (mconsp(STACK_0)) {
    unuse_1package(STACK_1,Car(STACK_0));
    STACK_0 = Cdr(STACK_0);
  }
  clr_break_sem_3();
  skipSTACK(2);
}

/* UP: returns the current package
 get_current_package()
 < result: current package
 can trigger GC */
global maygc object get_current_package (void) {
  var object pack = Symbol_value(S(packagestern)); /* value of *PACKAGE* */
  if (packagep(pack) && !pack_deletedp(pack)) {
    return pack;
  } else {
    var object newpack = /* reset *PACKAGE* */
      Symbol_value(S(packagestern)) = O(default_package);
    /* get_current_package() is often called by the reader,
       so we need to save and restore the read buffers */
    pushSTACK(O(token_buff_1)); O(token_buff_1) = NIL;
    pushSTACK(O(token_buff_2)); O(token_buff_2) = NIL;
    pushSTACK(NIL);             /* 8: "Proceed with the new value." */
    pushSTACK(S(type_error));   /* 7: error type */
    pushSTACK(S(Kdatum));       /* 6: :DATUM */
    pushSTACK(pack);            /* 5: TYPE-ERROR slot DATUM */
    pushSTACK(S(Kexpected_type)); /* 4: :EXPECTED-TYPE */
    pushSTACK(S(package));      /* 3: TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(NIL);             /* 2: "The value of ..." */
    pushSTACK(pack);            /* 1: old name */
    pushSTACK(newpack);         /* 0: new name */
    STACK_2 = CLSTEXT("The value of *PACKAGE* was not a package and was reset. The old value was ~S. The new value is ~S.");
    STACK_8 = CLSTEXT("Proceed with the new value.");
    funcall(L(cerror_of_type),9);
    O(token_buff_2) = popSTACK(); /* restore read buffers */
    O(token_buff_1) = popSTACK();
    return Symbol_value(S(packagestern));
  }
}

/* UP: checks a package-argument.
 Tests, if it is a package or a package name, and returns it as
 a package. Else error message.
 test_package_arg(obj)
 > obj: argument
 < result: argument turned into a package
 can trigger GC */
local maygc object test_package_arg (object obj) {
 restart_package_arg:
  if (packagep(obj)) { /* package -> mostly OK */
    if (!pack_deletedp(obj))
      return obj;
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(obj); /* PACKAGE-ERROR slot PACKAGE */
    pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
    check_value(package_error,GETTEXT("~S: Package ~S has been deleted."));
    obj = value1;
    goto restart_package_arg;
  }
  if (stringp(obj))
  string: { /* string -> search package with name obj: */
    var object pack = find_package(obj);
    if (!nullp(pack))
      return pack;
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(obj); /* PACKAGE-ERROR slot PACKAGE */
    pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
    check_value(package_error,GETTEXT("~S: There is no package with name ~S"));
    obj = value1;
    goto restart_package_arg;
  }
  if (symbolp(obj)) { /* symbol -> string */
    obj = Symbol_name(obj); goto string; /* use print name, no case-invert */
  }
  if (charp(obj)) { /* character -> string */
    var object new_string = allocate_string(1);
    TheSnstring(new_string)->data[0] = char_code(obj);
    obj = new_string;
    goto string;
  }
  pushSTACK(NIL); /* no PLACE */
  pushSTACK(obj); /* TYPE-ERROR slot DATUM */
  pushSTACK(O(type_packname)); /* TYPE-ERROR slot EXPECTED-TYPE */
  pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
  check_value(type_error,GETTEXT("~S: argument should be a package or a package name, not ~S"));
  obj = value1;
  goto restart_package_arg;
}

LISPFUNNR(make_symbol,1) { /* (MAKE-SYMBOL printname), CLTL p. 168 */
  var object arg = check_string(popSTACK());
  VALUES1(make_symbol(coerce_imm_ss(arg)));
}

LISPFUNNR(find_package,1) { /* (FIND-PACKAGE name), CLTL p. 183 */
  var object pack = popSTACK();
  if (packagep(pack)) VALUES1(pack);
  else {
    var object name = test_stringsymchar_arg(pack,false);
    VALUES1(find_package(name)); /* search package */
  }
}

LISPFUNN(pfind_package,1) { /* (SYSTEM::%FIND-PACKAGE name) */
  VALUES1(test_package_arg(popSTACK())); /* argument as package */
}

LISPFUNNR(package_name,1) { /* (PACKAGE-NAME package), CLTL p. 184 */
  var object pack = popSTACK();
  if (packagep(pack) && pack_deletedp(pack)) {
    VALUES1(NIL);
  } else {
    pack = test_package_arg(pack); /* argument as package */
    VALUES1(ThePackage(pack)->pack_name); /* the name */
  }
}

LISPFUNNR(package_nicknames,1)
{ /* (PACKAGE-NICKNAMES package), CLTL p. 184 */
  var object pack = popSTACK();
  if (packagep(pack) && pack_deletedp(pack)) {
    VALUES1(NIL);
  } else {
    pack = test_package_arg(pack); /* argument as package */
    /* copy nicknamelist for safety reasons */
    VALUES1(copy_list(ThePackage(pack)->pack_nicknames));
  }
}

/* UP: checks name and nicknames -
 arguments of RENAME-PACKAGE and MAKE-PACKAGE.
 Tests, if STACK_4 is a name, and turns it into a immutable simple-string.
 Tests, if STACK_3 is a name or a list of names, and turns it
 into a new list of immutable simple-strings.
 > subr-self: caller (a SUBR)
 can trigger GC */
local maygc void test_names_args (void) {
  /* check name for string and turn it into a simple-string: */
  STACK_4 = coerce_imm_ss(test_stringsymchar_arg(STACK_4,false));
  { /* convert nickname-argument into a list: */
    var object nicknames = STACK_3;
    if (!boundp(nicknames)) {
      STACK_3 = NIL; /* no nicknames specified -> default NIL */
    } else {
      if (!listp(nicknames)) {
        /* nicknames not a list -> turn it into a one-element list: */
        nicknames = allocate_cons();
        Car(nicknames) = STACK_3;
        STACK_3 = nicknames;
      }
    }
  }
  { /* check nickname(s) for string, turn into simple-strings
     and build a new nicknamelist: */
    pushSTACK(NIL); /* new nicknamelist := NIL */
    while (mconsp(STACK_4)) {
      {
        var object nickname = Car(STACK_4); /* next nickname */
        STACK_4 = Cdr(STACK_4);
        /* as simple-string */
        nickname = coerce_imm_ss(test_stringsymchar_arg(nickname,false));
        /* cons in front of the new nicknamelist: */
        pushSTACK(nickname);
      }
      var object new_cons = allocate_cons();
      Car(new_cons) = popSTACK();
      Cdr(new_cons) = STACK_0;
      STACK_0 = new_cons;
    }
    var object nicknames = popSTACK();
    STACK_3 = nicknames; /* new nicknamelist replaces the old */
  }
}

/* (RENAME-PACKAGE pack name [nicknames]), CLTL p. 184 */
LISPFUN(rename_package,seclass_default,2,1,norest,nokey,0,NIL) {
  /* Test, if pack is a package: */
  STACK_2 = test_package_arg(STACK_2);
  check_pack_lock(S(rename_package),STACK_2,STACK_1);
  /* check name and nicknames:
     name is a package designator here (but not in make-package!) */
  if (packagep(STACK_1)) STACK_1 = ThePackage(STACK_1)->pack_name;
  pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL); /* dummies on the stack */
  test_names_args();
  skipSTACK(3);
  var object pack = STACK_2;
  { /* test, if a package-name-conflict arises: */
    var object name = STACK_1;
    var object nicknamelistr = STACK_0;
    /* name loops over the names and all nicknames */
    while (1) { /* find package with this name: */
      var object found = find_package(name);
      if (!(nullp(found) || eq(found,pack))) {
        /* found, but another one than the given package: */
        pushSTACK(pack); /* PACKAGE-ERROR slot PACKAGE */
        pushSTACK(name); pushSTACK(TheSubr(subr_self)->name);
        error(package_error,GETTEXT("~S: there is already a package named ~S"));
      }
      /* none or only the given package has the Name name ->
         no conflict with this (nick)name, continue: */
      if (atomp(nicknamelistr))
        break;
      name = Car(nicknamelistr); /* next nickname */
      nicknamelistr = Cdr(nicknamelistr); /* shorten remaining nicknamelist */
    }
  }
  /* There are no conflicts. */
  set_break_sem_2();
  ThePackage(pack)->pack_name = STACK_1;
  ThePackage(pack)->pack_nicknames = STACK_0;
  clr_break_sem_2();
  ensure_pack_shortest_name(pack);
  skipSTACK(3);
  VALUES1(pack); /* pack as value */
}

LISPFUNNR(package_use_list,1) { /* (PACKAGE-USE-LIST package), CLTL p. 184 */
  var object pack = test_package_arg(popSTACK()); /* argument as package */
  /* copy use-list for safety reasons */
  VALUES1(copy_list(ThePackage(pack)->pack_use_list));
}

LISPFUNNR(package_used_by_list,1)
{ /* (PACKAGE-USED-BY-LIST package), CLTL p. 184 */
  var object pack = test_package_arg(popSTACK()); /* argument as package */
  /* copy used-by-list for safety reasons */
  VALUES1(copy_list(ThePackage(pack)->pack_used_by_list));
}

LISPFUNNR(package_shadowing_symbols,1)
{ /* (PACKAGE-SHADOWING-SYMBOLS package), CLTL p. 184 */
  var object pack = test_package_arg(popSTACK()); /* argument as package */
  /* copy shadowing-list for safety reasons */
  VALUES1(copy_list(ThePackage(pack)->pack_shadowing_symbols));
}

/* (EXT:PACKAGE-CASE-SENSITIVE-P package) */
LISPFUNNR(package_case_sensitive_p,1) {
  var object pack = test_package_arg(popSTACK());
  VALUES_IF(pack_casesensitivep(pack));
}

/* ((SETF EXT:PACKAGE-CASE-SENSITIVE-P) value package) */
LISPFUNN(set_package_case_sensitive_p,2) {
  var object pack = test_package_arg(popSTACK());
  var bool value = !nullp(popSTACK());
  if (value) mark_pack_casesensitive(pack);
  else mark_pack_caseinsensitive(pack);
  VALUES_IF(value);
}

/* (EXT:PACKAGE-CASE-INVERTED-P package) */
LISPFUNNR(package_case_inverted_p,1) {
  var object pack = test_package_arg(popSTACK());
  VALUES_IF(pack_caseinvertedp(pack));
}

/* ((SETF EXT:PACKAGE-CASE-INVERTED-P) value package) */
LISPFUNN(set_package_case_inverted_p,2) {
  var object pack = test_package_arg(popSTACK());
  var bool value = !nullp(popSTACK());
  if (value) mark_pack_caseinverted(pack);
  else mark_pack_casepreserved(pack);
  VALUES_IF(value);
}

/* (SYS::PACKAGE-DOCUMENTATION package) */
LISPFUNNR(package_documentation,1) {
  var object pack = test_package_arg(popSTACK());
  VALUES1(ThePackage(pack)->pack_docstring);
}

/* ((SETF SYS::PACKAGE-DOCUMENTATION) new-value package)
 documentation is either a doc-string or a list (doc-string impnotes-id) */
LISPFUNN(set_package_documentation,2) {
  STACK_0 = test_package_arg(STACK_0);
  if (!listp(STACK_1)) STACK_1 = check_string(STACK_1);
  VALUES1(ThePackage(STACK_0)->pack_docstring = STACK_1);
  skipSTACK(2);
}

LISPFUNNR(package_shortest_name,1)
{ /* (EXT:PACKAGE-SHORTEST-NAME package) */
  var object pack = test_package_arg(popSTACK());
  VALUES1(ThePackage(pack)->pack_shortest_name);
}

LISPFUNNR(package_lock,1)
{ /* (EXT:PACKAGE-LOCK package) */
  var object pack = test_package_arg(popSTACK());
  VALUES_IF(pack_locked_p(pack));
}

/* ((SETF EXT:PACKAGE-LOCK) lock package) */
LISPFUNN(set_package_lock,2) {
  var bool unlock_p = nullp(STACK_1);
  var object pack = STACK_0;
  if (mconsp(pack)) {
    while (mconsp(STACK_0)) {
      var object pa = test_package_arg(Car(STACK_0)); STACK_0 = Cdr(STACK_0);
      if (unlock_p) mark_pack_unlocked(pa);
      else          mark_pack_locked(pa);
    }
  } else if (nullp(pack)) { /* do nothing - package list was empty */
  } else {
    pack = test_package_arg(pack);
    if (unlock_p) mark_pack_unlocked(pack);
    else          mark_pack_locked(pack);
  }
  skipSTACK(2);
  VALUES_IF(!unlock_p);
}

/* barf when SYMBOL is an unaccessible special variable
   being modified from a non-home package.
   See compiler.lisp:set-check-lock.
   can trigger GC */
#define SYM_VAL_LOCK(symbol,pack)                                         \
  (!nullp(pack) && !eq(pack,Symbol_value(S(packagestern))) /* non-home */ \
   && special_var_p(TheSymbol(symbol))  /* special */                     \
   && !externalp(symbol,pack) /* for IN-PACKAGE forms */                  \
   && !accessiblep(symbol,Symbol_value(S(packagestern)))) /* accessible */
global maygc void symbol_value_check_lock (object caller, object symbol) {
  var object pack = Symbol_package(symbol);
  if (SYM_VAL_LOCK(symbol,pack))
    check_pack_lock(caller,pack,symbol);
}
LISPFUNN(symbol_value_lock,1) { /* SYS::SYMBOL-VALUE-LOCK */
  var object symb = check_symbol(popSTACK());
  var object pack = Symbol_package(symb);
  VALUES_IF(SYM_VAL_LOCK(symb,pack) && pack_locked_p(pack));
}

/* (SYSTEM::CHECK-PACKAGE-LOCK caller package symbol)
   when FUNCTION is (P)SETQ, calls symbol_value_check_lock() */
LISPFUNN(check_package_lock,3) {
  if (mconsp(STACK_1)) { /* package is actually a list of packages */
    var bool locked = true;
    var object list = STACK_1;
    /* for the package list to be "locked", _all_ members must be locked
       non-package members mean that the argument was a defmethod spec like
       (eql 1), which means unlocked: you can always redefine such methods */
    while (locked && mconsp(list)) {
      locked = (packagep(Car(list)) ? pack_locked_p(Car(list)) : false);
      list = Cdr(list);
    }
    if (locked) /* all packages are locked --> error */
      cerror_package_locked(STACK_2,STACK_1,STACK_0);
  } else if (packagep(STACK_1)) /* just one package - check it */
    check_pack_lock(STACK_2,STACK_1,STACK_0);
  skipSTACK(3);
  mv_count = 0;
}

LISPFUNNR(list_all_packages,0)
{ /* (LIST-ALL-PACKAGES) returns a list of all packages, CLTL p. 184 */
  VALUES1(reverse(O(all_packages))); /* (copy of the list, as a precaution) */
}

/* UP: check the last argument &optional (pack *package*) of
 a LISP-function.
 test_optional_package_arg()
 > STACK_0: last argument
 < STACK_0: argument transformed into a package
 can trigger GC */
local maygc void test_optional_package_arg (void) {
  var object pack = STACK_0;
  if (!boundp(pack)) {
    STACK_0 = get_current_package(); /* default is the value of *PACKAGE* */
  } else {
    STACK_0 = test_package_arg(pack);
  }
}

/* UP: Check of the arguments of INTERN and FIND-SYMBOL.
 test_intern_args()
 can trigger GC */
local maygc void test_intern_args (void) {
  STACK_1 = check_string(STACK_1); /* test string */
  test_optional_package_arg(); /* test package */
}

/* UP: Transforms a INTERN/FIND-SYMBOL - result into a keyword.
 intern_result(code)
 > code : flag as for intern and find_symbol
 < result : corresponding keyword */
local object intern_result (uintBWL code) {
  switch (code) {
    case 0: { return NIL; }           /* 0 -> NIL */
    case 1: { return S(Kexternal); }  /* 1 -> :EXTERNAL */
    case 2: { return S(Kinherited); } /* 2 -> :INHERITED */
    case 3: { return S(Kinternal); }  /* 3 -> :INTERNAL */
    default: NOTREACHED;
  }
}

/* (INTERN string [package]) and its case-inverted variant */
local maygc Values do_intern (bool invert) {
  test_intern_args(); /* test arguments */
  var object pack = popSTACK();
  var object string = popSTACK();
 #if !defined(VALUE1_EXTRA)
  var uintBWL code = intern(string,invert,pack,&value1); /* symbol to value1 */
 #else
  var object value;
  var uintBWL code = intern(string,invert,pack,&value); /* Symbol to value */
  value1 = value;
 #endif
  value2 = intern_result(code); mv_count=2; /* two values */
}

/* (INTERN string [package]), CLTL p. 184 */
LISPFUN(intern,seclass_default,1,1,norest,nokey,0,NIL) {
  do_intern(false);
}

/* (CS-COMMON-LISP:INTERN string [package]) */
LISPFUN(cs_intern,seclass_default,1,1,norest,nokey,0,NIL) {
  do_intern(true);
}

/* (FIND-SYMBOL string [package]) and its case-inverted variant */
local maygc Values do_find_symbol (bool invert) {
  test_intern_args(); /* test arguments */
  var object pack = popSTACK();
  var object string = popSTACK();
 #if !defined(VALUE1_EXTRA)
  var uintBWL code = find_symbol(string,invert,pack,&value1) & 3; /* symbol to value1 */
 #else
  var object value;
  var uintBWL code = find_symbol(string,invert,pack,&value) & 3; /* symbol to value */
  value1 = value;
 #endif
  value2 = intern_result(code); mv_count=2; /* two values */
}

/* (FIND-SYMBOL string [package]), CLTL p. 185 */
LISPFUN(find_symbol,seclass_read,1,1,norest,nokey,0,NIL)
{
  do_find_symbol(false);
}

/* (CS-COMMON-LISP:FIND-SYMBOL string [package]) */
LISPFUN(cs_find_symbol,seclass_read,1,1,norest,nokey,0,NIL)
{
  do_find_symbol(true);
}

/* (UNINTERN symbol [package]), CLTL p. 185 */
LISPFUN(unintern,seclass_default,1,1,norest,nokey,0,NIL) {
  /* test symbol: */
  STACK_1 = check_symbol(STACK_1);
  /* test package: */
  test_optional_package_arg();
  /* unintern: */
  VALUES1(unintern(&STACK_1,&STACK_0));
  skipSTACK(2);
}

/* UP: Dispatcher of a function like EXPORT, UNEXPORT, IMPORT, SHADOWING-IMPORT
 or SHADOW. tests, if the first argument is a symbol-list, if
 the second argument (default: *PACKAGE*) is a package, and applies the
 subroutine to each of the symbols. Return 1 value T.
 apply_symbols(&fun);
 specification of the subroutine fun:
   fun(&sym,&pack);
   > sym: symbol (in STACK)
   > pack: package (in STACK)
   < pack: package, EQ to the old one
   can trigger GC
 < STACK: cleaned up
 can trigger GC */
typedef maygc void sym_pack_function_t (const gcv_object_t* sym_, const gcv_object_t* pack_);
local maygc Values apply_symbols (sym_pack_function_t* fun) {
  { /* test, if the first argument is a symbol-list or a symbol: */
    var object symarg = STACK_1;
    /* test for symbol: */
    if (symbolp(symarg))
      goto ok;
    if ((fun == &shadow || fun == &cs_shadow)
        && (stringp(symarg) || charp(symarg)))
      goto ok;
    /* test for symbol-list: */
    while (consp(symarg)) { /* symarg loops over STACK_1 */
      if (!(symbolp(Car(symarg))
            || ((fun == &shadow || fun == &cs_shadow)
                && (stringp(Car(symarg)) || charp(Car(symarg))))))
        goto not_ok;
      symarg = Cdr(symarg);
    }
    if (!nullp(symarg))
      goto not_ok; /* list correctly finished? */
    goto ok; /* correct symbol-list */
  not_ok:
    pushSTACK(STACK_1); pushSTACK(TheSubr(subr_self)->name);
    error(error_condition,GETTEXT("~S: argument should be a symbol or a list of symbols, not ~S"));
  ok: ;
  }
  /* test package: */
  test_optional_package_arg();
  /* stack-layout: symarg, pack. */
  /* apply fun to all symbols: */
  if (matomp(STACK_1)) {
    if (nullp(STACK_1)) {
      /* ANSI CL 11.1.1. says
         "Where an operator takes an argument that is either a symbol or a list of
          symbols, an argument of nil is treated as an empty list of symbols." */
    } else {
      /* single symbol */
      /* stack-layout: sym, pack. */
      (*fun)(&STACK_1,&STACK_0);
    }
    skipSTACK(2);
  } else {
    /* non-empty symbol-list */
    pushSTACK(NIL);
    do {
      var object symlistr = STACK_2;
      STACK_2 = Cdr(symlistr);
      STACK_0 = Car(symlistr); /* symbol */
      /* stack-layout: symlistr, pack, sym. */
      (*fun)(&STACK_0,&STACK_1);
    } while (!matomp(STACK_2));
    skipSTACK(3);
  }
  /* finish: */
  VALUES1(T);
}

/* (EXPORT symbols [package]), CLTL p. 186 */
LISPFUN(export,seclass_default,1,1,norest,nokey,0,NIL) {
  return_Values apply_symbols(&export);
}

/* (UNEXPORT symbols [package]), CLTL p. 186 */
LISPFUN(unexport,seclass_default,1,1,norest,nokey,0,NIL) {
  return_Values apply_symbols(&unexport);
}

/* (IMPORT symbols [package]), CLTL p. 186 */
LISPFUN(import,seclass_default,1,1,norest,nokey,0,NIL) {
  return_Values apply_symbols(&import);
}

/* (SHADOWING-IMPORT symbols [package]), CLTL p. 186 */
LISPFUN(shadowing_import,seclass_default,1,1,norest,nokey,0,NIL) {
  return_Values apply_symbols(&shadowing_import);
}

/* (SHADOW symbols [package]), CLTL p. 186 */
LISPFUN(shadow,seclass_default,1,1,norest,nokey,0,NIL) {
  return_Values apply_symbols(&shadow);
}

/* (CS-COMMON-LISP:SHADOW symbols [package]) */
LISPFUN(cs_shadow,seclass_default,1,1,norest,nokey,0,NIL) {
  return_Values apply_symbols(&cs_shadow);
}

/* UP: Preparation of the arguments of USE-PACKAGE and UNUSE-PACKAGE.
 The first argument STACK_1 is turned into a (newly created)
 list of packages, the second argument STACK_0 is checked.
 can trigger GC */
local maygc void prepare_use_package (void) {
  /* check second argument (package) : */
  test_optional_package_arg();
  { /* check first argument (package or package-list) : */
    var object packs_to_use = STACK_1;
    if (!listp(packs_to_use)) {
      /* packs_to_use not a list -> turn it into a one-element list: */
      pushSTACK(test_package_arg(packs_to_use)); /* single package */
      var object new_cons = allocate_cons();
      Car(new_cons) = popSTACK();
      STACK_1 = new_cons;
    } else { /* packs_to_use a list -> build up new package-list: */
      pushSTACK(NIL); /* start with NIL */
      while (mconsp(STACK_2)) {
        var object packlistr = STACK_2;
        STACK_2 = Cdr(packlistr);
        pushSTACK(test_package_arg(Car(packlistr))); /* next package */
        var object new_cons = allocate_cons();
        Car(new_cons) = popSTACK();
        Cdr(new_cons) = STACK_0;
        STACK_0 = new_cons;
      }
      var object packlist = popSTACK(); /* new package-list */
      STACK_1 = packlist;
    }
  }
}

/* (USE-PACKAGE packs-to-use [package]), CLTL p. 187 */
LISPFUN(use_package,seclass_default,1,1,norest,nokey,0,NIL) {
  prepare_use_package();
  var object pack = popSTACK();
  var object packlist = popSTACK();
  use_package(packlist,pack);
  VALUES1(T);
}

/* (UNUSE-PACKAGE packs-to-use [package]), CLTL p. 187 */
LISPFUN(unuse_package,seclass_default,1,1,norest,nokey,0,NIL) {
  prepare_use_package();
  var object pack = popSTACK();
  var object packlist = popSTACK();
  unuse_package(packlist,pack);
  VALUES1(T);
}

/* UP: Corrects a package(nick)name.
 > name: Desired package-name (simple-string)
 > nickname_p: is this a name or a nickname
 < result: not yet existing package-name
           or NIL if CONTINUE restart is selected
 can trigger GC */
local maygc object correct_packname (object name, bool nickname_p) {
  var object pack;
  while (!nullp(pack=find_package(name))) {
    /* package with this name already exists */
    pushSTACK(NIL);             /* OPTIONS */
    pushSTACK(pack);            /* PACKAGE-ERROR slot package */
    pushSTACK(name); pushSTACK(TheSubr(subr_self)->name);
    /* fill OPTIONS */
    pushSTACK(S(continue));     /* restart name */
    pushSTACK(nickname_p ? CLSTEXT("discard this nickname")
              : CLSTEXT("return the existing package"));
    var object tmp = listof(2);
    pushSTACK(tmp);
    pushSTACK(S(read));         /* restart name */
    pushSTACK(nickname_p ? CLSTEXT("input another nickname")
              : CLSTEXT("input another name"));
    pushSTACK(S(prompt_for_new_value)); /* interactive function */
    pushSTACK(NIL); /* place */
    tmp = listof(4);
    pushSTACK(tmp);
    tmp = listof(2); STACK_3 = tmp; /* options list */
    correctable_error(package_error,GETTEXT("~S: a package with name ~S already exists."));
    if (nullp(value1)) return NIL; /* continue */
    name = test_stringsymchar_arg(value1,false);
  }
  return coerce_imm_ss(name);
}

/* UP for MAKE-PACKAGE and %IN-PACKAGE:
 Builds a new package and returns it as value.
 > STACK_4: name-argument
 > STACK_3: nicknames-argument
 > STACK_2: uselist-argument
 > STACK_1: case-sensitive-argument
 > STACK_0: case-inverted-argument
 removes the 5 STACK elements
 can trigger GC */
local maygc void in_make_package (bool case_inverted) {
  /* transform name into simple-string and
     nicknames into a new simple-string-list: */
  test_names_args();
  var object new_name = correct_packname(STACK_4,false);
  if (nullp(new_name)) {     /* CONTINUE: re-use the existing package */
    VALUES1(find_package(STACK_4));
    skipSTACK(5);
    return;
  } else                     /* corrected: replace */
    STACK_4 = new_name;
  /* check nicknames and maybe adjust: */
  pushSTACK(STACK_3);
  while (mconsp(STACK_0)) {
    var object correct_nick = correct_packname(Car(STACK_0),true);
    Car(STACK_0) = correct_nick;
    STACK_0 = Cdr(STACK_0);
  }
  skipSTACK(1);
  STACK_3 = deleteq(STACK_3,NIL);
  /* (DELETE-DUPLICATES NICKNAMES :TEST (FUNCTION STRING=)) */
  pushSTACK(STACK_3); pushSTACK(S(Ktest)); pushSTACK(L(string_eq));
  funcall(L(delete_duplicates),3);
  STACK_3 = value1;
  /* create package: */
  STACK_4 = make_package(STACK_4,STACK_3,
                         boundp(STACK_1) ? !nullp(STACK_1) : case_inverted,
                         boundp(STACK_0) ? !nullp(STACK_0) : case_inverted);
  /* stack-layout: pack, nicknames, uselist, case-sensitive, case-inverted. */
  /* use default value for use-argument: */
  if (!boundp(STACK_2))
    STACK_2 = O(use_default);
  /* execute (USE-PACKAGE uselist newpackage) : */
  pushSTACK(STACK_2); /* uselist */
  pushSTACK(STACK_(4+1)); /* package */
  funcall(L(use_package),2);
  skipSTACK(4);
  VALUES1(popSTACK()); /* package as value */
}

/* (MAKE-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]
                      [:CASE-SENSITIVE sensitivep] [:CASE-INVERTED invertedp]),
 CLTL p. 183 */
LISPFUN(make_package,seclass_default,1,0,norest,key,4,
        (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) {
  in_make_package(false);
}

/* (CS-COMMON-LISP:MAKE-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]
                                     [:CASE-SENSITIVE sensitivep] [:CASE-INVERTED invertedp]) */
LISPFUN(cs_make_package,seclass_default,1,0,norest,key,4,
        (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) {
  in_make_package(true);
}

/* (SYSTEM::%IN-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]
                        [:CASE-SENSITIVE sensitivep] [:CASE-INVERTED invertedp])
 is like (IN-PACKAGE name [:NICKNAMES nicknames] [:USE uselist]), CLTL p. 183,
 except that *PACKAGE* is not modified. */
LISPFUN(pin_package,seclass_default,1,0,norest,key,4,
        (kw(nicknames),kw(use),kw(case_sensitive),kw(case_inverted)) ) {
  /* check name and turn into string: */
  var object name = test_stringsymchar_arg(STACK_4,false);
  STACK_4 = name;
  /* find package with this name: */
  var object pack = find_package(name);
  if (nullp(pack)) { /* package not found, must create a new one */
    in_make_package(false);
  } else { /* package found */
    STACK_4 = pack; /* save pack */
    /* stack-layout: pack, nicknames, uselist, case-sensitive, case-inverted. */
    if (boundp(STACK_1)) { /* check the case-sensitivity: */
      var bool value = !nullp(STACK_1);
      if (!!pack_casesensitivep(pack) != value) {
        pushSTACK(pack); pushSTACK(pack);
        STACK_1 = CLSTEXT("One should not change the case sensitiveness of ~S.");
        funcall(S(warn),2);
        pack = STACK_4;         /* restore for GC-safety */
      }
      if (value) mark_pack_casesensitive(pack);
      else mark_pack_caseinsensitive(pack);
    }
    if (boundp(STACK_0)) { /* check the case-invertedness: */
      var bool value = !nullp(STACK_0);
      if (!!pack_caseinvertedp(pack) != value) {
        pushSTACK(pack); pushSTACK(pack);
        STACK_1 = CLSTEXT("One should not change the case inversion of ~S.");
        funcall(S(warn),2);
        pack = STACK_4;         /* restore for GC-safety */
      }
      if (value) mark_pack_caseinverted(pack);
      else mark_pack_casepreserved(pack);
    }
    /* adjust the nicknames: */
    if (boundp(STACK_3)) {
      /* install nicknames with RENAME-PACKAGE: */
      pushSTACK(pack); /* pack */
      pushSTACK(ThePackage(pack)->pack_name); /* (package-name pack) */
      pushSTACK(STACK_(3+2)); /* nicknames */
      /* (RENAME-PACKAGE pack (package-name pack) nicknames) */
      funcall(L(rename_package),3);
    }
    /* adjust the use-list: */
    if (boundp(STACK_2)) {
      /* extend use-list with USE-PACKAGE
         and shorten with UNUSE-PACKAGE: */
      STACK_1 = STACK_2; /* use-list as 1. argument for USE-PACKAGE */
      STACK_0 = STACK_4; /* pack as 2. argument for USE-PACKAGE */
      prepare_use_package(); /* check arguments STACK_1, STACK_0 */
      /* stack-layout: pack, nicknames, -, new use-list, pack. */
      { /* execute USE-PACKAGE (with copied use-list): */
        var object temp = reverse(STACK_1);
        use_package(temp,STACK_4);
      }
      /* All packages, that are still listed in the use-list of pack,
         but which do not occur in the uselist located in STACK_1,
         are removed with unuse_1package: */
      pack = STACK_4;
      { /* traverse use-list of pack */
        STACK_0 = ThePackage(pack)->pack_use_list;
        while (mconsp(STACK_0)) {
          var object qpack = Car(STACK_0);
          /* search in uselist: */
          if (nullp(memq(qpack,STACK_1)))
            /* not found in uselist */
            unuse_1package(STACK_4,qpack);
          STACK_0 = Cdr(STACK_0);
        }
      }
    }
    /* the use-list is adjusted correctly. */
    skipSTACK(4); /* forget uselist, nicknames etc. */
    VALUES1(popSTACK());
  }
}

local one_sym_function_t delete_package_aux;
/* (DELETE-PACKAGE package), CLTL2 p. 265-266 */
LISPFUNN(delete_package,1) {
  var object pack = popSTACK();
  if (packagep(pack)) {
    if (pack_deletedp(pack)) {
      VALUES1(NIL); return; /* already deleted -> 1 value NIL */
    }
  } else if (stringp(pack))
  string: { /* string -> find package with this name: */
    var object found = find_package(pack);
    if (nullp(found)) {
      /* raise Continuable Error: */
      pushSTACK(NIL); /* "Ignore." */
      pushSTACK(S(package_error)); /* PACKAGE-ERROR */
      pushSTACK(S(Kpackage)); /* :PACKAGE */
      pushSTACK(pack); /* package-name */
      pushSTACK(NIL); /* "~S: A package with name ~S does not exist." */
      pushSTACK(S(delete_package));
      pushSTACK(pack);
      STACK_6 = CLSTEXT("Ignore.");
      STACK_2 = CLSTEXT("~S: There is no package with name ~S.");
      /* (SYS::CERROR-OF-TYPE "..." 'PACKAGE-ERROR :PACKAGE pack "..."
                              'DELETE-PACKAGE pack) */
      funcall(L(cerror_of_type),7);
      VALUES1(NIL);
      return;
    }
    pack = found;
  } else if (symbolp(pack)) { /* symbol -> string */
    pack = Symbol_name(pack); goto string; /* use printname, no case-invert */
  } else if (charp(pack)) { /* character -> string */
    var object new_string = allocate_string(1);
    TheSnstring(new_string)->data[0] = char_code(pack);
    pack = new_string;
    goto string;
  } else
    pack = test_package_arg(pack); /* report error */
  pushSTACK(pack);
  if (!nullp(ThePackage(pack)->pack_used_by_list)) {
    /* raise Continuable Error: */
    pushSTACK(NIL); /* "~*Delete ~S anyway." */
    pushSTACK(S(package_error)); /* PACKAGE-ERROR */
    pushSTACK(S(Kpackage)); /* :PACKAGE */
    pushSTACK(pack); /* package */
    pushSTACK(NIL); /* "~S: ~S is used by ~{~S~^, ~}." */
    pushSTACK(S(delete_package));
    pushSTACK(pack);
    pushSTACK(ThePackage(pack)->pack_used_by_list);
    STACK_7 = CLSTEXT("~*Delete ~S anyway.");
    STACK_3 = CLSTEXT("~S: ~S is used by ~{~S~^, ~}.");
    /* (SYS::CERROR-OF-TYPE "..." 'PACKAGE-ERROR :PACKAGE pack "..."
                            'DELETE-PACKAGE pack used-by-list) */
    funcall(L(cerror_of_type),8);
  }
  /* execute (DOLIST (p used-py-list) (UNUSE-PACKAGE pack p)) : */
  set_break_sem_3();
  while ((pack = STACK_0, mconsp(ThePackage(pack)->pack_used_by_list))) {
    unuse_1package(Car(ThePackage(pack)->pack_used_by_list),pack);
  }
  clr_break_sem_3();
  /* execute (UNUSE-PACKAGE (package-use-list pack) pack) : */
  unuse_package(ThePackage(STACK_0)->pack_use_list,pack);
  /* apply delete_package_aux to the symbols present in pack: */
  map_symtab_c(&delete_package_aux,&STACK_0,
               ThePackage(STACK_0)->pack_external_symbols);
  map_symtab_c(&delete_package_aux,&STACK_0,
               ThePackage(STACK_0)->pack_internal_symbols);
  pack = popSTACK();
  /* remove pack from the list of all packages and mark as deleted: */
  set_break_sem_2();
  O(all_packages) = deleteq(O(all_packages),pack);
  mark_pack_deleted(pack);
  clr_break_sem_2();
  VALUES1(T);
}

/* UP: Auxiliary function for DELETE-PACKAGE:
 Remove the argument (a present symbol) from pack.
 can trigger GC */
local maygc void delete_package_aux (void* data, object sym) {
  var gcv_object_t* localptr = (gcv_object_t*)data; /* pointer to pack */
  pushSTACK(sym); unintern(&STACK_0,localptr); skipSTACK(1);
}

/* (FIND-ALL-SYMBOLS name) and its case-inverted variant */
local maygc Values do_find_all_symbols (bool invert) {
  STACK_0 = test_stringsymchar_arg(STACK_0,invert); /* name as string */
  pushSTACK(NIL); /* (so far empty) symbol-list */
  pushSTACK(O(all_packages)); /* traverse list of all packages */
  while (mconsp(STACK_0)) {
    var object pack = Car(STACK_0); /* next package */
    /* search in its internal and external symbols: */
    var object sym;
    if (package_lookup(STACK_2,invert,pack,&sym,)) {
      /* found: symbol sym is present in package pack,
         cons with (pushnew sym STACK_1 :test #'eq) on the symbol-list:
         Search, if the found symbol sym occurs in STACK_1: */
      if (nullp(memq(sym,STACK_1))) { /* not found, must cons: */
        pushSTACK(sym);
        {
          var object new_cons = allocate_cons();
          Car(new_cons) = popSTACK();
          Cdr(new_cons) = STACK_1;
          STACK_1 = new_cons;
        }
      }
    }
    STACK_0 = Cdr(STACK_0);
  }
  skipSTACK(1);
  VALUES1(popSTACK()); /* symbol-list as value */
  skipSTACK(1);
}

/* (FIND-ALL-SYMBOLS name), CLTL p. 187 */
LISPFUNNR(find_all_symbols,1)
{
  do_find_all_symbols(false);
}

/* (CS-COMMON-LISP:FIND-ALL-SYMBOLS name) */
LISPFUNNR(cs_find_all_symbols,1)
{
  do_find_all_symbols(true);
}

local one_sym_function_t map_symbols_aux;
/* (SYSTEM::MAP-SYMBOLS fun pack)
 applies the function fun to all accessible symbols in pack. Value NIL. */
LISPFUNN(map_symbols,2) {
  /* check second argument: */
  STACK_0 = test_package_arg(STACK_0);
  /* apply fun to all internal symbols: */
  map_symtab(STACK_1,ThePackage(STACK_0)->pack_internal_symbols);
  /* apply fun to all external symbols: */
  map_symtab(STACK_1,ThePackage(STACK_0)->pack_external_symbols);
  /* apply fun to all inherited symbols: */
  pushSTACK(ThePackage(STACK_0)->pack_use_list); /* traverse use-list */
  while (mconsp(STACK_0)) {
    var object usedpack = Car(STACK_0); /* next package from the use-list */
    STACK_0 = Cdr(STACK_0);
    map_symtab_c(&map_symbols_aux,&STACK_1,
                 ThePackage(usedpack)->pack_external_symbols);
  }
  skipSTACK(3);
  VALUES1(NIL);
}

/* UP: Auxiliary function for map_symbols:
 Test, if the argument is not shadowed in the given package, and
 then apply the given function.
 can trigger GC */
local maygc void map_symbols_aux (void* data, object sym) {
  var gcv_object_t* localptr = (gcv_object_t*)data;
  /* Pointer to local variables of map_symbols:
     *(localptr STACKop 1) = fun,
     *(localptr STACKop 0) = pack.
     The symbol STACK_0 is shadowed, if and only if a different
     symbol of the same name is located in the
     shadowing-list of pack. */
  var object shadowingsym;
  if (!(shadowing_lookup(Symbol_name(sym),false,*(localptr STACKop 0),&shadowingsym)
        && !eq(shadowingsym,sym))) {
    pushSTACK(sym); funcall(*(localptr STACKop 1),1);
  } else {
    /* symbol is shadowed in pack -> do not call function */
  }
}

/* (SYSTEM::MAP-EXTERNAL-SYMBOLS fun pack)
   applies the function fun to all external symbols in pack. Value NIL. */
LISPFUNN(map_external_symbols,2) {
  /* check second argument: */
  var object pack = test_package_arg(popSTACK());
  /* apply fun to all external symbols: */
  map_symtab(popSTACK(),ThePackage(pack)->pack_external_symbols);
  VALUES1(NIL);
}

/* (SYSTEM::MAP-ALL-SYMBOLS fun)
 applies the function fun to all symbols present in any package. */
LISPFUNN(map_all_symbols,1) {
  pushSTACK(O(all_packages)); /* traverse package-list */
  while (mconsp(STACK_0)) {
    var object pack = Car(STACK_0); /* next package */
    STACK_0 = Cdr(STACK_0);
    pushSTACK(pack); /* save */
    /* apply fun to all internal symbols: */
    map_symtab(STACK_2,ThePackage(pack)->pack_internal_symbols);
    pack = popSTACK();
    /* apply fun to all external symbols: */
    map_symtab(STACK_1,ThePackage(pack)->pack_external_symbols);
  }
  skipSTACK(2);
  VALUES1(NIL);
}

/* UP: Subroutine for EXT:RE-EXPORT.
 Exports a single symbol from TO-PACK. */
local void export_symbol_from (void *data, object sym) {
  var gcv_object_t* pack_ = (gcv_object_t*)data; /* points into the STACK */
  pushSTACK(sym);
  export(&STACK_0,pack_);
  skipSTACK(1);
}

/* (EXT:RE-EXPORT "FROM-PACK" "TO-PACK")
 export all external symbols in FROM-PACK from TO-PACK */
LISPFUNN(re_export,2) {
  STACK_1 = test_package_arg(STACK_1); /* FROM-PACK */
  STACK_0 = test_package_arg(STACK_0); /* TO-PACK */
  /* TO-PACK must be already using FROM-PACK */
  var object pack_u_l = ThePackage(STACK_0)->pack_use_list;
  if (nullp(memq(STACK_1,ThePackage(STACK_0)->pack_use_list))) {
    pushSTACK(STACK_0); /* TO-PACK: PACKAGE slot of PACKAGE-ERROR */
    pushSTACK(STACK_2); /* FROM-PACK */
    pushSTACK(STACK_1); /* TO-PACK */
    pushSTACK(S(re_export));
    error(package_error,GETTEXT("~S: ~S is not using ~S"));
  }
  map_symtab_c(&export_symbol_from,&STACK_0,
               ThePackage(STACK_1)->pack_external_symbols);
  VALUES1(NIL);
  skipSTACK(2);
}

/* Auxiliary functions for WITH-PACKAGE-ITERATOR, CLtL2 p. 275, and LOOP:
 (SYSTEM::PACKAGE-ITERATOR package flags) returns an internal state
 for iterating through the package.
 (SYSTEM::PACKAGE-ITERATE internal-state) iterates through a package by
 one, thereby changes the internal-state and returns: three values
 T, symbol, accessibility of the next symbols resp. 1 value NIL at the end. */

LISPFUNN(package_iterator,2) {
  STACK_1 = test_package_arg(STACK_1); /* check package-argument */
  /* An internal state consists of a vector
     #(entry index symtab inh-packages package flags)
     whereby flags is a sub-list of (:INTERNAL :EXTERNAL :INHERITED) ,
         package is the original package,
         inh-packages is a sub-list of (package-use-list package) ,
         symtab is a symbol-table or NIL,
         index is an Index in symtab,
         entry is the rest of an entry in symtab. */
  var object state = allocate_vector(6);
  /* TheSvector(state)->data[2] = NIL; */ /* invalid */
  TheSvector(state)->data[3] = ThePackage(STACK_1)->pack_use_list;
  TheSvector(state)->data[4] = STACK_1;
  TheSvector(state)->data[5] = STACK_0;
  VALUES1(state); skipSTACK(2); /* state as value */
}

LISPFUNN(package_iterate,1) {
  var object state = popSTACK(); /* internal state */
  /* hopefully a 6er-vector */
  if (simple_vector_p(state) && (Svector_length(state) == 6)) {
    /* state = #(entry index symtab inh-packages package flags) */
    var object symtab = TheSvector(state)->data[2];
    if (simple_vector_p(symtab)) {
      if (false) {
      search1:
        TheSvector(state)->data[2] = symtab;
        TheSvector(state)->data[1] = Symtab_size(symtab);
        TheSvector(state)->data[0] = NIL;
      }
    search2:
      {
        var object entry = TheSvector(state)->data[0];
      search3:
        /* continue search within entry: */
        if (consp(entry)) {
          TheSvector(state)->data[0] = Cdr(entry);
          value2 = Car(entry); goto found;
        } else if (!nullp(entry)) {
          TheSvector(state)->data[0] = NIL;
          value2 = entry; goto found;
        }
        if (false) {
        found:
          /* Found a symbol value.
             Verify that is it accessible in pack and, if :INHERITED
             is requested,
             1. not hidden by a different symbol (which must be on the
                shadowing-list of pack),
             2. itself not already present in pack (because in this case
                the accessibility would be :INTERNAL or :EXTERNAL). */
          {
            var object shadowingsym;
            if (!(eq(Car(TheSvector(state)->data[5]),S(Kinherited))
                  && (shadowing_lookup(Symbol_name(value2),false,
                                       TheSvector(state)->data[4],
                                       &shadowingsym)
                      || symtab_find(value2,
                                     ThePackage(TheSvector(state)->data[4])->
                                     pack_internal_symbols)
                      || symtab_find(value2,
                                     ThePackage(TheSvector(state)->data[4])->
                                     pack_external_symbols)))) {
              /* Symbol value2 is really accessible. */
              value1 = T; value3 = Car(TheSvector(state)->data[5]);
              mv_count=3; return;
            }
            goto search2;
          }
        }
        /* entry became =NIL -> go to next Index */
        {
          var uintL index = posfixnum_to_V(TheSvector(state)->data[1]);
          if (index > 0) {
            TheSvector(state)->data[1] = fixnum_inc(TheSvector(state)->
                                                    data[1],-1);
            index--;
            /* check index as a precaution */
            entry = (index < (uintL)posfixnum_to_V(Symtab_size(symtab))
                     ? (object)TheSvector(Symtab_table(symtab))->data[index]
                     : NIL);
            goto search3;
          }
        }
      }
      /* index became =0 -> go to next table */
      if (eq(Car(TheSvector(state)->data[5]),S(Kinherited))) {
      search4:
        if (mconsp(TheSvector(state)->data[3])) {
          /* go to next element of the list inh-packages */
          symtab = ThePackage(Car(TheSvector(state)->data[3]))->
            pack_external_symbols;
          TheSvector(state)->data[3] = Cdr(TheSvector(state)->data[3]);
          goto search1;
        }
      }
    search5:
      /* go to next element of flags */
      TheSvector(state)->data[5] = Cdr(TheSvector(state)->data[5]);
    }
    var object flags = TheSvector(state)->data[5];
    if (consp(flags)) {
      var object flag = Car(flags);
      if (eq(flag,S(Kinternal))) { /* :INTERNAL */
        symtab = ThePackage(TheSvector(state)->data[4])->
          pack_internal_symbols;
        goto search1;
      } else if (eq(flag,S(Kexternal))) { /* :EXTERNAL */
        symtab = ThePackage(TheSvector(state)->data[4])->
          pack_external_symbols;
        goto search1;
      }
      else if (eq(flag,S(Kinherited))) { /* :INHERITED */
        goto search4;
      }
      goto search5; /* skip invalid flag */
    }
  }
  VALUES1(NIL); return;
}

/* UP: initialize the package list
 init_packages();
 can trigger GC */
global maygc void init_packages (void) {
  O(all_packages) = NIL; /* ALL_PACKAGES := NIL */
  { /* #<PACKAGE CS-COMMON-LISP-USER>: */
    pushSTACK(coerce_imm_ss(ascii_to_string("CS-COMMON-LISP-USER")));
    pushSTACK(coerce_imm_ss(ascii_to_string("CS-CL-USER")));
    /* Provide nickname "CS-USER" for similarity with package "COMMON-LISP-USER". */
    pushSTACK(coerce_imm_ss(ascii_to_string("CS-USER")));
    var object nicks = listof(2); /* ("CS-CL-USER" "CS-USER") */
    O(modern_user_package) = make_package(popSTACK(),nicks,true,true); /* "CS-COMMON-LISP-USER" */
  }
  { /* #<PACKAGE CS-COMMON-LISP>: */
    pushSTACK(coerce_imm_ss(ascii_to_string("CS-COMMON-LISP")));
    pushSTACK(coerce_imm_ss(ascii_to_string("CS-CL")));
    /* Provide nickname "CS-LISP" for similarity with package "COMMON-LISP". */
    pushSTACK(coerce_imm_ss(ascii_to_string("CS-LISP")));
    var object nicks = listof(2); /* ("CS-CL" "CS-LISP") */
    make_package(popSTACK(),nicks,true,true); /* "CS-COMMON-LISP" */
  }
  /* #<PACKAGE CHARSET>: */
  pushSTACK(coerce_imm_ss(ascii_to_string("CHARSET")));
  O(charset_package) = make_package(popSTACK(),NIL,false,false); /* "CHARSET",() */
  /* #<PACKAGE KEYWORD>: */
  pushSTACK(coerce_imm_ss(ascii_to_string("KEYWORD")));
  O(keyword_package) = make_package(popSTACK(),NIL,false,false); /* "KEYWORD" */
  { /* #<PACKAGE SYSTEM>: */
    pushSTACK(coerce_imm_ss(ascii_to_string("SYSTEM")));
    pushSTACK(coerce_imm_ss(ascii_to_string("COMPILER")));
    pushSTACK(coerce_imm_ss(ascii_to_string("SYS")));
    var object nicks = listof(2); /* ("COMPILER" "SYS") */
    make_package(popSTACK(),nicks,false,false); /* "SYSTEM" */
  }
  { /* #<PACKAGE COMMON-LISP-USER>: */
    pushSTACK(coerce_imm_ss(ascii_to_string("COMMON-LISP-USER")));
    pushSTACK(coerce_imm_ss(ascii_to_string("CL-USER")));
    pushSTACK(coerce_imm_ss(ascii_to_string("USER")));
    var object nicks = listof(2); /* ("CL-USER" "USER") */
    make_package(popSTACK(),nicks,false,false); /* "COMMON-LISP-USER" */
  }
  { /* #<PACKAGE COMMON-LISP>: */
    pushSTACK(coerce_imm_ss(ascii_to_string("COMMON-LISP")));
    pushSTACK(coerce_imm_ss(ascii_to_string("LISP")));
    pushSTACK(coerce_imm_ss(ascii_to_string("CL")));
    var object nicks = listof(2); /* ("LISP" "CL") */
    O(default_package) = make_package(popSTACK(),nicks,false,false); /* "COMMON-LISP" */
  }
  /* Created all basic packages.
     Now append all further packages to the end of O(all_packages). */
  nreverse(O(all_packages));
 #define LISPPACK  LISPPACK_B
  #include "constpack.c"
 #undef LISPPACK
  nreverse(O(all_packages));
}