Implement all special functions.

diff --git a/cupl.h b/cupl.h
index 661e93b50bae2f3b0f78cecadd15091ab5f9b378..40242af7864c323b8bded28065da1567c3d80583 100644 (file)
--- 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 21f1ee70e8061d8df0a90ffbb5d48fcb951fcae9..a13b2a5dee2a955cbe91c2ea0a1d12e0be06855d 100644 (file)
--- 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 79a4d0d6c630c23a1c67a7ef15a204288d71ab83..c83a383cbe225267515189af50e55a16f7f651f7 100644 (file)
--- 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 <stdio.h>
+#include <stdlib.h>
 #include <stdarg.h>
 #include <math.h>
 #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 */