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);
}
