NODE *memberp_help(NODE *args, BOOLEAN notp, BOOLEAN substr) {
NODE *obj1, *obj2, *val;
int leng;
int caseig = varTrue(Caseignoredp);
val = FalseName();
obj1 = car(args);
obj2 = cadr(args);
if (is_list(obj2)) {
if (substr) return FalseName();
while (obj2 != NIL && NOT_THROWING) {
if (equalp_help(obj1, car(obj2), caseig))
return (notp ? obj2 : TrueName());
obj2 = cdr(obj2);
if (check_throwing) break;
}
return (notp ? NIL : FalseName());
}
else if (nodetype(obj2) == ARRAY) {
int len = getarrdim(obj2);
NODE **data = getarrptr(obj2);
if (notp)
err_logo(BAD_DATA_UNREC,obj2);
if (substr) return FalseName();
while (--len >= 0 && NOT_THROWING) {
if (equalp_help(obj1, *data++, caseig)) return TrueName();
}
return FalseName();
} else {
NODE *tmp;
int i;
if (aggregate(obj1)) return (notp ? Null_Word : FalseName());
setcar (cdr(args), cnv_node_to_strnode(obj2));
obj2 = cadr(args);
setcar (args, cnv_node_to_strnode(obj1));
obj1 = car(args);
tmp = NIL;
if (obj1 != UNBOUND && obj2 != UNBOUND &&
getstrlen(obj1) <= getstrlen(obj2) &&
(substr || (getstrlen(obj1) == 1))) {
leng = getstrlen(obj2) - getstrlen(obj1);
setcar(cdr(args),make_strnode(getstrptr(obj2), getstrhead(obj2),
getstrlen(obj1), nodetype(obj2),
strnzcpy));
tmp = cadr(args);
for (i = 0; i <= leng; i++) {
if (equalp_help(obj1, tmp, caseig)) {
if (notp) {
setstrlen(tmp,leng+getstrlen(obj1)-i);
return tmp;
} else return TrueName();
}
setstrptr(tmp, getstrptr(tmp) + 1);
}
}
return (notp ? Null_Word : FalseName());
}
}
NODE *loneof(NODE *args) {
NODE *val = UNBOUND, *argcopy;
if (!is_list(car(args))) {
setcar(args, cons(car(args), NIL));
}
/* now the first arg is always a list of objects */
/* make sure they're really objects */
argcopy = car(args);
while (argcopy != NIL && NOT_THROWING) {
while (!is_object(car(argcopy)) && NOT_THROWING) {
setcar(argcopy, err_logo(BAD_DATA, car(argcopy)));
}
argcopy = cdr(argcopy);
}
if (NOT_THROWING) {
val = newobj();
setparents(val, car(args));
/* apply [[InitList] [Exist Output Self]] cdr(args) */
return make_cont(withobject_continuation,
cons(val,
make_cont(begin_apply,
cons(askexist,
cons(cons(cdr(args), NIL),
NIL)))));
}
return val;
}
NODE *string_arg(NODE *args) {
NODE *arg = car(args), *val;
val = cnv_node_to_strnode(arg);
while (val == UNBOUND && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
val = cnv_node_to_strnode(arg);
}
setcar(args,val);
return(val);
}
NODE *char_arg(NODE *args) {
NODE *arg = car(args), *val;
val = cnv_node_to_strnode(arg);
while ((val == UNBOUND || getstrlen(val) != 1) && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
val = cnv_node_to_strnode(arg);
}
setcar(args,val);
return(val);
}
NODE *litem(NODE *args) {
int i;
NODE *obj, *val;
val = integer_arg(args);
obj = cadr(args);
while ((obj == NIL || obj == Null_Word) && NOT_THROWING) {
setcar(cdr(args), err_logo(BAD_DATA, obj));
obj = cadr(args);
}
if (NOT_THROWING) {
i = getint(val);
if (is_list(obj)) {
if (i <= 0) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
while (--i > 0) {
obj = cdr(obj);
if (obj == NIL) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
}
return car(obj);
}
else if (nodetype(obj) == ARRAY) {
i -= getarrorg(obj);
if (i < 0 || i >= getarrdim(obj)) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
return (getarrptr(obj))[i];
}
else {
if (i <= 0) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
setcar (cdr(args), cnv_node_to_strnode(obj));
obj = cadr(args);
if (i > getstrlen(obj)) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
return make_strnode(getstrptr(obj) + i - 1, getstrhead(obj),
1, nodetype(obj), strnzcpy);
}
}
return(UNBOUND);
}
SymeList
symeTwins(Syme syme)
{
static SymeList symes0 = listNil(Syme);
SymeList symes;
if (symes0 == listNil(Syme))
symes0 = listCons(Syme)((Syme) NULL, symes0);
if (symeHasTrigger(syme) && symeHasLocal(syme, SYFI_Twins)) {
symeClrTrigger(syme);
libGetAllSymes(symeLib(syme));
}
/* Use symeFull(syme) as an implicit twin if present. */
symes = symeLocalTwins(syme);
if (symeFullTwin(syme)) {
Syme osyme = symeFull(syme);
if (symes == listNil(Syme)) {
setcar(symes0, osyme);
symes = symes0;
}
else if (!listMemq(Syme)(symes, osyme)) {
symes = listCons(Syme)(osyme, symes);
symeSetTwins(syme, symes);
}
}
return symes;
}
NODE *lpprop(NODE *args)
{
NODE *plname, *pname, *newval, *plist, *val = NIL;
plname = string_arg(args);
pname = string_arg(cdr(args));
newval = car(cddr(args));
if (NOT_THROWING)
{
plname = intern(plname);
if (flag__caseobj(plname, PLIST_TRACED))
{
ndprintf(writestream, "Pprop %s %s %s", maybe_quote(plname),
maybe_quote(pname), maybe_quote(newval));
if (ufun != NIL)
ndprintf(writestream, " in %s\n%s", ufun, this_line);
new_line(writestream);
}
plist = plist__caseobj(plname);
if (plist != NIL)
val = getprop(plist, pname, FALSE);
if (val != NIL)
setcar(cdr(val), newval);
else
setplist__caseobj(plname, cons(pname, cons(newval, plist)));
}
return (UNBOUND);
}
NODE *lkindof(NODE *args) {
NODE *argcopy = args;
NODE *val = UNBOUND;
if (is_list(car(args))) {
if (cdr(args) != NIL) {
err_logo(TOO_MUCH, NIL); /* too many inputs */
}
args = car(args);
}
/* now args is always a list of objects */
/* make sure they're all really objects */
for (argcopy = args; (argcopy != NIL && NOT_THROWING);
argcopy = cdr(argcopy)) {
while (!is_object(car(argcopy)) && NOT_THROWING) {
setcar(argcopy, err_logo(BAD_DATA, car(argcopy)));
}
}
if (NOT_THROWING) {
val = newobj();
setparents(val, args);
}
return val;
}
NODE *lbutlast(NODE *args) {
NODE *val = UNBOUND, *lastnode = NIL, *tnode, *arg;
arg = bfable_arg(args);
if (NOT_THROWING) {
if (is_list(arg)) {
args = arg;
val = NIL;
while (cdr(args) != NIL) {
tnode = cons(car(args), NIL);
if (val == NIL) {
val = tnode;
lastnode = tnode;
} else {
setcdr(lastnode, tnode);
lastnode = tnode;
}
args = cdr(args);
if (check_throwing) break;
}
} else {
setcar(args, cnv_node_to_strnode(arg));
arg = car(args);
if (getstrlen(arg) > 1)
val = make_strnode(getstrptr(arg),
getstrhead(arg),
getstrlen(arg) - 1,
nodetype(arg),
strnzcpy);
else
val = Null_Word;
}
}
return(val);
}
NODE *lsentence(NODE *args) {
NODE *tnode = NIL, *lastnode = NIL, *val = NIL, *arg = NIL;
while (args != NIL && NOT_THROWING) {
arg = car(args);
while (nodetype(arg) == ARRAY && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
}
args = cdr(args);
if (stopping_flag == THROWING) break;
if (is_list(arg)) {
if (args == NIL) { /* 5.2 */
if (val == NIL) val = arg;
else setcdr(lastnode, arg);
break;
} else while (arg != NIL && NOT_THROWING) {
tnode = cons(car(arg), NIL);
arg = cdr(arg);
if (val == NIL) val = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
}
} else {
tnode = cons(arg, NIL);
if (val == NIL) val = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
}
}
if (stopping_flag == THROWING) {
return UNBOUND;
}
return(val);
}
void filesave(char *temp)
{
FILE *tmp;
NODE *arg;
int save_yield_flag;
if (::FindWindow(NULL, "Editor"))
{
MainWindowx->CommandWindow->MessageBox("Did you know you have an edit session running?\n\nAny changes in this edit session are not being saved.", "Information", MB_OK | MB_ICONQUESTION);
}
arg = cons(make_strnode(temp, NULL, strlen(temp), STRING, strnzcpy), NIL);
tmp = writestream;
writestream = open_file(car(arg), "w+");
if (writestream != NULL)
{
save_yield_flag = yield_flag;
yield_flag = 0;
lsetcursorwait();
setcar(arg, cons(lcontents(), NIL));
lpo(car(arg));
fclose(writestream);
IsDirty = 0;
lsetcursorarrow();
yield_flag = save_yield_flag;
}
else
err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
writestream = tmp;
}
/* Creates a new object */
NODE *newobj(void) {
NODE *result = newnode(OBJECT);
NODE *binding = newnode(CONS);
setcar(binding, theName(Name_licenseplate));
setobject(binding, newplate());
setvars(result, binding);
return result;
}
void spush(NODE *obj, NODE **stack) {
NODE *temp = newnode(CONS);
setcar(temp, obj);
temp->n_cdr = *stack;
ref(temp);
*stack = temp;
}
NODE *cons(NODE *x, NODE *y)
{
NODE *val = newnode(CONS);
setcar(val, x);
setcdr(val, y);
return(val);
}
NODE *list_arg(NODE *args) {
NODE *arg = car(args);
while (!(arg == NIL || is_list(arg)) && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
}
return arg;
}
/* Changes to Object the object in which subsequent top level instruction will
* be run until the next time TalkTo is run
* @params - Object
*/
NODE *ltalkto(NODE *args) {
while (!is_object(car(args)) && NOT_THROWING)
setcar(args, err_logo(BAD_DATA, car(args)));
if (NOT_THROWING)
current_object = car(args);
return UNBOUND;
}
NODE *bfable_arg(NODE *args) {
NODE *arg = car(args);
while ((arg == NIL || arg == UNBOUND || arg == Null_Word ||
nodetype(arg) == ARRAY) && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
}
return arg;
}
LISP evallist (LISP expr, LISP ctx)
{
LISP val, tail;
tail = val = cons (NIL, NIL);
for (;;) {
setcar (tail, eval (car (expr), &ctx));
if (! istype (expr = cdr (expr), TPAIR))
return (val);
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
/* Runs RunList, with Object as the current object for the duration of the
* Ask. After RunList finishes, the current object reverts to what it was
* before the Ask.
* @params - Object RunList
*/
NODE *lask(NODE *args) {
while (!is_object(car(args)) && NOT_THROWING)
setcar(args, err_logo(BAD_DATA, car(args)));
if (NOT_THROWING) {
return make_cont(withobject_continuation,
cons(car(args),
make_cont(begin_seq, cadr(args))));
}
return UNBOUND;
}
LISP quasiquote (LISP expr, LISP ctx, int level)
{
LISP val, tail, func, v;
if (! istype (expr, TPAIR))
return (expr);
if (istype (func = car (expr), TSYMBOL)) {
char *funcname = symname (func);
if (!strcmp (funcname, "quasiquote")) {
v = !istype (v = cdr (expr), TPAIR) ? NIL :
quasiquote (car (v), ctx, level+1);
return (cons (func, cons (v, NIL)));
}
if (!strcmp (funcname, "unquote") ||
!strcmp (funcname, "unquote-splicing")) {
if (!istype (v = cdr (expr), TPAIR))
return (level ? expr : NIL);
if (level)
return (cons (func, cons (quasiquote (car (v),
ctx, level-1), NIL)));
return (eval (car (v), &ctx));
}
}
tail = val = cons (NIL, NIL);
for (;;) {
v = car (expr);
if (! istype (v, TPAIR))
setcar (tail, v);
else if (istype (func = car (v), TSYMBOL) &&
!strcmp (symname (func), "unquote-splicing")) {
if (!istype (v = cdr (v), TPAIR)) {
if (level)
setcar (tail, car (expr));
} else if (level)
setcar (tail, cons (func,
cons (quasiquote (car (v), ctx,
level-1), NIL)));
else {
v = eval (car (v), &ctx);
if (istype (v, TPAIR)) {
LISP newtail;
setcar (tail, car (v));
setcdr (tail, copy (cdr (v), &newtail));
tail = newtail;
} else if (v != NIL) {
setcar (tail, v);
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
} else
setcar (tail, quasiquote (v, ctx, level));
if (! istype (expr = cdr (expr), TPAIR)) {
setcdr (tail, expr);
return (val);
}
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
NODE *lrunparse(NODE *args) {
NODE *arg;
arg = car(args);
while (nodetype(arg) == ARRAY && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
}
if (NOT_THROWING && !aggregate(arg))
arg = parser(arg, TRUE);
if (NOT_THROWING)
return runparse(arg);
return UNBOUND;
}
NODE *integer_arg(NODE *args) {
NODE *arg = car(args), *val;
FIXNUM i;
FLONUM f;
val = cnv_node_to_numnode(arg);
while ((nodetype(val) != INT) && NOT_THROWING) {
if (nodetype(val) == FLOATT &&
fmod((f = getfloat(val)), 1.0) == 0.0 &&
f >= -(FLONUM)MAXLOGOINT && f < (FLONUM)MAXLOGOINT) {
i = (FIXNUM)f;
val = make_intnode(i);
break;
}
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
val = cnv_node_to_numnode(arg);
}
setcar(args,val);
if (nodetype(val) == INT) return(val);
return UNBOUND;
}
NODE *lsave(NODE *arg)
{
FILE *tmp;
tmp = writestream;
writestream = open_file(car(arg), "w+");
if (writestream != NULL) {
setcar(arg, cons(lcontents(), NIL));
lpo(car(arg));
fclose(writestream);
}
else
err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
writestream = tmp;
return(UNBOUND);
}
/*FUNCTION*/
LVAL c_cons(tpLspObject pLSP
){
/*noverbatim
CUT*/
/*
TO_HEADER:
#define cons() c_cons(pLSP)
*/
LVAL p;
if( null((p = getnode())) )
return NIL;
settype(p,NTYPE_CON);
setcar(p,NIL);
setcdr(p,NIL);
return p;
}
LISP copy (LISP a, LISP *t)
{
LISP val, tail;
if (! istype (a, TPAIR))
return (NIL);
tail = val = cons (NIL, NIL);
for (;;) {
setcar (tail, car (a));
if (! istype (a = cdr (a), TPAIR))
break;
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
if (t)
*t = tail;
return (val);
}
NODE *lfirst(NODE *args) {
NODE *val = UNBOUND, *arg;
if (nodetype(car(args)) == ARRAY) {
return make_intnode((FIXNUM)getarrorg(car(args)));
}
arg = bfable_arg(args);
if (NOT_THROWING) {
if (is_list(arg))
val = car(arg);
else {
setcar(args, cnv_node_to_strnode(arg));
arg = car(args);
val = make_strnode(getstrptr(arg), getstrhead(arg), 1,
nodetype(arg), strnzcpy);
}
}
return(val);
}
/*FUNCTION*/
LVAL c_readlist(tpLspObject pLSP,
FILE *f
){
/*noverbatim
CUT*/
int ch;
LVAL p,q;
spaceat(ch,f);
if( ch == pLSP->cClose || ch == EOF )return NIL;
UNGETC(ch);
q = cons();
if( null(q) )
{
return NIL;
}
p = _readexpr(pLSP,f);
setcar(q,p);
setcdr(q,readlist(f));
return q;
}
NODE *lcount(NODE *args) {
int cnt = 0;
NODE *arg;
arg = car(args);
if (arg != NIL && arg != Null_Word) {
if (is_list(arg)) {
args = arg;
for (; args != NIL; cnt++) {
args = cdr(args);
if (check_throwing) break;
}
} else if (nodetype(arg) == ARRAY) {
cnt = getarrdim(arg);
} else {
setcar(args, cnv_node_to_strnode(arg));
cnt = getstrlen(car(args));
}
}
return(make_intnode((FIXNUM)cnt));
}
/*
* tl is one element of the cross product get(v,k)...get(v,n-1)
*/
local void
tposs0Multi(TPoss tp,Length k,TFormList tl,Length n,Pointer v,TPossGetter get)
{
if (k == 0)
tpossCons(tp, tfMultiFrList(tl));
else {
TPoss tpk = get(v, k-1);
TPossIterator tpi;
tl = listCons(TForm)(NULL, tl);
for (tpossITER(tpi,tpk); tpossMORE(tpi); tpossSTEP(tpi)) {
TForm t = tpossELT(tpi);
t = tfFollowOnly(t);
setcar(tl, t);
tposs0Multi(tp, k-1, tl, n, v, get);
}
listFreeCons(TForm)(tl);
tpossFree(tpk);
}
}
NODE *lbutfirst(NODE *args) {
NODE *val = UNBOUND, *arg;
arg = bfable_arg(args);
if (NOT_THROWING) {
if (is_list(arg))
val = cdr(arg);
else {
setcar(args, cnv_node_to_strnode(arg));
arg = car(args);
if (getstrlen(arg) > 1)
val = make_strnode(getstrptr(arg) + 1,
getstrhead(arg),
getstrlen(arg) - 1,
nodetype(arg),
strnzcpy);
else
val = Null_Word;
}
}
return(val);
}
