NODE *lactivearea(void) { // if custom return settings return ( cons(make_intnode((FIXNUM) PrinterAreaXLow), cons(make_intnode((FIXNUM) PrinterAreaYLow), cons(make_intnode((FIXNUM) PrinterAreaXHigh), cons(make_intnode((FIXNUM) PrinterAreaYHigh), NIL ))))); }
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 *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); }
/* The logo word ? <question-mark>. */ NODE *lqm(NODE *args) { FIXNUM argnum = 1, i; NODE *np = qm_list; if (args != NIL) argnum = getint(pos_int_arg(args)); if (stopping_flag == THROWING) return(UNBOUND); i = argnum; while (--i > 0 && np != NIL) np = cdr(np); if (np == NIL) return(err_logo(BAD_DATA_UNREC,make_intnode(argnum))); return(car(np)); }
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 *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 *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 *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 *Get_node_pen_pattern(void) { return(cons(make_intnode(0-1L), NIL)); }
/* Parenthesize an expression. Set expr to the node after the first full * expression. */ NODE *paren_expr(NODE **expr, BOOLEAN inparen) { NODE *first = NIL, *tree = NIL, *pproc, *retval; NODE **ifnode = (NODE **)NIL; if (*expr == NIL) { if (inparen) err_logo(PAREN_MISMATCH, NIL); return *expr; } first = car(*expr); pop(*expr); if (nodetype(first) == CASEOBJ && !numberp(first)) { if (first == Left_Paren) { tree = paren_expr(expr, TRUE); tree = paren_infix(tree, expr, -1, TRUE); if (*expr == NIL) err_logo(PAREN_MISMATCH, NIL); else if (car(*expr) != Right_Paren) { /* throw the rest away */ int parens; for (parens = 0; *expr; pop(*expr)) { if (car(*expr) == Left_Paren) parens++; else if (car(*expr) == Right_Paren) if (parens-- == 0) { pop(*expr); break; } } first = tree /* car(tree) */ ; /* 6.0 */ tree = cons(Not_Enough_Node, NIL); /* tell eval */ tree_dk_how=UNBOUND; if (is_list(first)) first = car(first); if (nodetype(first) != CASEOBJ || procnode__caseobj(first) == UNDEFINED) err_logo(DK_HOW, first); else err_logo(TOO_MUCH, first); } else pop(*expr); retval = tree; } else if (first == Right_Paren) { err_logo(UNEXPECTED_PAREN, NIL); if (inparen) push(first, *expr); retval = NIL; } else if (first == Minus_Sign) { push(Minus_Tight, *expr); retval = paren_infix(make_intnode((FIXNUM) 0), expr, -1, inparen); } else { /* it must be a procedure */ check_library(first); pproc = procnode__caseobj(first); if (pproc == UNDEFINED) { if (missing_space(first)) { push(missing_numeric, *expr); first = missing_alphabetic; pproc = procnode__caseobj(first); retval = gather_args(first, pproc, expr, inparen, ifnode); if (retval != UNBOUND) { retval = cons(first, retval); } } else if (is_setter(first)) { retval = gather_some_args(0, 1, expr, inparen, ifnode); if (retval != UNBOUND) { retval = cons(first, retval); } } else { retval = cons(first, NIL); tree_dk_how = first; } } else if (nodetype(pproc) == INFIX && NOT_THROWING) { err_logo(NOT_ENOUGH, first); retval = cons(first, NIL); } else { /* Kludge follows to turn IF to IFELSE sometimes. */ if (isName(first, Name_if)) { ifnode = &first; } retval = gather_args(first, pproc, expr, inparen, ifnode); if (retval != UNBOUND) { retval = cons(first, retval); } } } } else if (is_list(first)) { /* quoted list */ retval = make_quote(first); } else { return first; } return retval; }
NODE *lwritepos() { return(make_intnode(ftell(writestream))); }
NODE *lreadpos() { return(make_intnode(ftell(readstream))); }
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); }