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 *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);
}
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);
}
}
/* Treeify a body by appending the trees of the lines.
*/
void make_tree_from_body(NODE *body) {
NODE *body_ptr, *end_ptr = NIL, *tree = NIL;
if (body == NIL ||
(is_tree(body) && generation__tree(body) == the_generation))
return;
if (is_tree(body)) untreeify_body(body);
for (body_ptr = body; body_ptr != NIL; body_ptr = cdr(body_ptr)) {
tree = car(body_ptr);
if (tree == NIL) continue; /* skip blank line */
this_line = tree;
make_tree(tree);
if (is_tree(tree)) {
tree = tree__tree(tree);
make_line(tree, car(body_ptr));
if (end_ptr == NIL)
settree__tree(body, tree);
else
setcdr(end_ptr, tree);
if (generation__tree(car(body_ptr)) == UNBOUND)
setgeneration__tree(body, UNBOUND);
/* untreeify(car(body_ptr)); */
while (cdr(tree) != NIL)
tree = cdr(tree);
end_ptr = tree;
} else { /* error while treeifying */
untreeify(body);
return;
}
}
settype(body, TREE);
}
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 *lremprop(NODE *args)
{
NODE *plname, *pname, *plist, *val = NIL;
BOOLEANx caseig = FALSE;
if (compare_node(valnode__caseobj(Caseignoredp), Truex, TRUE) == 0)
caseig = TRUE;
plname = string_arg(args);
pname = string_arg(cdr(args));
if (NOT_THROWING)
{
plname = intern(plname);
plist = plist__caseobj(plname);
if (plist != NIL)
{
if (compare_node(car(plist), pname, caseig) == 0)
setplist__caseobj(plname, cddr(plist));
else
{
val = getprop(plist, pname, TRUE);
if (val != NIL)
setcdr(cdr(val), cddr(cddr(val)));
}
}
}
return (UNBOUND);
}
void lock_lease_exclusive(Worker *worker, Lease *lease) {
List *cleanup = worker->cleanup;
List *prev = NULL;
worker_attempt_to_acquire(worker, lease->wait_for_update);
/* clean out any regular locks that we hold on this lease */
while (lease->inflight > 0 && !null(cleanup)) {
if (caar(cleanup) == (void *) LOCK_LEASE && cdar(cleanup) == lease) {
lease->inflight--;
if (null(prev))
worker->cleanup = cdr(cleanup);
else
setcdr(prev, cdr(cleanup));
} else {
prev = cleanup;
}
cleanup = cdr(cleanup);
}
/* prevent any new transactions starting and signal our interest */
lease->wait_for_update = worker;
/* want for existing inflight transactions to finish */
if (lease->inflight > 0)
longjmp(worker->jmp, WORKER_BLOCKED);
/* only add to the cleanup list once we've succeeded */
worker_cleanup_add(worker, LOCK_LEASE_EXCLUSIVE, lease);
}
NODE *cons(NODE *x, NODE *y)
{
NODE *val = newnode(CONS);
setcar(val, x);
setcdr(val, y);
return(val);
}
int append2(int x, int y){
int res;
res = x;
while(!(nullp(cdr(x))))
x = cdr(x);
setcdr(x,y);
return(res);
}
NODE *parent_list_help(NODE *obj) {
NODE *p, *out, *tail;
out = tail = cons(obj, NIL);
for (p = getparents(obj); p != NIL; p = cdr(p)) {
setcdr(tail, parent_list_help(car(p)));
while (cdr(tail) != NIL) tail = cdr(tail);
}
return out;
}
LISP getlist () /* чтение списка ВЫР ('.' СПИС | ВЫР)... */
{
LISP p = cons (getexpr (), NIL);
switch (getlex ()) {
case '.':
setcdr (p, getexpr ());
break;
case ')':
ungetlex ();
break;
default:
ungetlex ();
setcdr (p, getlist ());
break;
case 0:
fatal ("unexpected eof");
}
return (p);
}
void setatom (LISP atom, LISP value, LISP ctx)
{
/* Присваивание значения переменной */
LISP pair = findatom (atom, ctx);
if (pair == NIL) {
fprintf (stderr, "unbound symbol: `%s'\n", symname (atom));
return;
}
setcdr (pair, value);
}
NODE *cons_list3(NODE *node1, NODE *node2, NODE *node3)
{
NODE *nptr, *outline = NIL, *lastnode, *val;
nptr = node1;
val = cons(nptr, NIL);
outline = val;
lastnode = outline;
nptr = node2;
val = cons(nptr, NIL);
setcdr(lastnode, val);
lastnode = val;
nptr = node3;
val = cons(nptr, NIL);
setcdr(lastnode, val);
lastnode = val;
return (outline);
}
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);
}
}
/*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 *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* remdup(NODE *seq) {
NODE* okay;
if (seq == NIL)
return seq;
/* finds the first element of new seq list */
while (memq(car(seq), cdr(seq))) {
seq = cdr(seq);
}
for (okay = seq; cdr(okay) != NIL; okay = cdr(okay)) {
while (memq(cadr(okay), cddr(okay))) {
setcdr(okay, cddr(okay));
}
}
return seq;
}
NODE *copy_list(NODE *arg)
{
NODE *tnode, *lastnode, *val = NIL;
while (arg != NIL)
{
tnode = cons(car(arg), NIL);
arg = cdr(arg);
if (val == NIL)
{
lastnode = val = tnode;
}
else
{
setcdr(lastnode, tnode);
lastnode = tnode;
}
}
return (val);
}
void worker_cleanup_remove(Worker *worker, enum lock_types type, void *object) {
List *prev = NULL;
List *cur = worker->cleanup;
while (!null(cur)) {
if (caar(cur) == (void *) type && cdar(cur) == object) {
if (prev == NULL)
worker->cleanup = cdr(cur);
else
setcdr(prev, cdr(cur));
return;
}
prev = cur;
cur = cdr(cur);
}
/* fail if we didn't find the requested entry */
assert(0);
}
/*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 *cons_list(int dummy, ...)
{
va_list ap;
NODE *nptr, *outline = NIL, *lastnode, *val;
va_start(ap, dummy);
while ((nptr = va_arg(ap, NODE *)) != END_OF_LIST)
{
val = cons(nptr, NIL);
if (outline == NIL)
{
outline = val;
lastnode = outline;
}
else
{
setcdr(lastnode, val);
lastnode = val;
}
}
va_end(ap);
return (outline);
}
FILE *find_file(NODE *arg, BOOLEAN remove) {
NODE *t, *prev = NIL;
FILE *fp = NULL;
t = file_list;
while (t != NIL) {
if ((is_list(arg) && arg == car(t)) ||
(!is_list(arg) && (compare_node(arg, car(t), FALSE) == 0))) {
fp = (FILE *)t->n_obj;
if (remove) {
t->n_obj = NIL;
if (prev == NIL)
file_list = cdr(t);
else
setcdr(prev, cdr(t));
}
break;
}
prev = t;
t = cdr(t);
}
return fp;
}
NODE *runparse(NODE *ndlist) {
NODE *curnd = NIL, *outline = NIL, *tnode = NIL, *lastnode = NIL;
char *str;
if (nodetype(ndlist) == RUN_PARSE)
return parsed__runparse(ndlist);
if (!is_list(ndlist)) {
err_logo(BAD_DATA_UNREC, ndlist);
return(NIL);
}
if (ndlist != NIL && is_word(curnd=car(ndlist)) && getstrlen(curnd) >= 2 &&
(str=getstrptr(curnd)) && *str++ == '#' && *str == '!')
return NIL; /* shell-script #! treated as comment line */
while (ndlist != NIL) {
curnd = car(ndlist);
ndlist = cdr(ndlist);
if (!is_word(curnd))
tnode = cons(curnd, NIL);
else {
if (!numberp(curnd))
tnode = runparse_node(curnd, &ndlist);
else
tnode = cons(cnv_node_to_numnode(curnd), NIL);
}
if (tnode != NIL) {
if (outline == NIL) outline = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
while (cdr(lastnode) != NIL) {
lastnode = cdr(lastnode);
if (check_throwing) break;
}
}
if (check_throwing) break;
}
return(outline);
}
LISP eval (LISP expr, LISP *ctxp)
{
LISP ctx = ctxp ? *ctxp : NIL;
LISP func;
again:
if (expr == NIL)
return (NIL);
/* Если это символ, берем его значение */
if (istype (expr, TSYMBOL)) {
/* Поиск значения по контексту */
LISP pair = findatom (expr, ctx);
if (pair == NIL) {
fprintf (stderr, "unbound symbol: `%s'\n", symname (expr));
return (NIL);
}
return (cdr (pair));
}
/* Все, что не атом и не список, не вычисляется */
if (! istype (expr, TPAIR))
return (expr);
/* Перебираем специальные формы.
* quote define set! begin lambda let let* letrec if
* and or cond else => quasiquote unquote unquote-splicing
*/
/* Зарезервированные имена:
* delay do case
*/
func = car (expr);
if (istype (func, TSYMBOL)) {
char *funcname = symname (func);
if (!strcmp (funcname, "quote")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
return (car (expr));
}
if (!strcmp (funcname, "define")) {
LISP value, atom, pair, arg;
int lambda;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
lambda = istype (atom = car (expr), TPAIR);
if (lambda) {
/* define, совмещенный с lambda */
arg = cdr (atom);
atom = car (atom);
}
if (! istype (atom, TSYMBOL) ||
! istype (expr = cdr (expr), TPAIR))
return (NIL);
pair = findatom (atom, ctx);
if (pair == NIL) {
/* Расширяем контекст */
pair = cons (atom, NIL);
if (ctxp)
/* локальный контекст */
*ctxp = ctx = cons (pair, ctx);
else
/* контекст верхнего уровня */
ENV = cons (pair, ENV);
}
if (lambda)
value = closure (cons (arg, expr), ctx);
else
value = evalblock (expr, ctx);
setcdr (pair, value);
return (value);
}
if (!strcmp (funcname, "set!")) {
LISP value = NIL;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
if (istype (cdr (expr), TPAIR))
value = evalblock (cdr (expr), ctx);
setatom (car (expr), value, ctx);
return (value);
}
if (!strcmp (funcname, "begin"))
return (evalblock (cdr (expr), ctx));
if (!strcmp (funcname, "lambda")) {
LISP arg = NIL;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
return (closure (cons (arg, expr), ctx));
}
if (!strcmp (funcname, "let")) {
LISP arg = NIL, oldctx = ctx;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными */
while (istype (arg, TPAIR)) {
LISP var = car (arg);
arg = cdr (arg);
/* Значения вычисляем в старом контексте */
if (istype (var, TPAIR))
ctx = cons (cons (car (var),
evalblock (cdr (var), oldctx)),
ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "let*")) {
LISP arg = NIL;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными */
while (istype (arg, TPAIR)) {
LISP var = car (arg);
arg = cdr (arg);
/* Значения вычисляем в текущем контексте */
if (istype (var, TPAIR))
ctx = cons (cons (car (var),
evalblock (cdr (var), ctx)),
ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "letrec")) {
LISP arg = NIL, a;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными с пустыми значениями */
for (a=arg; istype (a, TPAIR); a=cdr(a)) {
LISP var = car (a);
if (istype (var, TPAIR))
ctx = cons (cons (car (var), NIL), ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
/* Вычисляем значения в новом контексте */
for (a=arg; istype (a, TPAIR); a=cdr(a)) {
LISP var = car (a);
if (istype (var, TPAIR))
setatom (car (var),
evalblock (cdr (var), ctx),
ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "if")) {
LISP iftrue = NIL, iffalse = NIL, test;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
test = car (expr);
if (istype (expr = cdr (expr), TPAIR)) {
iftrue = car (expr);
iffalse = cdr (expr);
}
if (eval (test, &ctx) != NIL)
return (eval (iftrue, &ctx));
return (evalblock (iffalse, ctx));
}
if (!strcmp (funcname, "and")) {
while (istype (expr = cdr (expr), TPAIR))
if (eval (car (expr), &ctx) == NIL)
return (NIL);
return (T);
}
if (!strcmp (funcname, "or")) {
while (istype (expr = cdr (expr), TPAIR))
if (eval (car (expr), &ctx) == NIL)
return (T);
return (NIL);
}
if (!strcmp (funcname, "cond")) {
LISP oldctx = ctx, test, clause;
while (istype (expr = cdr (expr), TPAIR)) {
if (! istype (clause = car (expr), TPAIR))
continue;
ctx = oldctx;
if (istype (car (clause), TSYMBOL) &&
! strcmp (symname (car (clause)), "else"))
return (evalblock (cdr (clause), ctx));
test = eval (car (clause), &ctx);
if (test == NIL ||
! istype (clause = cdr (clause), TPAIR))
continue;
if (istype (car (clause), TSYMBOL) &&
! strcmp (symname (car (clause)), "=>")) {
clause = evalblock (cdr (clause), ctx);
if (istype (clause, THARDW))
return ((*hardwval (clause)) (cons (test, NIL), ctx));
if (istype (clause, TCLOSURE))
return (evalclosure (clause, cons (test, NIL)));
return (NIL);
}
return (evalblock (clause, ctx));
}
return (NIL);
}
if (!strcmp (funcname, "quasiquote")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
return (quasiquote (car (expr), ctx, 0));
}
if (!strcmp (funcname, "unquote") ||
!strcmp (funcname, "unquote-splicing")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
expr = car (expr);
goto again;
}
}
/* Вычисляем все аргументы */
expr = evallist (expr, ctx);
return (evalfunc (car (expr), cdr (expr), ctxp ? *ctxp : TOPLEVEL));
}
int start (int argc,char ** argv) {
#else
int main(int argc, char *argv[]) {
#endif
NODE *exec_list = NIL;
NODE *cl_tail = NIL;
int argc2;
char **argv2;
#ifdef SYMANTEC_C
extern void (*openproc)(void);
extern void __open_std(void);
openproc = &__open_std;
#endif
#ifdef mac
init_mac_memory();
#endif
bottom_stack = &exec_list; /*GC*/
#ifndef HAVE_WX
#ifdef x_window
x_window_init(argc, argv);
#endif
#endif
(void)addseg();
term_init();
init();
math_init();
#ifdef ibm
signal(SIGINT, SIG_IGN);
#if defined(__RZTC__) && !defined(WIN32) /* sowings */
_controlc_handler = do_ctrl_c;
controlc_open();
#endif
#else /* !ibm */
signal(SIGINT, logo_stop);
#endif /* ibm */
#ifdef mac
signal(SIGQUIT, SIG_IGN);
#else /* !mac */
//signal(SIGQUIT, logo_pause);
#endif
/* SIGQUITs never happen on the IBM */
if (argc < 2) {
#ifndef WIN32
if (1 || isatty(1)) // fix this. for interactive from menu bar.
#endif
{
#ifdef HAVE_WX
extern char *SVN;
#endif
char version[20];
lcleartext(NIL);
#ifdef HAVE_WX
strcpy(version,"6.0");
strcat(version,SVN);
#else
strcpy(version,"5.6");
#endif
ndprintf(stdout, message_texts[WELCOME_TO], version);
new_line(stdout);
}
}
#ifdef HAVE_WX
setvalnode__caseobj(LogoVersion, make_floatnode(6.0));
#else
setvalnode__caseobj(LogoVersion, make_floatnode(5.6));
#endif
setflag__caseobj(LogoVersion, VAL_BURIED);
argv2 = argv; argc2 = argc;
if (!strcmp(*argv+strlen(*argv)-4, "logo")) {
argv++;
while (--argc > 0 && strcmp(*argv, "-") && NOT_THROWING) {
argv++;
}
}
argv++;
while (--argc > 0) {
if (command_line == NIL)
cl_tail = command_line = cons(make_static_strnode(*argv++), NIL);
else {
setcdr(cl_tail, cons(make_static_strnode(*argv++), NIL));
cl_tail = cdr(cl_tail);
}
}
setvalnode__caseobj(CommandLine, command_line);
silent_load(Startuplg, logolib);
silent_load(Startup, NULL); /* load startup.lg */
if (!strcmp(*argv2+strlen(*argv2)-4, "logo")) {
argv2++;
while (--argc2 > 0 && strcmp(*argv2, "-") && NOT_THROWING) {
silent_load(NIL,*argv2++);
}
}
for (;;) {
if (NOT_THROWING) {
check_reserve_tank();
current_line = reader(stdin,"? ");
#ifdef __RZTC__
(void)feof(stdin);
if (!in_graphics_mode)
printf(" \b");
fflush(stdout);
#endif
#ifndef WIN32
if (feof(stdin) && !isatty(0)) lbye(NIL);
#endif
#ifdef __RZTC__
if (feof(stdin)) clearerr(stdin);
#endif
if (NOT_THROWING) {
exec_list = parser(current_line, TRUE);
if (exec_list != NIL) eval_driver(exec_list);
}
}
#ifdef HAVE_WX
if (wx_leave_mainloop) {
break;
}
#endif
if (stopping_flag == THROWING) {
if (isName(throw_node, Name_error)) {
err_print(NULL);
} else if (isName(throw_node, Name_system))
break;
else if (!isName(throw_node, Name_toplevel)) {
err_logo(NO_CATCH_TAG, throw_node);
err_print(NULL);
}
stopping_flag = RUN;
}
if (stopping_flag == STOP || stopping_flag == OUTPUT) {
/* ndprintf(stdout, "%t\n", message_texts[CANT_STOP]); */
stopping_flag = RUN;
}
}
//prepare_to_exit(TRUE);
exit(0);
return 0;
}
int main(int argc, char *argv[]) {
NODE *exec_list = NIL;
NODE *cl_tail = NIL;
int argc2;
char **argv2;
bottom_stack = &exec_list; /*GC*/
(void) addseg();
term_init();
init();
math_init();
my_init();
signal(SIGINT, logo_stop);
if (argc < 2) {
if (1 || isatty(1)) // fix this. for interactive from menu bar.
{
char version[20];
lcleartext(NIL);
strcpy(version, "5.6");
ndprintf(stdout, message_texts[WELCOME_TO], version);
new_line(stdout);
}
}
setvalnode__caseobj(LogoVersion, make_floatnode(5.6));
setflag__caseobj(LogoVersion, VAL_BURIED);
argv2 = argv;
argc2 = argc;
if (!strcmp(*argv + strlen(*argv) - 4, "logo")) {
argv++;
while (--argc > 0 && strcmp(*argv, "-") && NOT_THROWING) {
argv++;
}
}
argv++;
while (--argc > 0) {
if (command_line == NIL)
cl_tail = command_line = cons(make_static_strnode(*argv++), NIL);
else {
setcdr(cl_tail, cons(make_static_strnode(*argv++), NIL));
cl_tail = cdr(cl_tail);
}
}
setvalnode__caseobj(CommandLine, command_line);
silent_load(Startuplg, logolib);
silent_load(Startup, NULL); /* load startup.lg */
if (!strcmp(*argv2 + strlen(*argv2) - 4, "logo")) {
argv2++;
while (--argc2 > 0 && strcmp(*argv2, "-") && NOT_THROWING) {
silent_load(NIL, *argv2++);
}
}
for (;;) {
if (NOT_THROWING) {
check_reserve_tank();
current_line = reader(stdin, "? ");
if (feof(stdin) && !isatty(0))
lbye(NIL);
if (NOT_THROWING) {
exec_list = parser(current_line, TRUE);
if (exec_list != NIL)
eval_driver(exec_list);
}
}
if (stopping_flag == THROWING) {
if (isName(throw_node, Name_error)) {
err_print(NULL);
} else if (isName(throw_node, Name_system))
break;
else if (!isName(throw_node, Name_toplevel)) {
err_logo(NO_CATCH_TAG, throw_node);
err_print(NULL);
}
stopping_flag = RUN;
}
if (stopping_flag == STOP || stopping_flag == OUTPUT) {
/* ndprintf(stdout, "%t\n", message_texts[CANT_STOP]); */
stopping_flag = RUN;
}
}
//prepare_to_exit(TRUE);
my_finish();
exit(0);
return 0;
}
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);
}
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);
}
