Revision 53367e1be236df465d1d1b43e96c1581e974b30c authored by Joshua Cogliati on 14 December 2020, 03:23:22 UTC, committed by GitHub on 14 December 2020, 03:23:22 UTC
HOTFIX ISSUE-69: Added declaration of linemode_on to fix compile error in some OSX environments
lists.c
/*
* lists.c logo list functions module dvb
*
* Copyright (C) 1993 by the Regents of the University of California
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see <https://www.gnu.org/licenses/>.
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "logo.h"
#include "globals.h"
#include <math.h>
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;
}
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;
}
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 *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 *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 *lfirsts(NODE *args) {
NODE *val = UNBOUND, *arg, *argp, *tail;
arg = list_arg(args);
if (car(args) == NIL) return(NIL);
if (NOT_THROWING) {
val = cons(lfirst(arg), NIL);
tail = val;
for (argp = cdr(arg); argp != NIL; argp = cdr(argp)) {
setcdr(tail, cons(lfirst(argp), NIL));
tail = cdr(tail);
if (check_throwing) break;
}
if (stopping_flag == THROWING) {
return UNBOUND;
}
}
return(val);
}
NODE *lbfs(NODE *args) {
NODE *val = UNBOUND, *arg, *argp, *tail;
arg = list_arg(args);
if (car(args) == NIL) return(NIL);
if (NOT_THROWING) {
val = cons(lbutfirst(arg), NIL);
tail = val;
for (argp = cdr(arg); argp != NIL; argp = cdr(argp)) {
setcdr(tail, cons(lbutfirst(argp), NIL));
tail = cdr(tail);
if (check_throwing) break;
}
if (stopping_flag == THROWING) {
return UNBOUND;
}
}
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);
}
NODE *llist(NODE *args) {
return(args);
}
NODE *lemptyp(NODE *arg) {
return torf(car(arg) == NIL || car(arg) == Null_Word);
}
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 *lascii(NODE *args) {
FIXNUM i;
NODE *val = UNBOUND, *arg;
arg = char_arg(args);
if (NOT_THROWING) {
if (nodetype(arg) == BACKSLASH_STRING)
i = (FIXNUM)(*getstrptr(arg)) & 0377;
else
i = (FIXNUM)clearparity(*getstrptr(arg)) & 0377;
val = make_intnode(i);
}
return(val);
}
NODE *lrawascii(NODE *args) {
FIXNUM i;
NODE *val = UNBOUND, *arg;
arg = char_arg(args);
if (NOT_THROWING) {
i = (FIXNUM)((unsigned char)*getstrptr(arg));
val = make_intnode(i);
}
return(val);
}
NODE *lvbarredp(NODE *args) {
char i;
NODE *arg;
arg = char_arg(args);
if (NOT_THROWING) {
i = *getstrptr(arg);
return torf(getparity(i));
}
return(UNBOUND);
}
NODE *lchar(NODE *args) {
NODE *val = UNBOUND, *arg;
char c;
arg = pos_int_arg(args);
if (NOT_THROWING) {
c = (char)getint(arg);
val = make_strnode(&c, (struct string_block *)NULL, 1,
STRING, strnzcpy);
}
return(val);
}
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));
}
NODE *lfput(NODE *args) {
NODE *lst, *arg;
if (is_word(cadr(args)) && is_word(car(args)) &&
getstrlen(cnv_node_to_strnode(car(args))) == 1)
return lword(args);
arg = car(args);
lst = list_arg(cdr(args));
if (NOT_THROWING)
return cons(arg,lst);
else
return UNBOUND;
}
NODE *llput(NODE *args) {
NODE *lst, *arg, *val = UNBOUND, *lastnode = NIL, *tnode = NIL;
if (is_word(cadr(args)) && is_word(car(args)) &&
getstrlen(cnv_node_to_strnode(car(args))) == 1)
return lword(cons(cadr(args), cons(car(args), NIL)));
arg = car(args);
lst = list_arg(cdr(args));
if (NOT_THROWING) {
val = NIL;
while (lst != NIL) {
tnode = cons(car(lst), NIL);
if (val == NIL) {
val = tnode;
} else {
setcdr(lastnode, tnode);
}
lastnode = tnode;
lst = cdr(lst);
if (check_throwing) break;
}
if (val == NIL)
val = cons(arg, NIL);
else
setcdr(lastnode, cons(arg, 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 *lword(NODE *args) {
NODE *val = NIL, *arg = NIL;
int cnt = 0;
NODETYPES str_type = STRING;
if (args == NIL) return Null_Word;
val = args;
while (val != NIL && NOT_THROWING) {
arg = string_arg(val);
val = cdr(val);
if (NOT_THROWING) {
if (backslashed(arg))
str_type = VBAR_STRING;
cnt += getstrlen(arg);
}
}
if (NOT_THROWING)
val = make_strnode((char *)args, (struct string_block *)NULL,
cnt, str_type, word_strnzcpy); /* kludge */
else
val = UNBOUND;
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);
}
NODE *lwordp(NODE *arg) {
arg = car(arg);
return torf(arg != UNBOUND && !aggregate(arg));
}
NODE *llistp(NODE *arg) {
arg = car(arg);
return torf(is_list(arg));
}
NODE *lnumberp(NODE *arg) {
setcar(arg, cnv_node_to_numnode(car(arg)));
return torf(car(arg) != UNBOUND);
}
NODE *larrayp(NODE *arg) {
return torf(nodetype(car(arg)) == ARRAY);
}
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 *lmemberp(NODE *args) {
return(memberp_help(args, FALSE, FALSE));
}
NODE *lsubstringp(NODE *args) {
return(memberp_help(args, FALSE, TRUE));
}
NODE *lmember(NODE *args) {
return(memberp_help(args, TRUE, FALSE));
}
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) {
#if HAVE_IRINT
i = irint(f);
#else
i = (FIXNUM)f;
#endif
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;
}
FIXNUM int_arg(NODE *args) {
NODE *arg =integer_arg(args);
if (NOT_THROWING) return getint(arg);
return 0;
}
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);
}
int circular(NODE *arr, NODE *new) {
if (new == NIL) return(0);
else if (nodetype(new) == ARRAY) {
int i = getarrdim(new);
NODE **p = getarrptr(new);
if (new == arr) return(1);
while (--i >= 0) {
if (circular(arr,*p++)) return(1);
}
return(0);
} else if (is_list(new)) {
while (new != NIL) {
if (circular(arr,car(new))) return(1);
new = cdr(new);
}
return(0);
} else return(0);
}
NODE *setitem_helper(NODE *args, BOOLEAN safe) {
int i;
NODE *obj, *val, *cont;
val = integer_arg(args);
obj = cadr(args);
while (nodetype(obj) != ARRAY && NOT_THROWING) {
setcar(cdr(args), err_logo(BAD_DATA, obj));
obj = cadr(args);
}
cont = car(cddr(args));
if (NOT_THROWING) {
i = getint(val);
if (safe) {
while (circular(obj,cont) && NOT_THROWING) {
setcar(cddr(args), err_logo(BAD_DATA, cont));
cont = car(cddr(args));
}
}
if (NOT_THROWING) {
i -= getarrorg(obj);
while ((i < 0 || i >= getarrdim(obj)) && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, val));
val = integer_arg(args);
i = getint(val);
}
if (NOT_THROWING) {
(getarrptr(obj))[i] = cont;
check_valid_oldyoung(obj, cont);
}
}
}
return(UNBOUND);
}
NODE *lsetitem(NODE *args) {
return setitem_helper(args, TRUE);
}
NODE *l_setitem(NODE *args) {
return setitem_helper(args, FALSE);
}
NODE *larray(NODE *args) {
NODE *arg;
FIXNUM d, o;
arg = pos_int_arg(args);
if (cdr(args) != NIL) o = int_arg(cdr(args));
else o = 1;
if (NOT_THROWING) {
d = getint(arg);
arg = make_array(d);
setarrorg(arg,o);
return arg;
}
return UNBOUND;
}
NODE *llisttoarray(NODE *args) {
int len = 0, org = 1, i;
NODE *p, *arr = UNBOUND;
while (car(args) != NIL && !is_list(car(args)) && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, car(args)));
}
if (cdr(args) != NIL) {
p = cnv_node_to_numnode(car(cdr(args)));
while (nodetype(p) != INT && NOT_THROWING) {
setcar(cdr(args), err_logo(BAD_DATA, car(cdr(args))));
p = cnv_node_to_numnode(car(cdr(args)));
}
}
if (NOT_THROWING) {
for (p = car(args); p != NIL; p = cdr(p)) len++;
if (cdr(args) != NIL)
org = getint(car(cdr(args)));
arr = make_array(len);
setarrorg(arr,org);
i = 0;
for (p = car(args); p != NIL; p = cdr(p))
(getarrptr(arr))[i++] = car(p);
}
return(arr);
}
NODE *larraytolist(NODE *args) {
NODE *p = NIL, *arg;
int i;
while (nodetype(car(args)) != ARRAY && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, car(args)));
}
if (NOT_THROWING) {
arg = car(args);
for (i = getarrdim(arg) - 1; i >= 0; i--)
p = cons(getarrptr(arg)[i], p);
return p;
}
return UNBOUND;
}
FLONUM float_arg(NODE *args) {
NODE *arg = car(args), *val;
val = cnv_node_to_numnode(arg);
while (!is_number(val) && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
val = cnv_node_to_numnode(arg);
}
setcar(args,val);
if (nodetype(val) == FLOATT) return getfloat(val);
if (nodetype(val) == INT) return (FLONUM)getint(val);
return 0.0;
}
NODE *lform(NODE *args) {
FLONUM number;
int width, precision = 0;
char result[100];
char format[20];
char *old_stringptr = print_stringptr;
int old_stringlen = print_stringlen;
number = float_arg(args);
width = (int)int_arg(cdr(args));
if (width < 0) {
print_stringptr = format;
print_stringlen = 20;
ndprintf((FILE *)NULL,"%p\n",string_arg(cddr(args)));
*print_stringptr = '\0';
print_stringptr = old_stringptr;
print_stringlen = old_stringlen;
} else
precision = (int)int_arg(cddr(args));
if (NOT_THROWING) {
if (width >= 100) width = 99;
if (width < 0)
sprintf(result,format,number);
else
sprintf(result,"%*.*f",width,precision,number);
return(make_strnode(result, (struct string_block *)NULL,
(int)strlen(result), STRING, strnzcpy));
}
return(UNBOUND);
}
NODE *l_setfirst(NODE *args) {
NODE *list, *newval;
list = car(args);
newval = cadr(args);
while (NOT_THROWING && (list == NIL || !is_list(list))) {
setcar(args, err_logo(BAD_DATA,list));
list = car(args);
}
setcar(list,newval);
return(UNBOUND);
}
NODE *l_setbf(NODE *args) {
NODE *list, *newval;
list = car(args);
newval = cadr(args);
while (NOT_THROWING && (list == NIL || !is_list(list))) {
setcar(args, err_logo(BAD_DATA,list));
list = car(args);
}
setcdr(list,newval);
return(UNBOUND);
}
![swh spinner](/static/img/swh-spinner.gif)
Computing file changes ...