/** Dispatch.c
*
*   DESCRIPTION:
*   ===========
*
*	This function is called as the "query" entry point from the
*	library.  The arguments are contained in a RexxMsg structure, which is
*	used as a parameter block and doesn't need to be unlinked from a port.
*	Dispatch() searches a table to see whether the requested function is
*	contained in this library and calls it if it is found.  The "query"
*	function should never alter the message packet, as it must be passed
*	along to other libraries until the function is found.
*
*       Arguments:
*	Up to 15 arguments may be passed in the rm_Args[] array of the parameter
*	block.  Arguments are ALWAYS passed as argstrings and can generally be
*	treated like string pointers in a 'C' program.  The called function may
*	need to convert the strings to numeric values if arithmetic operations
*	are to be performed.  A NULL value in the argument slot means that the
*	argument was omitted from the function call.
*
*	The total number of arguments (including the defaulted ones) is available
*	in the low-order byte of the action code field rm_Action.
*	Note that REXX supports function calls with varying numbers of arguments,
*	and that the called function can always determine how many were actually
*	passed.
*
*	Error reporting:
*	The function must return an integer error code and a result string if no
*	errors were detected.  Errors are considered to be ARexx internal error
*	codes, so the function should make use of these values as appropriate.
*	A code of 0 is interpreted to mean that everything worked.
*
*	Result strings:
*	The result string must be returned as an argstring, a pointer to the
*	string buffer of an RexxArg structure.  Argstrings can be created by a
*	call to the ARexx Systems library function CreateArgstring().
*	N.B. Never allocate a result string if the error code is non-zero!
*
*   THIS VERSION:
*   ============
*
*	This version is written for Aztec C and implements a basic AmigaREXX
*	math library. It is based on the example library by Jim Mackraz who
*	got some stuff from Neil Katin, and the Dispatch() routine by Bill Hawes.
*	All changes and additions by me.
*
*   AUTHOR/DATE:  W.G.J. Langeveld, November 1987.
*   ============
*
**/

#include <rexx/storage.h>
#include <rexx/rxslib.h>
#include <math.h>
#include <functions.h>

/*
*   ARexx Systems library functions
*/
char *CreateArgstring(), *CVi2arg(), *CVr2arg();
long CVa2i();
long StrcpyU();

extern struct Library *RexxSysBase;
/*
*   Some stuff we should get from REXX
*/
#define PRECISION 15
#define FUZZ 0.0000001
/*
*   The functions that aren't standard C.
*/
double rxf_null(), asinh(), acosh(), atanh(), sec(), csc(), nint(),
       fact(), rxf_atan2();
/*
*   The function structure definitions
*/
struct RXfunc { double  (*rexxfunc)();
                char    *rexxname;  
                int     nargs;
                int     argrange;        };

/*
*   Argument range checking flags.
*/
#define A1_ANY                       0
#define A1_ABS_LE_1                  1
#define A1_GT_0                      2
#define A1_GE_0                      3
#define A1_ABS_LT_1                  4
#define A1_GE_1                      5
#define A2_ANY                       0
#define A2_ABS_LE_1  (A1_ABS_LE_1 << 4)
#define A2_GT_0      (A1_GT_0     << 4)
#define A2_GE_0      (A1_GE_0     << 4)
#define A2_ABS_LT_1  (A1_ABS_LT_1 << 4)
#define A2_GE_1      (A1_GE_1     << 4) 
/*
*   The function table
*/
static struct RXfunc rxfs[] = { 
   { fabs,     "ABS"     , 1, A1_ANY           },
   { acos,     "ACOS"    , 1, A1_ABS_LE_1      },
   { asin,     "ASIN"    , 1, A1_ABS_LE_1      },
   { atan,     "ATAN"    , 1, A1_ANY           },
   { rxf_atan2,"ATAN2"   , 2, A1_ANY | A2_ANY  },
   { ceil,     "CEIL"    , 1, A1_ANY           },
   { cos,      "COS"     , 1, A1_ANY           },
   { cosh,     "COSH"    , 1, A1_ANY           },
   { cotan,    "COTAN"   , 1, A1_ANY           },
   { exp,      "EXP"     , 1, A1_ANY           },
   { fabs,     "FABS"    , 1, A1_ANY           },
   { floor,    "FLOOR"   , 1, A1_ANY           },
   { floor,    "INT"     , 1, A1_ANY           },
   { log,      "LOG"     , 1, A1_GT_0          },
   { log10,    "LOG10"   , 1, A1_GT_0          },
   { pow,      "POW"     , 2, A1_GE_0 | A2_ANY },
   { pow,      "POWER"   , 2, A1_GE_0 | A2_ANY },
   { sin,      "SIN"     , 1, A1_ANY           },
   { sinh,     "SINH"    , 1, A1_ANY           },
   { sqrt,     "SQRT"    , 1, A1_GE_0          },
   { tan,      "TAN"     , 1, A1_ANY           },
   { tanh,     "TANH"    , 1, A1_ANY           },
   { log,      "LN"      , 1, A1_GT_0          },
   { cotan,    "COT"     , 1, A1_ANY           },
   { pow,      "XTOY"    , 2, A1_GE_0 | A2_ANY },
   { acosh,    "ACOSH"   , 1, A1_GE_1          },
   { asinh,    "ASINH"   , 1, A1_ANY           },
   { atanh,    "ATANH"   , 1, A1_ABS_LT_1      },
   { sec,      "SEC"     , 1, A1_ANY           },
   { csc,      "CSC"     , 1, A1_ANY           },
   { nint,     "NINT"    , 1, A1_ANY           },
   { fact,     "FACT"    , 1, A1_GE_0          },
   { rxf_null,  NULL     , 1, 0                }
};

