home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / X_PROLOG.LZH / X_PROLOG / SOURCES / BIMATH.C < prev    next >
C/C++ Source or Header  |  1990-08-13  |  3KB  |  162 lines
  1. /*
  2.  *        X PROLOG  Vers. 2.0
  3.  *
  4.  *
  5.  *    Written by :     Andreas Toenne
  6.  *            CS Dept. , IRB
  7.  *            University of Dortmund, W-Germany
  8.  *            <at@unido.uucp>
  9.  *            <....!seismo!unido!at>
  10.  *            <at@unido.bitnet>
  11.  *
  12.  *    Copyright :    This software is copyrighted by Andreas Toenne.
  13.  *            Permission is granted hereby to copy the entire
  14.  *            package including this copyright notice without fee.
  15.  *
  16.  */
  17.  
  18. #include "prolog.h"
  19. #include "error.h"
  20. #include "extern.h"
  21.  
  22. #define ARG1 eval(argument(t, Topenv, 1))
  23. #define ARG2 eval(argument(t, Topenv, 2))
  24.  
  25. extern term *int_copy();        /* terms */
  26. extern term *argument();        /* terms */
  27. extern long cputime();            /* bisys */
  28.  
  29. long eval();                /* forward */
  30.  
  31. /*    The evaluating function    */
  32.  
  33. short biis(args)
  34. term *args[];
  35. {
  36.     long l;
  37.     
  38.     if (! ISINT(args[0]) && ! ISVAR(args[0]))
  39.         BIERROR(EBAD);
  40.         
  41.     if (ISVAR(args[1]))
  42.         BIERROR(EBAD);
  43.         
  44.     l = eval(args[1]);
  45.     if (c_errno)
  46.         return(FALSE);
  47.     else
  48.         if (ISINT(args[0]))
  49.             return(VALUE(args[0]) == l);
  50.         else
  51.             BIND_VAR(args[0], int_copy(l));
  52.     return(TRUE);
  53. }
  54.  
  55. long eval(t)
  56. register term *t;
  57. {
  58.     long l;
  59.  
  60.     if (ISVAR(t))
  61.         BIERROR(EEVAL);
  62.         
  63.     if (ISINT(t))                /* return it's value */
  64.         return(VALUE(t));
  65.  
  66.     if (FUNC(t) == DOTFUNCTOR)        /* take it's first arg */
  67.         return((long)FUNC(argument(t,Topenv,1))->name[0]);
  68.         
  69.     if (!EXP_NO(FUNC(t)))            /* no expression */
  70.         BIERROR(EEVAL);    
  71.             
  72.     switch(EXP_NO(FUNC(t)))
  73.     {
  74.         case EXPPLUS:    return(ARG1 + ARG2);
  75.         case EXPMINUS:    return(ARG1 - ARG2);
  76.         case EXPTIMES:    return(ARG1 * ARG2);
  77.         case EXPDIV:    if ((l = ARG2) == 0L)
  78.                     BIERROR(EEVAL);
  79.                 return(ARG1 / l);
  80.         case EXPMOD:    if ((l = ARG2) == 0L)
  81.                     BIERROR(EEVAL);
  82.                 return(ARG1 % l);
  83.         case EXPNEGATE:    return(-1 * ARG1);
  84.         case EXPAND:    return(ARG1 & ARG2);
  85.         case EXPOR:    return(ARG1 | ARG2);
  86.         case EXPLEFT:    return(ARG1 << ARG2);
  87.         case EXPRIGHT:    return(ARG1 >> ARG2);
  88.         case EXPNOT:    return(~ ARG1);
  89.         case EXPCPU:    return(cputime());
  90.         case EXPHEAP:    return((long)protonext-(long)protostack);
  91.         default: BIERROR(EEVAL);
  92.     }
  93. }
  94.  
  95. /*    SUCC ( X, X+1 ) */
  96.  
  97. short bisucc(args)
  98. term *args[];
  99. {
  100.     if (ISINT(args[0]))
  101.     {
  102.         if (ISINT(args[1]))
  103.             return(VALUE(args[0]) == VALUE(args[1])+1);
  104.         if (!ISVAR(args[1]))
  105.             BIERROR(EBAD);
  106.         BIND_VAR(args[1], int_copy(VALUE(args[0])+1));
  107.         return(TRUE);
  108.     }
  109.     if (!ISVAR(args[0]) || !ISINT(args[1]))
  110.         BIERROR(EBAD);
  111.     BIND_VAR(args[0], int_copy(VALUE(args[1])-1));
  112.     return(TRUE);
  113. }
  114.  
  115. /*    A =:= B    */
  116.  
  117. short bieeq(args)
  118. term *args[];
  119. {
  120.     return(eval(args[0]) == eval(args[1]));
  121. }
  122.  
  123. /*    A =\= B    */
  124.  
  125. short bieneq(args)
  126. term *args[];
  127. {
  128.     return(eval(args[0]) != eval(args[1]));
  129. }
  130.  
  131. /*    A < B    */
  132.  
  133. short bieless(args)
  134. term *args[];
  135. {
  136.     return(eval(args[0]) < eval(args[1]));
  137. }
  138.  
  139. /*    A > B    */
  140.  
  141. short biegreat(args)
  142. term *args[];
  143. {
  144.     return(eval(args[0]) > eval(args[1]));
  145. }
  146.  
  147. /*    A =< B    */
  148.  
  149. short bieeqless(args)
  150. term *args[];
  151. {
  152.     return(eval(args[0]) <= eval(args[1]));
  153. }
  154.  
  155. /*    A >= B     */
  156.  
  157. short biegreateq(args)
  158. term *args[];
  159. {
  160.     return(eval(args[0]) >= eval(args[1]));
  161. }
  162.