int missing_space(NODE *name) {
NODE *str = strnode__caseobj(name);
char *s = getstrptr(str);
FIXNUM len = getstrlen(str);
char *t;
char ch;
char alpha[100], numer[100];
int i;
NODE *first;
t = s+len-1;
ch = *t;
if (!isdigit(ch)) return 0;
i = 1;
while ((t>s) && (isdigit(*--t))) i++;
if (t<=s) return 0;
strncpy(numer,t+1,i);
numer[i] = '\0';
strncpy(alpha,s,len-i);
alpha[len-i] = '\0';
first = intern(make_strnode(alpha, 0, len-i, STRING, strnzcpy));
check_library(first);
if (procnode__caseobj(first) == UNDEFINED) return 0;
missing_alphabetic = first;
missing_numeric = make_intnode(atoi(numer));
err_logo(MISSING_SPACE,
cons_list(0, cons_list(0, missing_alphabetic, missing_numeric,
END_OF_LIST),
name, END_OF_LIST));
return 1;
}
NODE *lreadchars(NODE *args)
{
unsigned int c, i;
char *strhead, *strptr;
NODETYPES type = STRING;
c = (unsigned int)getint(pos_int_arg(args));
if (stopping_flag == THROWING) return UNBOUND;
charmode_on();
input_blocking++;
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
{
strhead = malloc((size_t)(c + 2));
strptr = strhead + 1;
fread(strptr, 1, (int)c, readstream);
setstrrefcnt(strhead, 0);
}
input_blocking = 0;
#ifndef TIOCSTI
if (stopping_flag == THROWING) return(UNBOUND);
#endif
if (feof(readstream)) {
free(strhead);
return(NIL);
}
for (i = 0; i < c; i++)
if (getparity(strptr[i])) type = BACKSLASH_STRING;
return(make_strnode(strptr, strhead, (int)c, type, strnzcpy));
}
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;
}
NODE *lclose(NODE *arg) {
FILE *tmp;
NODE *margs;
if ((tmp = find_file(car(arg), TRUE)) == NULL)
err_logo(NOT_OPEN_ERROR, car(arg));
else if (is_list (car(arg))) {
margs = cons(caar(arg),
cons(make_strnode((char *)tmp, NULL, strlen((char *)tmp),
STRING, strnzcpy),
NIL));
lmake(margs);
free((char *)tmp);
} else
fclose(tmp);
if ((is_list(car(arg)) && car(arg) == writer_name) ||
(!is_list(car(arg)) &&
(compare_node(car(arg), writer_name, FALSE) == 0))) {
writer_name = NIL;
writestream = stdout;
}
if ((is_list(car(arg)) && car(arg) == reader_name) ||
(!is_list(car(arg)) &&
(compare_node(car(arg), reader_name, FALSE) == 0))) {
reader_name = NIL;
readstream = stdin;
}
return(UNBOUND);
}
void silent_load(NODE *arg, char *prefix) {
FILE *tmp_stream;
NODE *tmp_line, *exec_list;
char load_path[200];
NODE *st = valnode__caseobj(Startup);
/* This procedure is called three ways:
* silent_load(NIL,*argv) loads *argv
* silent_load(proc,logolib) loads logolib/proc
* silent_load(proc,NULL) loads proc.lg
* The "/" or ".lg" is supplied by this procedure as needed.
*/
/* [This is no longer true! But for Windows we change FOO? to FOOQ.]
* In the case that this procedure is called to load a procedure from the
* logo library, it must first truncate the name of the procedure to
* eight characters, to find the filename (so as to be compatible with
* MS-DOS)
*/
if (prefix == NULL && arg == NIL) return;
strcpy(load_path, (prefix == NULL ? "" :
(arg == NIL ? prefix : addsep(prefix))));
if (arg != NIL) {
arg = cnv_node_to_strnode(arg);
if (arg == UNBOUND) return;
if (!strncmp(getstrptr(arg), ".", getstrlen(arg))) return;
if (!strncmp(getstrptr(arg), "..", 2)) return;
if (getstrlen(arg) > 150) return;
noparitylow_strnzcpy(load_path + (int)strlen(load_path),
getstrptr(arg), getstrlen(arg));
if (prefix == NULL)
strcat(load_path, ".lg");
/* #ifdef WIN32 */
else if (arg != NIL) {
char *cp;
for (cp = load_path; *cp != '\0'; cp++)
if (*cp == '?') *cp = 'Q';
}
/* strcpy(load_path, eight_dot_three(load_path)); */
/* #endif */
}
tmp_stream = loadstream;
tmp_line = current_line;
loadstream = fopen(load_path, "r");
if (loadstream != NULL) {
while (!(feof(loadstream)) && NOT_THROWING) {
current_line = reader(loadstream, "");
exec_list =parser(current_line, TRUE);
if (exec_list != NIL) eval_driver(exec_list);
}
fclose(loadstream);
runstartup(st);
} else if (arg == NIL || prefix == csls)
err_logo(CANT_OPEN_ERROR,
make_strnode(load_path, NULL, strlen(load_path), STRING,
strnzcpy));
loadstream = tmp_stream;
current_line = tmp_line;
}
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 *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 *cnv_node_to_strnode(NODE *nd)
{
char s[MAX_NUMBER];
if (nd == UNBOUND || aggregate(nd))
{
return (UNBOUND);
}
switch (nodetype(nd))
{
case STRING:
case BACKSLASH_STRING:
case VBAR_STRING:
return (nd);
case CASEOBJ:
return strnode__caseobj(nd);
case QUOTE:
nd = valref(cnv_node_to_strnode(node__quote(nd)));
nd = reref(nd, make_strnode(getstrptr(nd),
(char *) NULL, getstrlen(nd) + 1,
nodetype(nd), quote_strnzcpy));
unref(nd);
return (nd);
case COLON:
nd = valref(cnv_node_to_strnode(node__colon(nd)));
nd = reref(nd, make_strnode(getstrptr(nd),
(char *) NULL, getstrlen(nd) + 1,
nodetype(nd), colon_strnzcpy));
unref(nd);
return (nd);
case INT:
sprintf(s, "%ld", getint(nd));
return (make_strnode(s, (char *) NULL, (int) strlen(s),
STRING, strnzcpy));
case FLOAT:
sprintf(s, "%0.15g", getfloat(nd));
return (make_strnode(s, (char *) NULL, (int) strlen(s),
STRING, strnzcpy));
}
/*NOTREACHED*/
return (NIL);
}
NODE *luppercase(NODE *args)
{
NODE *arg;
arg = string_arg(args);
if (NOT_THROWING)
{
return make_strnode(getstrptr(arg), (char *) NULL,
getstrlen(arg), nodetype(arg), cap_strnzcpy);
}
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 *lreadchar(NODE *args) {
#ifdef WIN32
MSG msg;
#endif /* WIN32 */
char c;
if (readchar_lookahead_buf >= 0) {
c = (char)readchar_lookahead_buf;
readchar_lookahead_buf = -1;
return(make_strnode((char *)&c, (struct string_block *)NULL, 1,
(getparity(c) ? BACKSLASH_STRING : STRING), strnzcpy));
}
charmode_on();
input_blocking++;
#ifdef HAVE_WX
if (interactive && readstream==stdin) {
reading_char_now = 1;
c = getFromWX();
reading_char_now = 0;
}
else
c = (char)getc(readstream);
#else
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
{
#ifdef mac
csetmode(C_RAW, stdin);
while ((c = (char)getc(readstream)) == EOF && readstream == stdin);
csetmode(C_ECHO, stdin);
#else /* !mac */
#ifdef ibm
if (interactive && readstream==stdin)
#ifndef WIN32
c = (char)getch();
#else /* WIN32 */
{
win32_update_text();
if (!char_avail)
while(GetMessage(&msg, NULL, 0, 0))
{
TranslateMessage(&msg);
DispatchMessage(&msg);
if (char_avail)
break;
}
c = buffered_char;
char_avail = 0;
}
#endif /* WIN32 */
else
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);
}
void fileload(char *temp)
{
FILE *tmp;
NODE *tmp_line, *exec_list, *arg;
NODE *st = valnode__caseobj(Startup);
int sv_val_status = val_status;
int IsDirtySave;
int save_yield_flag;
arg = make_strnode(temp, NULL, strlen(temp), STRING, strnzcpy);
IsDirtySave = IsDirty;
tmp = loadstream;
tmp_line = vref(current_line);
loadstream = open_file(arg, "r");
if (loadstream != NULL)
{
save_yield_flag = yield_flag;
yield_flag = 0;
lsetcursorwait();
while (!feof(loadstream) && NOT_THROWING)
{
current_line = reref(current_line, reader(loadstream, ""));
exec_list = parser(current_line, TRUE);
val_status = 0;
if (exec_list != NIL) eval_driver(exec_list);
}
fclose(loadstream);
lsetcursorarrow();
yield_flag = save_yield_flag;
runstartup(st);
val_status = sv_val_status;
}
else
err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
loadstream = tmp;
deref(current_line);
current_line = tmp_line;
IsDirty = IsDirtySave;
}
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 *lsetwrite(NODE *arg) {
FILE *tmp;
NODE *margs;
if (writestream == NULL) {
/* Any setwrite finishes earlier write to string */
*print_stringptr = '\0';
writestream = stdout;
if (find_file(writer_name, FALSE) == NULL) {
/* pre-5.4 compatibility mode, implicitly close string */
margs = cons(car(writer_name),
cons(make_strnode(write_buf, NULL, strlen(write_buf),
STRING, strnzcpy),
NIL));
lmake(margs);
free(write_buf);
}
writer_name = NIL;
}
if (car(arg) == NIL) {
writestream = stdout;
writer_name = NIL;
} else if (is_list(car(arg))) { /* print to string */
FIXNUM i = int_arg(cdar(arg));
if ((tmp = find_file(car(arg), FALSE)) != NULL) {
writestream = NULL;
writer_name = car(arg);
print_stringptr = (char *)tmp + strlen((char *)tmp);
print_stringlen = i - strlen((char *)tmp);
} else if (NOT_THROWING && i > 0 && cddr(car(arg)) == NIL) {
writestream = NULL;
writer_name = copy_list(car(arg));
print_stringptr = write_buf = (char *)malloc(i);
print_stringlen = i;
} else err_logo(BAD_DATA_UNREC, car(arg));
} else if ((tmp = find_file(car(arg), FALSE)) != NULL) {
writestream = tmp;
writer_name = car(arg);
} else
err_logo(NOT_OPEN_ERROR, car(arg));
return(UNBOUND);
}
/* representation of an object */
NODE *lrepresentation(NODE *args) {
NODE *license, *binding, *classbind;
char buffer[200];
char *old_stringptr = print_stringptr;
int old_stringlen = print_stringlen;
print_stringlen = 200;
print_stringptr = buffer;
license = assoc(theName(Name_licenseplate), getvars(current_object));
ndprintf(NULL, "${Object %p", getobject(license));
binding = assoc(theName(Name_name), getvars(current_object));
if (binding != NIL && getobject(binding) != UNBOUND) {
ndprintf(NULL, ": %p", getobject(binding));
}
classbind = assoc(theName(Name_class), getvars(current_object));
if (classbind != NIL) {
if (binding == NIL || getobject(binding) == UNBOUND) {
ndprintf(NULL, ":");
}else {
ndprintf(NULL, ",");
}
ndprintf(NULL, " the class %p", getobject(classbind));
} else {
classbind = varInObjectHierarchy(theName(Name_class), FALSE);
if (classbind != UNBOUND && classbind != (NODE *)(-1)) {
if (binding == NIL) {
ndprintf(NULL, ":");
} else {
ndprintf(NULL, ",");
}
ndprintf(NULL, " a %p", classbind);
}
}
ndprintf(NULL, "}");
print_stringptr* = '\0';
print_stringptr = old_stringptr;
print_stringlen = old_stringlen;
return make_strnode(buffer, NULL, strlen(buffer), STRING, strnzcpy);
}
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 *lreadchar()
{
char c;
charmode_on();
input_blocking++;
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
#ifdef mac
csetmode(C_RAW, stdin);
while ((c = (char)getc(readstream)) == EOF && readstream == stdin);
csetmode(C_ECHO, stdin);
#else
#ifdef ibm
if (interactive && readstream==stdin)
c = (char)getch();
else
c = (char)getc(readstream);
if (c == 17) { /* control-q */
to_pending = 0;
err_logo(STOP_ERROR,NIL);
}
if (c == 23) { /* control-w */
logo_pause();
return(lreadchar());
}
#else
c = (char)getc(readstream);
#endif
#endif
input_blocking = 0;
if (feof(readstream)) {
return(NIL);
}
return(make_strnode(&c, (char *)NULL, 1,
(getparity(c) ? STRING : BACKSLASH_STRING), strnzcpy));
}
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 *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 *reader(FILE *strm, char *prompt) {
int c = 0, dribbling, vbar = 0, paren = 0;
int bracket = 0, brace = 0, p_pos, contin=1, insemi=0, raw=0;
char *phys_line, *lookfor = ender;
NODETYPES this_type = STRING;
NODE *ret;
char *old_stringptr = print_stringptr;
int old_stringlen = print_stringlen;
fix_turtle_shownness();
//readingInstruction = !strcmp(prompt, "? ");
readingInstruction = (strm == stdin);
#ifdef HAVE_WX
wx_refresh();
if(readingInstruction) {
wx_enable_scrolling();
}
#endif
print_stringptr = ender;
print_stringlen = 99;
ndprintf(NULL, "\n%p\n", theName(Name_end));
*print_stringptr = '\0';
print_stringptr = old_stringptr;
print_stringlen = old_stringlen;
if (!strcmp(prompt, "RW")) { /* called by readword */
prompt = "";
contin = 0;
}
if (!strcmp(prompt, "RAW")) { /* called by readrawline */
prompt = "";
contin = 0;
raw = 1;
}
charmode_off();
#ifdef WIN32
dribbling = 0;
#else
dribbling = (dribblestream != NULL && strm == stdin);
#endif
if (p_line == 0) {
p_line = malloc(MAX_PHYS_LINE);
if (p_line == NULL) {
err_logo(OUT_OF_MEM, NIL);
return UNBOUND;
}
p_end = &p_line[MAX_PHYS_LINE-1];
}
phys_line = p_line;
if (strm == stdin && *prompt) {
if (interactive) {
rd_print_prompt(prompt);
#ifdef WIN32
win32_update_text();
#endif
}
}
if (strm == stdin) {
input_blocking++;
erract_errtype = FATAL;
}
#ifndef TIOCSTI
if (!setjmp(iblk_buf)) {
#endif
c = rd_getc(strm);
/* if ((c=='\b' || c=='\127') && strm==stdin && interactive) {
silent_load(LogoLogo, logolib);
c = rd_getc(strm);
} */ /* 6.0 */
#ifdef mac
if (c == '\r') c = '\n'; /* seen in raw mode by keyp, never read */
#endif
while (c != EOF && (vbar || paren || bracket || brace || c != '\n')
&& NOT_THROWING) {
if (dribbling) rd_putc(c, dribblestream);
if (!raw && c == '\\' && (c = rd_getc(strm)) != EOF) {
if (dribbling) rd_putc(c, dribblestream);
c = setparity(c);
this_type = BACKSLASH_STRING;
if (c == setparity('\n') && strm == stdin) {
if (interactive) zrd_print_prompt("\\ ");
}
}
if (c != EOF) into_line(c);
if (raw) {
c = rd_getc(strm);
continue;
}
if (*prompt && (c&0137) == ((*lookfor)&0137)) {
lookfor++;
if (*lookfor == 0) {
if (deepend_proc_name != NIL)
err_logo(DEEPEND, deepend_proc_name);
else
err_logo(DEEPEND_NONAME, NIL);
break;
}
} else lookfor = ender;
if (c == '|' && !insemi) {
vbar = !vbar;
this_type = VBAR_STRING;
} else if (contin && !vbar && !insemi) {
if (c == '(') paren++;
else if (paren && c == ')') paren--;
else if (c == '[') bracket++;
else if (bracket && c == ']') bracket--;
else if (c == '{') brace++;
else if (brace && c == '}') brace--;
else if (c == ';') insemi++;
}
if (this_type == STRING && strchr(special_chars, c))
this_type = VBAR_STRING;
if (/* (vbar || paren ...) && */ c == '\n') {
insemi = 0;
if (strm == stdin) {
if (interactive) zrd_print_prompt(vbar ? "| " : "~ ");
}
}
while (!vbar && c == '~' && (c = rd_getc(strm)) != EOF) {
int gotspc = 0;
while (c == ' ' || c == '\t') {
gotspc = 1;
c = rd_getc(strm);
}
if (dribbling) rd_putc(c, dribblestream);
if (c != '\n' && gotspc) into_line(' ');
into_line(c);
if (c == '\n') {
insemi = 0;
if (interactive && strm == stdin) zrd_print_prompt("~ ");
}
else if (c == '(') paren++;
else if (paren && c == ')') paren--;
else if (c == '[') bracket++;
else if (bracket && c == ']') bracket--;
else if (c == '{') brace++;
else if (brace && c == '}') brace--;
else if (c == ';') insemi++;
}
if (c != EOF) c = rd_getc(strm);
}
#ifndef TIOCSTI
}
#endif
*phys_line = '\0';
input_blocking = 0;
#if defined(__RZTC__) && !defined(WIN32) /* sowings */
fix_cursor();
if (interactive && strm == stdin) newline_bugfix();
#endif
if (dribbling)
rd_putc('\n', dribblestream);
if (c == EOF && strm == stdin) {
if (interactive) clearerr(stdin);
rd_print_prompt("\n");
}
if (phys_line == p_line) return(Null_Word); /* so emptyp works */
ret = make_strnode(p_line, (struct string_block *)NULL, (int)strlen(p_line),
this_type, strnzcpy);
#if 0
if (strm == stdin && !strcmp(prompt, "? ")){
char *histline = malloc(1+strlen(p_line));
strcpy(histline, p_line);
*hist_inptr++ = histline;
if (hist_inptr >= &cmdHistory[HIST_MAX]) {
hist_inptr = cmdHistory;
}
if (*hist_inptr) {
free(*hist_inptr);
*hist_inptr = 0;
}
hist_outptr = hist_inptr;
}
#endif
//added (evan)
readingInstruction = 0;
return(ret);
}
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);
}
/* Creates new license plate for object */
NODE *newplate(void) {
char buffer[20];
sprintf(buffer,"G%d", gensymnum++);
return make_strnode(buffer, NULL, strlen(buffer), STRING, strnzcpy);
return UNBOUND;
}