home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume10 / ifp / part03 / interp / F_pred.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-07-05  |  11.4 KB  |  512 lines
  1.  
  2. /****** F_pred.c ******************************************************/
  3. /**                                                                  **/
  4. /**                    University of Illinois                        **/
  5. /**                                                                  **/
  6. /**                Department of Computer Science                    **/
  7. /**                                                                  **/
  8. /**   Tool: IFP                         Version: 0.5                 **/
  9. /**                                                                  **/
  10. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  11. /**                                                                  **/
  12. /**   Revised by: Arch D. Robison       Date:   Dec 1, 1985          **/
  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 "struct.h"
  26. #include "node.h"
  27.  
  28. /************************** boolean functions **************************/
  29.  
  30. /*
  31.  * PairTest
  32.  *
  33.  * Check if object is a pair of <type1,type2>
  34.  *
  35.  * Input
  36.  *      X = object to test
  37.  *      Mask1,Mask2 = masks representing type1 and type2 respectively.
  38.  *                    E.g 1<<INT is type INT, (1<<INT)|(1<<FLOAT) is numeric.
  39.  *
  40.  * Output
  41.  *      result = 1 if true, 0 if false
  42.  */
  43. boolean PairTest (X,Mask1,Mask2)
  44.    ObjectPtr X;
  45.    int Mask1,Mask2;
  46.    {
  47.       register ListPtr P,Q;
  48.  
  49.       if (X->Tag != LIST) 
  50.      if (X->Tag == NODE) NodeExpand (X);
  51.      else return 0;
  52.  
  53.       if ((P=X->List) == NULL || (Q=P->Next) == NULL || Q->Next!=NULL) return 0;
  54.       if (P->Val.Tag == NODE) NodeExpand (&P->Val);
  55.       if (Q->Val.Tag == NODE) NodeExpand (&Q->Val);
  56.       return Mask1 >> P->Val.Tag & Mask2 >> Q->Val.Tag & 1; 
  57.    }
  58.  
  59. /*
  60.  * Anytime two objects are found to be equal, we can replace one with
  61.  * the other to save memory.  Clearly the memory savings is offset by
  62.  * a little more time, program complexity, and bringing obscure bugs
  63.  * out of the woodwork!  Therefore the replacing action is enabled if
  64.  * MERGE=1, disabled if MERGE=0.
  65.  *
  66.  * P.S. Someone should check if the merging is really worth the cost.
  67.  */
  68. #define MERGE 0
  69.  
  70. /*
  71.  * BoolOp
  72.  *
  73.  * Boolean operation
  74.  *
  75.  * Input
  76.  *      InOut = argument
  77.  *      Op = boolean op (4-bit vector representing truth table)
  78.  *
  79.  * Output
  80.  *      *A = first element of pair if result is true, undefined otherwise
  81.  *      *B = second ...
  82.  */
  83. private BoolOp (InOut,Op)
  84.    ObjectPtr InOut;
  85.    int Op;
  86.    {
  87.       extern void RepBool ();
  88.       register ListPtr P;
  89.  
  90.       if (PairTest (InOut,1<<BOOLEAN,1<<BOOLEAN)) {
  91.      P = InOut->List;
  92.      RepBool (InOut, (Op >> (P->Next->Val.Bool << 1) + P->Val.Bool) & 1);
  93.       } else
  94.      FunError ("not a boolean pair",InOut);
  95.    }
  96.  
  97.  
  98. /*
  99.  * F_Not
  100.  *
  101.  * Boolean negation
  102.  */
  103. private F_Not (InOut)
  104.    ObjectPtr InOut;
  105.    {
  106.       if (InOut->Tag == BOOLEAN) InOut->Bool ^= 1;
  107.       else FunError ("not boolean",InOut);
  108.    }
  109.  
  110.  
  111. /* 
  112.  * F_L2
  113.  */
  114. private F_L2 (InOut)
  115.    ObjectPtr InOut;
  116.    {
  117.       switch (InOut->Tag) {
  118.      case INT: RepBool (InOut,InOut->Int < 2); break;
  119.      case FLOAT: RepBool (InOut,InOut->Float < 2); break;
  120.      default: FunError ("not numeric",InOut); break;
  121.       }
  122.    } 
  123.  
  124. /*
  125.  * F_False
  126.  *
  127.  * Check if argument is boolean false (#f).
  128.  */
  129. private F_False (InOut)
  130.    ObjectPtr InOut;
  131.    {
  132.       if (InOut->Tag == BOTTOM)
  133.      FunError (ArgBottom,InOut);
  134.       else
  135.      if (InOut->Tag == BOOLEAN) InOut->Bool ^= 1;
  136.      else RepBool (InOut,0);
  137.    }
  138.  
  139. /*
  140.  * F_Odd
  141.  *
  142.  * Check if integral argument is odd.
  143.  */
  144. private F_Odd (InOut)
  145.    ObjectPtr InOut;
  146.    {
  147.       FPint N;
  148.  
  149.       switch (GetFPInt (InOut,&N)) {
  150.       case 0:
  151.          RepBool (InOut,(int)N & 1);
  152.          return;
  153.       case 2:
  154.          FunError ("not enough precision",InOut);
  155.          return;
  156.       default:
  157.          FunError ("not an integer",InOut);
  158.          return;
  159.       }
  160.    }
  161.  
  162. /*
  163.  * BoolSeq
  164.  *
  165.  * Evaluate "any" or "all" predicate.
  166.  *
  167.  * Input
  168.  *      *InOut = argument
  169.  *      Op = identity element of operation
  170.  *
  171.  * Output
  172.  *      *InOut = result
  173.  */
  174. private BoolSeq (InOut,Op)
  175.    ObjectPtr InOut;
  176.    int Op;
  177.    {
  178.       register boolean R;
  179.       register ListPtr P;
  180.  
  181.       if (InOut->Tag != LIST) FunError (ArgNotSeq,InOut);
  182.       else {
  183.      R = 0;
  184.      for (P = InOut->List; P != NULL; P=P->Next) 
  185.         if (P->Val.Tag == BOOLEAN) R |= P->Val.Bool ^ Op;
  186.         else {
  187.            FunError ("non-boolean element",InOut);
  188.            return;
  189.         }
  190.      RepBool (InOut, R ^ Op);
  191.       }
  192.    }
  193.  
  194.  
  195. #if MERGE
  196. /*
  197.  * StrMerge
  198.  *
  199.  * Compare two strings.  Merge together if they are equal.
  200.  *
  201.  * Output
  202.  *      result = 1 if equal, 0 otherwise
  203.  */
  204. static int StrMerge (S,T)
  205.    register StrPtr *S,*T;
  206.    {
  207.       if (*S == *T) return 2;               /* strings are identical */
  208.       else if (StrComp (*S,*T)) return 0;   /* strings are different */
  209.       else {
  210.      register StrPtr *U;                /* equal and not identical */
  211.      if ((*S)->SRef < (*T)->SRef) 
  212.         U=S, S=T, T=U;
  213.      if ((*S)->SRef + 1) {              /* S has larger SRef */
  214.         DelSPtr (*T);
  215.         *T = *S;
  216.         (*S)->SRef++;
  217.      }
  218.      return 1;
  219.       }
  220.    }
  221. #endif
  222.  
  223. /*
  224.  * ObEqual
  225.  *
  226.  * Compare two objects.  A comparison tolerance is used for floating point
  227.  * comparisons.
  228.  *
  229.  * Output
  230.  *       result = 0 if objects are not equal
  231.  *                1 if objects are equal within comparison tolerance
  232.  */
  233. boolean ObEqual (X,Y)
  234.    ObjectPtr X,Y;
  235.    {
  236.       if (X->Tag != Y->Tag) {
  237.  
  238.      switch (X->Tag) {
  239.  
  240.         case INT:
  241.            return Y->Tag==FLOAT && 
  242.               !FloatComp ((double) X->Int,(double) Y->Float);
  243.  
  244.         case FLOAT:
  245.            return Y->Tag==INT && 
  246.               !FloatComp ((double) X->Float,(double) Y->Int);
  247.  
  248.         case NODE:
  249.            NodeExpand (X);
  250.            break;
  251.  
  252.         case LIST:
  253.            if (Y->Tag==NODE) NodeExpand (Y); 
  254.            break;
  255.  
  256.         default: return 0;
  257.      }
  258.       }
  259.       switch (X->Tag) {
  260.  
  261.      case BOTTOM:  return 1;
  262.      case BOOLEAN: return X->Bool == Y->Bool;
  263.      case INT:     return X->Int == Y->Int;
  264.      case FLOAT:   return !FloatComp ((double) X->Float, (double) Y->Float);
  265.      case STRING:
  266. #if MERGE
  267.         return StrMerge (&X->String,&Y->String);
  268. #else
  269.         return !StrComp (X->String,Y->String);
  270. #endif
  271.      case LIST: {
  272.         register ListPtr P=X->List, Q=Y->List;
  273.         while (1) {
  274.            if (P == NULL) return Q == NULL;
  275.            if (Q == NULL || !ObEqual (&P->Val,&Q->Val)) return 0;
  276.            P = P->Next; Q = Q->Next;
  277.         }
  278.      }
  279.      case NODE: return X->Node == Y->Node; 
  280.      default:   return 0; /* Tag error */
  281.       }
  282.    }
  283.  
  284. #define max(A,B) ((A) > (B) ? (A) : (B))
  285.  
  286. /*
  287.  * FloatComp
  288.  *
  289.  * X ~= Y if abs(X-Y) / max(abs(X),abs(Y)) <= comparison tolerance.
  290.  *
  291.  * Output
  292.  *      result = -1 if X < Y
  293.  *                0 if X ~= Y
  294.  *                1 if X > Y
  295.  */
  296. int FloatComp (X,Y)
  297.    double X,Y;
  298.    {
  299.       double Xm,Ym,D;
  300.       Xm = fabs (X);
  301.       Ym = fabs (Y);
  302.       D = X-Y;
  303.       if (fabs (D) <= CompTol*max(Xm,Ym)) return 0;
  304.       else return D>0 ? 1 : -1;
  305.    }
  306.  
  307. /*
  308.  * F_Equal
  309.  *
  310.  * Object comparison for equality or inequality
  311.  */
  312. private F_Equal (InOut,Not)
  313.    ObjectPtr InOut;
  314.    int Not;
  315.    {
  316.       if (!PairTest (InOut,~0,~0))
  317.      FunError ("argument not a pair",InOut);
  318.       else 
  319.      RepBool (InOut, Not ^ (0 < ObEqual (&InOut->List->Val,
  320.                          &InOut->List->Next->Val)));
  321.    }
  322.  
  323.  
  324. /*
  325.  * F_Null
  326.  *
  327.  * Null sequence test
  328.  */
  329. private F_Null (InOut)
  330.    ObjectPtr InOut;
  331.    {
  332.       switch (InOut->Tag) {
  333.      case LIST:
  334.         RepBool (InOut, InOut->List == NULL);
  335.         break;
  336.      default: 
  337.         FunError (ArgNotSeq,InOut);
  338.         break;
  339.       }
  340.    }
  341.  
  342.  
  343. /*
  344.  * F_Pair
  345.  *
  346.  * Check if argument is a pair.
  347.  */
  348. private F_Pair (InOut)
  349.    ObjectPtr InOut;
  350.    {
  351.       RepBool (InOut, PairTest (InOut,~0,~0));
  352.    }
  353.  
  354.  
  355. /*
  356.  * F_Tag
  357.  *
  358.  * Check for specified tag
  359.  */
  360. private F_Tag (InOut,TagSet)
  361.    ObjectPtr InOut;
  362.    {
  363.       if (InOut->Tag) 
  364.      RepBool (InOut,TagSet >> InOut->Tag & 1);
  365.       else 
  366.      FunError (ArgBottom,InOut);
  367.    }
  368.  
  369.  
  370. /*
  371.  * CompAtom
  372.  *
  373.  * Compare two atoms for <,<=,=>, or >
  374.  *
  375.  * Strings are ordered lexigraphically.
  376.  * Numbers are ordered in increasing value.
  377.  *
  378.  * Input
  379.  *      *InOut = <X,Y>
  380.  *      Op = comparison bit vector [>,=,<]
  381.  *
  382.  * Output
  383.  *      *InOut = sign (X - Y) or BOTTOM
  384.  */
  385. private CompAtom (InOut,Op)
  386.    ObjectPtr InOut;
  387.    int Op;
  388.    {
  389.       register ObjectPtr X,Y;
  390.       int D,E;
  391.       static char *ErrMessage [3] = {
  392.      "not an atomic pair",
  393.      "booleans not comparable",
  394.      "strings and numbers not comparable"
  395.       };
  396.  
  397.       E = 0;
  398.       if (!PairTest (InOut,ATOMIC,ATOMIC)) E = 1;
  399.       else {
  400.      X = &InOut->List->Val;
  401.      Y = &InOut->List->Next->Val;
  402.      if (X->Tag == BOOLEAN || Y->Tag == BOOLEAN) E = 2;
  403.      else if (X->Tag == STRING || Y->Tag == STRING) {
  404.         if (X->Tag != Y->Tag) E = 3;
  405.         else {
  406.            D = StrComp (X->String,Y->String);
  407.            if (D) D = (D>0) ? 1 : -1;
  408.         }
  409.      } else
  410.         if (X->Tag == INT)
  411.            if (Y->Tag == INT)
  412.           D = (X->Int > Y->Int) - (X->Int < Y->Int);
  413.            else
  414.           D = FloatComp ((double) X->Int,(double) Y->Float);
  415.         else
  416.            if (Y->Tag == INT)
  417.           D = FloatComp ((double) X->Float,(double) Y->Int);
  418.            else
  419.           D = FloatComp ((double) X->Float,(double) Y->Float);
  420.      }
  421.       if (E) FunError (ErrMessage [E-1],InOut);
  422.       else RepBool (InOut, (Op >> (D+1)) & 1);
  423.    }
  424.  
  425.  
  426. /*
  427.  * CompLength
  428.  *
  429.  * Compare the length of two sequences.
  430.  *
  431.  * Input
  432.  *      InOut = argument
  433.  *      Shorter = if 0 then "longer" comparison, "shorter" otherwise.
  434.  */
  435. private CompLength (InOut,Shorter)
  436.    ObjectPtr InOut;
  437.    int Shorter;
  438.    {
  439.       register ListPtr P,Q;
  440.  
  441.       if (!PairTest (InOut,1<<LIST,1<<LIST))
  442.      FunError ("not a pair of sequences",InOut);
  443.       else {
  444.      P = InOut->List;
  445.      Q = P->Next->Val.List;
  446.      P = P->Val.List;
  447.      while (P != NULL && Q != NULL) {
  448.         P = P->Next;
  449.         Q = Q->Next;
  450.      }
  451.      RepBool (InOut, (Shorter ? Q : P) != NULL);
  452.       }
  453.    }
  454.  
  455. /*
  456.  * F_Member
  457.  */
  458. private F_Member (InOut)
  459.    ObjectPtr InOut;
  460.    {
  461.       register ListPtr P;
  462.       register ObjectPtr X;
  463.  
  464.       if (! PairTest (InOut,1 << LIST,~0))
  465.  
  466.      FunError (ArgSeqOb,InOut);
  467.  
  468.       else {
  469.  
  470.      P = InOut->List;
  471.      X = & P->Next->Val;
  472.      for (P = P->Val.List; P!=NULL; P=P->Next)
  473.         if (ObEqual (& P->Val,X)) break;
  474.      RepBool (InOut, P != NULL);
  475.       }
  476.    }
  477.  
  478. private OpDef LogicOps [] = {
  479.    {"all",      1,      BoolSeq},
  480.    {"and",      0x8,    BoolOp},
  481.    {"any",      0,      BoolSeq},
  482.    {"atom",     ATOMIC, F_Tag},
  483.    {"boolean",  1<<BOOLEAN,     F_Tag},
  484.    {"false",    -1,     F_False},
  485.    {"imply",    0xD,    BoolOp},
  486.    {"longer",   0,      CompLength},
  487.    {"member",   -1,     F_Member},
  488.    {"null",     -1,     F_Null},
  489.    {"numeric",  NUMERIC,F_Tag},
  490.    {"odd",      -1,     F_Odd},
  491.    {"or",       0xE,    BoolOp},
  492.    {"pair",     -1,     F_Pair},
  493.    {"shorter",  1,      CompLength},
  494.    {"xor",      0x6,    BoolOp},
  495.    {"=",        0,      F_Equal},
  496.    {"~=",       1,      F_Equal},
  497.    {"~",        -1,     F_Not},
  498.    {">",        0x4,    CompAtom},
  499.    {"<",        0x1,    CompAtom},
  500.    {">=",       0x6,    CompAtom},
  501.    {"<=",       0x3,    CompAtom},
  502.    {"l2",    0,    F_L2}
  503. };
  504.  
  505. void D_pred ()
  506.    {
  507.       GroupDef (LogicOps, OpCount (LogicOps), LogicNode);
  508.    }
  509.  
  510. /******************************* end of F_pred *******************************/
  511.  
  512.