home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / fp / ifp_unix.lzh / ifp / interp / F_arith.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-05-23  |  9.7 KB  |  387 lines
  1.  
  2. /****** F_arith.c *****************************************************/
  3. /**                                                                  **/
  4. /**                    University of Illinois                        **/
  5. /**                                                                  **/
  6. /**                Department of Computer Science                    **/
  7. /**                                                                  **/
  8. /**   Tool: IFP                         Version: 0.6                 **/
  9. /**                                                                  **/
  10. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  11. /**                                                                  **/
  12. /**   Revised by: Arch D. Robison       Date:  May 23, 1989          **/
  13. /**                                                                  **/
  14. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  15. /**                            Prof. W. J. Kubitz                    **/
  16. /**                                                                  **/
  17. /**                                                                  **/
  18. /**------------------------------------------------------------------**/
  19. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  20. /**                       All Rights Reserved.                       **/
  21. /**********************************************************************/
  22.  
  23. #include <stdio.h>
  24. #include <math.h>
  25. #include <errno.h>
  26. #include "struct.h"
  27. #include "node.h"
  28.  
  29. #if OPSYS==APPLE
  30. #include "apple.c"
  31. #endif
  32.  
  33. #if OPSYS!=CTSS
  34. extern int errno;      /* exists somewhere in UNIX */
  35. #endif
  36.  
  37. /* NOTE - function Dyadic assumes integers are in two's complement form! */
  38.  
  39. private F_Minus (), F_AddN (), Monadic (), Dyadic (), F_Sum ();
  40.  
  41. private OpDef OpArith [] = {
  42. #if OPSYS!=CTSS
  43.    OPDEF ("ln",       0,      Monadic,    &TypeNUM),
  44.    OPDEF ("exp",      1,      Monadic,    &TypeNUM),
  45.    OPDEF ("sqrt",     2,      Monadic,    &TypeNUM),
  46.    OPDEF ("sin",      3,      Monadic,    &TypeNUM),
  47.    OPDEF ("cos",      4,      Monadic,    &TypeNUM),
  48.    OPDEF ("tan",      5,      Monadic,    &TypeNUM),
  49.    OPDEF ("arcsin",   6,      Monadic,    &TypeNUM),
  50.    OPDEF ("arccos",   7,      Monadic,    &TypeNUM),
  51.    OPDEF ("arctan",   8,      Monadic,    &TypeNUM),
  52. #endif
  53.    OPDEF ("minus",   -1,      F_Minus,    &TypeNUM),
  54.    OPDEF ("add1",     1,      F_AddN,    &TypeNUM),
  55.    OPDEF ("sub1",    -1,      F_AddN,    &TypeNUM),
  56.    OPDEF ("+",        0,      Dyadic,    &TypeNUM_NUM),
  57.    OPDEF ("-",        1,      Dyadic,    &TypeNUM_NUM),
  58.    OPDEF ("*",        2,      Dyadic,    &TypeNUM_NUM),
  59.    OPDEF ("%",        3,      Dyadic,    &TypeNUM_NUM),
  60. #if OPSYS!=CTSS
  61.    OPDEF ("mod",      4,      Dyadic,    &TypeNUM_NUM),
  62.    OPDEF ("div",      5,      Dyadic,    &TypeNUM_NUM),
  63. #endif
  64.    OPDEF ("min",      6,      Dyadic,    &TypeNUM_NUM),
  65.    OPDEF ("max",      7,      Dyadic,    &TypeNUM_NUM),
  66. #if OPSYS!=CTSS
  67.    OPDEF ("power",    8,      Dyadic,    &TypeNUM_NUM),
  68. #endif
  69.    OPDEF ("sum",      -1,     F_Sum,    &TypeLIST)
  70. };
  71.  
  72.  
  73. /*
  74.  * Monadic
  75.  *
  76.  * Evaluate a monadic function
  77.  *
  78.  * Input
  79.  *      InOut = argument to apply function
  80.  *      Op = operation - see array F_Name in code for values
  81.  *
  82.  * Output
  83.  *      InOut = result of applying function
  84.  */
  85. private Monadic (InOut,Op)
  86.    ObjectPtr InOut;
  87.    int Op;
  88.    {
  89.       double X,Z;
  90.       register int E;
  91.  
  92.       if (GetDouble (InOut,&X)) FunError ("not numeric",InOut);
  93.       else {
  94.      E = 0;
  95.      switch (Op) {
  96. #if OPSYS!=CTSS
  97.         case 0:                     /* base e log */
  98.            if (X <= 0) E = EDOM;
  99.            else Z = log (X);
  100.            break;
  101.         case 1:                     /* base e power */
  102.            if (X >= LNMAXFLOAT) E = ERANGE;
  103.            else Z = exp (X);
  104.            break;
  105.         case 2:                     /* square root */
  106.            if (X < 0) E = EDOM;
  107.            else Z = sqrt (X);
  108.            break;
  109.         case 3:                     /* sin */
  110.            Z = sin (X);
  111.            break;
  112.         case 4:                     /* cos */
  113.            Z = cos (X);
  114.            break;
  115.         case 5:                     /* tan */
  116.            Z = tan (X);
  117.            break;
  118.         case 6:                     /* arcsin */
  119.            Z = asin (X);
  120.            E = errno;
  121.            break;
  122.         case 7:                     /* arccos */
  123.            Z = acos (X);
  124.            E = errno;
  125.            break;
  126.         case 8:                     /* arctan */
  127.            Z = atan (X);
  128.            E = errno;
  129.            break;
  130. #endif /* OPSYS!=CTSS */
  131.         case 9:                     /* minus */
  132.            Z = -X;
  133.            E = 0;
  134.            break;
  135.      }
  136.      switch (E) {
  137. #if OPSYS!=CTSS
  138.         case EDOM:
  139.            FunError ("domain error",InOut);
  140.            break;
  141.         case ERANGE:
  142.            FunError ("range error",InOut);
  143.            break;
  144. #endif
  145.         default:
  146.            InOut->Tag = FLOAT;
  147.            InOut->Float = Z;
  148.            break;
  149.      }
  150.       }
  151.    }
  152.  
  153.  
  154. private F_Minus (InOut)
  155.    register ObjectPtr InOut;
  156.    {
  157.       if (InOut->Tag == INT && InOut->Int != FPMaxInt+1)
  158.      InOut->Int = - InOut->Int;
  159.       else Monadic (InOut,9);
  160.    }
  161.  
  162.  
  163. /*
  164.  * F_Sum
  165.  */
  166. private F_Sum (InOut)
  167.    ObjectPtr InOut;
  168.    {
  169.       Object S;
  170.       register ListPtr P;
  171.  
  172.       switch (InOut->Tag) {
  173.      default:
  174.         FunError (ArgNotSeq,InOut);
  175.         return;
  176.      case LIST:
  177.         S.Tag = INT;
  178.         S.Int = 0;
  179.         for (P=InOut->List; P!=NULL; P=P->Next) {
  180.            if (P->Val.Tag != INT && P->Val.Tag != FLOAT) {
  181.           FunError ("non-numeric sequence",InOut); 
  182.           return;
  183.            }
  184.            if (S.Tag == INT) {
  185.           if (P->Val.Tag == INT) {
  186.  
  187.              /* Both arguments are integers. See if we can avoid    */
  188.              /* floating arithmetic.                                */
  189.  
  190.              FPint Zi = S.Int + P->Val.Int;
  191.              if ((S.Int ^ P->Val.Int) < 0 || (S.Int^Zi)) 
  192.              /* arithmetic overflow occured - float result */;
  193.              else {
  194.             S.Int = Zi; 
  195.             continue;
  196.              }
  197.           }
  198.           S.Float = S.Int; 
  199.           S.Tag = FLOAT;
  200.            }
  201.            S.Float += P->Val.Tag==INT ? P->Val.Int : P->Val.Float;
  202.         }
  203.         break;
  204.       }
  205.       RepObject (InOut,&S);
  206.    }
  207.  
  208. /*
  209.  * Dyadic
  210.  *
  211.  * Evaluate a dyadic function
  212.  *
  213.  * Input
  214.  *      InOut = argument to apply function
  215.  *      Op = operation - see case statement in code for possibilities
  216.  *
  217.  * Output
  218.  *      InOut = result of applying function
  219.  *
  220.  * The author sold his anti-GOTO morals for speed.
  221.  */
  222. private Dyadic (InOut,Op)
  223.    register ObjectPtr InOut;
  224.    register int Op;
  225.    {
  226.       double X,Y,Z;
  227.       register FPint Xi,Yi,Zi;
  228.       register ListPtr P,Q;
  229.       static char *DivZero = "division by zero";
  230.  
  231.       if (InOut->Tag != LIST ||
  232.       NULL == (P=InOut->List) ||
  233.       NULL == (Q=P->Next) ||
  234.       Q->Next != NULL ||
  235.       NotNumPair (P->Val.Tag,Q->Val.Tag)) {
  236.  
  237.          FunError ("not a numeric pair",InOut);
  238.          return;
  239.           }
  240.  
  241.       if (IntPair (P->Val.Tag,Q->Val.Tag)) {
  242.  
  243.      /* Both arguments are integers. See if we can avoid floating point */
  244.      /* arithmetic.                                                     */
  245.  
  246.      Xi = P->Val.Int;
  247.      Yi = Q->Val.Int;
  248.  
  249.      switch (Op) {
  250.  
  251.         case 0:
  252.            /* Assume two's complement arithmetic */
  253.            Zi = Xi+Yi;
  254.            if (((Xi ^ Yi) | ~(Xi ^ Zi)) < 0) goto RetInt;
  255.            break;
  256.            /* else arithmetic overflow occured */
  257.  
  258.         case 1:
  259.            /* Assume two's complement arithmetic */
  260.            Zi = Xi - Yi;
  261.            if (((Xi ^ Yi) & (Xi ^ Zi)) >= 0) goto RetInt;
  262.            /* else arithmetic overflow occured */
  263.            break;
  264.  
  265.         case 2:
  266.            /* 
  267.         * Assume two's complement arithmetic and that overflow does  
  268.             * not cause exception.  Thanks to Tim McDaniels for pointing  
  269.         * out that -1*MinInt needs to be handled as special case.
  270.         */
  271.                Zi = Xi*Yi;
  272.            if (Yi==0 || (Zi/Yi==Xi && !(Yi==-1&&Xi==FPMinInt))) goto RetInt;
  273.            /* else arithmetic overflow occured */
  274.            break;
  275.  
  276.      /* case 3: division  result always FLOAT */
  277.  
  278. #if OPSYS!=CTSS
  279.         case 4:                     /* mod */
  280.            if (Xi >= 0 && Yi > 0) {
  281.           Zi = Xi % Yi;
  282.           goto RetInt;
  283.            }
  284.            break;
  285.  
  286.         case 5:                     /* div */
  287.            if (Xi >= 0 && Yi > 0) {
  288.           Zi = Xi / Yi;
  289.           goto RetInt;
  290.            }
  291.            break;
  292. #endif /* OPSYS!=CTSS */
  293.  
  294.         case 6:
  295.            Zi = Xi > Yi ? Yi : Xi;
  296.            goto RetInt;
  297.  
  298.         case 7:
  299.            Zi = Xi < Yi ? Yi : Xi;
  300.            goto RetInt;
  301.  
  302.      /* case 8: power result always FLOAT */
  303.      }
  304.       }
  305.  
  306.       X = P->Val.Tag==INT ? P->Val.Int : P->Val.Float;
  307.       Y = Q->Val.Tag==INT ? Q->Val.Int : Q->Val.Float;
  308.  
  309.       switch (Op) {
  310.      case 0: Z = X + Y; break;
  311.      case 1: Z = X - Y; break;
  312.      case 2: Z = X * Y; break;
  313.      case 3: 
  314.         if (Y==0.0) {
  315.            FunError (DivZero,InOut);
  316.            return;
  317.         }
  318.         Z = X / Y; 
  319.         break;
  320. #if OPSYS!=CTSS
  321.      case 4:
  322.         Z = Y==0.0 ? 0.0 : X - floor (X / Y) * Y;   /* mod */
  323.         break;
  324.      case 5:
  325.         if (Y==0.0) {                               /* div */
  326.            FunError (DivZero,InOut);
  327.            return;
  328.         }
  329.         Z = floor (X / Y);
  330.         break;
  331. #endif
  332.      case 6: Z = X > Y ? Y:X; break;
  333.      case 7: Z = X > Y ? X:Y; break;
  334. #if OPSYS!=CTSS
  335.      case 8: Z = pow (X,Y);   break;
  336. #endif
  337.       }
  338.       InOut->Tag = FLOAT;
  339.       InOut->Float = Z;
  340.  
  341.    Return:
  342.       DelLPtr (P);
  343.       return;
  344.  
  345.    RetInt: 
  346.       InOut->Tag = INT;
  347.       InOut->Int = Zi;
  348.       goto Return;
  349.    }
  350.  
  351.  
  352. /*
  353.  * F_Add1
  354.  */
  355. private F_AddN (InOut,N)
  356.    register ObjectPtr InOut;
  357.    int N;
  358.    {
  359.       register FPint K;
  360.  
  361.       switch (InOut->Tag) {
  362.      case INT:
  363.         K = InOut->Int + N;
  364.         if (N >= 0 ? InOut->Int <= K : InOut->Int >  K) {
  365.            InOut->Int = K;
  366.            return;
  367.         }
  368.         /* else integer overflow - convert and drop down */
  369.         InOut->Float = ((FPfloat) InOut->Int);
  370.         InOut->Tag = FLOAT;
  371.      case FLOAT:
  372.         InOut->Float = InOut->Float + N;
  373.         break;
  374.      default:
  375.         FunError ("not a number",InOut);
  376.         break;
  377.       }
  378.    }
  379.  
  380. void D_arith ()
  381.    {
  382.       GroupDef (OpArith,OpCount (OpArith), ArithNode);
  383.    }
  384.  
  385. /************************** end of F_arith.c **************************/
  386.  
  387.