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 *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 *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); }
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 *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 *lvbarredp(NODE *args) { char i; NODE *arg; arg = char_arg(args); if (NOT_THROWING) { i = *getstrptr(arg); return torf(getparity(i)); } return(UNBOUND); }
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 *lerasefile(NODE *arg) { char *fnstr; arg = cnv_node_to_strnode(car(arg)); if (arg == UNBOUND) return(UNBOUND); fnstr = malloc((size_t)getstrlen(arg) + 1); strnzcpy(fnstr, getstrptr(arg), getstrlen(arg)); unlink(fnstr); free(fnstr); return(UNBOUND); }
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; }
char *word_strnzcpy(char *s1, NODE *kludge, int n) /* KLUDGE! */ { char *temp = s1; while (kludge != NIL) { strncpy(s1, getstrptr(car(kludge)), getstrlen(car(kludge))); s1 += getstrlen(car(kludge)); kludge = cdr(kludge); } temp[n] = '\0'; return (temp); }
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 *cnv_node_to_numnode(NODE *ndi) { NODE *val; int dr; char s2[MAX_NUMBER], *s = s2; if (is_number(ndi)) return (ndi); ndi = cnv_node_to_strnode(ndi); if (ndi == UNBOUND) return (UNBOUND); if (((getstrlen(ndi)) < MAX_NUMBER) && (dr = numberp(ndi))) { if (backslashed(ndi)) noparity_strnzcpy(s, getstrptr(ndi), getstrlen(ndi)); else strnzcpy(s, getstrptr(ndi), getstrlen(ndi)); if (*s == '+') ++s; if (s2[getstrlen(ndi) - 1] == '.') s2[getstrlen(ndi) - 1] = 0; if (/*TRUE || */ dr - 1 || getstrlen(ndi) > 9) { val = newnode(FLOAT); setfloat(val, atof(s)); } else { val = newnode(INT); setint(val, atol(s)); } gcref(ndi); return (val); } else { gcref(ndi); return (UNBOUND); } }
NODE *lerasefile(NODE *arg) { char *fnstr; arg = cnv_node_to_strnode(car(arg)); if (arg == UNBOUND) return(UNBOUND); fnstr = malloc((size_t)getstrlen(arg) + 1); if (fnstr == NULL) { err_logo(FILE_ERROR, make_static_strnode(message_texts[MEM_LOW])); return UNBOUND; } strnzcpy(fnstr, getstrptr(arg), getstrlen(arg)); unlink(fnstr); free(fnstr); return(UNBOUND); }
FILE *open_file(NODE *arg, char *access) { char *fnstr; FILE *tstrm; ref(arg); arg = reref(arg, cnv_node_to_strnode(arg)); if (arg == UNBOUND) return(NULL); fnstr = (char *) malloc((size_t)getstrlen(arg) + 1); strnzcpy(fnstr, getstrptr(arg), getstrlen(arg)); tstrm = fopen(fnstr, access); deref(arg); free(fnstr); return(tstrm); }
FILE *open_file(NODE *arg, char *access) { char *fnstr; FILE *tstrm; char *old_stringptr = print_stringptr; int old_stringlen = print_stringlen; if (is_list(arg)) { /* print to string */ if (*access != 'w') { err_logo(BAD_DATA_UNREC, arg); return NULL; } else { FIXNUM i = int_arg(cdr(arg)); if (NOT_THROWING && i > 0 && cddr(arg) == NIL) { char *tmp = (char *)malloc(i); *tmp = '\0'; return (FILE *)tmp; } err_logo(BAD_DATA_UNREC, car(arg)); return NULL; } } arg = cnv_node_to_strnode(arg); if (arg == UNBOUND) return(NULL); if (file_prefix != NIL) { print_stringlen = getstrlen(file_prefix) + getstrlen(arg) + 2; fnstr = (char *)malloc((size_t)print_stringlen + 1); } else fnstr = (char *) malloc((size_t)getstrlen(arg) + 1); if (fnstr == NULL) { err_logo(FILE_ERROR, make_static_strnode(message_texts[MEM_LOW])); print_stringptr = old_stringptr; print_stringlen = old_stringlen; return NULL; } if (file_prefix != NIL) { print_stringptr = fnstr; ndprintf((FILE *)NULL, "%p%t%p", file_prefix, separator, arg); *print_stringptr = '\0'; print_stringptr = old_stringptr; print_stringlen = old_stringlen; } else noparity_strnzcpy(fnstr, getstrptr(arg), getstrlen(arg)); tstrm = fopen(fnstr, access); free(fnstr); return(tstrm); }
void silent_load(NODE *arg, char *prefix) { FILE *tmp_stream; NODE *tmp_line, *exec_list; char load_path[200]; NODE *st = valnode__caseobj(Startup); int sv_val_status = val_status; /* 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. */ if (prefix == NULL && arg == NIL) return; strcpy(load_path, (prefix == NULL ? "" : prefix)); if (arg != NIL) { arg = cnv_node_to_strnode(arg); if (arg == UNBOUND) return; #ifdef unix if (prefix != NULL) strcat(load_path, "/"); #endif noparitylow_strnzcpy(load_path + (int)strlen(load_path), getstrptr(arg), getstrlen(arg)); if (prefix == NULL) strcat(load_path, ".lg"); gcref(arg); } tmp_stream = loadstream; tmp_line = vref(current_line); loadstream = fopen(load_path, "r"); if (loadstream != NULL) { 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); runstartup(st); val_status = sv_val_status; } else if (arg == NIL) ndprintf(stdout,"File not found: %t\n", prefix); loadstream = tmp_stream; deref(current_line); current_line = tmp_line; }
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 *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 *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 *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); }
char *asciiz(NODE *arg) { char *out = (char *)malloc(getstrlen(arg)+1); return noparity_strnzcpy(out, getstrptr(arg), getstrlen(arg)); }
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); }
/* See if an unknown procedure name starts with SET */ int is_setter(NODE *name) { NODE *string = cnv_node_to_strnode(name); if (getstrlen(string) < 4) return FALSE; return !low_strncmp(getstrptr(string), "set", 3); }