/* xlsym - symbol handling routines */
/* Copyright (c) 1989, by David Michael Betz. */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution. */
#include "xlisp.h"
/* forward declarations */
#ifdef PACKAGES
LOCAL VOID fail_message P5H(char *, LVAL, LVAL, LVAL, LVAL);
LOCAL LVAL adjoin P2H(LVAL, LVAL);
LOCAL int check_export_conflicts P2H(LVAL, LVAL);
LOCAL VOID check_use_conflicts P2H(LVAL, LVAL);
LOCAL VOID check_unintern_conflicts P2H(LVAL, LVAL);
LOCAL LVAL makepackage P1H(char *);
LOCAL VOID check_nicknames P2H(LVAL, LVAL);
LOCAL VOID add_nickname P2H(char *, LVAL);
LOCAL VOID set_nicknames P2H(LVAL, LVAL);
LOCAL VOID xlunexport P2H(LVAL, LVAL);
LOCAL VOID use_package P2H(LVAL, LVAL);
LOCAL VOID unuse_package P2H(LVAL, LVAL);
LOCAL int xlunintern P2H(LVAL, LVAL);
LOCAL int findsym P3H(char *, LVAL, LVAL *);
LOCAL VOID xlshadow P2H(char *, LVAL);
LOCAL VOID xlshadowingimport P2H(LVAL, LVAL);
LOCAL LVAL intern P3H(char *, LVAL, int);
LOCAL VOID unintern P3H(LVAL, LVAL, int);
LOCAL LVAL packop P1H(int);
#endif /* PACKAGES */
#ifdef PACKAGES
/* xlenter - enter an external symbol in the current package */
#define ENTER_PACK_SIZE 50
LVAL xlenter P1C(char *, name)
{
LVAL sym, pack;
int export = TRUE;
char *p;
/***** should this also shadow if there is a conflict? */
if (name[0] == ':') { /* keyword package */
name++; /* skip colon */
pack = xlkeypack;
}
else if ((p = strchr(name, ':')) != NULL
&& p - name < ENTER_PACK_SIZE) { /* '<' leaves room for null byte */
char pbuf[ENTER_PACK_SIZE];
memcpy(pbuf, name, p - name);
pbuf[p - name] = 0;
if (p[1] == ':') { /* '::' means make internal */
name = p + 2;
export = FALSE;
}
else name = p + 1; /* ':' means make external */
if (null(pack = xlfindpackage(pbuf))) {
pack = makepackage(pbuf);
obarray = cons(pack, obarray); /* register the package */
}
}
else {
pack = getvalue(s_package);
}
if (xlfindsymbol(name, pack, &sym) == SYM_NOT_FOUND)
sym = intern(name, pack, export);
return sym;
}
#else
/* xlenter - enter a symbol into the obarray */
LVAL xlenter P1C(char *, name)
{
LVAL sym,array;
int i;
/* check for symbol already in table */
array = getvalue(obarray);
i = hash(name,HSIZE);
for (sym = getelement(array,i); consp(sym); sym = cdr(sym))
if (STRCMP(name,getstring(getpname(car(sym)))) == 0)
return (car(sym));
/* make a new symbol node and link it into the list */
xlsave1(sym);
sym = consd(getelement(array,i));
rplaca(sym,xlmakesym(name));
setelement(array,i,sym);
xlpop();
/* return the new symbol */
return (car(sym));
}
#endif /* PACKAGES */
/* xlmakesym - make a new symbol node */
LVAL xlmakesym P1C(char *, name)
{
LVAL sym;
sym = cvsymbol(name);
#ifdef PACKAGES
setsnormal(sym);
#else
if (*name == ':') {
setvalue(sym,sym);
setsconstant(sym);
}
else setsnormal(sym);
#endif /* PACKAGES */
return (sym);
}
/* xlgetvalue - get the value of a symbol (with check) */
LVAL xlgetvalue P1C(LVAL, sym)
{
LVAL val;
/* look for the value of the symbol */
while ((val = xlxgetvalue(sym)) == s_unbound)
xlunbound(sym);
/* return the value */
return (val);
}
/* xlcopytree - local version of COPY-TREE */
LOCAL LVAL xlcopytree P1C(LVAL, x)
{
if (consp(x)) {
LVAL val;
#ifdef STSZ /* This function is a good candidate for stack ov */
stchck();
#endif
xlsave1(val);
val = cons(NIL, NIL);
rplaca(val, xlcopytree(car(x)));
rplacd(val, xlcopytree(cdr(x)));
xlpop();
return val;
}
else return x;
}
#define symbol_macro_binding_p(ep) \
cdr(car(ep)) == k_symbol_macro && consp(cdr(ep)) \
&& car(car(cdr(ep))) == k_symbol_macro
LOCAL LVAL symbol_macro_value P1C(LVAL, form)
{
/* Need to copy the form in case eval splices in macros.
Protecting the form may not be necessary, but do it
anyway just to be safe. */
LVAL val;
xlprot1(form);
form = xlcopytree(form);
val = xleval(form);
xlpop();
return val;
}
LOCAL VOID set_symbol_macro P2C(LVAL, place, LVAL, val)
{
/* Need to copy the place in case eval splices in macros.
Protecting the place may not be necessary, but do it anyway just
to be safe. */
LVAL form;
static LVAL s_setf = NULL;
if (s_setf == NULL) s_setf = xlenter("XLISP::SETF");
xlsave1(form);
xlprot1(place);
place = xlcopytree(place);
/* This builds up an expression of the form `(setf ,place (quote ,val)). */
form = consa(val);
form = cons(s_quote, form);
form = consa(form);
form = cons(place, form);
form = cons(s_setf, form);
xleval(form);
xlpopn(2);
}
/* xlxgetvalue - get the value of a symbol */
LVAL xlxgetvalue P1C(LVAL, sym)
{
register LVAL fp,ep;
LVAL val;
/* check the environment list */
for (fp = xlenv; consp(fp); fp = cdr(fp))
/* check for an instance variable */
if (!null(ep = car(fp)) && objectp(car(ep))) {
if (xlobgetvalue(ep,sym,&val))
return (val);
}
/* check an environment stack frame */
else {
for (; consp(ep); ep = cdr(ep))
if (sym == car(car(ep))) {
if (symbol_macro_binding_p(ep))
return symbol_macro_value(cdr(car(cdr(ep))));
else return cdr(car(ep));
}
}
/* return the global value */
if (! boundp(sym) && ! specialp(sym) &&
(ep = findprop(getplist(sym), k_symbol_macro)) != NIL)
return symbol_macro_value(car(ep));
else return (getvalue(sym));
}
/* xlsetvalue - set the value of a symbol */
VOID xlsetvalue P2C(LVAL, sym, LVAL, val)
{
register LVAL fp,ep;
if (constantp(sym)) {
xlnoassign(sym);
/* never returns */
}
/* look for the symbol in the environment list */
for (fp = xlenv; consp(fp); fp = cdr(fp))
/* check for an instance variable */
if (!null(ep = car(fp)) && objectp(car(ep))) {
if (xlobsetvalue(ep,sym,val))
return;
}
/* check an environment stack frame */
else {
for (; consp(ep); ep = cdr(ep))
if (sym == car(car(ep))) {
if (symbol_macro_binding_p(ep))
set_symbol_macro(cdr(car(cdr(ep))), val);
else
rplacd(car(ep),val);
return;
}
}
/* store the global value */
if (! boundp(sym) && ! specialp(sym) &&
(ep = findprop(getplist(sym), k_symbol_macro)) != NIL)
set_symbol_macro(car(ep), val);
else
setvalue(sym,val);
}
/* xlgetfunction - get the functional value of a symbol (with check) */
LVAL xlgetfunction P1C(LVAL, sym)
{
LVAL val;
/* look for the functional value of the symbol */
while ((val = xlxgetfunction(sym)) == s_unbound)
xlfunbound(sym);
/* return the value */
return (val);
}
/* xlxgetfunction - get the functional value of a symbol */
LVAL xlxgetfunction P1C(LVAL, sym)
{
register LVAL fp,ep;
/* check the environment list */
for (fp = xlfenv; consp(fp); fp = cdr(fp))
for (ep = car(fp); consp(ep); ep = cdr(ep))
if (sym == car(car(ep)))
return (cdr(car(ep)));
/* return the global value */
return (getfunction(sym));
}
/* xlgetprop - get the value of a property */
LVAL xlgetprop P2C(LVAL, sym, LVAL, prp)
{
LVAL p;
return (null(p = findprop(getplist(sym),prp)) ? NIL : car(p));
}
/* xlputprop - put a property value onto the property list */
VOID xlputprop P3C(LVAL, sym, LVAL, val, LVAL, prp)
{
LVAL pair;
if (!null(pair = findprop(getplist(sym),prp)))
rplaca(pair,val);
else
setplist(sym,cons(prp,cons(val,getplist(sym))));
}
/* xlremprop - remove a property from a property list */
VOID xlremprop P2C(LVAL, sym, LVAL, prp)
{
LVAL last,p;
last = NIL;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
if (car(p) == prp)
if (!null(last))
rplacd(last,cdr(cdr(p)));
else
setplist(sym,cdr(cdr(p)));
last = cdr(p);
}
}
/* findprop - find a property pair */
LVAL findprop P2C(LVAL, p, LVAL, prp)
{
for (; consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
if (car(p) == prp)
return (cdr(p));
return (NIL);
}
/* hash - hash a symbol name string */
int hash P2C(char *, str, int, len)
{
int i;
for (i = 0; *str; )
i = (i << 1) ^ *str++;
i %= len;
return (i < 0 ? -i : i);
}
/* xlhash -- hash any xlisp object */
/* TAA extension */
int xlhash P2C(LVAL, obj, int, len)
{
int i;
unsigned long tot;
union {FIXTYPE i; float j; unsigned FIXTYPE k;} swizzle;
hashloop: /* iterate on conses */
switch (ntype(obj)) {
case SYMBOL:
obj = getpname(obj);
case STRING:
return hash(getstring(obj),len);
case TVEC:
{
int n = getslength(obj);
char *str = getstring(obj);
for (tot = 0; n > 0; n--)
tot = (tot << 1) ^ *str++;
return tot;
}
case SUBR: case FSUBR:
return getoffset(obj) % len;
case FIXNUM:
swizzle.i = getfixnum(obj);
return (int) (swizzle.k % len);
case FLONUM:
swizzle.j = (float)(getflonum(obj));
return (int) (swizzle.k % len);
case CHAR:
return getchcode(obj) % len;
case CONS:
case USTREAM:
obj = car(obj); /* just base on CAR */
goto hashloop;
case DARRAY:
obj = getdarraydata(obj);
goto hashloop;
case STREAM:
case ADATA:
return 0; /* nothing we can do on this */
case COMPLEX:
return (xlhash(getreal(obj), len)+xlhash(getimag(obj), len) % len);
#ifdef BIGNUMS
case RATIO:
return (xlhash(getnumer(obj),len)+xlhash(getdenom(obj),len) % len);
case BIGNUM:
{ BIGNUMDATA *xd = getbignumarray(obj);
for (i = getbignumsize(obj), tot = 0; i-- > 0;)
tot += xd[i];
return (int)(tot % len);
}
#endif
case OBJECT:
/* Bandaid: class contains a reference to itself - JK */
if (obj == cls_class)
return 123 % len; /* pick a random value */
/* else fall through... */
default:
if (ntype(obj) >= ARRAY) { /* all array types */
for (i = getsize(obj), tot = 0; i-- > 0;)
tot += (unsigned)xlhash(getelement(obj,i),len);
return (int)(tot % len);
}
else
return 0; /* nothing we can do on this */
}
}
/* unbind a variable/constant */
LVAL xmakunbound(V)
{
LVAL sym;
sym = xlgasymbol();
xllastarg();
if (constantp(sym))
xlerror("can't unbind constant", sym);
setvalue(sym, s_unbound);
setsnormal(sym);
return(sym);
}
/* unbind a function */
LVAL xfmakunbound(V)
{
LVAL sym;
sym = xlgasymbol();
xllastarg();
setfunction(sym,s_unbound);
return(sym);
}
/* define a constant -- useful in initialization */
VOID defconstant P2C(LVAL, sym, LVAL, val)
{
setvalue(sym, val);
setsconstant(sym);
}
/* DEFCONSTANT DEFPARAMETER and DEFVAR */
LVAL xdefconstant(V)
{
LVAL sym, val, doc;
sym = xlgasymbol();
val = xlgetarg();
doc = (moreargs()) ? xlgastring() : NIL;
xllastarg();
/* evaluate constant value */
val = xleval(val);
if (null(sym)) xlfail("can't redefine NIL");
if (specialp(sym)) {
if (constantp(sym)) {
if (!eql(getvalue(sym),val)) {
errputstr("WARNING-- redefinition of constant ");
errprint(sym);
}
}
else xlerror("can't make special variable into a constant", sym);
}
if (doc != NIL && getvalue(s_keepdocs) != NIL)
xlputprop(sym, doc, s_vardoc);
defconstant(sym, val);
return(sym);
}
LVAL xdefparameter(V)
{
LVAL sym, val, doc;
sym = xlgasymbol();
val = xlgetarg();
doc = (moreargs()) ? xlgastring() : NIL;
xllastarg();
if (constantp(sym)) xlnoassign(sym);
setvalue(sym, xleval(val));
setsspecial(sym);
if (doc != NIL && getvalue(s_keepdocs) != NIL)
xlputprop(sym, doc, s_vardoc);
return(sym);
}
LVAL xdefvar(V)
{
LVAL sym, val=NIL, doc=NIL;
int setval = FALSE;
sym = xlgasymbol();
if (moreargs()) {
val = xlgetarg();
setval = TRUE;
}
if (moreargs()) doc = xlgastring();
xllastarg();
if (constantp(sym)) xlnoassign(sym);
if (setval && getvalue(sym) == s_unbound) setvalue(sym, xleval(val));
setsspecial(sym);
if (doc != NIL && getvalue(s_keepdocs) != NIL)
xlputprop(sym, doc, s_vardoc);
return(sym);
}
/* xlsinit - symbol initialization routine */
VOID xlsinit(V)
{
#ifdef PACKAGES
/* initialize the package list */
obarray = NIL;
/* make the system packages */
xlisppack = makepackage("XLISP");
obarray = cons(xlisppack, obarray);
add_nickname("LISP", xlisppack);
add_nickname("COMMON-LISP", xlisppack);
add_nickname("CL", xlisppack);
add_nickname("SYSTEM", xlisppack);
xlkeypack = makepackage("KEYWORD");
obarray = cons(xlkeypack, obarray);
xluserpack = makepackage("USER");
obarray = cons(xluserpack, obarray);
add_nickname("COMMON-LISP-USER", xluserpack);
add_nickname("CL-USER", xluserpack);
use_package(xlisppack, xluserpack);
/* add the package symbol */
s_package = xlmakesym("*PACKAGE*");
setpackage(s_package, xlisppack);
setsvalue(s_package,xlisppack);
xlimport(s_package, xlisppack);
xlexport(s_package, xlisppack);
#else
LVAL array,p;
/* initialize the obarray */
obarray = xlmakesym("*OBARRAY*");
array = newvector(HSIZE);
setsvalue(obarray,array);
/* add the symbol *OBARRAY* to the obarray */
p = consa(obarray);
setelement(array,hash("*OBARRAY*",HSIZE),p);
#endif /* PACKAGES */
}
/* added - L. Tierney */
int syminterned P1C(LVAL, sym)
{
#ifdef PACKAGES
return(! null(getpackage(sym)) ? TRUE : FALSE);
#else
char *name;
LVAL list, array;
name = (char *) getstring(getpname(sym));
array = getvalue(obarray);
list = getelement(array, hash(name, HSIZE));
for (; consp(list); list = cdr(list))
if (sym == car(list)) return(TRUE);
return(FALSE);
#endif /* PACKAGES */
}
#ifdef PACKAGES
LVAL xldelete1 P2C(LVAL, x, LVAL, list)
{
LVAL val, next;
if (consp(list)) {
if (x == car(list)) {
val = cdr(list);
}
else {
val = list;
for (next = cdr(list); consp(next); list = next, next = cdr(next)) {
if (x == car(next)) {
rplacd(list, cdr(next));
break;
}
}
}
}
else val = NIL;
return(val);
}
LOCAL LVAL adjoin P2C(LVAL, x, LVAL, list)
{
LVAL next;
for (next = list; consp(next); next = cdr(next))
if (x == car(next))
return(list);
return(cons(x, list));
}
LOCAL VOID fail_message P5C(char *, msg, LVAL, arg1, LVAL, arg2, LVAL, arg3, LVAL, arg4)
{
FRAMEP oldargv = xlargv;
int oldargc = xlargc;
LVAL msgarg;
/* check if there's room for the new call frame (4 slots needed) */
if (xlsp >= (xlargstktop-4)) xlargstkoverflow();
xlprot1(msgarg);
msgarg = cvstring(msg);
xlargv = xlsp; /* We will cheat badly with this call */
xlargc = 4;
*xlsp++ = arg1;
*xlsp++ = arg2;
*xlsp++ = arg3;
*xlsp++ = arg4;
xlformat(msgarg, getvalue(s_debugio));
xlsp -= 4;
xlargv = oldargv;
xlargc = oldargc;
xlpop();
}
LOCAL int check_export_conflicts P2C(LVAL, sym, LVAL, pack)
{
LVAL list, fsym;
char *name;
int failure = FALSE;
name = getstring(getpname(sym));
for (list = getusedby(pack); consp(list); list = cdr(list))
if (xlfindsymbol(name, car(list), &fsym) &&
sym != fsym &&
! findsym(name, getshadowing(car(list)), &fsym)) {
fail_message(
"~&Name conflict with ~s in ~s~% when exporting ~s from ~s",
fsym, car(list), sym, pack);
failure = TRUE;
}
return failure;
}
LOCAL VOID check_use_conflicts P2C(LVAL, pack_to_use, LVAL, pack)
{
LVAL array, list, sym, fsym;
char *name;
int i;
int failure = FALSE;
do {
if (failure) {
xlcerror("recheck for conflicts", "name conflicts", s_unbound);
failure = FALSE;
}
for (i = 0; i < HSIZE; i++) {
array = getextsyms(pack_to_use);
for (list = getelement(array, i); consp(list); list = cdr(list)) {
sym = car(list);
name = getstring(getpname(sym));
if (xlfindsymbol(name, pack, &fsym) &&
sym != fsym &&
! findsym(name, getshadowing(pack), &fsym)) {
fail_message("~&Name conflict of ~s and ~s~% when using ~s in ~s",
sym, fsym, pack_to_use, pack);
failure = TRUE;
}
}
}
} while (failure);
}
LOCAL VOID check_unintern_conflicts P2C(LVAL, sym, LVAL, pack)
{
LVAL uselist, list, fsym1, fsym2;
int found, i;
char *name;
name = getstring(getpname(sym));
if (findsym(name, getshadowing(pack), &fsym1)) {
i = hash(name,HSIZE);
found = FALSE;
for (uselist = getuses(pack); consp(uselist); uselist = cdr(uselist)) {
list = getelement(getextsyms(car(uselist)), i);
if (findsym(name, list, &fsym2)) {
if (found) {
if (fsym1 != fsym2) {
fail_message(
"~&Name conflict of ~s and ~s~% when uninterning ~s from ~s",
fsym1, fsym2, sym, pack);
xlerror("name conflict", s_unbound);
/* I didn't make this continuable, since it should be a rare error
and the fix to continue is problematic (for the xlisp user) */
}
}
else {
found = TRUE;
fsym2 = fsym1;
}
}
}
}
}
/* make and install a new package -- does not check for an existing package */
LOCAL LVAL makepackage P1C(char *, name)
{
LVAL pack;
xlsave1(pack);
pack = newpackage();
setpacknames(pack, consa(cvstring(name)));
xlpop();
return(pack);
}
VOID xlimport P2C(LVAL, sym, LVAL, pack)
{
LVAL list, fsym;
int found, i;
found = xlfindsymbol(getstring(getpname(sym)), pack, &fsym);
if (found == SYM_NOT_FOUND || found == SYM_INHERITED) {
/* enter the symbol as an internal symbol */
i = hash(getstring(getpname(sym)),HSIZE);
list = cons(sym, getelement(getintsyms(pack),i));
setelement(getintsyms(pack),i,list);
}
}
VOID xlexport P2C(LVAL, sym, LVAL, pack)
{
LVAL fsym, list;
int found, i;
found = xlfindsymbol(getstring(getpname(sym)), pack, &fsym);
if (found == SYM_NOT_FOUND || fsym != sym)
/* (error "~s not accessible from ~s" sym pack) */
xlerror("symbol not accessible", sym);
else if (found == SYM_INTERNAL) {
/* move it from internal to external */
i = hash(getstring(getpname(sym)),HSIZE);
list = xldelete1(sym, getelement(getintsyms(pack), i));
setelement(getintsyms(pack), i, list);
list = cons(sym, getelement(getextsyms(pack), i));
setelement(getextsyms(pack),i,list);
}
else if (found == SYM_INHERITED) {
/* import it and make it external */
i = hash(getstring(getpname(sym)),HSIZE);
list = cons(sym,getelement(getextsyms(pack), i));
setelement(getextsyms(pack),i,list);
}
}
LOCAL VOID xlunexport P2C(LVAL, sym, LVAL, pack)
{
LVAL fsym, list;
int i;
char *name;
name = getstring(getpname(sym));
if (xlfindsymbol(name, pack, &fsym) == SYM_EXTERNAL && sym == fsym) {
i = hash(name, HSIZE);
list = xldelete1(sym, getelement(getextsyms(pack), i));
setelement(getextsyms(pack), i, list);
list = cons(sym, getelement(getintsyms(pack), i));
setelement(getintsyms(pack),i,list);
}
/***** We should check for internal and sym != fsym and give an error
message in that case *********/
}
LOCAL LVAL intern P3C(char *, name, LVAL, pack, int, export)
{
LVAL sym, list, array;
int i;
if (pack == xlkeypack) export = TRUE;
/* make a new symbol and enter it as an internal or external symbol */
xlsave1(sym);
sym = xlmakesym(name);
if (export)
while(check_export_conflicts(sym, pack))
xlcerror("recheck for conflicts", "name conflict", s_unbound);
i = hash(name,HSIZE);
array = (export) ? getextsyms(pack) : getintsyms(pack);
list = cons(sym, getelement(array,i));
setelement(array,i,list);
setpackage(sym,pack);
xlpop();
if (pack == xlkeypack) {
setvalue(sym,sym);
setsconstant(sym);
}
return(sym);
}
LOCAL VOID unintern P3C(LVAL, sym, LVAL, pack, int, external)
{
LVAL array, list;
int i;
array = (external) ? getextsyms(pack) : getintsyms(pack);
i = hash(getstring(getpname(sym)), HSIZE);
list = getelement(array, i);
setelement(array, i, xldelete1(sym, list));
if (pack == getpackage(sym))
setpackage(sym, NIL);
setshadowing(pack, xldelete1(sym, getshadowing(pack)));
}
LVAL xlintern P2C(char *, name, LVAL, pack)
{
LVAL sym;
if (! goodpackagep(pack)) sym = NIL;
else if (! xlfindsymbol(name, pack, &sym))
sym = intern(name, pack, FALSE);
return(sym);
}
LOCAL int xlunintern P2C(LVAL, sym, LVAL, pack)
{
LVAL fsym;
char *name;
int found, val;
name = getstring(getpname(sym));
found = xlfindsymbol(name, pack, &fsym);
if (sym == fsym && (found == SYM_INTERNAL || found == SYM_EXTERNAL)) {
check_unintern_conflicts(sym, pack);
unintern(sym, pack, (found == SYM_EXTERNAL) ? TRUE : FALSE);
val = TRUE;
}
else val = FALSE;
return(val);
}
LVAL xlfindpackage P1C(char *, name)
{
LVAL list, names, pack;
for (list = obarray; consp(list); list = cdr(list)) {
pack = car(list);
for (names = getpacknames(pack); consp(names); names = cdr(names)) {
if (STRCMP(name,getstring(car(names))) == 0)
return(pack);
}
}
return(NIL);
}
LOCAL int findsym P3C(char *, name, LVAL, list, LVAL *, psym)
{
for (; consp(list); list = cdr(list))
if (STRCMP(name,getstring(getpname(car(list)))) == 0) {
if (psym != NULL) *psym = car(list);
return(TRUE);
}
return(FALSE);
}
int xlfindsymbol P3C(char *, name, LVAL, pack, LVAL *, psym)
{
LVAL list;
int i;
i = hash(name,HSIZE);
if (findsym(name, getelement(getintsyms(pack),i), psym))
return(SYM_INTERNAL);
else if (findsym(name, getelement(getextsyms(pack), i), psym))
return(SYM_EXTERNAL);
else {
for (list = getuses(pack); consp(list); list = cdr(list))
if (findsym(name, getelement(getextsyms(car(list)),i), psym))
return(SYM_INHERITED);
return(SYM_NOT_FOUND);
}
}
LOCAL VOID check_nicknames P2C(LVAL, list, LVAL, pack)
{
LVAL s, p;
if (!listp(list)) /* TAA added error check 10/93 */
xlerror("must be a list", list);
for (; consp(list); list = cdr(list)) {
s = car(list);
if (! stringp(s) && ! symbolp(s))
xlerror("not a string or symbol", s);
p = xlfindpackage(getstring(symbolp(s) ? getpname(s) : s));
if (!null(p) && p != pack)
xlerror("package already exists", s);
}
}
LOCAL VOID add_nickname P2C(char *, name, LVAL, pack)
{
LVAL nlist, rest;
nlist = getpacknames(pack);
if (consp(nlist)) {
rest = cdr(nlist);
rplacd(nlist, consa(cvstring(name)));
rplacd(cdr(nlist), rest);
}
}
LOCAL VOID set_nicknames P2C(LVAL, pack, LVAL, names)
{
LVAL nlist, s;
nlist = getpacknames(pack);
if (consp(nlist)) {
rplacd(nlist, NIL);
for (; consp(names); names = cdr(names)) {
s = car(names);
add_nickname(getstring((symbolp(s) ? getpname(s) : s)), pack);
}
}
}
LVAL xlpackagename P1C(LVAL, pack)
{
if (goodpackagep(pack))
return(car(getpacknames(pack)));
else
return(getpname(NIL));
}
LOCAL VOID use_package P2C(LVAL, pack_to_use, LVAL, pack)
{
if (pack != pack_to_use && pack != xlkeypack && pack_to_use != xlkeypack) {
check_use_conflicts(pack_to_use, pack);
setuses(pack, adjoin(pack_to_use, getuses(pack)));
setusedby(pack_to_use, adjoin(pack, getusedby(pack_to_use)));
}
}
LOCAL VOID unuse_package P2C(LVAL, pack_to_unuse, LVAL, pack)
{
if (pack != pack_to_unuse) {
setuses(pack, xldelete1(pack_to_unuse, getuses(pack)));
setusedby(pack_to_unuse, xldelete1(pack, getusedby(pack_to_unuse)));
}
}
LVAL xlgetpackage P1C(LVAL, arg)
{
LVAL pack;
if (stringp(arg)) pack = xlfindpackage(getstring(arg));
else if (symbolp(arg)) pack = xlfindpackage(getstring(getpname(arg)));
else pack = arg;
if (! packagep(pack))
xlerror("package not found", arg);
if (null(getpacknames(pack)))
xlfail("deleted package");
return(pack);
}
LOCAL VOID xlshadow P2C(char *, name, LVAL, pack)
{
LVAL sym;
int found;
/* don't allow shadowing of keywords */
if (pack == xlkeypack) return;
found = xlfindsymbol(name, pack, &sym);
if (found == SYM_NOT_FOUND || found == SYM_INHERITED)
sym = intern(name, pack, FALSE);
setshadowing(pack, adjoin(sym, getshadowing(pack)));
}
LOCAL VOID xlshadowingimport P2C(LVAL, sym, LVAL, pack)
{
LVAL fsym, array;
int found, i;
char *name;
/* don't allow shadowing of keywords */
if (pack == xlkeypack) return;
name = getstring(getpname(sym));
found = xlfindsymbol(name, pack, &fsym);
if ((found == SYM_INTERNAL || found == SYM_EXTERNAL) && fsym != sym)
unintern(fsym, pack, (found == SYM_EXTERNAL) ? TRUE : FALSE);
if (found == SYM_INHERITED || found == SYM_NOT_FOUND || fsym != sym) {
i = hash(name, HSIZE);
array = getintsyms(pack);
setelement(array, i, cons(sym, getelement(array, i)));
}
setshadowing(pack, adjoin(sym, getshadowing(pack)));
}
/* TAA MOD 10/96 -- modified to not create package if there is any error
function setuselist() no longer needed */
LVAL xmakepackage(V)
{
LVAL name, nicknames, uselist, pack;
char *str;
name = xlgastrorsym();
if (xlgetkeyarg(k_nicknames, &nicknames))
check_nicknames(nicknames, NIL);
else nicknames = NIL;
if (xlgetkeyarg(k_use, &uselist)) {
LVAL temp;
/* TAA added 10/93 to catch error */
if (!listp(uselist)) xlerror("must be a list", uselist);
for (temp = uselist; consp(temp); temp = cdr(temp))
if (xlgetpackage(car(temp)) == xlkeypack)
xlfail("can't explicitly use KEYWORD package");
}
else
uselist = NIL;
xllastkey();
str = getstring(symbolp(name) ? getpname(name) : name);
if (!null(xlfindpackage(str))) xlerror("package already exists", name);
pack = makepackage(str);
xlprot1(pack);
set_nicknames(pack, nicknames);
for (; consp(uselist); uselist = cdr(uselist))
use_package(xlgetpackage(car(uselist)), pack);
xlpop();
/* All is ok -- make package real */
obarray = cons(pack, obarray);
return(pack);
}
LVAL xinpackage(V)
{
LVAL name, pack;
name = xlgastrorsym();
xllastarg();
pack = xlfindpackage(getstring(symbolp(name) ? getpname(name) : name));
if (null(pack)) xlerror("package not found", name);
if (! goodpackagep(pack)) xlerror ("bad package", pack);
setvalue(s_package, pack);
return(pack);
}
enum {
EXPORT_POP,
UNEXPORT_POP,
IMPORT_POP,
SHADOW_POP,
SHADOWING_IMPORT_POP,
USE_PACKAGE_POP,
UNUSE_PACKAGE_POP
};
LOCAL LVAL packop P1C(int, which)
{
LVAL arg, arglist, pack;
arglist = xlgetarg();
pack = xlgetpackage(moreargs() ? xlgetarg() : getvalue(s_package));
xllastarg();
if (! goodpackagep(pack)) xlerror ("bad package", pack);
xlprot1(arglist);
if (! consp(arglist)) arglist = consa(arglist);
/* TAA MOD 10/96 -- do error checking in advance as much as is practical */
for (arg = arglist; consp(arg); arg = cdr(arg)) {
if (which == USE_PACKAGE_POP || which == UNUSE_PACKAGE_POP) {
/* signals error if invalid */
if (xlgetpackage(car(arg))==xlkeypack && which==USE_PACKAGE_POP)
xlfail("can't explicitly use KEYWORD package");
}
else if (!(symbolp(car(arg)) ||
(which == SHADOW_POP && stringp(car(arg)))))
xlbadtype(car(arg));
}
if (pack == xlkeypack) {
if (which == UNEXPORT_POP) xlfail("can't unexport in KEYWORD package");
/* ignore in other cases */
xlpop();
return(s_true);
}
if (which == IMPORT_POP) {
LVAL fsym;
int failflag = FALSE;
do {
if (failflag) {
xlcerror("try importing again", "name conflict", s_unbound);
failflag = FALSE;
}
for (arg = arglist; consp(arg); arg = cdr(arg)) {
if (xlfindsymbol(getstring(getpname(car(arg))), pack, &fsym) &&
fsym != car(arg)) {
fail_message("~&Name conflict importing ~s into ~s",
car(arg),pack,NIL,NIL);
failflag = TRUE;
}
}
} while (failflag);
}
else if (which == EXPORT_POP) {
int failflag = FALSE;
do {
if (failflag) {
xlcerror("recheck for conflicts", "name conflict", s_unbound);
failflag = FALSE;
}
for (arg = arglist; consp(arg); arg = cdr(arg)) {
if (check_export_conflicts(car(arg), pack))
failflag = TRUE;
}
} while (failflag);
}
/* TAA Mod 10/96 -- remainder of code doesn't have error checks */
for (; consp(arglist); arglist = cdr(arglist)) {
arg = car(arglist);
switch (which) {
case EXPORT_POP:
xlexport(arg, pack);
break;
case UNEXPORT_POP:
xlunexport(arg, pack);
break;
case IMPORT_POP:
xlimport(arg, pack);
break;
case SHADOW_POP:
xlshadow(getstring(symbolp(arg) ? getpname(arg) : arg), pack);
break;
case SHADOWING_IMPORT_POP:
xlshadowingimport(arg, pack);
break;
case USE_PACKAGE_POP:
use_package(xlgetpackage(arg), pack);
break;
case UNUSE_PACKAGE_POP:
unuse_package(xlgetpackage(arg), pack);
break;
}
}
xlpop();
return(s_true);
}
LVAL xexport(V) { return(packop(EXPORT_POP)); }
LVAL xunexport(V) { return(packop(UNEXPORT_POP)); }
LVAL ximport(V) { return(packop(IMPORT_POP)); }
LVAL xshadow(V) { return(packop(SHADOW_POP)); }
LVAL xshadowingimport(V) { return(packop(SHADOWING_IMPORT_POP)); }
LVAL xusepackage(V) { return(packop(USE_PACKAGE_POP)); }
LVAL xunusepackage(V) { return(packop(UNUSE_PACKAGE_POP)); }
LVAL xfindpackage(V)
{
LVAL name, pack;
name = xlgetarg();
xllastarg();
if (stringp(name)) pack = xlfindpackage(getstring(name));
else if (symbolp(name)) pack = xlfindpackage(getstring(getpname(name)));
else pack = name;
return(goodpackagep(pack) ? pack : NIL);
}
LVAL xfindsymbol(V)
{
LVAL name, pack, sym;
int found;
name = xlgastring();
pack = xlgetpackage(moreargs() ? xlgetarg() : getvalue(s_package));
xllastarg();
found = xlfindsymbol(getstring(name), pack, &sym);
if (! found) sym = NIL;
#ifdef MULVALS
xlnumresults = 2;
xlresults[0] = sym;
switch (found) {
case SYM_INTERNAL: xlresults[1] = k_internal; break;
case SYM_EXTERNAL: xlresults[1] = k_external; break;
case SYM_INHERITED: xlresults[1] = k_inherited; break;
default: xlresults[1] = NIL;
}
#endif /* MULVALS */
return(sym);
}
LVAL xpackageuselist(V)
{
LVAL pack;
pack = xlgetpackage(xlgetarg());
xllastarg();
return(copylist(getuses(pack)));
}
LVAL xpackageusedbylist(V)
{
LVAL pack;
pack = xlgetpackage(xlgetarg());
xllastarg();
return(copylist(getusedby(pack)));
}
LVAL xpackageshadows(V)
{
LVAL pack;
pack = xlgetpackage(xlgetarg());
xllastarg();
return(copylist(getshadowing(pack)));
}
LVAL xpackagename(V)
{
LVAL pack;
pack = xlgetpackage(xlgetarg());
xllastarg();
return(car(getpacknames(pack)));
}
LVAL xpackagenicknames(V)
{
LVAL pack;
pack = xlgetpackage(xlgetarg());
xllastarg();
return(cdr(copylist(getpacknames(pack))));
}
LVAL xpackageobarray(V)
{
LVAL pack;
int external;
pack = xlgetpackage(xlgetarg());
if (moreargs())
external = (null(xlgetarg())) ? FALSE : TRUE;
else
external = TRUE;
xllastarg();
return(external ? getextsyms(pack) : getintsyms(pack));
}
LVAL xpackagevalidp(V)
{
LVAL pack;
pack = xlgetarg();
return(goodpackagep(pack) ? s_true : NIL);
}
LVAL xunintern(V)
{
LVAL sym, pack;
sym =xlgasymbol();
pack = xlgetpackage(moreargs() ? xlgetarg() : getvalue(s_package));
xllastarg();
return(xlunintern(sym, pack) ? s_true : NIL);
}
LVAL xlistallpackages(V)
{
LVAL val, list;
xllastarg();
xlsave1(val);
for (val = NIL, list = obarray; consp(list); list = cdr(list))
val = cons(car(list), val);
xlpop();
return(val);
}
LVAL xdeletepackage(V)
{
LVAL pack, list, array;
int i;
pack = xlgetpackage(xlgetarg());
xllastarg();
if (pack == xlisppack || pack == xlkeypack)
return(NIL);
if (pack == getvalue(s_package))
xlfail("can't delete the current package");
if (! null(getusedby(pack)))
xlerror("package is used", getusedby(pack));
if (! null(getuses(pack)))
for (list = getuses(pack); consp(list); list = cdr(list))
unuse_package(car(list), pack);
for (i = 0; i < HSIZE; i++) {
array = getintsyms(pack);
for (list = getelement(array, i); consp(list); list = cdr(list))
if (getpackage(car(list)) == pack)
setpackage(car(list), NIL);
setelement(array, i, NIL);
array = getextsyms(pack);
for (list = getelement(array, i); consp(list); list = cdr(list))
if (getpackage(car(list)) == pack)
setpackage(car(list), NIL);
setelement(array, i, NIL);
}
setshadowing(pack, NIL);
setpacknames(pack, NIL);
for (list = obarray; consp(list); list = cdr(list))
if (pack == car(list)) {
obarray = xldelete1(pack, obarray);
return(s_true);
}
return(NIL);
}
LVAL xrenamepackage(V)
{
LVAL pack, name, nicknames, p;
pack = xlgetpackage(xlgetarg());
name = xlgastrorsym();
nicknames = (moreargs()) ? xlgalist() : NIL;
xllastarg();
if (symbolp(name)) name = getpname(name);
if (pack == xlisppack || pack == xlkeypack || pack == xluserpack) {
name = car(getpacknames(pack));
}
p = xlfindpackage(getstring(name));
if (!null(p) && p != pack)
xlerror("packages already exists", name);
check_nicknames(nicknames, pack);
setpacknames(pack, consa(name));
set_nicknames(pack, nicknames);
return(pack);
}
LVAL xfindallsymbols(V)
{
LVAL arg, val, sym, packs;
char *name;
arg = xlgastrorsym();
xllastarg();
name = getstring(symbolp(arg) ? getpname(arg) : arg);
xlsave1(val);
for (val = NIL, packs = obarray; consp(packs); packs = cdr(packs))
if (xlfindsymbol(name, car(packs), &sym))
val = adjoin(sym, val);
xlpop();
return(val);
}
/* xsympackage - get the package name of a symbol */
LVAL xsympackage(V)
{
LVAL sym;
/* get the symbol */
sym = xlgasymbol();
xllastarg();
/* return the print name */
return (getpackage(sym));
}
#endif /* PACKAGES */
LVAL xinstallfun(V)
{
LVAL symbol = xlgasymbol();
LVAL fun = xlgetarg();
LVAL def = moreargs() ? xlgetarg() : NIL;
LVAL env = moreargs() ? xlgetarg() : NIL;
xllastarg();
switch (ntype(fun)) {
case BCCLOSURE:
if (getbcname(getbcccode(fun)) == NIL)
setbcname(getbcccode(fun), symbol);
if (def != NIL && getbcdef(getbcccode(fun)) == NIL)
setbcdef(getbcccode(fun), cons(def,env));
break;
case CLOSURE:
if (getname(fun) == NIL)
setname(fun, symbol);
break;
}
setfunction(symbol, fun);
return symbol;
}
syntax highlighted by Code2HTML, v. 0.9.1