/src/package.d

Large files files are truncated, but you can click here to view the full file

/*
 * 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(t…

Large files files are truncated, but you can click here to view the full file