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 *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 *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);
}
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);
}
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);
}
NODE *llast(NODE *args) {
NODE *val = UNBOUND, *arg;
arg = bfable_arg(args);
if (NOT_THROWING) {
if (is_list(arg)) {
args = arg;
while (cdr(args) != NIL) {
args = cdr(args);
if (check_throwing) break;
}
val = car(args);
}
else {
setcar(args, cnv_node_to_strnode(arg));
arg = car(args);
val = make_strnode(getstrptr(arg) + getstrlen(arg) - 1,
getstrhead(arg), 1, nodetype(arg), strnzcpy);
}
}
return(val);
}
void gc(NODE *nd)
{
NODE *tcar, *tcdr, *tobj;
int i;
NODE **pp;
for (;;) {
switch (nodetype(nd)) {
case PUNBOUND:
setrefcnt(nd,10000); /* save some time */
case PNIL:
if (gctop == gcstack) return;
nd = *--gctop;
continue;
case LINE:
nd->n_obj = NIL;
case CONS:
case CASEOBJ:
case RUN_PARSE:
case QUOTE:
case COLON:
case TREE:
case CONT:
tcdr = cdr(nd);
tcar = car(nd);
tobj = getobject(nd);
break;
case ARRAY:
pp = getarrptr(nd);
i = getarrdim(nd);
while (--i >= 0) {
tobj = *pp++;
deref(tobj);
}
free((char *)getarrptr(nd));
tcar = tcdr = tobj = NIL;
break;
case STRING:
case BACKSLASH_STRING:
case VBAR_STRING:
if (getstrhead(nd) != NULL && decstrrefcnt(getstrhead(nd)) == 0)
free(getstrhead(nd));
default:
tcar = tcdr = tobj = NIL;
}
nd->n_cdr = free_list;
free_list = nd;
#ifdef MEM_DEBUG
mem_freed++;
#endif
if (tcdr != NIL && decrefcnt(tcdr) == 0)
if (gctop < &gcstack[GCMAX])
*gctop++ = tcdr;
if (tcar != NIL && decrefcnt(tcar) == 0)
if (gctop < &gcstack[GCMAX])
*gctop++ = tcar;
if (tobj != NIL && decrefcnt(tobj) == 0)
if (gctop < &gcstack[GCMAX])
*gctop++ = tobj;
if (gctop == gcstack) return;
nd = *--gctop;
}
}
NODE *runparse_node(NODE *nd, NODE **ndsptr) {
NODE *outline = NIL, *tnode = NIL, *lastnode = NIL, *snd;
char *wptr, *tptr;
struct string_block *whead;
int wlen, wcnt, tcnt, isnumb, gotdot;
NODETYPES wtyp;
BOOLEAN monadic_minus = FALSE;
if (nd == Minus_Tight) return cons(nd, NIL);
snd = cnv_node_to_strnode(nd);
wptr = getstrptr(snd);
wlen = getstrlen(snd);
wtyp = nodetype(snd);
wcnt = 0;
whead = getstrhead(snd);
while (wcnt < wlen) {
if (*wptr == ';') {
*ndsptr = NIL;
break;
}
if (*wptr == '"') {
tcnt = 0;
tptr = ++wptr;
wcnt++;
while (wcnt < wlen && !parens(*wptr)) {
if (wtyp == BACKSLASH_STRING && getparity(*wptr))
wtyp = PUNBOUND; /* flag for "\( case */
wptr++, wcnt++, tcnt++;
}
if (wtyp == PUNBOUND) {
wtyp = BACKSLASH_STRING;
tnode = cons(make_quote(intern(make_strnode(tptr, NULL,
tcnt, wtyp, noparity_strnzcpy))), NIL);
} else
tnode = cons(make_quote(intern(make_strnode(tptr, whead, tcnt,
wtyp, strnzcpy))), NIL);
} else if (*wptr == ':') {
tcnt = 0;
tptr = ++wptr;
wcnt++;
while (wcnt < wlen && !parens(*wptr) && !infixs(*wptr))
wptr++, wcnt++, tcnt++;
tnode = cons(make_colon(intern(make_strnode(tptr, whead, tcnt,
wtyp, strnzcpy))), NIL);
} else if (wcnt == 0 && *wptr == '-' && monadic_minus == FALSE &&
wcnt+1 < wlen && !white_space(*(wptr+1))) {
/* minus sign with space before and no space after is unary */
tnode = cons(make_intnode((FIXNUM)0), NIL);
monadic_minus = TRUE;
} else if (parens(*wptr) || infixs(*wptr)) {
if (monadic_minus)
tnode = cons(Minus_Tight, NIL);
else if (wcnt+1 < wlen &&
((*wptr == '<' && (*(wptr+1) == '=' || *(wptr+1) == '>'))
|| (*wptr == '>' && *(wptr+1) == '='))) {
tnode = cons(intern(make_strnode(wptr, whead, 2,
STRING, strnzcpy)), NIL);
wptr++, wcnt++;
} else
tnode = cons(intern(make_strnode(wptr, whead, 1,
STRING, strnzcpy)), NIL);
monadic_minus = FALSE;
wptr++, wcnt++;
} else {
tcnt = 0;
tptr = wptr;
/* isnumb 4 means nothing yet;
* 0 means digits so far, 1 means just saw
* 'e' so minus can be next, 2 means no longer
* eligible even if an 'e' comes along */
isnumb = 4;
gotdot = 0;
if (*wptr == '?') {
isnumb = 3; /* turn ?5 to (? 5) */
wptr++, wcnt++, tcnt++;
}
while (wcnt < wlen && !parens(*wptr) &&
(!infixs(*wptr) || (isnumb == 1 && (*wptr == '-' || *wptr == '+')))) {
if (isnumb == 4 && isdigit(*wptr)) isnumb = 0;
if (isnumb == 0 && tcnt > 0 && (*wptr == 'e' || *wptr == 'E'))
isnumb = 1;
else if (!(isdigit(*wptr) || (!gotdot && *wptr == '.')) || isnumb == 1)
isnumb = 2;
if (*wptr == '.') gotdot++;
wptr++, wcnt++, tcnt++;
}
if (isnumb == 3 && tcnt > 1) { /* ?5 syntax */
NODE *qmtnode;
qmtnode = cons_list(0, Left_Paren, Query,
cnv_node_to_numnode
(make_strnode(tptr+1, whead,
tcnt-1, wtyp, strnzcpy)),
END_OF_LIST);
if (outline == NIL) {
outline = qmtnode;
} else {
setcdr(lastnode, qmtnode);
}
lastnode = cddr(qmtnode);
tnode = cons(Right_Paren, NIL);
} else if (isnumb < 2 && tcnt > 0) {
tnode = cons(cnv_node_to_numnode(make_strnode(tptr, whead, tcnt,
wtyp, strnzcpy)),
NIL);
} else
tnode = cons(intern(make_strnode(tptr, whead, tcnt,
wtyp, strnzcpy)),
NIL);
}
if (outline == NIL) outline = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
}
return(outline);
}
NODE *parser_iterate(char **inln, char *inlimit, struct string_block *inhead,
BOOLEAN semi, int endchar) {
char ch, *wptr = NULL;
static char terminate = '\0'; /* KLUDGE */
NODE *outline = NIL, *lastnode = NIL, *tnode = NIL;
int windex = 0, vbar = 0;
NODETYPES this_type = STRING;
BOOLEAN broken = FALSE;
do {
/* get the current character and increase pointer */
ch = **inln;
if (!vbar && windex == 0) wptr = *inln;
if (++(*inln) >= inlimit) *inln = &terminate;
/* skip through comments and line continuations */
while (!vbar && ((semi && ch == ';') ||
#ifdef WIN32
(ch == '~' && (**inln == 012 || **inln == 015)))) {
while (ch == '~' && (**inln == 012 || **inln == 015)) {
#else
(ch == '~' && **inln == '\n'))) {
while (ch == '~' && **inln == '\n') {
#endif
if (++(*inln) >= inlimit) *inln = &terminate;
ch = **inln;
if (windex == 0) wptr = *inln;
else {
if (**inln == ']' || **inln == '[' ||
**inln == '{' || **inln == '}') {
ch = ' ';
break;
} else {
broken = TRUE;
}
}
if (++(*inln) >= inlimit) *inln = &terminate;
}
if (semi && ch == ';') {
#ifdef WIN32
if (**inln != 012 && **inln != 015)
#else
if (**inln != '\n')
#endif
do {
ch = **inln;
if (windex == 0) wptr = *inln;
else broken = TRUE;
if (++(*inln) >= inlimit) *inln = &terminate;
}
#ifdef WIN32
while (ch != '\0' && ch != '~' && **inln != 012 && **inln != 015);
#else /* !Win32 */
while (ch != '\0' && ch != '~' && **inln != '\n');
#endif
if (ch != '\0' && ch != '~') ch = '\n';
}
}
/* flag that this word will be of BACKSLASH_STRING type */
if (getparity(ch)) this_type = BACKSLASH_STRING;
if (ch == '|') {
vbar = !vbar;
this_type = VBAR_STRING;
broken = TRUE; /* so we'll copy the chars */
}
else if (vbar || (!white_space(ch) && ch != ']' &&
ch != '{' && ch != '}' && ch != '['))
windex++;
if (vbar) continue;
else if (ch == endchar) break;
else if (ch == ']') err_logo(UNEXPECTED_BRACKET, NIL);
else if (ch == '}') err_logo(UNEXPECTED_BRACE, NIL);
/* if this is a '[', parse a new list */
else if (ch == '[') {
tnode = cons(parser_iterate(inln,inlimit,inhead,semi,']'), NIL);
if (**inln == '\0') ch = '\0';
}
else if (ch == '{') {
tnode = cons(list_to_array
(parser_iterate(inln,inlimit,inhead,semi,'}')), NIL);
if (**inln == '@') {
int i = 0, sign = 1;
(*inln)++;
if (**inln == '-') {
sign = -1;
(*inln)++;
}
while ((ch = **inln) >= '0' && ch <= '9') {
i = (i*10) + ch - '0';
(*inln)++;
}
setarrorg(car(tnode),sign*i);
}
if (**inln == '\0') ch = '\0';
}
/* if this character or the next one will terminate string, make the word */
else if (white_space(ch) || **inln == ']' || **inln == '[' ||
**inln == '{' || **inln == '}') {
if (windex > 0 || this_type == VBAR_STRING) {
if (broken == FALSE)
tnode = cons(make_strnode(wptr, inhead, windex,
this_type, strnzcpy),
NIL);
else {
tnode = cons(make_strnode(wptr,
(struct string_block *)NULL, windex,
this_type, (semi ? mend_strnzcpy : mend_nosemi)),
NIL);
broken = FALSE;
}
this_type = STRING;
windex = 0;
}
}
/* put the word onto the end of the return list */
if (tnode != NIL) {
if (outline == NIL) outline = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
tnode = NIL;
}
} while (ch);
return(outline);
}
NODE *parser(NODE *nd, BOOLEAN semi) {
NODE *rtn;
int slen;
char *lnsav;
rtn = cnv_node_to_strnode(nd);
slen = getstrlen(rtn);
lnsav = getstrptr(rtn);
rtn = parser_iterate(&lnsav,lnsav + slen,getstrhead(rtn),semi,-1);
return(rtn);
}
NODE *lparse(NODE *args) {
NODE *arg, *val = UNBOUND;
arg = string_arg(args);
if (NOT_THROWING) {
val = parser(arg, FALSE);
}
return(val);
}
