#include "real.h" #include #include #include #include #include #include #include #include #include #define MAX_INPUT_LEN 80 #define STACK_SIZE 120 // Placeholder functions to stave off warnings from macros // TODO: raise error if these are ever called. static inline Real mod_R_R(Real _, Real __) { ++_; return __; } static inline Real mod_R_Int(Real _, int __) { ++__; return _; } static inline Real mod_Int_R(int _, Real __) { ++_; return __; } static inline Real add_Int_R(int _, Real __) { ++_; return __; } static inline Real mul_Int_R(int _, Real __) { ++_; return __; } /* static inline Real add_Int_R(int _, Real __) { while(false) {++_; return __; }} */ // Saves the state for error handling. jmp_buf env; // Error types #define BAD_COMMAND 1 #define UNDERFLOW 2 #define UNDERFLOW_REG 3 #define OVERFLOW 4 #define OVERFLOW_REG 5 #define BAD_VALUE 6 #define EXIT 7 // Cells are what live on the stack and in registers. // They abstract over the underlying number type. typedef enum { REAL = 1, STRING = 2, INTEGER = 3, NATIVE = 4, } CellType; typedef struct { int reference_count; char register_in; int register_location; CellType type; union { Real r; char *s; mpz_t z; int n; }; } StackCell; // Main stack. StackCell calc_stack[STACK_SIZE]; int stack_top = -1; // Register stacks. StackCell registers[256][STACK_SIZE]; int register_tops[256] = {0}; // Global parameters. // The precision is a display precision: the numbers are lazily computed, but conceptually infinite. int precision = 10; // Alternative bases greater than 10 have additional digits given by uppercase letters A-F. // This agrees with both GMP and C's reading conventions; restricting to uppercase avoids collision with dc commands. // The maximum radix is accordingly 16 (minimum of course 2). int input_radix = 10; int output_radix = 10; // Functions to interact with the stack. // They are specialized according to cell type, so that errors can be caught early. // Most errors just print info about them and reset the parser (via longjmp). static inline void push(StackCell c) { if (stack_top == STACK_SIZE - 1) { longjmp(env, OVERFLOW); } ++stack_top; calc_stack[stack_top] = c; } static inline void pushr(Real x) { if (stack_top == STACK_SIZE - 1) { longjmp(env, OVERFLOW); } ++stack_top; StackCell new = {.type = REAL, .r = x, .register_location = -1}; calc_stack[stack_top] = new; } static inline void pushs(const char *string) { // NOTE: string passed in gets strdup'ed. if (stack_top == STACK_SIZE - 1) { longjmp(env, OVERFLOW); } ++stack_top; char *persistent = strdup(string); StackCell new = {.type = STRING, .s = persistent, .reference_count = 1, .register_location = -1}; calc_stack[stack_top] = new; } static inline void pushz(mpz_t integer) { if (stack_top == STACK_SIZE - 1) { longjmp(env, OVERFLOW); } ++stack_top; StackCell new = {.type = INTEGER, .reference_count = 1, .register_location = -1}; mpz_init(new.z); mpz_set(new.z, integer); calc_stack[stack_top] = new; } static inline void pushn(int native) { if (stack_top == STACK_SIZE - 1) { longjmp(env, OVERFLOW); } ++stack_top; StackCell new = {.type = NATIVE, .n = native, .register_location = -1}; calc_stack[stack_top] = new; } static inline StackCell pop(void) { if (stack_top < 0) { longjmp(env, UNDERFLOW); } --stack_top; return calc_stack[stack_top + 1]; } static inline Real popr(void) { if (stack_top < 0) { longjmp(env, UNDERFLOW); } StackCell top = calc_stack[stack_top]; if (top.type != REAL) { longjmp(env, BAD_VALUE); } --stack_top; return top.r; } static inline int popn(int min, int max) { if (stack_top < 0) { longjmp(env, UNDERFLOW); } StackCell top = calc_stack[stack_top]; if (top.type != NATIVE || top.n < min || top.n > max) { longjmp(env, BAD_VALUE); } --stack_top; return top.n; } static inline StackCell peek(void) { if (stack_top < 0) { longjmp(env, UNDERFLOW); } return calc_stack[stack_top]; } #define gcz(var) do { \ if (var.register_location > -1) \ if (--registers[(int)var.register_in][(int)var.register_location].reference_count == 0) { \ mpz_clear(var.z); \ var.register_location = -1; \ } \ } while (0) #define gcs(var) do { \ if (var.register_location > -1) \ if (--registers[(int)var.register_in][(int)var.register_location].reference_count == 0) { \ free(var.s); \ var.register_location = -1; \ } \ } while (0) static inline void display(StackCell cell) { switch (cell.type) { case REAL: print_R_Dec(cell.r, precision); break; case STRING: printf(cell.s); #ifdef DEBUG if (cell.register_location > -1) printf(" reference count: %i", registers[(int)cell.register_in][(int)cell.register_location].reference_count); #endif break; case INTEGER: mpz_out_str(stdout, output_radix, cell.z); #ifdef DEBUG if (cell.register_location > -1) printf(" reference count: %i", registers[(int)cell.register_in][(int)cell.register_location].reference_count); #endif break; case NATIVE: { int n = (cell.n < 0) ? -cell.n : cell.n; char converted[12]; char base_digits[16] = {'0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'}; int index = 0; while (n) { converted[index] = n % output_radix; n /= output_radix; ++index; } if (cell.n < 0) { putchar('-'); } while(--index >= 0) { putchar(base_digits[(int)converted[index]]); } } } putchar('\n'); } static inline void displayf(StackCell cell) { // Freeing display. switch (cell.type) { case REAL: print_R_Dec(cell.r, precision); break; case STRING: printf(cell.s); gcs(cell); break; case INTEGER: mpz_out_str(stdout, output_radix, cell.z); gcz(cell); break; case NATIVE: { int n = (cell.n < 0) ? -cell.n : cell.n; char converted[12]; char base_digits[16] = {'0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'}; int index = 0; while (n) { converted[index] = n % output_radix; n /= output_radix; ++index; } if (cell.n < 0) { putchar('-'); } while(--index >= 0) { putchar(base_digits[(int)converted[index]]); } } } } typedef enum { START, DIGITS_OR_DECIMAL_OR_VINCULUM, DIGITS, TRIG, HYPERB, TRIG_OR_HYPERB, STORE_REGISTER_NAME, LOAD_REGISTER_NAME, PUSHSTORE_REGISTER_NAME, POPLOAD_REGISTER_NAME, STRING_CONTENTS, GREATER_THAN_REG, LESS_THAN_REG, EQUAL_REG, NOT_CONTENTS, NOT_GREATER_THAN_REG, NOT_LESS_THAN_REG, NOT_EQUAL_REG, WAITING_TARGET_MACRO_DEPTH, COMMENT_CONTENTS, REGISTER_SET_NAME, REGISTER_GET_NAME } ParseState; typedef struct { int macro_depth; unsigned int string_depth; ParseState expecting; char parse_stack[MAX_INPUT_LEN]; int stack_top; bool integer; int target_macro_depth; bool inverse; } ParseVars; ParseVars pv = {0, 0, START, {0}, -1, true, 0, false}; static inline void parse_push(char token) { if (pv.stack_top == MAX_INPUT_LEN - 1) { longjmp(env, OVERFLOW); } ++pv.stack_top; pv.parse_stack[pv.stack_top] = token; } static inline void progress(ParseState next) { pv.expecting = next; } static inline void reset(void) { pv.expecting = START; pv.stack_top = -1; pv.integer = true; pv.inverse = false; } // A global variable containing an mpz_t with value 1, so we don't need to constantly initialize it. mpz_t one; // This macro saves us a whole lotta work by abstracting away the patterns in ERA and GMP function names. // It's hard on the eyes, but copying out the type dispatching logic almost verbatim four times would be worse. // TODO: ensure that operation on ints don't over- or underflow, upgrading otherwise. // TODO: think extra hard about memory management with GMP integers and strings. // TODO: note reversing the stupid dc ordering. // TODO: note the difference from dc: a is only greater than b if it is /provably/ greater than b. // to within the provided extra argument's level of precision. // A is equal to B if it is not provable that they are different within precision.e #define upgradez(var) do { \ if (var.type == NATIVE) { \ mpz_t upgraded; \ mpz_init(upgraded); \ mpz_set_si(upgraded, var.n); \ mpz_set(var.z, upgraded); \ var.type = INTEGER; \ var.reference_count = 1; \ } \ } while (0) #define upgrader(var) do { \ if (var.type == INTEGER) { \ mpz_t copy; \ mpz_init_set(copy, var.z); \ if (--var.reference_count == 0) \ mpz_clear(var.z); \ var.r = real_QZ(copy, one); \ var.type = REAL; \ mpz_clear(copy); \ } \ } while (0) #define pair(x, y) ((x + y - 1) * (x + y - 2) / 2 + y) // Emacs' syntax highlighting and alignment for interesting macros is janky. #define dispatch(op, real_opname, commutative, integer_only, gmp_opname) do { \ StackCell b = pop(); \ StackCell a = pop(); \ \ if (integer_only) { \ if (!((a.type == NATIVE || a.type == INTEGER) \ && (b.type == NATIVE || b.type == INTEGER))) { \ longjmp(env, BAD_VALUE);}} \ \ \ switch (pair(a.type, b.type)) { \ case pair(NATIVE, NATIVE): \ pushn(a.n op b.n); \ break; \ case pair(NATIVE, INTEGER): \ if (commutative) { \ mpz_t result; \ mpz_init(result); \ mpz_##gmp_opname##_ui(result, b.z, a.n); \ pushz(result); \ gcz(b); \ } else { \ mpz_t upgraded; \ mpz_t result; \ mpz_init(upgraded); \ mpz_init(result); \ mpz_set_si(upgraded, a.n); \ mpz_##gmp_opname(result, upgraded, b.z); \ pushz(result); \ mpz_clear(upgraded); \ gcz(b); \ } \ \ break; \ case pair(NATIVE, REAL): \ if (commutative) { \ pushr(real_opname##_R_Int(b.r, a.n)); \ } else { \ pushr(real_opname##_Int_R(a.n, b.r)); \ } \ \ break; \ case pair(INTEGER, NATIVE): { \ mpz_t result; \ mpz_init(result); \ mpz_##real_opname##_ui(result, a.z, b.n); \ pushz(result); \ gcz(a); \ break; \ } \ case pair(INTEGER, INTEGER): { \ mpz_t result; \ mpz_init(result); \ mpz_##gmp_opname(result, a.z, b.z); \ pushz(result); \ gcz(a); \ gcz(b); \ break; \ } \ case pair(INTEGER, REAL): \ pushr(real_opname##_R_R(real_QZ(a.z, one), b.r)); \ gcz(a); \ break; \ case pair(REAL, NATIVE): \ pushr(real_opname##_R_Int(a.r, b.n)); \ break; \ case pair(REAL, INTEGER): \ pushr(real_opname##_R_R(a.r, real_QZ(b.z, one))); \ gcz(b); \ break; \ case pair(REAL, REAL): \ pushr(real_opname##_R_R(a.r, b.r)); \ break; \ default: \ longjmp(env, BAD_VALUE); \ } \ } while (0) // Ugly, but appreciably fast. static inline int count_digits(int n) { if (n < 0) n = (n == INT_MIN) ? INT_MAX : -n; if (n < 10) return 1; if (n < 100) return 2; if (n < 1000) return 3; if (n < 10000) return 4; if (n < 100000) return 5; if (n < 1000000) return 6; if (n < 10000000) return 8; if (n < 100000000) return 9; return 10; } #define dispatch_pred(op, op_neg, name, name_neg) do { \ int prec = popn(0, INT_MAX); \ StackCell b = pop(); \ StackCell a = pop(); \ bool result; \ switch (pair(a.type, b.type)) { \ case pair(NATIVE, NATIVE): \ result = a.n op b.n; \ break; \ case pair(NATIVE, INTEGER): \ result = mpz_cmp_si(b.z, a.n) op_neg 0; \ gcz(b); \ break; \ case pair(INTEGER, NATIVE): \ result = mpz_cmp_si(a.z, b.n) op 0; \ gcz(a); \ break; \ case pair(INTEGER, INTEGER): \ result = mpz_cmp(a.z, b.z) op 0; \ gcz(a); \ gcz(b); \ break; \ case pair(NATIVE, REAL): { \ Bool r_lazy = not_B(name_neg##_R_QInt(b.r, a.n, 1)); \ force_B(r_lazy, prec); \ result = boolValue(r_lazy) == LAZY_TRUE; \ break; \ } \ case pair(REAL, NATIVE): { \ Bool r_lazy = name##_R_QInt(b.r, a.n, 1); \ force_B(r_lazy, prec); \ \ result = boolValue(r_lazy) == LAZY_TRUE; \ break; \ } \ case pair(INTEGER, REAL): \ case pair(REAL, INTEGER): \ case pair(REAL, REAL): { \ if (a.type == INTEGER) { \ upgrader(a); \ } \ if (b.type == INTEGER) { \ upgrader(b); \ } \ Bool r_lazy = name##_R_R(a.r, b.r); \ force_B(r_lazy, prec); \ result = boolValue(r_lazy) == LAZY_TRUE; \ break; \ } \ default: \ longjmp(env, BAD_VALUE); \ break; \ } \ \ reset(); \ \ if (result) { \ interpret('l'); \ interpret(token); \ interpret('x'); \ } \ } while(0) #define special_func(name) do { \ StackCell c = pop(); \ switch (c.type) { \ case NATIVE: \ pushr(name##_QInt(c.n, 1)); \ break; \ case INTEGER: \ pushr(name##_QZ(c.z, one)); \ gcz(c); \ break; \ case REAL: \ pushr(name##_R(c.r)); \ break; \ case STRING: \ longjmp(env, BAD_VALUE); \ break; \ } \ } while(0) #define invertible_special(name) do { \ StackCell c = pop(); \ switch (c.type) { \ case NATIVE: \ if (pv.inverse) \ pushr(a##name##_QInt(c.n, 1)); \ else \ pushr(name##_QInt(c.n, 1)); \ break; \ case INTEGER: \ if (pv.inverse) \ pushr(a##name##_QZ(c.z, one)); \ else \ pushr(name##_QZ(c.z, one)); \ gcz(c); \ break; \ case REAL: \ if (pv.inverse) \ pushr(a##name##_R(c.r)); \ else \ pushr(a##name##_R(c.r)); \ break; \ case STRING: \ longjmp(env, BAD_VALUE); \ break; \ } \ } while(0) #define execute(command) do { \ for (size_t i = 0; i < strlen(command); i++) { \ interpret(command[i]); \ } \ } while(false) // returns void because we need to handle errors with longjmp anyway. void interpret(char token) { // The manpage very helpfully provides definitions of some redundant operators. if (token == EOF) { longjmp(env, EXIT); } switch (pv.expecting) { case START: switch (token) { // Number entry. case '_': parse_push('-'); progress(DIGITS_OR_DECIMAL_OR_VINCULUM); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': parse_push(token); progress(DIGITS_OR_DECIMAL_OR_VINCULUM); break; // Printing commands. case 'p': if (stack_top >= 0) { display(peek()); } break; case 'm': displayf(pop()); break; case 'f': for (int i = 0; i <= stack_top; i++) { display(calc_stack[i]); } break; case 'N': {// Negation. StackCell a = pop(); switch (a.type) { case NATIVE: a.n *= -1; pushn(a.n); break; case INTEGER: { mpz_t result; mpz_init(result); mpz_neg(result, a.z); pushz(result); gcz(a); break; } case REAL: pushr(neg_R(a.r)); break; default: longjmp(env, BAD_VALUE); } break; } case 'M': {// Magnitude (absolute value). StackCell a = pop(); switch (a.type) { case NATIVE: pushn(abs(a.n)); break; case INTEGER:{ mpz_t result; mpz_init(result); mpz_abs(result, a.z); pushz(result); gcz(a); break; } case REAL: pushr(abs_R(a.r)); break; default: longjmp(env, BAD_VALUE); break; } break; } case '+': dispatch(+, add, true, false, add); break; case '-': dispatch(-, sub, false, false, sub); break; case '*': dispatch(*, mul, true, false, mul); break; case '/': // Division by (real) zero has to be nonterminating because equality with zero is nonterminating. Otherwise, segfault. dispatch(/, div, false, false, tdiv_q); break; case '%': dispatch(%, mod, false, true, mod); break; case '~': execute("SdSn lnld/ LnLd%"); break; case '^': { // Has to be different because we must upgrade mixed terms. StackCell b = pop(); StackCell a = pop(); switch (pair(a.type, b.type)) { case pair(NATIVE, NATIVE): { mpz_t result; mpz_init(result); mpz_ui_pow_ui(result, a.n, b.n); pushz(result); } break; case pair(INTEGER, NATIVE):{ mpz_t result; mpz_init(result); mpz_pow_ui(result, a.z, b.n); pushz(result); break; } case pair(NATIVE, INTEGER): case pair(INTEGER, INTEGER): case pair(REAL, INTEGER): case pair(INTEGER, REAL): case pair(REAL, REAL): if (a.type == NATIVE) upgradez(a); if (a.type == INTEGER) upgrader(a); if (b.type == INTEGER) upgrader(b); pushr(pow_R_R(a.r, b.r)); break; default: longjmp(env, BAD_VALUE); break; } break; } case 'T': { int arity = popn(1, 2); switch (arity) { case 1: { StackCell d = pop(); StackCell c = pop(); StackCell b = pop(); StackCell a = pop(); Real x = popr(); if (a.type == NATIVE && b.type == NATIVE && c.type == NATIVE && d.type == NATIVE) { pushr(lft_R_Int(x, a.n, b.n, c.n, d.n)); } else { if (a.type == REAL || b.type == REAL || c.type == REAL || d.type == REAL || \ a.type == STRING || b.type == STRING || c.type == STRING || d.type == STRING) longjmp(env, BAD_VALUE); upgradez(a); upgradez(b); upgradez(c); upgradez(d); pushr(lft_R_Z(x, a.z, b.z, c.z, d.z)); gcz(a); gcz(b); gcz(c); gcz(d); } break; } case 2: { StackCell h = pop(); StackCell g = pop(); StackCell f = pop(); StackCell e = pop(); StackCell d = pop(); StackCell c = pop(); StackCell b = pop(); StackCell a = pop(); Real y = popr(); Real x = popr(); if (a.type == NATIVE && b.type == NATIVE && c.type == NATIVE && d.type == NATIVE && \ e.type == NATIVE && f.type == NATIVE && g.type == NATIVE && h.type == NATIVE) { pushr(lft_R_R_Int(x, y, a.n, b.n, c.n, d.n, e.n, f.n, g.n, h.n)); } else { if (a.type == REAL || b.type == REAL || c.type == REAL || d.type == REAL || \ a.type == STRING || b.type == STRING || c.type == STRING || d.type == STRING || \ e.type == REAL || f.type == REAL || g.type == REAL || h.type == REAL || \ e.type == STRING || f.type == STRING || g.type == STRING || h.type == STRING) longjmp(env, BAD_VALUE); upgradez(a); upgradez(b); upgradez(c); upgradez(d); upgradez(e); upgradez(f); upgradez(g); upgradez(h); pushr(lft_R_R_Z(x, y, a.z, b.z, c.z, d.z, e.z, f.z, g.z, h.z)); gcz(a); gcz(b); gcz(c); gcz(d); gcz(e); gcz(f); gcz(g); gcz(h); } break; } default: longjmp(env, BAD_VALUE); break; } break; } case '|': execute("Sm^Lm%"); break; case 'v': { // Integers are pretty rarely squares. special_func(sqrt); break; } case 'e': // Exponential. special_func(exp); break; case 'g': // natural loG. special_func(log); break; case 't': // Trigonometric. progress(TRIG); break; case 'h': // Hyperbolic. progress(HYPERB); break; case 'n': // iNverse. pv.inverse = true; progress(TRIG_OR_HYPERB); break; case 'P': // π. pushr(Pi); break; case 'X': // Xponential constant (e). pushr(E); break; // Stack control. case 'c': for (int i = 0; i <= stack_top; i++) { StackCell c = calc_stack[i]; switch (c.type) { case INTEGER: gcz(c); break; case STRING: gcs(c); break; default: break; } } stack_top = -1; break; case 'd': push(peek()); break; case 'r': { StackCell top = pop(); StackCell next = pop(); push(top); push(next); break; } case 'R': { int rotation_count = popn(-STACK_SIZE, STACK_SIZE); bool rotation_positive = rotation_count > 0; rotation_count = rotation_positive ? rotation_count : -rotation_count; int rotation_start_idx = stack_top - rotation_count + 1; if (rotation_start_idx < 0) { rotation_start_idx = 0; rotation_count = stack_top + 1; } StackCell to_rotate[rotation_count]; memcpy(to_rotate, calc_stack + rotation_start_idx, rotation_count * sizeof(StackCell)); for (int i = 0; i < rotation_count; i++) { if (rotation_positive) { int rotated = (i == 0) ? rotation_count - 1 : (i - 1); calc_stack[rotation_start_idx + i] = to_rotate[rotated]; } else { int rotated = (i == rotation_count - 1) ? 0 : i + 1; calc_stack[rotation_start_idx + i] = to_rotate[rotated]; } } break; } // Registers. case 's': progress(STORE_REGISTER_NAME); break; case 'l': progress(LOAD_REGISTER_NAME); break; case 'S': progress(PUSHSTORE_REGISTER_NAME); break; case 'L': progress(POPLOAD_REGISTER_NAME); break; // Parameters. case 'i': input_radix = popn(2, 16); break; case 'o': output_radix = popn(2, 16); break; case 'k': precision = popn(0, INT_MAX); break; case 'I': pushn(input_radix); break; case 'O': pushn(output_radix); break; case 'K': pushn(precision); break; // Strings. case '[': ++pv.string_depth; progress(STRING_CONTENTS); break; case 'a': { StackCell result = pop(); switch (result.type) { case NATIVE: { char low_byte[2] = {(char)result.n, '\0'}; pushs(low_byte); break; } case INTEGER: { char low_byte[2] = {(char)(mpz_get_ui(result.z)), '\0'}; pushs(low_byte); gcz(result); break; } case STRING: { char low_byte[2] = {result.s[0], '\0'}; pushs(low_byte); gcs(result); break; } case REAL: longjmp(env, BAD_VALUE); // Reals are conceptually infinite (and hard to work with digitally, the true reason). } break; } case 'x': { StackCell c = pop(); if (c.type != STRING) longjmp(env, BAD_VALUE); char *macro = c.s; int index = 0; pv.string_depth = 0; ++pv.macro_depth; do { interpret(macro[index]); ++index; } while (macro[index] != '\0'); --pv.macro_depth; gcs(c); break; } case '>': progress(GREATER_THAN_REG); break; case '<': progress(LESS_THAN_REG); break; case '=': progress(EQUAL_REG); break; case '!': progress(NOT_CONTENTS); break; case '?': { char *line[] = {malloc(MAX_INPUT_LEN)}; size_t len[] = {MAX_INPUT_LEN}; getline(line, len, stdin); int i = 0; while (line[0][i] != '\n') { interpret(line[0][i]); ++i; } free(line[0]); break; } case 'q': pv.target_macro_depth -= 2; if (pv.target_macro_depth < 0) { longjmp(env, EXIT); } progress(WAITING_TARGET_MACRO_DEPTH); break; case 'Q': pv.target_macro_depth -= popn(0, INT_MAX); if (pv.target_macro_depth < 0) { longjmp(env, EXIT); } progress(WAITING_TARGET_MACRO_DEPTH); break; // Status inquiry. case 'Z': { StackCell a = pop(); switch (a.type) { case NATIVE: pushn(count_digits(a.n)); break; case INTEGER: { pushn(mpz_sizeinbase(a.z, 10)); gcz(a); break; } case REAL: { Sign *sign = NULL; int *count = NULL; mpz_t digits; mpz_init(digits); retrieveInfo(a.r, sign, count, digits); pushn(*count); mpz_clear(digits); break; } case STRING: pushn(strlen(a.s)); gcs(a); break; } break; } case 'z': pushn(stack_top + 1); break; // Miscellaneous. case '#': progress(COMMENT_CONTENTS); break; case ':': progress(REGISTER_SET_NAME); break; case ';': progress(REGISTER_GET_NAME); break; // Ignored tokens. case ' ': case '\f': case '\n': case '\r': case '\t': case '\v': break; default: longjmp(env, BAD_COMMAND); break; } break; case DIGITS_OR_DECIMAL_OR_VINCULUM: switch (token) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': parse_push(token); break; case '.': case '/': pv.integer = false; parse_push(token); progress(DIGITS); break; default: { parse_push('\0'); errno = -1; long int attempt_read = strtol(pv.parse_stack, NULL, input_radix); if (pv.integer && errno != ERANGE) { pushn(attempt_read); } else if (pv.integer) { mpz_t integer; mpz_init(integer); mpz_set_str(integer, pv.parse_stack, input_radix); pushz(integer); } else { mpq_t rational; mpq_init(rational); mpq_set_str(rational, pv.parse_stack, input_radix); mpq_canonicalize(rational); pushr(real_QZ(mpq_numref(rational), mpq_denref(rational))); pv.integer = true; } reset(); interpret(token); break; } } break; case DIGITS: switch (token) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': parse_push(token); break; default: { parse_push('\0'); errno = -1; long int attempt_read = strtol(pv.parse_stack, NULL, input_radix); if (pv.integer && errno != ERANGE) { pushn(attempt_read); } else if (pv.integer) { mpz_t integer; mpz_init(integer); mpz_set_str(integer, pv.parse_stack, input_radix); pushz(integer); } else { mpq_t rational; mpq_init(rational); mpq_set_str(rational, pv.parse_stack, input_radix); mpq_canonicalize(rational); pushr(real_QZ(mpq_numref(rational), mpq_denref(rational))); pv.integer = true; } reset(); interpret(token); break; } } break; case TRIG: switch (token) { case 's': invertible_special(sin); reset(); break; case 'c': invertible_special(cos); reset(); break; case 't': invertible_special(tan); reset(); break; case 'S': invertible_special(sec); reset(); break; case 'C': invertible_special(cosec); reset(); break; case 'T': invertible_special(cotan); reset(); break; default: longjmp(env, BAD_COMMAND); break; } break; case HYPERB: switch (token) { case 's': invertible_special(sinh); reset(); break; case 'c': invertible_special(cosh); reset(); break; case 't': invertible_special(tanh); reset(); break; case 'S': invertible_special(sech); reset(); break; case 'C': invertible_special(cosech); reset(); break; case 'T': invertible_special(cotanh); reset(); break; default: longjmp(env, BAD_COMMAND); break; } break; case TRIG_OR_HYPERB: switch (token) { case 't': progress(TRIG); break; case 'h': progress(HYPERB); break; default: longjmp(env, BAD_COMMAND); break; } break; case STORE_REGISTER_NAME: registers[(int)token][register_tops[(int)token]] = pop(); reset(); break; case PUSHSTORE_REGISTER_NAME: { if (register_tops[(int)token] == STACK_SIZE - 1) { longjmp(env, OVERFLOW_REG); } ++register_tops[(int)token]; registers[(int)token][register_tops[(int)token]] = pop(); reset(); } break; case LOAD_REGISTER_NAME: ++registers[(int)token][register_tops[(int)token]].reference_count; push(registers[(int)token][register_tops[(int)token]]); reset(); break; case POPLOAD_REGISTER_NAME: if (register_tops[(int)token] < 0) { longjmp(env, UNDERFLOW_REG); } push(registers[(int)token][register_tops[(int)token]]); --register_tops[(int)token]; reset(); break; case STRING_CONTENTS: switch (token) { case '[': parse_push(token); ++pv.string_depth; break; case ']': --pv.string_depth; if (pv.string_depth == 0) { parse_push('\0'); pushs(pv.parse_stack); reset(); } else { parse_push(token); } break; default: parse_push(token); break; } break; case GREATER_THAN_REG: dispatch_pred(>, <=, gt, ltEq); break; case LESS_THAN_REG: dispatch_pred(<, >=, lt, gtEq); break; case NOT_CONTENTS: switch (token) { case '>': progress(NOT_GREATER_THAN_REG); break; case '<': progress(NOT_LESS_THAN_REG); break; case '=': progress(NOT_EQUAL_REG); break; default: longjmp(env, BAD_COMMAND); break; } break; case NOT_GREATER_THAN_REG: dispatch_pred(<=, >, ltEq, gt); break; case NOT_LESS_THAN_REG: dispatch_pred(>=, <, gtEq, lt); break; case NOT_EQUAL_REG: { int prec = popn(0, INT_MAX); StackCell b = pop(); StackCell a = pop(); bool result; switch (pair(a.type, b.type)) { case pair(NATIVE, NATIVE): result = a.n != b.n; break; case pair(NATIVE, INTEGER): result = mpz_cmp_si(b.z, a.n) != 0; gcz(b); break; case pair(INTEGER, NATIVE): result = mpz_cmp_si(a.z, b.n) != 0; gcz(a); break; case pair(INTEGER, INTEGER): result = mpz_cmp(a.z, b.z) != 0; gcz(a); gcz(b); break; case pair(NATIVE, REAL): { Bool r_neg_lazy = or_B_B(gt_R_QInt(b.r, a.n, 1), lt_R_QInt(b.r, a.n, 1)); force_B(r_neg_lazy, prec); result = boolValue(r_neg_lazy) == LAZY_TRUE; break; } case pair(REAL, NATIVE): { Bool r_neg_lazy = or_B_B(gt_R_QInt(a.r, b.n, 1), lt_R_QInt(a.r, b.n, 1)); force_B(r_neg_lazy, prec); result = boolValue(r_neg_lazy) == LAZY_TRUE; break; } case pair(INTEGER, REAL): case pair(REAL, INTEGER): case pair(REAL, REAL): { if (a.type == INTEGER) { upgrader(a); } if (b.type == INTEGER) { upgrader(b); } Bool r_neg_lazy = or_B_B(gt_R_R(a.r, b.r), lt_R_R(a.r, b.r)); force_B(r_neg_lazy, prec); result = boolValue(r_neg_lazy) == LAZY_TRUE; break; } default: longjmp(env, BAD_VALUE); break; } reset(); if (result) { interpret('l'); interpret(token); interpret('x'); } break; } case EQUAL_REG: { // Has to be different because it's based on terminal fuziness. int prec = popn(0, INT_MAX); StackCell b = pop(); StackCell a = pop(); bool result; switch (pair(a.type, b.type)) { case pair(NATIVE, NATIVE): result = a.n == b.n; break; case pair(NATIVE, INTEGER): result = mpz_cmp_si(b.z, a.n) == 0; gcz(b); break; case pair(INTEGER, NATIVE): result = mpz_cmp_si(a.z, b.n) == 0; gcz(a); break; case pair(INTEGER, INTEGER): result = mpz_cmp(a.z, b.z) == 0; gcz(a); gcz(b); break; case pair(NATIVE, REAL): { Bool r_neg_lazy = and_B_B(gt_R_QInt(b.r, a.n, 1), lt_R_QInt(b.r, a.n, 1)); force_B(r_neg_lazy, prec); result = boolValue(r_neg_lazy) == LAZY_UNKNOWN; break; } case pair(REAL, NATIVE): { Bool r_neg_lazy = and_B_B(gt_R_QInt(a.r, b.n, 1), lt_R_QInt(a.r, b.n, 1)); force_B(r_neg_lazy, prec); result = boolValue(r_neg_lazy) == LAZY_UNKNOWN; break; } case pair(INTEGER, REAL): case pair(REAL, INTEGER): case pair(REAL, REAL): { if (a.type == INTEGER) { upgrader(a); } if (b.type == INTEGER) { upgrader(b); } Bool r_neg_lazy = and_B_B(gt_R_R(a.r, b.r), lt_R_R(a.r, b.r)); force_B(r_neg_lazy, prec); result = boolValue(r_neg_lazy) == LAZY_UNKNOWN; break; } default: longjmp(env, BAD_VALUE); break; } reset(); if (result) { interpret('l'); interpret(token); interpret('x'); } break; } case WAITING_TARGET_MACRO_DEPTH: if (pv.macro_depth == pv.target_macro_depth) { reset(); } break; case COMMENT_CONTENTS: if (token == '\n') { reset(); } break; case REGISTER_SET_NAME: { int top = popn(0, 255); StackCell pentultimate = pop(); pentultimate.register_in = token; pentultimate.register_location = top; registers[(int)token][top] = pentultimate; reset(); break; } case REGISTER_GET_NAME: { int index = popn(0, 255); ++registers[(int)token][index].reference_count; StackCell c = registers[(int)token][index]; push(c); reset(); break; } } } int process(FILE *stream) { while(true) { char input = getc(stream); switch (setjmp(env)) { case BAD_COMMAND: putchar('?'); putchar(input); putchar('\n'); reset(); break; case UNDERFLOW: printf("!-\n"); reset(); break; case UNDERFLOW_REG: printf("!%c-\n", input); reset(); break; case OVERFLOW: printf("!+\n"); reset(); break; case OVERFLOW_REG: printf("!%c+\n", input); reset(); break; case BAD_VALUE: printf("!?\n"); reset(); break; case EXIT: return 0; break; default: { interpret(input); break; } } } } const char *argp_program_version = "Exact Desk Calculator V0.1"; const char *argp_program_bug_address = "duncannwilkie@gmail.com"; static struct argp_option options[] = { {.name = "expression", .key = 'e', .arg = "scriptexpression", .flags = 0, .doc = "Add the commands in scriptexpression to the set of commands to be run while processing the input."}, {.name = "file", .key = 'f', .arg = "script-file", .flags = 0, .doc = "Add the commands contained in the file script-file to the set of commands to be run while processing the input."}, { 0 }}; error_t parser(int key, char *arg, struct argp_state *state) { switch (key) { case ARGP_KEY_INIT: return 0; case ARGP_KEY_ARG: // Non-option argument; filename. if (strcmp(arg, "-")) { printf("%s\n", argp_program_version); process(stdin); return 0; } else { FILE *contents = fopen(arg, "r"); process(contents); fclose(contents); return 0; } case 'e': { // Evaluate the script expression. FILE *contents = fmemopen(arg, strlen(arg), "r"); process(contents); fclose(contents); return 0; } case 'f': { // Evaluate the file. FILE *contents = fopen(arg, "r"); process(contents); fclose(contents); return 0; } case ARGP_KEY_ERROR: argp_error(state, "argument parsing error."); return 1; break; case ARGP_KEY_SUCCESS: if (state->argc == 1) { // Only program name; interactive calculation. printf("%s\n", argp_program_version); process(stdin); } return 0; case ARGP_KEY_NO_ARGS: case ARGP_KEY_END: case ARGP_KEY_FINI: return 0; default: return ARGP_ERR_UNKNOWN; } } static char args_doc[] = "[file ...]"; static char doc[] = "\n" "Run the exact desk calculator, " "an implementation of the classic UNIX RPN desk calculator (dc) " "using the exact real arithmetic and corresponding IC-Reals library " "developed at Imperial College." "\v" "If any command-line parameters remain after processing the above, " "these parameters are interpreted as the names of input files to be processed. " "A file name of - refers to the standard input stream. " "The standard input will processed if no script files or expressions specified.\n\n" "See man edc for the language syntax."; static struct argp argp = {options, parser, args_doc, doc, NULL, NULL, NULL}; // TODO: hypothesis testing. // TODO: make stack size a CLI argument. // TODO: IC-Real environment variables. // TODO: currently, | does a literal exponentiation; the mpz function would be faster. int main(int argc, char *argv[]) { initReals(); mpz_init(one); mpz_set_si(one, 1); for (int i = 0; i < 256; i++) { register_tops[i] = -1; } argp_parse(&argp, argc, argv, 0, NULL, NULL); return 0; }