unroff/src/expr.c

236 lines
4.8 KiB
C

/* $Revision: 1.5 $
*/
/* Scheme primitives that deal with troff numeric expressions.
*/
#include "unroff.h"
#define SCALE_INDICATORS "icPmnpuv"
enum operator {
ADD, SUB, DIV, MUL, MOD, LT, GT, LE, GE, EQ, AND, OR, OOPS
};
static int scale_factor[128];
static int scale_divisor[128];
static Object p_set_scaling(Object scale, Object x, Object y) {
int d, c;
Check_Type(scale, T_Character);
c = CHAR(scale);
if (c == 0 || strchr(SCALE_INDICATORS, c) == 0)
Primitive_Error("invalid scale indicator ~s", scale);
scale_factor[c] = Get_Integer(x);
if ((d = Get_Integer(y)) == 0)
Range_Error(y);
scale_divisor[c] = d;
return Void;
}
static Object p_get_scaling(Object scale) {
int c;
Object ret = Null;
GC_Node;
Check_Type(scale, T_Character);
c = CHAR(scale);
if (c == 0 || strchr(SCALE_INDICATORS, c) == 0)
Primitive_Error("invalid scale indicator ~s", scale);
GC_Link(ret);
ret = Cons(Make_Integer(scale_factor[c]), Null);
Cdr(ret) = Make_Integer(scale_divisor[c]);
GC_Unlink;
return ret;
}
static enum operator get_operator(char **p) {
enum operator op;
switch (**p) {
case '+':
op = ADD; break;
case '-':
op = SUB; break;
case '/':
op = DIV; break;
case '*':
op = MUL; break;
case '%':
op = MOD; break;
case '<':
if ((*p)[1] == '=') {
(*p)++;
op = LE;
} else
op = LT;
break;
case '>':
if ((*p)[1] == '=') {
(*p)++;
op = GE;
} else
op = GT;
break;
case '&':
op = AND; break;
case ':':
op = OR; break;
case '=':
if ((*p)[1] == '=')
(*p)++;
op = EQ;
break;
default:
return OOPS;
}
(*p)++;
return op;
}
static double parse_expr(char **, int, int);
static double get_operand(char **p, int scale, int rest) {
double d;
char *ep;
if (**p == '(') {
(*p)++;
d = parse_expr(p, scale, rest);
if (*p) {
if (**p != ')') *p = 0;
else (*p)++;
}
return d;
}
d = strtod(*p, &ep);
if (ep == *p) {
*p = 0;
return 0;
}
*p = ep;
if (**p && strchr(SCALE_INDICATORS, **p)) {
scale = **p;
(*p)++;
}
return d * scale_factor[scale] / scale_divisor[scale];
}
static double parse_expr(char **p, int scale, int rest) {
double acc, d;
enum operator op;
acc = get_operand(p, scale, rest);
if (*p == 0)
return 0;
while (**p && **p != ')') {
if ((op = get_operator(p)) == OOPS) {
if (rest)
break;
err: *p = 0;
return 0;
}
d = get_operand(p, scale, rest);
if (*p == 0)
return 0;
switch (op) {
case ADD:
acc += d; break;
case SUB:
acc -= d; break;
case DIV:
if (d == 0.0) {
warn("division by zero"); goto err;
}
acc /= d; break;
case MUL:
acc *= d; break;
case MOD:
acc = fmod(acc, d);
if (isnan(acc)) {
warn("division by zero"); goto err;
}
break;
case LT:
acc = acc < d; break;
case GT:
acc = acc > d; break;
case LE:
acc = acc <= d; break;
case GE:
acc = acc >= d; break;
case EQ:
acc = acc == d; break;
case AND:
acc = acc > 0 && d > 0; break;
case OR:
acc = acc > 0 || d > 0; break;
case OOPS:
assert(0);
}
}
if (!isfinite(acc)) {
warn("expression evaluates to infinity"); goto err;
}
return acc;
}
static Object parse_expression(Object str, Object fail, Object scale,
int rest) {
int c;
char *e, *s;
double d;
Object ret;
Check_Type(scale, T_Character);
c = CHAR(scale);
if (c == 0 || strchr(SCALE_INDICATORS, c) == 0)
Primitive_Error("invalid scale indicator ~s", scale);
e = s = Get_String(str);
d = parse_expr(&s, c, rest);
if (s == 0 || (*s && !rest)) {
warn("invalid expression: `%s'", e);
return fail;
}
ret = P_Inexact_To_Exact(Make_Flonum(d));
if (rest) {
Object x;
GC_Node;
GC_Link(ret);
ret = Cons(ret, Null);
x = Make_String(s, strlen(s));
Cdr(ret) = x;
GC_Unlink;
}
return ret;
}
static Object p_parse_expression(Object str, Object fail, Object scale) {
return parse_expression(str, fail, scale, 0);
}
static Object p_parse_expression_rest(Object str, Object fail, Object scale) {
return parse_expression(str, fail, scale, 1);
}
static Object p_char_expression_delimiter(Object c) {
Check_Type(c, T_Character);
return strchr("0123456789()+-*/%<>=:&.", CHAR(c)) ? True : False;
}
void init_expr(void) {
char *p;
for (p = SCALE_INDICATORS; *p; p++)
scale_factor[(int)*p] = scale_divisor[(int)*p] = 1;
Define_Primitive(p_set_scaling, "set-scaling!", 3, 3, EVAL);
Define_Primitive(p_get_scaling, "get-scaling", 1, 1, EVAL);
Define_Primitive(p_parse_expression, "parse-expression", 3, 3, EVAL);
Define_Primitive(p_parse_expression_rest,
"parse-expression-rest", 3, 3, EVAL);
Define_Primitive(p_char_expression_delimiter,
"char-expression-delimiter?", 1, 1, EVAL);
}