/*
*   Global error value
*/
int rxf_error = 0;

/**
*
*   The dispatcher.
*
**/
long Dispatch(rmptr, resptr)
struct RexxMsg *rmptr;			/* message packet                */
char **resptr;				/* return pointer                */
{
   char *retval = NULL;
   double arg1, arg2, result, atof();
   int nargs, ival;

/*
*   Get the function index
*/
   ival = get_index(rmptr->rm_Args[0]);
   if (ival < 0) return(1L);
   if (strcmpu(rmptr->rm_Args[0], rxfs[ival].rexxname) != 0) return(1L);
/*
*   Get the number of provided arguments.
*/
   nargs = (rmptr->rm_Action) & 0xFF;
/*
*   Check number of arguments and ranges and convert them
*/
   if (rxfs[ival].nargs != nargs) return(17L);

   if (nargs >= 1) {
      arg1 = atof(rmptr->rm_Args[1]);
      if (bad_arg(rxfs[ival].argrange, arg1)) return(48L);
   }
   if (nargs >= 2) {
      arg2 = atof(rmptr->rm_Args[2]);
      if (bad_arg((rxfs[ival].argrange) >> 4, arg2)) return(48L);
   }
/*
*   Call the function with the proper number of arguments.
*/
   rxf_error = 0;

   if      (nargs == 1) result = (*rxfs[ival].rexxfunc)(arg1);
   else if (nargs == 2) result = (*rxfs[ival].rexxfunc)(arg1, arg2);
/*
*   Check global error flag, it can be set by some of the non-standard-C
*   functions.
*/
   if (rxf_error) return(48L);

   retval = CVr2arg(result);
/*
*   Set the return values
*/
   *resptr = retval;

   return(0L);
}

/**
*
*   Check arguments.
*
**/
int bad_arg(mask, a)
int mask;
double a;
{
   switch (mask & 0xF) {
      case A1_ANY :
         break;
      case A1_ABS_LE_1 :
         if (fabs(a) > 1.0) return(1);
         break;
      case A1_ABS_LT_1 :
         if (fabs(a) >= 1.0) return(1);
         break;
      case A1_GT_0 :
         if (a <= 0.0) return(1);
         break;
      case A1_GE_0 :
         if (a < 0.0) return (1);
         break;
      case A1_GE_1 :
         if (a < 1.0) return (1);
         break;
      default:
         return(1);
   }

   return(0);
}
/**
*
*   Case insensitive compare
*
**/
strcmpu(s, t)
char *s, *t;
{
   for ( ; toupper(*s) == toupper(*t); s++, t++)
      if (*s == '\0') return(0);

   return(toupper(*s) - toupper(*t));
}

/**
*
*   Convert real value to arg string
*
**/
char *CVr2arg(value)
double value;
{
   char buffer[50];
   
   ftoa(value, buffer, PRECISION, 0);

   return(CreateArgstring(buffer, (long) strlen(buffer)));
}

/**
*
*   The null function
*
**/
double rxf_null(arg)
double arg;
{
   return(0L);
}

/**
*
*   Some functions that aren't in the standard C library.
*
**/
double rxf_atan2(a, b)
double a, b;
{
   if (a == 0.0 && b == 0.0) {
      rxf_error = 1;
      return(0.0);
   }

   return(atan2(a, b));
}

double sec(a)
double a;
{
   a = cos(a);

   if (a == 0.0) {
      rxf_error = 1;
      return(0.0);
   }

   return(1.0 / a);
}

double csc(a)
double a;
{
   a = sin(a);

   if (a == 0.0) {
      rxf_error = 1;
      return(0.0);
   }

   return(1.0 / a);
}

double asinh(a)
double a;
{
   if (a > 0.0) return( log(sqrt(1.0 + a*a) + a) );
   else         return(-log(sqrt(1.0 + a*a) - a) );
}

double acosh(a)
double a;
{
   return(log(sqrt(a*a - 1.0) + a) );
}

double atanh(a)
double a;
{
   return(0.5 * log( (1.0 + a)/(1.0 - a) ) );
}

double nint(a)
double a;
{
   if (a >= 0.0) return(floor(a + 0.5));
   else          return(ceil(a - 0.5));
}

double fact(a)
double a;
{
   if (fabs(a - nint(a)) > FUZZ) {
      rxf_error = 1;
      return(0.0);
   }
   if (a > 170.0) {
      rxf_error = 1;
      return(0.0);
   }

   if (a == 0.0) return(1.0);
   else          return(fact(a - 1.0) * a);
}