struct expr *prefix(char *expect)
{
struct expr *res = NULL;
int toktype = tok->type;
switch (toktype)
{
case IDENTIFIER:
return identexpr(strdup(tok->val));
case LPAREN:
res = expression(0);
eat(RPAREN);
return res;
case PLUS: case MINUS: case NOT:
return unopexpr(toktype, expression(lbp(toktype) - 1));
case REAL:
return expr_from_val(realval(atof(tok->val)));
case INT:
return expr_from_val(intval(atoi(tok->val)));
case CHAR:
return expr_from_val(charval(tok->val[1]));
case STRING:
return expr_from_val(strval(strdup(tok->val)));
case TRUE:
return expr_from_val(boolval(1));
case FALSE:
return expr_from_val(boolval(0));
case NULLKW:
return nullexpr();
default:
syntaxerror("expected %s, not %s", expect, tok->val);
return NULL;
}
}
struct val *parse_val(void)
{
next();
switch (tok->type)
{
case INT: return intval(atoi(tok->val));
case REAL: return realval(atof(tok->val));
case STRING: return strval(tok->val);
case TRUE: return boolval(true);
case FALSE: return boolval(false);
case CHAR: return charval(tok->val[1]);
default:
syntaxerror("expected a value, not %s", tok->val);
return intval(0);
}
}
nialptr
testbinfaults(nialptr x, nialptr stdfault, int divflag)
{
nialptr x0 = fetch_array(x, 0),
x1 = fetch_array(x, 1);
switch (kind(x0)) {
case booltype:
case inttype:
case realtype:
freeup(stdfault);
return (x1);
case chartype:
case phrasetype: /* fall out to return stdfault */
break;
case faulttype:
switch (kind(x1)) {
case booltype:
if (divflag && boolval(x1) == 0)
break;
freeup(stdfault);
return (x0);
case inttype:
if (divflag && intval(x1) == 0)
break;
freeup(stdfault);
return (x0);
case realtype:
if (divflag && realval(x1) == 0.0)
break;
freeup(stdfault);
return (x0);
case chartype:
case phrasetype:
break;
case faulttype:
if (x0 == x1) {
freeup(stdfault);
return (x0);
}
break;
}
}
return (stdfault);
}
void putatom (LISP p, FILE *fd)
{
if (p == NIL) {
fputs ("()", fd);
return;
}
switch (mem[p].type) {
case TSYMBOL: fputs (symname (p), fd); break;
case TBOOL: fputs ("#t", fd); break;
case TINTEGER: fprintf (fd, "%ld", numval (p)); break;
case TREAL: fprintf (fd, "%#g", realval (p)); break;
case TSTRING: putstring (p, fd); break;
case TVECTOR: putvector (p, fd); break;
case TCHAR: putchr (charval (p), fd); break;
case THARDW: fprintf (fd, "<builtin-%lx>", (long) hardwval (p)); break;
case TCLOSURE: fprintf (fd, "<closure-%lx>", p); break;
default: fputs ("<?>", fd); break;
}
}
