From 11da511c784eca003deb90c23570f0873954e0de Mon Sep 17 00:00:00 2001 From: Duncan Wilkie Date: Sat, 18 Nov 2023 06:11:09 -0600 Subject: Initial commit. --- edc.c | 1666 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1666 insertions(+) create mode 100644 edc.c (limited to 'edc.c') diff --git a/edc.c b/edc.c new file mode 100644 index 0000000..6207874 --- /dev/null +++ b/edc.c @@ -0,0 +1,1666 @@ +#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; +} -- cgit v1.2.3