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) { i = (FIXNUM)f; 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; }
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); }
void set_list_pen_pattern(NODE *arg) { NODE *temp; temp = cnv_node_to_numnode(car(arg)); ztc_linepattern = getint(temp); }
NODE *lnumberp(NODE *arg) { setcar(arg, cnv_node_to_numnode(car(arg))); return torf(car(arg) != UNBOUND); }
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); }