home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-arith.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  25KB  |  1,177 lines
  1. /*  pl-arith.c,v 1.4 1993/02/23 13:16:24 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: arithmetic built in functions
  8. */
  9.  
  10. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  11. The arithmetic module defines a small set of logical integer  predicates
  12. as   well   as  the  evaluation  of  arbitrary  arithmetic  expressions.
  13. Arithmetic can be interpreted or compiled (see  -O  flag).   Interpreted
  14. arithmetic  is  supported  by  the  built-in  predicates is/2, >/2, etc.
  15. These functions call valueExpression() to evaluate a Prolog term holding
  16. an arithmetic expression.
  17.  
  18. For compiled arithmetic, the compiler generates WAM codes that execute a
  19. stack machine.  This module maintains an array of arithmetic  functions.
  20. These  functions are addressed by the WAM instructions using their index
  21. in this array.
  22.  
  23. The  current  version  of  this  module  also  supports  Prolog  defined
  24. arithmetic  functions.   In  the  current  version these can only return
  25. numbers.  This should be changed to return arbitrary Prolog  terms  some
  26. day.
  27. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  28.  
  29. #include "pl-incl.h"
  30. #include "pl-itf.h"
  31. #include <math.h>
  32. #ifndef M_PI
  33. #define M_PI (3.141593)
  34. #endif
  35. #ifndef M_E
  36. #define M_E (2.718282)
  37. #endif
  38.  
  39. #define MAXARITHFUNCTIONS (100)
  40.  
  41. #define V_ERROR        FALSE        /* so we can use `fail' */
  42. #define V_REAL        1
  43. #define V_INTEGER    2
  44.  
  45. typedef struct arithFunction *     ArithFunction;
  46.  
  47. typedef union
  48. { real        f;        /* value as real */
  49.   long        i;        /* value as integer */
  50. } number;
  51.  
  52. typedef number * Number;    /* pointer to a number */
  53.  
  54. typedef int (*ArithF)();
  55.  
  56. struct arithFunction
  57. { ArithFunction next;        /* Next of chain */
  58.   FunctorDef    functor;    /* Functor defined */
  59.   ArithF    function;    /* Implementing function */
  60.   Module    module;        /* Module visibility module */
  61. #if O_PROLOG_FUNCTIONS
  62.   Procedure    proc;        /* Prolog defined functions */
  63. #endif
  64. #if O_COMPILE_ARITH
  65.   code        index;        /* Index of function */
  66. #endif
  67. };
  68.  
  69. forwards int        valueExpression P((Word t, Number r));
  70. forwards ArithFunction    isCurrentArithFunction P((FunctorDef, Module));
  71.  
  72. static ArithFunction arithFunctionTable[ARITHHASHSIZE];
  73. static code next_index;
  74. static ArithFunction functions;
  75.  
  76.         /********************************
  77.         *   LOGICAL INTEGER FUNCTIONS   *
  78.         *********************************/
  79.  
  80. word
  81. pl_between(l, h, n, b)
  82. register Word l, h, n;
  83. word b;
  84. { switch( ForeignControl(b) )
  85.   { case FRG_FIRST_CALL:
  86.       { if (!isInteger(*l) || !isInteger(*h))
  87.       return warning("between/3: instantiation fault");
  88.  
  89.     if (isInteger(*n))
  90.     { if (valNum(*l) > valNum(*n))
  91.         fail;
  92.       if (valNum(*h) < valNum(*n))
  93.         fail;
  94.       succeed;
  95.     }
  96.     if (!isVar(*n))
  97.       return warning("between/3: instantiation fault");
  98.     if ( valNum(*h) < valNum(*l) )
  99.       fail;
  100.     unifyAtomic(n, *l);
  101.  
  102.     ForeignRedo(valNum(*l));
  103.       }
  104.     case FRG_REDO:
  105.       { long next = ForeignContext(b) + 1;
  106.     word nextword;
  107.  
  108.     if (next > valNum(*h) )
  109.       fail;
  110.  
  111.     nextword = consNum(next);
  112.     unifyAtomic(n, nextword);
  113.  
  114.     ForeignRedo(next);
  115.       }
  116.     default:;
  117.       succeed;
  118.   }
  119. }
  120.  
  121. word
  122. pl_succ(n1, n2)
  123. register Word n1, n2;
  124. { if (isVar(*n1))
  125.   { if (isInteger(*n2))
  126.       return unifyAtomic(n1, consNum(valNum(*n2)-1));
  127.  
  128.     return warning("succ/2: instantiation fault");
  129.   }
  130.  
  131.   if (isVar(*n2))
  132.   { if (isInteger(*n1))
  133.       return unifyAtomic(n2, consNum(valNum(*n1)+1));
  134.  
  135.     return warning("succ/2: instantiation fault");
  136.   }
  137.  
  138.   if (isInteger(*n1) && isInteger(*n2) )
  139.   { if (valNum(*n1) + 1 == valNum(*n2) )
  140.       succeed;
  141.     else
  142.       fail;
  143.   }
  144.  
  145.   return warning("succ/2: instantiation fault");
  146. }
  147.  
  148. word
  149. pl_plus(a, b, c)
  150. register Word a, b, c;
  151. { if (isVar(*a) && isInteger(*b) && isInteger(*c) )
  152.     return unifyAtomic(a, consNum(valNum(*c) - valNum(*b)) );
  153.   if (isInteger(*a) && isVar(*b) && isInteger(*c) )
  154.     return unifyAtomic(b, consNum(valNum(*c) - valNum(*a)) );
  155.   if (isInteger(*a) && isInteger(*b) && isVar(*c) )
  156.     return unifyAtomic(c, consNum(valNum(*a) + valNum(*b)) );
  157.   if (isInteger(*a) && isInteger(*b) && isInteger(*c) )
  158.     if (valNum(*a) + valNum(*b) == valNum(*c) )
  159.       succeed;
  160.  
  161.   fail;
  162. }
  163.  
  164.  
  165.         /********************************
  166.         *           COMPARISON          *
  167.         *********************************/
  168.  
  169. word
  170. compareNumbers(n1, n2, what)
  171. Word n1, n2;
  172. int what;
  173. { int result;
  174.   number left, right;
  175.   int tl, tr;
  176.  
  177.   TRY( tl = valueExpression(n1, &left) );
  178.   TRY( tr = valueExpression(n2, &right) );
  179.  
  180.   if (tl == V_INTEGER && tr == V_INTEGER)
  181.   { switch(what)
  182.     { case LT:    result = left.i <  right.i; break;
  183.       case GT:  result = left.i >  right.i; break;
  184.       case LE:    result = left.i <= right.i; break;
  185.       case GE:    result = left.i >= right.i; break;
  186.       case NE:    result = left.i != right.i; break;
  187.       case EQ:    result = left.i == right.i; break;
  188.       default:    fail;
  189.     }
  190.     if (result)
  191.       succeed;
  192.   } else
  193.   { real F1, F2;
  194.  
  195.     F1 = (tl == V_INTEGER ? (real)left.i  : left.f);
  196.     F2 = (tr == V_INTEGER ? (real)right.i : right.f);
  197.     switch(what)
  198.     { case LT:    result = F1 <  F2; break;
  199.       case GT:  result = F1 >  F2; break;
  200.       case LE:    result = F1 <= F2; break;
  201.       case GE:    result = F1 >= F2; break;
  202.       case NE:    result = F1 != F2; break;
  203.       case EQ:    result = F1 == F2; break;
  204.       default:    fail;
  205.     }
  206.     if (result)
  207.       succeed;
  208.   }  
  209.   fail;
  210. }
  211.  
  212. word
  213. pl_lessNumbers(n1, n2)            /* </2 */
  214. Word n1, n2;
  215. { return compareNumbers(n1, n2, LT);
  216. }
  217.  
  218. word
  219. pl_greaterNumbers(n1, n2)        /* >/2 */
  220. Word n1, n2;
  221. { return compareNumbers(n1, n2, GT);
  222. }
  223.  
  224. word
  225. pl_lessEqualNumbers(n1, n2)        /* =</2 */
  226. Word n1, n2;
  227. { return compareNumbers(n1, n2, LE);
  228. }
  229.  
  230. word
  231. pl_greaterEqualNumbers(n1, n2)        /* >=/2 */
  232. Word n1, n2;
  233. { return compareNumbers(n1, n2, GE);
  234. }
  235.  
  236. word
  237. pl_nonEqualNumbers(n1, n2)        /* =\=/2 */
  238. Word n1, n2;
  239. { return compareNumbers(n1, n2, NE);
  240. }
  241.  
  242. word
  243. pl_equalNumbers(n1, n2)            /* =:=/2 */
  244. Word n1, n2;
  245. { return compareNumbers(n1, n2, EQ);
  246. }
  247.  
  248.  
  249.         /********************************
  250.         *           FUNCTIONS           *
  251.         *********************************/
  252.  
  253. /* not used any longer, but might be usefull to export via the interface
  254. static
  255. ArithFunction
  256. newArithFunction(f, func)
  257. FunctorDef f;
  258. ArithF func;
  259. { int v = pointerHashValue(f, ARITHHASHSIZE);
  260.   register ArithFunction a;
  261.  
  262.   for(a=arithFunctionTable[v]; a && !isRef((word)a); a=a->next)
  263.   { if (a->functor == f)
  264.       return a;
  265.   }
  266.   a = (ArithFunction) allocHeap(sizeof(struct arithFunction));
  267.   a->next = arithFunctionTable[v];
  268.   arithFunctionTable[v] = a;
  269.   a->functor = f;
  270.   a->function = func;
  271.  
  272.   return a;
  273. }
  274. */
  275.  
  276. static
  277. ArithFunction
  278. isCurrentArithFunction(f, m)
  279. register FunctorDef f;
  280. register Module m;
  281. { register ArithFunction a;
  282.   ArithFunction r = NULL;
  283.   int level = 30000;
  284.  
  285.   for(a = arithFunctionTable[pointerHashValue(f, ARITHHASHSIZE)];
  286.       a && !isRef((word)a); a = a->next)
  287.   { if ( a->functor == f )
  288.     { register Module m2;
  289.       register int l;
  290.  
  291.       for( m2 = m, l = 0; m2; m2 = m2->super, l++ )
  292.       { if ( m2 == a->module && l < level )
  293.     { r = a;
  294.       level = l;
  295.     }
  296.       }
  297.     }
  298.   }
  299.  
  300.   return r;
  301. }
  302.  
  303. #if unix || EMX
  304. static void
  305. realExceptionHandler(sig, type, scp, addr)
  306. int sig, type;
  307. SIGNAL_CONTEXT_TYPE scp;
  308. char *addr;
  309. { if ( status.arithmetic > 0 )
  310.   { warning("Floating point exception");
  311.  
  312.     pl_abort();
  313.   } else
  314.   { deliverSignal(sig, type, scp, addr);
  315.   }
  316. }
  317. #endif
  318.  
  319. #if __TURBOC__
  320. static int
  321. realExceptionHandler(e)
  322. struct exception *e;
  323. { warning("Floating point exception");
  324.  
  325.   pl_abort();
  326.   /*NOTREACHED*/
  327.   fail;                /* make tc happy */
  328. }
  329. #endif
  330.  
  331.  
  332. #if O_PROLOG_FUNCTIONS
  333.  
  334. static int prologFunction P((ArithFunction, Word, Number));
  335.  
  336. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  337. Activating a Prolog predicate as function below the arithmetic functions
  338. is/0, >, etc.
  339. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  340.  
  341. static int
  342. prologFunction(f, av, r)
  343. ArithFunction f;
  344. Word av;                /* pointer to term arguments */
  345. Number r;
  346. { word goal;
  347.   int arity = f->proc->functor->arity;
  348.   int n;
  349.   Word ap;
  350.   mark m;
  351.   Word result;
  352.   bool rval;
  353.   LocalFrame fr = lTop;
  354.  
  355.   Mark(m);
  356.   goal = globalFunctor(f->proc->functor);
  357.   ap = argTermP(goal, 0);
  358.   for(n=0; n < arity-1; n++)
  359.   { number num;
  360.  
  361.     switch( valueExpression(av++, &num) )
  362.     { case V_INTEGER:    *ap++ = consNum(num.i);
  363.                   break;
  364.       case V_REAL:    *ap++ = globalReal(num.f);
  365.                   break;
  366.       case V_ERROR:
  367.       default:
  368.                   return V_ERROR;
  369.     }
  370.   }
  371.  
  372.   if ( (LocalFrame) &av[1] > lBase )
  373.   { lTop = (LocalFrame) &av[1];
  374.     DEBUG(8, printf("Setting lTop to 0x%x\n", lTop));
  375.   }
  376.   DEBUG(2, Putf("calling "); pl_write(&goal); pl_nl());
  377.   rval = PL_call(&goal, f->proc->definition->module);
  378.   DEBUG(2, Putf("rval = %d; return ", rval); pl_write(&goal); pl_nl());
  379.   lTop = fr;
  380.   if ( rval == FALSE )
  381.   { warning("Arithmetic function %s failed", procedureName(f->proc));
  382.     return V_ERROR;
  383.   }
  384.  
  385.   result = argTermP(goal, arity-1);
  386.   deRef(result);
  387.   
  388.   if ( isInteger(*result) )
  389.   { r->i = valNum(*result);
  390.     Undo(m);
  391.     return V_INTEGER;
  392.   } else if ( isReal(*result) )
  393.   { r->f = valReal(*result);
  394.     Undo(m);
  395.     return V_REAL;
  396.   } else
  397.   { warning("Arithmetic function %s did not bind return value to a number",
  398.                             procedureName(f->proc));
  399.     fail;
  400.   }
  401. }
  402.  
  403. #endif /* O_PROLOG_FUNCTIONS */
  404.  
  405. static int
  406. valueExpression(t, r)
  407. register Word t;
  408. Number r;
  409. { volatile ArithFunction f;
  410.   volatile Word args;
  411.   volatile FunctorDef fDef;
  412.  
  413.   deRef(t);
  414.  
  415.   if (isInteger(*t) )
  416.   { r->i = valNum(*t);
  417.     return V_INTEGER;
  418.   }
  419.   if (isReal(*t) )
  420.   { long i;
  421.  
  422.     r->f = valReal(*t);
  423.     i = (long) r->f;
  424.     if ( r->f == (real)i && r->f >= (real)PLMININT && r->f <= (real)PLMAXINT )
  425.     { r->i = i;
  426.       return V_INTEGER;
  427.     }
  428.  
  429.     return V_REAL;
  430.   }
  431.  
  432.   if ( isTerm(*t) )
  433.   { fDef = functorTerm(*t);
  434.     args = argTermP(*t, 0);
  435.   } else if ( isAtom(*t) )
  436.   { fDef = lookupFunctorDef((Atom)*t, 0);
  437.   } else if ( isVar(*t) )
  438.     return warning("Unbound variable in arithmetic expression");
  439.   else
  440.     return warning("Illegal data type in arithmetic expression");
  441.  
  442.   if ((f = isCurrentArithFunction(fDef,
  443.                   contextModule(environment_frame))) == NULL)
  444.     return warning("Unknown arithmetic operator: %s", stringAtom(fDef->name));
  445.  
  446. #if O_PROLOG_FUNCTIONS
  447.   if ( f->proc != (Procedure) NULL )
  448.     return prologFunction(f, args, r);
  449. #endif
  450.  
  451.   { int type;
  452.     Word a0, a1;
  453.  
  454.     status.arithmetic++;
  455.     switch(fDef->arity)
  456.     { case 0:    type = (*f->function)(r); break;
  457.       case 1:    deRef2(args, a0);
  458.         type = (*f->function)(a0, r);
  459.         break;
  460.       case 2:    deRef2(args, a0);
  461.         deRef2((args+1), a1);
  462.         type = (*f->function)(a0, a1, r);
  463.         break;
  464.       default:    sysError("Illegal arity for arithmic function");
  465.         type = V_ERROR;
  466.     }
  467.     status.arithmetic--;
  468.  
  469.     if ( type == V_REAL )
  470.     { long i = (long) r->f;
  471.  
  472.       if ( r->f == (real)i && r->f >= (real)PLMININT && r->f <= (real)PLMAXINT )
  473.       { r->i = i;
  474.     return V_INTEGER;
  475.       }
  476.     }
  477.  
  478.     return type;
  479.   }
  480. }
  481.  
  482.         /********************************
  483.         *     ARITHMETIC FUNCTIONS      *
  484.         *********************************/
  485.  
  486. /* C-primitive binairy operators */
  487.  
  488. #define BINAIRYFUNCTION(name, op) \
  489.   int \
  490.   name(n1, n2, r) \
  491.   Word n1, n2; \
  492.   Number r; \
  493.   { number left, right; \
  494.     int tl, tr; \
  495.     TRY(tl = valueExpression(n1, &left) ); \
  496.     TRY(tr = valueExpression(n2, &right) ); \
  497.     if (tl == V_INTEGER && tr == V_INTEGER) \
  498.     { r->i = left.i op right.i; \
  499.       if ( r->i < PLMININT || r->i > PLMAXINT ) \
  500.       { r->f = (real) r->i; \
  501.         return V_REAL; \
  502.       } \
  503.       return V_INTEGER; \
  504.     } \
  505.     if (tl == V_REAL && tr == V_INTEGER) \
  506.     { r->f = left.f op (real)right.i; \
  507.       return V_REAL; \
  508.     } \
  509.     if (tl == V_INTEGER && tr == V_REAL) \
  510.     { r->f = (real)left.i op right.f; \
  511.       return V_REAL; \
  512.     } \
  513.     if (tl == V_REAL && tr == V_REAL) \
  514.     { r->f = left.f op right.f; \
  515.       return V_REAL; \
  516.     } \
  517.     return sysError("Arithmetic internal error"); \
  518.   }
  519.  
  520. /* Real unairy functions. */
  521.  
  522. #define UNAIRYFUNCTION(name, op) \
  523.   static int \
  524.   name(n1, r) \
  525.   Word n1; \
  526.   Number r; \
  527.   { /*extern double op(); normally defined in <math.h> */ \
  528.     number arg; \
  529.     switch( valueExpression(n1, &arg) ) \
  530.     { case V_INTEGER:    r->f = op((real)arg.i); \
  531.             return V_REAL; \
  532.       case V_REAL:    r->f = op(arg.f); \
  533.             return V_REAL; \
  534.       default:        fail; \
  535.     } \
  536.   }
  537.  
  538. #define BINAIRY_INT_FUNCTION(name, op) \
  539.   static int \
  540.   name(n1, n2, r) \
  541.   Word n1, n2; \
  542.   Number r; \
  543.   { number left, right; \
  544.     int tl, tr; \
  545.     TRY(tl = valueExpression(n1, &left) ); \
  546.     TRY(tr = valueExpression(n2, &right) ); \
  547.     if (tl == V_INTEGER && tr == V_INTEGER) \
  548.     { r->i = left.i op right.i; \
  549.       return V_INTEGER; \
  550.     } \
  551.     return warning("is/2: arguments are not integers"); \
  552.   }
  553.  
  554. #define BINAIRY_FLOAT_FUNCTION(name, func) \
  555.   static int \
  556.   name(n1, n2, r) \
  557.   Word n1, n2; \
  558.   Number r; \
  559.   { number left, right; \
  560.     real f1, f2; \
  561.     int tl, tr; \
  562.     TRY(tl = valueExpression(n1, &left) ); \
  563.     TRY(tr = valueExpression(n2, &right) ); \
  564.     f1 = (tl == V_INTEGER ? (real) left.i  : left.f); \
  565.     f2 = (tr == V_INTEGER ? (real) right.i : right.f); \
  566.     r->f = func(f1, f2); \
  567.     return V_REAL; \
  568.   }
  569.  
  570. BINAIRYFUNCTION(ar_add, +)
  571. BINAIRYFUNCTION(ar_minus, -)
  572.  
  573. UNAIRYFUNCTION(ar_sqrt, sqrt)
  574. UNAIRYFUNCTION(ar_sin, sin)
  575. UNAIRYFUNCTION(ar_cos, cos)
  576. UNAIRYFUNCTION(ar_tan, tan)
  577. UNAIRYFUNCTION(ar_asin, asin)
  578. UNAIRYFUNCTION(ar_acos, acos)
  579. UNAIRYFUNCTION(ar_atan, atan)
  580. UNAIRYFUNCTION(ar_log, log)
  581. UNAIRYFUNCTION(ar_exp, exp)
  582. UNAIRYFUNCTION(ar_log10, log10)
  583.  
  584. BINAIRY_FLOAT_FUNCTION(ar_atan2, atan2)
  585.  
  586. BINAIRY_INT_FUNCTION(ar_mod, %)
  587. BINAIRY_INT_FUNCTION(ar_div, /)
  588. BINAIRY_INT_FUNCTION(ar_disjunct, |)
  589. BINAIRY_INT_FUNCTION(ar_conjunct, &)
  590. BINAIRY_INT_FUNCTION(ar_shift_right, >>)
  591. BINAIRY_INT_FUNCTION(ar_shift_left, <<)
  592. BINAIRY_INT_FUNCTION(ar_xor, ^)
  593.  
  594. static int
  595. ar_divide(n1, n2, r)
  596. Word n1, n2;
  597. Number r;
  598. { number left, right;
  599.   int tl, tr;
  600.  
  601.   TRY( tl = valueExpression(n1, &left) );
  602.   TRY( tr = valueExpression(n2, &right) );
  603.  
  604.   if (tl == V_INTEGER && tr == V_INTEGER)
  605.   { if (left.i % right.i == 0)
  606.     { r->i = left.i / right.i;
  607.       return V_INTEGER;
  608.     }
  609.     r->f = (real)left.i / (real)right.i;
  610.  
  611.     return V_REAL;
  612.   }
  613.   if (tl == V_REAL && tr == V_INTEGER)
  614.   { r->f = left.f / (real)right.i;
  615.     return V_REAL;
  616.   }
  617.   if (tl == V_INTEGER && tr == V_REAL)
  618.   { r->f = (real)left.i / right.f;
  619.     return V_REAL;
  620.   }
  621.   if (tl == V_REAL && tr == V_REAL)
  622.   { r->f = left.f / right.f;
  623.     return V_REAL;
  624.   }
  625.  
  626.   return sysError("Arithmetic internal error");
  627. }
  628.  
  629. static int
  630. ar_times(n1, n2, r)
  631. Word n1, n2;
  632. Number r;
  633. { number left, right;
  634.   int tl, tr;
  635.  
  636.   TRY( tl = valueExpression(n1, &left) );
  637.   TRY( tr = valueExpression(n2, &right) );
  638.  
  639.   if ( tl == V_INTEGER && tr == V_INTEGER )
  640.   { if ( abs(left.i) >= (1 << 13) || abs(right.i) >= (1 << 13) )
  641.     { r->f = (real)left.i * (real)right.i;
  642.       return V_REAL;
  643.     }
  644.     r->i = left.i * right.i;
  645.     return V_INTEGER;
  646.   }
  647.   if (tl == V_REAL && tr == V_INTEGER)
  648.   { r->f = left.f * (real)right.i;
  649.     return V_REAL;
  650.   }
  651.   if (tl == V_INTEGER && tr == V_REAL)
  652.   { r->f = (real)left.i * right.f;
  653.     return V_REAL;
  654.   }
  655.   if (tl == V_REAL && tr == V_REAL)
  656.   { r->f = left.f * right.f;
  657.     return V_REAL;
  658.   }
  659.  
  660.   return sysError("Arithmetic internal error");
  661. }
  662.  
  663. static
  664. int
  665. ar_pow(n1, n2, result)
  666. Word n1, n2;
  667. Number result;
  668. { number left, right;
  669.   int tl, tr;
  670.   real l, r;
  671.  
  672.   TRY( tl = valueExpression(n1, &left) );
  673.   TRY( tr = valueExpression(n2, &right) );
  674.  
  675.   l = (tl == V_INTEGER ? (real)left.i  : left.f);
  676.   r = (tr == V_INTEGER ? (real)right.i : right.f);
  677.  
  678.   result->f = pow(l, r);
  679.  
  680.   return V_REAL;
  681. }
  682.  
  683. static
  684. int
  685. ar_max(n1, n2, result)
  686. Word n1, n2;
  687. Number result;
  688. { number left, right;
  689.   int tl, tr;
  690.  
  691.   TRY( tl = valueExpression(n1, &left) );
  692.   TRY( tr = valueExpression(n2, &right) );
  693.  
  694.   if ( tl == V_INTEGER && tr == V_INTEGER )
  695.   { result->i = (left.i > right.i ? left.i : right.i);
  696.     return V_INTEGER;
  697.   } else
  698.   { real l = (tl == V_INTEGER ? (real)left.i  : left.f);
  699.     real r = (tr == V_INTEGER ? (real)right.i : right.f);
  700.  
  701.     result->f = (l > r ? l : r);
  702.   }
  703.  
  704.   return V_REAL;
  705. }
  706.  
  707. static
  708. int
  709. ar_min(n1, n2, result)
  710. Word n1, n2;
  711. Number result;
  712. { number left, right;
  713.   int tl, tr;
  714.  
  715.   TRY( tl = valueExpression(n1, &left) );
  716.   TRY( tr = valueExpression(n2, &right) );
  717.  
  718.   if ( tl == V_INTEGER && tr == V_INTEGER )
  719.   { result->i = (left.i < right.i ? left.i : right.i);
  720.     return V_INTEGER;
  721.   } else
  722.   { real l = (tl == V_INTEGER ? (real)left.i  : left.f);
  723.     real r = (tr == V_INTEGER ? (real)right.i : right.f);
  724.  
  725.     result->f = (l < r ? l : r);
  726.   }
  727.  
  728.   return V_REAL;
  729. }
  730.  
  731. static
  732. int
  733. ar_dot(c, nil, r)
  734. Word c, nil;
  735. Number r;
  736. { long chr;
  737.  
  738.   if ( isInteger(*c) && isNil(*nil) )
  739.   { if ((chr = valNum(*c)) >= 0 && chr <= 255)
  740.     { r->i = chr;
  741.       return V_INTEGER;
  742.     }
  743.   }
  744.   return warning("is/2: illegal character specification");
  745. }    
  746.  
  747. static
  748. int
  749. ar_negation(n1, r)
  750. Word n1;
  751. Number r;
  752. { number arg;
  753.  
  754.   switch( valueExpression(n1, &arg) )
  755.   { case V_INTEGER:
  756.     r->i = ~arg.i;
  757.     return V_INTEGER;
  758.     case V_REAL:
  759.     return warning("is/2: argument to \\/1 should be an integer");
  760.     default:
  761.     fail;
  762.   }
  763. }
  764.  
  765. static
  766. int
  767. ar_u_minus(n1, r)
  768. Word n1;
  769. Number r;
  770. { number arg;
  771.  
  772.   switch( valueExpression(n1, &arg) )
  773.   { case V_INTEGER:    r->i = -arg.i;
  774.             return V_INTEGER;
  775.     case V_REAL:    r->f = -arg.f;
  776.             return V_REAL;
  777.     default:        fail;
  778.   }
  779. }
  780.  
  781. static
  782. int
  783. ar_abs(n1, r)
  784. Word n1;
  785. Number r;
  786. { number arg;
  787.  
  788.   switch( valueExpression(n1, &arg) )
  789.   { case V_INTEGER:    r->i = (arg.i < 0 ? -arg.i : arg.i);
  790.             return V_INTEGER;
  791.     case V_REAL:    r->f = (arg.f < 0 ? -arg.f : arg.f);
  792.             return V_REAL;
  793.     default:        fail;
  794.   }
  795. }
  796.  
  797. static
  798. int
  799. ar_integer(n1, r)
  800. Word n1;
  801. Number r;
  802. { number arg;
  803.  
  804.   switch( valueExpression(n1, &arg) )
  805.   { case V_INTEGER:    r->i = arg.i;
  806.             return V_INTEGER;
  807.     case V_REAL:    r->i = (arg.f > 0 ? (long)(arg.f + 0.5)
  808.                       : (long)(arg.f - 0.5));
  809.             return V_INTEGER;
  810.     default:        fail;
  811.   }
  812. }
  813.  
  814. static
  815. int
  816. ar_floor(n1, r)
  817. Word n1;
  818. Number r;
  819. { number arg;
  820.  
  821.   switch( valueExpression(n1, &arg) )
  822.   { case V_INTEGER:    r->i = arg.i;
  823.             return V_INTEGER;
  824.     case V_REAL:    r->i = (long)arg.f;
  825.             return V_INTEGER;
  826.     default:        fail;
  827.   }
  828. }
  829.  
  830. static
  831. int
  832. ar_ceil(n1, r)
  833. Word n1;
  834. Number r;
  835. { number arg;
  836.  
  837.   switch( valueExpression(n1, &arg) )
  838.   { case V_INTEGER:    r->i = arg.i;
  839.             return V_INTEGER;
  840.     case V_REAL:    r->i = (long)arg.f;
  841.             if ( (real)r->i < arg.f )
  842.               (r->i)++;
  843.             return V_INTEGER;
  844.     default:        fail;
  845.   }
  846. }
  847.  
  848. static
  849. int
  850. ar_random(n1, r)
  851. Word n1;
  852. Number r;
  853. { number arg;
  854.  
  855.   switch( valueExpression(n1, &arg) )
  856.   { case V_INTEGER:    r->i = Random() % arg.i;
  857.             return V_INTEGER;
  858.     case V_REAL:    return warning("is/2: argument to random/1 should be a positive integer");
  859.     default:        fail;
  860.   }
  861. }
  862.  
  863. static
  864. int
  865. ar_pi(r)
  866. Number r;
  867. { r->f = M_PI;
  868.  
  869.   return V_REAL;
  870. }
  871.  
  872. static
  873. int
  874. ar_e(r)
  875. Number r;
  876. { r->f = M_E;
  877.  
  878.   return V_REAL;
  879. }
  880.  
  881. static
  882. int
  883. ar_cputime(r)
  884. Number r;
  885. { r->f = CpuTime();
  886.  
  887.   return V_REAL;
  888. }
  889.  
  890.  
  891.         /********************************
  892.         *       PROLOG CONNECTION       *
  893.         *********************************/
  894.  
  895. word
  896. pl_is(v, e)
  897. Word v, e;
  898. { number arg;
  899.  
  900.   switch( valueExpression(e, &arg) )
  901.   { case V_INTEGER:
  902.     return unifyAtomic(v, consNum(arg.i));
  903.     case V_REAL:
  904.     return unifyAtomic(v, globalReal(arg.f));
  905.     default:
  906.     fail;
  907.   }
  908. }
  909.  
  910. #if O_PROLOG_FUNCTIONS
  911. word
  912. pl_arithmetic_function(descr)
  913. Word descr;
  914. { Procedure proc;
  915.   FunctorDef fd;
  916.   register ArithFunction f;
  917.   Module m = NULL;
  918.   int v;
  919.  
  920.   if ( stripModule(descr, &m) == NULL )
  921.     fail;
  922.  
  923.   if ( (proc = findCreateProcedure(descr)) == (Procedure)NULL )
  924.     fail;
  925.   if ( proc->functor->arity < 1 )
  926.     return warning("arithmetic_function/1: Illegal arity");
  927.   fd = lookupFunctorDef(proc->functor->name, proc->functor->arity - 1);
  928.  
  929.   if ( (f = isCurrentArithFunction(fd, m)) != NULL && f->module == m )
  930.     succeed;                /* already registered */
  931.  
  932.   if ( next_index >= MAXARITHFUNCTIONS )
  933.     return warning("Cannot handle more than %d arithmetic functions",
  934.            MAXARITHFUNCTIONS);
  935.  
  936.   v = pointerHashValue(fd, ARITHHASHSIZE);
  937.   f = &functions[next_index];
  938.   f->functor  = fd;
  939.   f->function = NULL;
  940.   f->module   = m;
  941.   f->proc     = proc;
  942.   f->index    = next_index++;
  943.   f->next     = arithFunctionTable[v];
  944.   arithFunctionTable[v] = f;  
  945.  
  946.   succeed;
  947. }
  948.  
  949. word
  950. pl_current_arithmetic_function(f, h)
  951. Word f;
  952. word h;
  953. { ArithFunction a;
  954.   Module m = NULL;
  955.  
  956.   switch( ForeignControl(h) )
  957.   { case FRG_FIRST_CALL:
  958.       if ( (f = stripModule(f, &m)) == NULL )
  959.     fail;
  960.  
  961.       if ( isVar(*f) )
  962.       { a = arithFunctionTable[0];
  963.         break;
  964.       } else if ( isTerm(*f) )
  965.       {    if ( isCurrentArithFunction(functorTerm(*f), m) != NULL )
  966.       succeed;
  967.     fail;
  968.       } else
  969.         return warning("current_arithmetic_function/2: instantiation fault");
  970.     case FRG_REDO:
  971.       if ( (f = stripModule(f, &m)) == NULL )
  972.     fail;
  973.  
  974.       a = (ArithFunction) ForeignContextAddress(h);
  975.       break;
  976.     case FRG_CUTTED:
  977.     default:
  978.       succeed;
  979.   }
  980.  
  981.   for( ; a; a = a->next )
  982.   { Module m2;
  983.  
  984.     while( isRef((word)a) )
  985.     { a = *((ArithFunction *)unRef(a));
  986.       if ( a == (ArithFunction) NULL )
  987.         fail;
  988.     }
  989.  
  990.     for(m2 = m; m2; m2 = m2->super)
  991.     { if ( m2 == a->module && a == isCurrentArithFunction(a->functor, m) )
  992.       { if ( unifyFunctor(f, a->functor) == TRUE )
  993.     { return_next_table(ArithFunction, a);
  994.     }
  995.       }
  996.     }
  997.   }
  998.  
  999.   fail;
  1000. }
  1001.  
  1002. #endif /* O_PROLOG_FUNCTIONS */
  1003.  
  1004. #define ADD(functor, func) { (ArithFunction)NULL, functor, func }
  1005.  
  1006. static struct arithFunction ar_functions[MAXARITHFUNCTIONS] = {
  1007.   ADD(FUNCTOR_plus2,        ar_add),
  1008.   ADD(FUNCTOR_minus2,        ar_minus),
  1009.   ADD(FUNCTOR_star2,        ar_times),
  1010.   ADD(FUNCTOR_divide2,        ar_divide),
  1011.   ADD(FUNCTOR_minus1,        ar_u_minus),
  1012.   ADD(FUNCTOR_abs1,        ar_abs),
  1013.   ADD(FUNCTOR_max2,        ar_max),
  1014.   ADD(FUNCTOR_min2,        ar_min),
  1015.  
  1016.   ADD(FUNCTOR_mod2,        ar_mod),
  1017.   ADD(FUNCTOR_div2,        ar_div),
  1018.  
  1019.   ADD(FUNCTOR_and2,        ar_conjunct),
  1020.   ADD(FUNCTOR_or2,        ar_disjunct),
  1021.   ADD(FUNCTOR_rshift2,        ar_shift_right),
  1022.   ADD(FUNCTOR_lshift2,        ar_shift_left),
  1023.   ADD(FUNCTOR_xor2,        ar_xor),
  1024.   ADD(FUNCTOR_backslash1,    ar_negation),
  1025.  
  1026.   ADD(FUNCTOR_dot2,        ar_dot),
  1027.   ADD(FUNCTOR_random1,        ar_random),
  1028.  
  1029.   ADD(FUNCTOR_integer1,        ar_integer),
  1030.   ADD(FUNCTOR_floor1,        ar_floor),
  1031.   ADD(FUNCTOR_ceil1,        ar_ceil),
  1032.  
  1033.   ADD(FUNCTOR_sqrt1,        ar_sqrt),
  1034.   ADD(FUNCTOR_sin1,        ar_sin),
  1035.   ADD(FUNCTOR_cos1,        ar_cos),
  1036.   ADD(FUNCTOR_tan1,        ar_tan),
  1037.   ADD(FUNCTOR_asin1,        ar_asin),
  1038.   ADD(FUNCTOR_acos1,        ar_acos),
  1039.   ADD(FUNCTOR_atan1,        ar_atan),
  1040.   ADD(FUNCTOR_atan2,        ar_atan2),
  1041.   ADD(FUNCTOR_log1,        ar_log),
  1042.   ADD(FUNCTOR_exp1,        ar_exp),
  1043.   ADD(FUNCTOR_log101,        ar_log10),
  1044.   ADD(FUNCTOR_hat2,        ar_pow),
  1045.   ADD(FUNCTOR_pi0,        ar_pi),
  1046.   ADD(FUNCTOR_e0,        ar_e),
  1047.  
  1048.   ADD(FUNCTOR_cputime0,        ar_cputime),
  1049.  
  1050.   ADD((FunctorDef)NULL,        (ArithF)NULL)
  1051. };
  1052.  
  1053. #undef ADD
  1054.  
  1055.  
  1056. void
  1057. initArith()
  1058. {
  1059. #if unix || EMX
  1060.   pl_signal(SIGFPE, realExceptionHandler);
  1061. #endif
  1062. #if __TURBOC__
  1063.   setmatherr(realExceptionHandler);
  1064. #endif
  1065.  
  1066.                     /* link the table to enumerate */
  1067.   { register ArithFunction *f;
  1068.     register int n;
  1069.  
  1070.     for(n=0, f = arithFunctionTable; n < (ARITHHASHSIZE-1); n++, f++)
  1071.       *f = (ArithFunction) makeRef(f+1);
  1072.   }
  1073.  
  1074.                     /* initialise it */
  1075.   { register ArithFunction f;
  1076.     register int v;
  1077.  
  1078.     functions = ar_functions;
  1079.  
  1080.     for( f = functions, next_index = 0; f->functor; f++, next_index++ )
  1081.     { v = pointerHashValue(f->functor, ARITHHASHSIZE);
  1082.       f->module = MODULE_system;
  1083. #if O_COMPILE_ARITH
  1084.       f->index = next_index;
  1085. #endif
  1086.       f->next = arithFunctionTable[v];
  1087.       arithFunctionTable[v] = f;
  1088.     }
  1089.   }
  1090. }
  1091.  
  1092. #if O_COMPILE_ARITH
  1093.  
  1094.         /********************************
  1095.         *    VIRTUAL MACHINE SUPPORT    *
  1096.         *********************************/
  1097.  
  1098. int
  1099. indexArithFunction(fdef, m)
  1100. register FunctorDef fdef;
  1101. register Module m;
  1102. { register ArithFunction f;
  1103.  
  1104.   if ( (f = isCurrentArithFunction(fdef, m)) == (ArithFunction) NULL )
  1105.     return -1;
  1106.  
  1107.   return (int)f->index;
  1108. }
  1109.  
  1110. FunctorDef
  1111. functorArithFunction(n)
  1112. int n;
  1113. { return functions[(int)n].functor;
  1114. }
  1115.  
  1116.  
  1117. #if PROTO
  1118. bool
  1119. ar_func_n(register code n, int argc, register Word *stack)
  1120. #else
  1121. bool
  1122. ar_func_n(n, argc, stack)
  1123. register code n;
  1124. int argc;
  1125. register Word *stack;
  1126. #endif
  1127. { number result;
  1128.   int type;
  1129.   ArithFunction f = &functions[(int)n];
  1130.  
  1131.   (*stack) -= argc;
  1132.   if ( f->proc != (Procedure) NULL )
  1133.     type = prologFunction(f, *stack, &result);
  1134.   else
  1135.   { 
  1136. #define F    type = (*f->function)
  1137. #define A(n) ((*stack) + (n))
  1138. #define R    &result
  1139.     switch(argc)
  1140.     { case 0:    F(R); break;
  1141.       case 1:    F(A(0), R); break;
  1142.       case 2:    F(A(0), A(1), R); break;
  1143.       case 3:    F(A(0), A(1), A(2), R); break;
  1144.       case 4:    F(A(0), A(1), A(2), A(3), R); break;
  1145.       case 5:    F(A(0), A(1), A(2), A(3), A(4), R); break;
  1146.       default:  type = V_ERROR;
  1147.               sysError("Too many arguments to arithmetic function");
  1148.     }
  1149. #undef R
  1150. #undef A
  1151. #undef F
  1152.   }
  1153.  
  1154.   switch( type )
  1155.   { case V_INTEGER:    *(*stack)++ = consNum(result.i);
  1156.             succeed;
  1157.     case V_REAL:    *(*stack)++ = globalReal(result.f);
  1158.             succeed;
  1159.     default:        fail;
  1160.   }
  1161. }
  1162.  
  1163. #endif /* O_COMPILE_ARITH */
  1164.  
  1165. word
  1166. evaluate(p)
  1167. Word p;
  1168. { number result;
  1169.  
  1170.   switch( valueExpression(p, &result) )  
  1171.   { case V_INTEGER:    return consNum(result.i);
  1172.     case V_REAL:    return globalReal(result.f);
  1173.     case V_ERROR:
  1174.     default:        fail;
  1175.   }
  1176. }
  1177.