From: Eric S. Raymond Date: Fri, 4 Nov 1994 19:04:06 +0000 (+0000) Subject: Implement all special functions. X-Git-Tag: 1-2~70 X-Git-Url: http://thyrsus.com/gitweb/?a=commitdiff_plain;h=df0f68ccb9a0eeb7572c835fb6a4717d810f6449;p=cupl.git Implement all special functions. --- diff --git a/cupl.h b/cupl.h index 661e93b..40242af 100644 --- a/cupl.h +++ b/cupl.h @@ -106,16 +106,28 @@ extern void execute(node *tree); /* monitor.c */ extern void die(char *msg, ...); extern void warn(char *msg, ...); + extern void make_scalar(value *v, scalar n); extern value copy_value(value); extern void deallocate_value(value *); + extern value cupl_add(value, value); extern value cupl_multiply(value, value); extern value cupl_subtract(value, value); extern value cupl_divide(value, value); extern value cupl_power(value, value); extern value cupl_uminus(value); + +extern value cupl_abs(value); +extern value cupl_atan(value); +extern value cupl_cos(value); +extern value cupl_exp(value); +extern value cupl_floor(value); +extern value cupl_log(value); extern value cupl_sqrt(value); +extern value cupl_max(value, value); +extern value cupl_min(value, value); +extern value cupl_rand(value); #define DEBUG_PARSEDUMP 1 #define DEBUG_CHECKDUMP 2 diff --git a/execute.c b/execute.c index 21f1ee7..a13b2a5 100644 --- a/execute.c +++ b/execute.c @@ -192,12 +192,68 @@ static value cupl_eval(node *tree) deallocate_value(&rightside); return(result); + case ABS: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_abs(rightside); + deallocate_value(&rightside); + return(result); + + case ATAN: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_atan(rightside); + deallocate_value(&rightside); + return(result); + + case COS: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_cos(rightside); + deallocate_value(&rightside); + return(result); + + case EXP: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_exp(rightside); + deallocate_value(&rightside); + return(result); + + case FLOOR: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_floor(rightside); + deallocate_value(&rightside); + return(result); + + case LOG: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_log(rightside); + deallocate_value(&rightside); + return(result); + case SQRT: rightside = EVAL_WRAP(cupl_eval(tree->cdr)); result = cupl_sqrt(rightside); deallocate_value(&rightside); return(result); + case MAX: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_max(leftside, rightside); + deallocate_value(&leftside); + deallocate_value(&rightside); + return(result); + + case MIN: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_min(leftside, rightside); + deallocate_value(&leftside); + deallocate_value(&rightside); + return(result); + + case RAND: + rightside = EVAL_WRAP(cupl_eval(tree->cdr)); + result = cupl_rand(rightside); + deallocate_value(&rightside); + return(result); + default: die("unknown node type %d (%s), cannot execute\n", tree->type, diff --git a/monitor.c b/monitor.c index 79a4d0d..c83a383 100644 --- a/monitor.c +++ b/monitor.c @@ -5,11 +5,9 @@ NAME SYNOPSIS void die(char *msg, ...) - void warn(char *msg, ...) void make_scalar(value *v, scalar i) - void copy_value(value v); void deallocate_value(value *v) @@ -18,19 +16,42 @@ SYNOPSIS value cupl_subtract(value, value) value cupl_divide(value, value) value cupl_uminus(value, value) - value cupl_sqrt(value, value) + + value cupl_abs(value) + value cupl_atan(value) + value cupl_cos(value) + value cupl_exp(value) + value cupl_floor(value) + value cupl_log(value) + value cupl_sqrt(value) + value cupl_max(value, value) + value cupl_min(value, value) + value cupl_rand(value) DESCRIPTION Runtime support. This is segregated from the execute() code in case anyone -ever wants to write a back end that is a compiler. +ever wants to write a back end that is a compiler. For the same reason +we do an allocate each time an intrinsic returns a value. This is +relatively inefficient but means these functions could be used as a runtime +library. *****************************************************************************/ /*LINTLIBRARY*/ #include +#include #include #include #include "cupl.h" +#define max(x, y) ((x) > (y) ? (x) : (y)) +#define min(x, y) ((x) < (y) ? (x) : (y)) + +/**************************************************************************** + * + * Error reporting + * + ****************************************************************************/ + void warn(char *msg, ...) /* warn of an error and die */ { @@ -53,6 +74,12 @@ void die(char *msg, ...) exit(1); } +/**************************************************************************** + * + * Value allocation + * + ****************************************************************************/ + void make_scalar(value *v, scalar i) /* initialize a scalar value element */ { @@ -78,6 +105,12 @@ void deallocate_value(value *v) (void) free(v->elements); } +/**************************************************************************** + * + * Functions for arithmetic intrinsics + * + ****************************************************************************/ + #define CONGRUENT(l, r) ((l.rank == r.rank) \ && (l.width == r.width) \ && (l.depth == r.depth)) @@ -172,13 +205,109 @@ value cupl_uminus(value right) return(result); } +/**************************************************************************** + * + * Scalar functions + * + ****************************************************************************/ + +value cupl_abs(value right) +/* apply absolute-value function */ +{ + value result; + + if (right.rank != 0) + die("ABS is only defined for scalar arguments\n"); + else + { + make_scalar(&result, 0); + result.elements[0] = abs(right.elements[0]); + return(result); + } +} + +value cupl_atan(value right) +/* apply arctangent */ +{ + value result; + + if (right.rank != 0) + die("ATAN is only defined for scalar arguments\n"); + else + { + make_scalar(&result, 0); + result.elements[0] = atan(right.elements[0]); + return(result); + } +} + +value cupl_cos(value right) +/* apply cosine */ +{ + value result; + + if (right.rank != 0) + die("COS is only defined for scalar arguments\n"); + else + { + make_scalar(&result, 0); + result.elements[0] = cos(right.elements[0]); + return(result); + } +} + +value cupl_exp(value right) +/* apply exponent function */ +{ + value result; + + if (right.rank != 0) + die("EXP is only defined for scalar arguments\n"); + else + { + make_scalar(&result, 0); + result.elements[0] = exp(right.elements[0]); + return(result); + } +} + +value cupl_floor(value right) +/* apply floor function */ +{ + value result; + + if (right.rank != 0) + die("FLOOR is only defined for scalar arguments\n"); + else + { + make_scalar(&result, 0); + result.elements[0] = floor(right.elements[0]); + return(result); + } +} + +value cupl_log(value right) +/* apply ln function */ +{ + value result; + + if (right.rank != 0) + die("LOG is only defined for scalar arguments\n"); + else + { + make_scalar(&result, 0); + result.elements[0] = log(right.elements[0]); + return(result); + } +} + value cupl_sqrt(value right) /* apply square root */ { value result; if (right.rank != 0) - die("SQRT is only defined for scalars\n"); + die("SQRT is only defined for scalar arguments\n"); else { make_scalar(&result, 0); @@ -187,4 +316,64 @@ value cupl_sqrt(value right) } } +/**************************************************************************** + * + * Special functions + * + ****************************************************************************/ + +value cupl_max(value left, value right) +/* apply max function */ +{ + value result; + + if (right.rank != 0 || left.rank != 0) + die("MAX is not yet supported for vectors and matrices\n"); + else + { + make_scalar(&result, 0); + result.elements[0] = max(right.elements[0], left.elements[0]); + return(result); + } +} + +value cupl_min(value left, value right) +/* apply min functionnot yet supported for vectors and matrices */ +{ + value result; + + if (right.rank != 0 || left.rank != 0) + die("MIN is \n"); + else + { + make_scalar(&result, 0); + result.elements[0] = min(right.elements[0], left.elements[0]); + return(result); + } +} + +value cupl_rand(value right) +/* get a random number from a seed */ +{ + value result; + + if (right.rank != 0) + die("RAND is only defined for scalar arguments\n"); + else + { + make_scalar(&result, 0); + srand(right.elements[0]); + result.elements[0] = rand(); + return(result); + } +} + +/**************************************************************************** + * + * Matrix functions + * + ****************************************************************************/ + +/* FIXME: not yet implemented */ + /* monitor.c ends here */