home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / fp / ifp_unix.lzh / ifp / interp / F_pred.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-05-23  |  11.7 KB  |  500 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:  Sept 9, 1987          **/
  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_False
  113.  *
  114.  * Check if argument is boolean false (#f).
  115.  */
  116. private F_False (InOut)
  117.    ObjectPtr InOut;
  118.    {
  119.       if (InOut->Tag == BOTTOM)
  120.      FunError (ArgBottom,InOut);
  121.       else
  122.      if (InOut->Tag == BOOLEAN) InOut->Bool ^= 1;
  123.      else RepBool (InOut,0);
  124.    }
  125.  
  126. /*
  127.  * F_Odd
  128.  *
  129.  * Check if integral argument is odd.
  130.  */
  131. private F_Odd (InOut)
  132.    ObjectPtr InOut;
  133.    {
  134.       FPint N;
  135.  
  136.       switch (GetFPInt (InOut,&N)) {
  137.       case 0:
  138.          RepBool (InOut,(int)N & 1);
  139.          return;
  140.       case 2:
  141.          FunError ("not enough precision",InOut);
  142.          return;
  143.       default:
  144.          FunError ("not an integer",InOut);
  145.          return;
  146.       }
  147.    }
  148.  
  149. /*
  150.  * BoolSeq
  151.  *
  152.  * Evaluate "any" or "all" predicate.
  153.  *
  154.  * Input
  155.  *      *InOut = argument
  156.  *      Op = identity element of operation
  157.  *
  158.  * Output
  159.  *      *InOut = result
  160.  */
  161. private BoolSeq (InOut,Op)
  162.    ObjectPtr InOut;
  163.    int Op;
  164.    {
  165.       register boolean R;
  166.       register ListPtr P;
  167.  
  168.       if (InOut->Tag != LIST) FunError (ArgNotSeq,InOut);
  169.       else {
  170.      R = 0;
  171.      for (P = InOut->List; P != NULL; P=P->Next) 
  172.         if (P->Val.Tag == BOOLEAN) R |= P->Val.Bool ^ Op;
  173.         else {
  174.            FunError ("non-boolean element",InOut);
  175.            return;
  176.         }
  177.      RepBool (InOut, R ^ Op);
  178.       }
  179.    }
  180.  
  181.  
  182. #if MERGE
  183. /*
  184.  * StrMerge
  185.  *
  186.  * Compare two strings.  Merge together if they are equal.
  187.  *
  188.  * Output
  189.  *      result = 1 if equal, 0 otherwise
  190.  */
  191. static int StrMerge (S,T)
  192.    register StrPtr *S,*T;
  193.    {
  194.       if (*S == *T) return 2;               /* strings are identical */
  195.       else if (StrComp (*S,*T)) return 0;   /* strings are different */
  196.       else {
  197.      register StrPtr *U;                /* equal and not identical */
  198.      if ((*S)->SRef < (*T)->SRef) 
  199.         U=S, S=T, T=U;
  200.      if ((*S)->SRef + 1) {              /* S has larger SRef */
  201.         DelSPtr (*T);
  202.         *T = *S;
  203.         (*S)->SRef++;
  204.      }
  205.      return 1;
  206.       }
  207.    }
  208. #endif
  209.  
  210. /*
  211.  * ObEqual
  212.  *
  213.  * Compare two objects.  A comparison tolerance is used for floating point
  214.  * comparisons.
  215.  *
  216.  * Output
  217.  *       result = 0 if objects are not equal
  218.  *                1 if objects are equal within comparison tolerance
  219.  */
  220. boolean ObEqual (X,Y)
  221.    ObjectPtr X,Y;
  222.    {
  223.       if (X->Tag != Y->Tag) {
  224.  
  225.      switch (X->Tag) {
  226.  
  227.         case INT:
  228.            return Y->Tag==FLOAT && 
  229.               !FloatComp ((double) X->Int,(double) Y->Float);
  230.  
  231.         case FLOAT:
  232.            return Y->Tag==INT && 
  233.               !FloatComp ((double) X->Float,(double) Y->Int);
  234.  
  235.         case NODE:
  236.            if (Y->Tag != LIST) return 0;
  237.            NodeExpand (X);
  238.            break;
  239.  
  240.         case LIST:
  241.            if (Y->Tag != NODE) return 0;
  242.            NodeExpand (Y); 
  243.            break;
  244.  
  245.         default: return 0;
  246.      }
  247.       }
  248.       switch (X->Tag) {
  249.  
  250.      case BOTTOM:  return 1;
  251.      case BOOLEAN: return X->Bool == Y->Bool;
  252.      case INT:     return X->Int == Y->Int;
  253.      case FLOAT:   return !FloatComp ((double) X->Float, (double) Y->Float);
  254.      case STRING:
  255. #if MERGE
  256.         return StrMerge (&X->String,&Y->String);
  257. #else
  258.         return !StrComp (X->String,Y->String);
  259. #endif
  260.      case LIST: {
  261.         register ListPtr P=X->List, Q=Y->List;
  262.         while (1) {
  263.            if (P == NULL) return Q == NULL;
  264.            if (Q == NULL || !ObEqual (&P->Val,&Q->Val)) return 0;
  265.            P = P->Next; Q = Q->Next;
  266.         }
  267.      }
  268.      case NODE: return X->Node == Y->Node; 
  269.      default:   return 0; /* Tag error */
  270.       }
  271.    }
  272.  
  273. #define max(A,B) ((A) > (B) ? (A) : (B))
  274.  
  275. /*
  276.  * FloatComp
  277.  *
  278.  * X ~= Y if abs(X-Y) / max(abs(X),abs(Y)) <= comparison tolerance.
  279.  *
  280.  * Output
  281.  *      result = -1 if X < Y
  282.  *                0 if X ~= Y
  283.  *                1 if X > Y
  284.  */
  285. int FloatComp (X,Y)
  286.    double X,Y;
  287.    {
  288.       double Xm,Ym,D;
  289.       Xm = fabs (X);
  290.       Ym = fabs (Y);
  291.       D = X-Y;
  292.       if (fabs (D) <= CompTol*max(Xm,Ym)) return 0;
  293.       else return D>0 ? 1 : -1;
  294.    }
  295.  
  296. /*
  297.  * F_Equal
  298.  *
  299.  * Object comparison for equality or inequality
  300.  */
  301. private F_Equal (InOut,Not)
  302.    ObjectPtr InOut;
  303.    int Not;
  304.    {
  305.       if (!PairTest (InOut,~0,~0))
  306.      FunError ("argument not a pair",InOut);
  307.       else 
  308.      RepBool (InOut, Not ^ (0 < ObEqual (&InOut->List->Val,
  309.                          &InOut->List->Next->Val)));
  310.    }
  311.  
  312.  
  313. /*
  314.  * F_Null
  315.  *
  316.  * Null sequence test
  317.  */
  318. private F_Null (InOut)
  319.    ObjectPtr InOut;
  320.    {
  321.       switch (InOut->Tag) {
  322.      case LIST:
  323.         RepBool (InOut, InOut->List == NULL);
  324.         break;
  325.      default: 
  326.         FunError (ArgNotSeq,InOut);
  327.         break;
  328.       }
  329.    }
  330.  
  331.  
  332. /*
  333.  * F_Pair
  334.  *
  335.  * Check if argument is a pair.
  336.  */
  337. private F_Pair (InOut)
  338.    ObjectPtr InOut;
  339.    {
  340.       RepBool (InOut, PairTest (InOut,~0,~0));
  341.    }
  342.  
  343.  
  344. /*
  345.  * F_Tag
  346.  *
  347.  * Check for specified tag
  348.  */
  349. private F_Tag (InOut,TagSet)
  350.    ObjectPtr InOut;
  351.    {
  352.       if (InOut->Tag) 
  353.      RepBool (InOut,TagSet >> InOut->Tag & 1);
  354.       else 
  355.      FunError (ArgBottom,InOut);
  356.    }
  357.  
  358.  
  359. /*
  360.  * CompAtom
  361.  *
  362.  * Compare two atoms for <,<=,=>, or >
  363.  *
  364.  * Strings are ordered lexigraphically.
  365.  * Numbers are ordered in increasing value.
  366.  *
  367.  * Input
  368.  *      *InOut = <X,Y>
  369.  *      Op = comparison bit vector [>,=,<]
  370.  *
  371.  * Output
  372.  *      *InOut = sign (X - Y) or BOTTOM
  373.  */
  374. private CompAtom (InOut,Op)
  375.    ObjectPtr InOut;
  376.    int Op;
  377.    {
  378.       register ObjectPtr X,Y;
  379.       int D,E;
  380.       static char *ErrMessage [3] = {
  381.      "not an atomic pair",
  382.      "booleans not comparable",
  383.      "strings and numbers not comparable"
  384.       };
  385.  
  386.       E = 0;
  387.       if (!PairTest (InOut,ATOMIC,ATOMIC)) E = 1;
  388.       else {
  389.      X = &InOut->List->Val;
  390.      Y = &InOut->List->Next->Val;
  391.      if (X->Tag == BOOLEAN || Y->Tag == BOOLEAN) E = 2;
  392.      else if (X->Tag == STRING || Y->Tag == STRING) {
  393.         if (X->Tag != Y->Tag) E = 3;
  394.         else {
  395.            D = StrComp (X->String,Y->String);
  396.            if (D) D = (D>0) ? 1 : -1;
  397.         }
  398.      } else
  399.         if (X->Tag == INT)
  400.            if (Y->Tag == INT)
  401.           D = (X->Int > Y->Int) - (X->Int < Y->Int);
  402.            else
  403.           D = FloatComp ((double) X->Int,(double) Y->Float);
  404.         else
  405.            if (Y->Tag == INT)
  406.           D = FloatComp ((double) X->Float,(double) Y->Int);
  407.            else
  408.           D = FloatComp ((double) X->Float,(double) Y->Float);
  409.      }
  410.       if (E) FunError (ErrMessage [E-1],InOut);
  411.       else RepBool (InOut, (Op >> (D+1)) & 1);
  412.    }
  413.  
  414.  
  415. /*
  416.  * CompLength
  417.  *
  418.  * Compare the length of two sequences.
  419.  *
  420.  * Input
  421.  *      InOut = argument
  422.  *      Shorter = if 0 then "longer" comparison, "shorter" otherwise.
  423.  */
  424. private CompLength (InOut,Shorter)
  425.    ObjectPtr InOut;
  426.    int Shorter;
  427.    {
  428.       register ListPtr P,Q;
  429.  
  430.       if (!PairTest (InOut,1<<LIST,1<<LIST))
  431.      FunError ("not a pair of sequences",InOut);
  432.       else {
  433.      P = InOut->List;
  434.      Q = P->Next->Val.List;
  435.      P = P->Val.List;
  436.      while (P != NULL && Q != NULL) {
  437.         P = P->Next;
  438.         Q = Q->Next;
  439.      }
  440.      RepBool (InOut, (Shorter ? Q : P) != NULL);
  441.       }
  442.    }
  443.  
  444. /*
  445.  * F_Member
  446.  */
  447. private F_Member (InOut)
  448.    ObjectPtr InOut;
  449.    {
  450.       register ListPtr P;
  451.       register ObjectPtr X;
  452.  
  453.       if (! PairTest (InOut,1 << LIST,~0))
  454.  
  455.      FunError (ArgSeqOb,InOut);
  456.  
  457.       else {
  458.  
  459.      P = InOut->List;
  460.      X = & P->Next->Val;
  461.      for (P = P->Val.List; P!=NULL; P=P->Next)
  462.         if (ObEqual (& P->Val,X)) break;
  463.      RepBool (InOut, P != NULL);
  464.       }
  465.    }
  466.  
  467. private OpDef LogicOps [] = {
  468.    OPDEF ("all",      1,          BoolSeq,    &TypeLIST),
  469.    OPDEF ("and",      0x8,        BoolOp,        &TypeBOOLEAN_BOOLEAN),
  470.    OPDEF ("any",      0,          BoolSeq,    &TypeLIST),
  471.    OPDEF ("atom",     ATOMIC,    F_Tag,        &TypeOBJECT),
  472.    OPDEF ("boolean",  1<<BOOLEAN, F_Tag,    &TypeOBJECT),
  473.    OPDEF ("false",    -1,         F_False,    &TypeOBJECT),
  474.    OPDEF ("imply",    0xD,        BoolOp,        &TypeBOOLEAN_BOOLEAN),
  475.    OPDEF ("longer",   0,          CompLength,    &TypeLIST_LIST),
  476.    OPDEF ("member",   -1,         F_Member,    &TypeLIST_OBJECT),
  477.    OPDEF ("null",     -1,         F_Null,        &TypeLIST),
  478.    OPDEF ("numeric",  NUMERIC,    F_Tag,        &TypeOBJECT),
  479.    OPDEF ("odd",      -1,         F_Odd,        &TypeNUM),
  480.    OPDEF ("or",       0xE,        BoolOp,        &TypeBOOLEAN_BOOLEAN),
  481.    OPDEF ("pair",     -1,         F_Pair,        &TypeOBJECT),
  482.    OPDEF ("shorter",  1,          CompLength,    &TypeLIST_LIST),
  483.    OPDEF ("xor",      0x6,        BoolOp,        &TypeBOOLEAN_BOOLEAN),
  484.    OPDEF ("~",        -1,         F_Not,        &TypeBOOLEAN),
  485.    OPDEF ("=",        0,          F_Equal,    &TypeNUM_NUM),
  486.    OPDEF ("~=",       1,          F_Equal,    &TypeNUM_NUM),
  487.    OPDEF (">",        0x4,        CompAtom,    &TypeNUM_NUM),
  488.    OPDEF ("<",        0x1,        CompAtom,    &TypeNUM_NUM),
  489.    OPDEF (">=",       0x6,        CompAtom,    &TypeNUM_NUM),
  490.    OPDEF ("<=",       0x3,        CompAtom,    &TypeNUM_NUM),
  491. };
  492.  
  493. void D_pred ()
  494.    {
  495.       GroupDef (LogicOps, OpCount (LogicOps), LogicNode);
  496.    }
  497.  
  498. /******************************* end of F_pred *******************************/
  499.  
  500.