home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / X_PROLOG.LZH / X_PROLOG / SOURCES / BICOMPAR.C < prev    next >
C/C++ Source or Header  |  1990-08-13  |  3KB  |  146 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 "extern.h"
  20. #include "error.h"
  21.  
  22. #define COMPARE(x,y) (x < y ? -1 : x==y ? 0 : 1)
  23. extern term *argument();        /* terms */
  24.  
  25. /*
  26.  *    Compare a and b and return
  27.  *    -1 for a < b
  28.  *    0  for a = b
  29.  *    1  for a > b  (analogous to strcmp in C)
  30.  *    
  31.  *    Ordering is defined as :
  32.  *
  33.  *    Var < Int < Struct
  34.  *
  35.  *    Comparing vars is not well defined as frame < ? > copy is unknown.
  36.  *    Ints are ordered as usual.
  37.  *    Structs are ordered by
  38.  *        1. arity
  39.  *        2. name
  40.  *        3. arguments from left to right
  41.  */
  42.  
  43. short _compare(a,b)
  44. register term *a,*b;
  45. {
  46.     short aritya, arityb, i, j;
  47.     
  48.     if (ISVAR(a))
  49.     {
  50.         if (!ISVAR(b))
  51.             return(-1);
  52.         return(COMPARE(a,b));
  53.     }
  54.     if (ISINT(a))
  55.     {
  56.         if (ISVAR(b))
  57.             return(1);
  58.         if (ISINT(b))
  59.             return(COMPARE(VALUE(a), VALUE(b)));
  60.         return(-1);
  61.     }
  62.     if (ISSTRUCT(a))
  63.     {
  64.         if (!ISSTRUCT(b))
  65.             return(1);
  66.         aritya = ARITY(a);
  67.         arityb = ARITY(b);
  68.         i = COMPARE(aritya, arityb);
  69.         if (i)            /* arities differ */
  70.             return(i);
  71.         i = strcmp(NAME(a), NAME(b));
  72.         if (i)
  73.             return(i);    /* names differ */
  74.         for (j=1; j<=aritya; j++)
  75.             if ((i = _compare(argument(a,Topenv,j),
  76.                       argument(b,Topenv,j))))
  77.                 break;
  78.         return(i);
  79.     }
  80. }
  81.  
  82. /*    A == B    */
  83.  
  84. short bieq(args)
  85. term *args[];
  86. {
  87.     return(!_compare(args[0], args[1]));
  88. }
  89.  
  90. /*    A \== B    */
  91.  
  92. short bineq(args)
  93. term *args[];
  94. {
  95.     return(_compare(args[0], args[1]));
  96. }
  97.  
  98. /*    A @< B    */
  99.  
  100. short biless(args)
  101. term *args[];
  102. {
  103.     return(_compare(args[0], args[1]) < 0);
  104. }
  105.  
  106. /*    A @> B    */
  107.  
  108. short bigreat(args)
  109. term *args[];
  110. {
  111.     return(_compare(args[0], args[1]) > 0);
  112. }
  113.  
  114. /*    A @=< B    */
  115.  
  116. short bieqless(args)
  117. term *args[];
  118. {
  119.     return(_compare(args[0], args[1]) <= 0);
  120. }
  121.  
  122. /*    A @>= B    */
  123.  
  124. short bigreateq(args)
  125. term *args[];
  126. {
  127.     return(_compare(args[0], args[1]) >= 0);
  128. }
  129.  
  130. /*    compare(op, a, b)    */
  131.  
  132. short bicompare(args)
  133. term *args[];
  134. {
  135.     if (!ISATOM(args[0]))
  136.         BIERROR(EBAD);
  137.         
  138.     switch(NAME(args[0])[0])
  139.     {
  140.         case '=':    return(!_compare(args[1], args[2]));
  141.         case '<':    return(_compare(args[1], args[2]) < 0);
  142.         case '>':    return(_compare(args[1], args[2]) > 0);
  143.         default:    BIERROR(EBAD);
  144.     }
  145. }
  146.