src/clipsrules/core/prdctfun.c Source File

00001    /*******************************************************/
00002    /*      "C" Language Integrated Production System      */
00003    /*                                                     */
00004    /*             CLIPS Version 6.24  06/05/06            */
00005    /*                                                     */
00006    /*              PREDICATE FUNCTIONS MODULE             */
00007    /*******************************************************/
00008 
00009 /*************************************************************/
00010 /* Purpose: Contains the code for several predicate          */
00011 /*   functions including not, and, or, eq, neq, <=, >=, <,   */
00012 /*   >, =, <>, symbolp, stringp, lexemep, numberp, integerp, */
00013 /*   floatp, oddp, evenp, multifieldp, sequencep, and        */
00014 /*   pointerp.                                               */
00015 /*                                                           */
00016 /* Principal Programmer(s):                                  */
00017 /*      Gary D. Riley                                        */
00018 /*                                                           */
00019 /* Contributing Programmer(s):                               */
00020 /*                                                           */
00021 /* Revision History:                                         */
00022 /*      6.23: Correction for FalseSymbol/TrueSymbol. DR0859  */
00023 /*                                                           */
00024 /*      6.24: Renamed BOOLEAN macro type to intBool.         */
00025 /*                                                           */
00026 /*************************************************************/
00027 
00028 #define _PRDCTFUN_SOURCE_
00029 
00030 #include <stdio.h>
00031 #define _STDIO_INCLUDED_
00032 
00033 #include "setup.h"
00034 
00035 #include "envrnmnt.h"
00036 #include "exprnpsr.h"
00037 #include "argacces.h"
00038 #include "multifld.h"
00039 #include "router.h"
00040 
00041 #include "prdctfun.h"
00042 
00043 /**************************************************/
00044 /* PredicateFunctionDefinitions: Defines standard */
00045 /*   math and predicate functions.                */
00046 /**************************************************/
00047 globle void PredicateFunctionDefinitions(
00048   void *theEnv)
00049   {
00050 #if ! RUN_TIME
00051    EnvDefineFunction2(theEnv,"not", 'b', NotFunction, "NotFunction", "11");
00052    EnvDefineFunction2(theEnv,"and", 'b', AndFunction, "AndFunction", "2*");
00053    EnvDefineFunction2(theEnv,"or", 'b', OrFunction, "OrFunction", "2*");
00054 
00055    EnvDefineFunction2(theEnv,"eq", 'b', EqFunction, "EqFunction", "2*");
00056    EnvDefineFunction2(theEnv,"neq", 'b', NeqFunction, "NeqFunction", "2*");
00057 
00058    EnvDefineFunction2(theEnv,"<=", 'b', LessThanOrEqualFunction, "LessThanOrEqualFunction", "2*n");
00059    EnvDefineFunction2(theEnv,">=", 'b', GreaterThanOrEqualFunction, "GreaterThanOrEqualFunction", "2*n");
00060    EnvDefineFunction2(theEnv,"<", 'b', LessThanFunction, "LessThanFunction", "2*n");
00061    EnvDefineFunction2(theEnv,">", 'b', GreaterThanFunction, "GreaterThanFunction", "2*n");
00062    EnvDefineFunction2(theEnv,"=", 'b', NumericEqualFunction, "NumericEqualFunction", "2*n");
00063    EnvDefineFunction2(theEnv,"<>", 'b', NumericNotEqualFunction, "NumericNotEqualFunction", "2*n");
00064    EnvDefineFunction2(theEnv,"!=", 'b', NumericNotEqualFunction, "NumericNotEqualFunction", "2*n");
00065 
00066    EnvDefineFunction2(theEnv,"symbolp", 'b', SymbolpFunction, "SymbolpFunction", "11");
00067    EnvDefineFunction2(theEnv,"wordp", 'b', SymbolpFunction, "SymbolpFunction", "11");
00068    EnvDefineFunction2(theEnv,"stringp", 'b', StringpFunction, "StringpFunction", "11");
00069    EnvDefineFunction2(theEnv,"lexemep", 'b', LexemepFunction, "LexemepFunction", "11");
00070    EnvDefineFunction2(theEnv,"numberp", 'b', NumberpFunction, "NumberpFunction", "11");
00071    EnvDefineFunction2(theEnv,"integerp", 'b', IntegerpFunction, "IntegerpFunction", "11");
00072    EnvDefineFunction2(theEnv,"floatp", 'b', FloatpFunction, "FloatpFunction", "11");
00073    EnvDefineFunction2(theEnv,"oddp", 'b', OddpFunction, "OddpFunction", "11i");
00074    EnvDefineFunction2(theEnv,"evenp", 'b', EvenpFunction, "EvenpFunction", "11i");
00075    EnvDefineFunction2(theEnv,"multifieldp",'b', MultifieldpFunction, "MultifieldpFunction", "11");
00076    EnvDefineFunction2(theEnv,"sequencep",'b', MultifieldpFunction, "MultifieldpFunction", "11");
00077    EnvDefineFunction2(theEnv,"pointerp", 'b', PointerpFunction, "PointerpFunction", "11");
00078 #else
00079 #if MAC_MCW || WIN_MCW || MAC_XCD
00080 #pragma unused(theEnv)
00081 #endif
00082 #endif
00083   }
00084 
00085 /************************************/
00086 /* EqFunction: H/L access routine   */
00087 /*   for the eq function.           */
00088 /************************************/
00089 globle intBool EqFunction(
00090   void *theEnv)
00091   {
00092    DATA_OBJECT item, nextItem;
00093    int numArgs, i;
00094    struct expr *theExpression;
00095 
00096    /*====================================*/
00097    /* Determine the number of arguments. */
00098    /*====================================*/
00099 
00100    numArgs = EnvRtnArgCount(theEnv);
00101    if (numArgs == 0) return(FALSE);
00102 
00103    /*==============================================*/
00104    /* Get the value of the first argument against  */
00105    /* which subsequent arguments will be compared. */
00106    /*==============================================*/
00107 
00108    theExpression = GetFirstArgument();
00109    EvaluateExpression(theEnv,theExpression,&item);
00110 
00111    /*=====================================*/
00112    /* Compare all arguments to the first. */
00113    /* If any are the same, return FALSE.  */
00114    /*=====================================*/
00115 
00116    theExpression = GetNextArgument(theExpression);
00117    for (i = 2 ; i <= numArgs ; i++)
00118      {
00119       EvaluateExpression(theEnv,theExpression,&nextItem);
00120 
00121       if (GetType(nextItem) != GetType(item))
00122         { return(FALSE); }
00123 
00124       if (GetType(nextItem) == MULTIFIELD)
00125         {
00126          if (MultifieldDOsEqual(&nextItem,&item) == FALSE)
00127            { return(FALSE); }
00128         }
00129       else if (nextItem.value != item.value)
00130         { return(FALSE); }
00131 
00132       theExpression = GetNextArgument(theExpression);
00133      }
00134 
00135    /*=====================================*/
00136    /* All of the arguments were different */
00137    /* from the first. Return TRUE.        */
00138    /*=====================================*/
00139 
00140    return(TRUE);
00141   }
00142 
00143 /*************************************/
00144 /* NeqFunction: H/L access routine   */
00145 /*   for the neq function.           */
00146 /*************************************/
00147 globle intBool NeqFunction(
00148   void *theEnv)
00149   {
00150    DATA_OBJECT item, nextItem;
00151    int numArgs, i;
00152    struct expr *theExpression;
00153 
00154    /*====================================*/
00155    /* Determine the number of arguments. */
00156    /*====================================*/
00157 
00158    numArgs = EnvRtnArgCount(theEnv);
00159    if (numArgs == 0) return(FALSE);
00160 
00161    /*==============================================*/
00162    /* Get the value of the first argument against  */
00163    /* which subsequent arguments will be compared. */
00164    /*==============================================*/
00165 
00166    theExpression = GetFirstArgument();
00167    EvaluateExpression(theEnv,theExpression,&item);
00168 
00169    /*=====================================*/
00170    /* Compare all arguments to the first. */
00171    /* If any are different, return FALSE. */
00172    /*=====================================*/
00173 
00174    for (i = 2, theExpression = GetNextArgument(theExpression);
00175         i <= numArgs;
00176         i++, theExpression = GetNextArgument(theExpression))
00177      {
00178       EvaluateExpression(theEnv,theExpression,&nextItem);
00179       if (GetType(nextItem) != GetType(item))
00180         { continue; }
00181       else if (nextItem.type == MULTIFIELD)
00182         {
00183          if (MultifieldDOsEqual(&nextItem,&item) == TRUE)
00184            { return(FALSE); }
00185         }
00186       else if (nextItem.value == item.value)
00187         { return(FALSE); }
00188      }
00189 
00190    /*=====================================*/
00191    /* All of the arguments were identical */
00192    /* to the first. Return TRUE.          */
00193    /*=====================================*/
00194 
00195    return(TRUE);
00196   }
00197 
00198 /*****************************************/
00199 /* StringpFunction: H/L access routine   */
00200 /*   for the stringp function.           */
00201 /*****************************************/
00202 globle intBool StringpFunction(
00203   void *theEnv)
00204   {
00205    DATA_OBJECT item;
00206 
00207    if (EnvArgCountCheck(theEnv,"stringp",EXACTLY,1) == -1) return(FALSE);
00208 
00209    EnvRtnUnknown(theEnv,1,&item);
00210 
00211    if (GetType(item) == STRING)
00212      { return(TRUE); }
00213    else
00214      { return(FALSE); }
00215   }
00216 
00217 /*****************************************/
00218 /* SymbolpFunction: H/L access routine   */
00219 /*   for the symbolp function.           */
00220 /*****************************************/
00221 globle intBool SymbolpFunction(
00222   void *theEnv)
00223   {
00224    DATA_OBJECT item;
00225 
00226    if (EnvArgCountCheck(theEnv,"symbolp",EXACTLY,1) == -1) return(FALSE);
00227 
00228    EnvRtnUnknown(theEnv,1,&item);
00229 
00230    if (GetType(item) == SYMBOL)
00231      { return(TRUE); }
00232    else
00233      { return(FALSE); }
00234   }
00235 
00236 /*****************************************/
00237 /* LexemepFunction: H/L access routine   */
00238 /*   for the lexemep function.           */
00239 /*****************************************/
00240 globle intBool LexemepFunction(
00241   void *theEnv)
00242   {
00243    DATA_OBJECT item;
00244 
00245    if (EnvArgCountCheck(theEnv,"lexemep",EXACTLY,1) == -1) return(FALSE);
00246 
00247    EnvRtnUnknown(theEnv,1,&item);
00248 
00249    if ((GetType(item) == SYMBOL) || (GetType(item) == STRING))
00250      { return(TRUE); }
00251    else
00252      { return(FALSE); }
00253   }
00254 
00255 /*****************************************/
00256 /* NumberpFunction: H/L access routine   */
00257 /*   for the numberp function.           */
00258 /*****************************************/
00259 globle intBool NumberpFunction(
00260   void *theEnv)
00261   {
00262    DATA_OBJECT item;
00263 
00264    if (EnvArgCountCheck(theEnv,"numberp",EXACTLY,1) == -1) return(FALSE);
00265 
00266    EnvRtnUnknown(theEnv,1,&item);
00267 
00268    if ((GetType(item) == FLOAT) || (GetType(item) == INTEGER))
00269      { return(TRUE); }
00270    else
00271      { return(FALSE); }
00272   }
00273 
00274 /****************************************/
00275 /* FloatpFunction: H/L access routine   */
00276 /*   for the floatp function.           */
00277 /****************************************/
00278 globle intBool FloatpFunction(
00279   void *theEnv)
00280   {
00281    DATA_OBJECT item;
00282 
00283    if (EnvArgCountCheck(theEnv,"floatp",EXACTLY,1) == -1) return(FALSE);
00284 
00285    EnvRtnUnknown(theEnv,1,&item);
00286 
00287    if (GetType(item) == FLOAT)
00288      { return(TRUE); }
00289    else
00290      { return(FALSE); }
00291   }
00292 
00293 /******************************************/
00294 /* IntegerpFunction: H/L access routine   */
00295 /*   for the integerp function.           */
00296 /******************************************/
00297 globle intBool IntegerpFunction(
00298   void *theEnv)
00299   {
00300    DATA_OBJECT item;
00301 
00302    if (EnvArgCountCheck(theEnv,"integerp",EXACTLY,1) == -1) return(FALSE);
00303 
00304    EnvRtnUnknown(theEnv,1,&item);
00305 
00306    if (GetType(item) != INTEGER) return(FALSE);
00307 
00308    return(TRUE);
00309   }
00310 
00311 /*********************************************/
00312 /* MultifieldpFunction: H/L access routine   */
00313 /*   for the multifieldp function.           */
00314 /*********************************************/
00315 globle intBool MultifieldpFunction(
00316   void *theEnv)
00317   {
00318    DATA_OBJECT item;
00319 
00320    if (EnvArgCountCheck(theEnv,"multifieldp",EXACTLY,1) == -1) return(FALSE);
00321 
00322    EnvRtnUnknown(theEnv,1,&item);
00323 
00324    if (GetType(item) != MULTIFIELD) return(FALSE);
00325 
00326    return(TRUE);
00327   }
00328 
00329 /******************************************/
00330 /* PointerpFunction: H/L access routine   */
00331 /*   for the pointerp function.           */
00332 /******************************************/
00333 globle intBool PointerpFunction(
00334   void *theEnv)
00335   {
00336    DATA_OBJECT item;
00337 
00338    if (EnvArgCountCheck(theEnv,"pointerp",EXACTLY,1) == -1) return(FALSE);
00339 
00340    EnvRtnUnknown(theEnv,1,&item);
00341 
00342    if (GetType(item) != EXTERNAL_ADDRESS) return(FALSE);
00343 
00344    return(TRUE);
00345   }
00346 
00347 /*************************************/
00348 /* NotFunction: H/L access routine   */
00349 /*   for the not function.           */
00350 /*************************************/
00351 globle intBool NotFunction(
00352   void *theEnv)
00353   {
00354    EXPRESSION *theArgument;
00355    DATA_OBJECT result;
00356 
00357    theArgument = GetFirstArgument();
00358    if (theArgument == NULL) { return(FALSE); }
00359 
00360    if (EvaluateExpression(theEnv,theArgument,&result)) return(FALSE);
00361 
00362    if ((result.value == EnvFalseSymbol(theEnv)) && (result.type == SYMBOL))
00363      { return(TRUE); }
00364    
00365    return(FALSE);
00366   }
00367 
00368 /*************************************/
00369 /* AndFunction: H/L access routine   */
00370 /*   for the and function.           */
00371 /*************************************/
00372 globle intBool AndFunction(
00373   void *theEnv)
00374   {
00375    EXPRESSION *theArgument;
00376    DATA_OBJECT result;
00377 
00378    for (theArgument = GetFirstArgument();
00379         theArgument != NULL;
00380         theArgument = GetNextArgument(theArgument))
00381      {
00382       if (EvaluateExpression(theEnv,theArgument,&result)) return(FALSE);
00383       if ((result.value == EnvFalseSymbol(theEnv)) && (result.type == SYMBOL))
00384         { return(FALSE); }
00385      }
00386 
00387    return(TRUE);
00388   }
00389 
00390 /************************************/
00391 /* OrFunction: H/L access routine   */
00392 /*   for the or function.           */
00393 /************************************/
00394 globle intBool OrFunction(
00395   void *theEnv)
00396   {
00397    EXPRESSION *theArgument;
00398    DATA_OBJECT result;
00399 
00400    for (theArgument = GetFirstArgument();
00401         theArgument != NULL;
00402         theArgument = GetNextArgument(theArgument))
00403      {
00404       if (EvaluateExpression(theEnv,theArgument,&result)) return(FALSE);
00405 
00406       if ((result.value != EnvFalseSymbol(theEnv)) || (result.type != SYMBOL))
00407         { return(TRUE); }
00408      }
00409 
00410    return(FALSE);
00411   }
00412 
00413 /*****************************************/
00414 /* LessThanOrEqualFunction: H/L access   */
00415 /*   routine for the <= function.        */
00416 /*****************************************/
00417 globle intBool LessThanOrEqualFunction(
00418   void *theEnv)
00419   {
00420    EXPRESSION *theArgument;
00421    DATA_OBJECT rv1, rv2;
00422    int pos = 1;
00423 
00424    /*=========================*/
00425    /* Get the first argument. */
00426    /*=========================*/
00427 
00428    theArgument = GetFirstArgument();
00429    if (theArgument == NULL) { return(TRUE); }
00430    if (! GetNumericArgument(theEnv,theArgument,"<=",&rv1,FALSE,pos)) return(FALSE);
00431    pos++;
00432 
00433    /*====================================================*/
00434    /* Compare each of the subsequent arguments to its    */
00435    /* predecessor. If any is greater, then return FALSE. */
00436    /*====================================================*/
00437 
00438    for (theArgument = GetNextArgument(theArgument);
00439         theArgument != NULL;
00440         theArgument = GetNextArgument(theArgument), pos++)
00441      {
00442       if (! GetNumericArgument(theEnv,theArgument,"<=",&rv2,FALSE,pos)) return(FALSE);
00443       if (rv1.type == INTEGER)
00444         {
00445          if (rv2.type == INTEGER)
00446            {
00447             if (ValueToLong(rv1.value) > ValueToLong(rv2.value))
00448               { return(FALSE); }
00449            }
00450          else
00451            {
00452             if ((double) ValueToLong(rv1.value) > ValueToDouble(rv2.value))
00453               { return(FALSE); }
00454            }
00455         }
00456       else
00457         {
00458          if (rv2.type == INTEGER)
00459            {
00460             if (ValueToDouble(rv1.value) > (double) ValueToLong(rv2.value))
00461               { return(FALSE); }
00462            }
00463          else
00464            {
00465             if (ValueToDouble(rv1.value) > ValueToDouble(rv2.value))
00466               { return(FALSE); }
00467            }
00468         }
00469 
00470       rv1.type = rv2.type;
00471       rv1.value = rv2.value;
00472      }
00473 
00474    /*======================================*/
00475    /* Each argument was less than or equal */
00476    /* to it predecessor. Return TRUE.      */
00477    /*======================================*/
00478 
00479    return(TRUE);
00480   }
00481 
00482 /********************************************/
00483 /* GreaterThanOrEqualFunction: H/L access   */
00484 /*   routine for the >= function.           */
00485 /********************************************/
00486 globle intBool GreaterThanOrEqualFunction(
00487   void *theEnv)
00488   {
00489    EXPRESSION *theArgument;
00490    DATA_OBJECT rv1, rv2;
00491    int pos = 1;
00492 
00493    /*=========================*/
00494    /* Get the first argument. */
00495    /*=========================*/
00496 
00497    theArgument = GetFirstArgument();
00498    if (theArgument == NULL) { return(TRUE); }
00499    if (! GetNumericArgument(theEnv,theArgument,">=",&rv1,FALSE,pos)) return(FALSE);
00500    pos++;
00501 
00502    /*===================================================*/
00503    /* Compare each of the subsequent arguments to its   */
00504    /* predecessor. If any is lesser, then return FALSE. */
00505    /*===================================================*/
00506 
00507    for (theArgument = GetNextArgument(theArgument);
00508         theArgument != NULL;
00509         theArgument = GetNextArgument(theArgument), pos++)
00510      {
00511       if (! GetNumericArgument(theEnv,theArgument,">=",&rv2,FALSE,pos)) return(FALSE);
00512       if (rv1.type == INTEGER)
00513         {
00514          if (rv2.type == INTEGER)
00515            {
00516             if (ValueToLong(rv1.value) < ValueToLong(rv2.value))
00517               { return(FALSE); }
00518            }
00519          else
00520            {
00521             if ((double) ValueToLong(rv1.value) < ValueToDouble(rv2.value))
00522               { return(FALSE); }
00523            }
00524         }
00525       else
00526         {
00527          if (rv2.type == INTEGER)
00528            {
00529             if (ValueToDouble(rv1.value) < (double) ValueToLong(rv2.value))
00530               { return(FALSE); }
00531            }
00532          else
00533            {
00534             if (ValueToDouble(rv1.value) < ValueToDouble(rv2.value))
00535               { return(FALSE); }
00536            }
00537         }
00538 
00539       rv1.type = rv2.type;
00540       rv1.value = rv2.value;
00541      }
00542 
00543    /*=========================================*/
00544    /* Each argument was greater than or equal */
00545    /* to its predecessor. Return TRUE.        */
00546    /*=========================================*/
00547 
00548    return(TRUE);
00549   }
00550 
00551 /**********************************/
00552 /* LessThanFunction: H/L access   */
00553 /*   routine for the < function.  */
00554 /**********************************/
00555 globle intBool LessThanFunction(
00556   void *theEnv)
00557   {
00558    EXPRESSION *theArgument;
00559    DATA_OBJECT rv1, rv2;
00560    int pos = 1;
00561 
00562    /*=========================*/
00563    /* Get the first argument. */
00564    /*=========================*/
00565 
00566    theArgument = GetFirstArgument();
00567    if (theArgument == NULL) { return(TRUE); }
00568    if (! GetNumericArgument(theEnv,theArgument,"<",&rv1,FALSE,pos)) return(FALSE);
00569    pos++;
00570 
00571    /*==========================================*/
00572    /* Compare each of the subsequent arguments */
00573    /* to its predecessor. If any is greater or */
00574    /* equal, then return FALSE.                */
00575    /*==========================================*/
00576 
00577    for (theArgument = GetNextArgument(theArgument);
00578         theArgument != NULL;
00579         theArgument = GetNextArgument(theArgument), pos++)
00580      {
00581       if (! GetNumericArgument(theEnv,theArgument,"<",&rv2,FALSE,pos)) return(FALSE);
00582       if (rv1.type == INTEGER)
00583         {
00584          if (rv2.type == INTEGER)
00585            {
00586             if (ValueToLong(rv1.value) >= ValueToLong(rv2.value))
00587               { return(FALSE); }
00588            }
00589          else
00590            {
00591             if ((double) ValueToLong(rv1.value) >= ValueToDouble(rv2.value))
00592               { return(FALSE); }
00593            }
00594         }
00595       else
00596         {
00597          if (rv2.type == INTEGER)
00598            {
00599             if (ValueToDouble(rv1.value) >= (double) ValueToLong(rv2.value))
00600               { return(FALSE); }
00601            }
00602          else
00603            {
00604             if (ValueToDouble(rv1.value) >= ValueToDouble(rv2.value))
00605               { return(FALSE); }
00606            }
00607         }
00608 
00609       rv1.type = rv2.type;
00610       rv1.value = rv2.value;
00611      }
00612 
00613    /*=================================*/
00614    /* Each argument was less than its */
00615    /* predecessor. Return TRUE.       */
00616    /*=================================*/
00617 
00618    return(TRUE);
00619   }
00620 
00621 /*************************************/
00622 /* GreaterThanFunction: H/L access   */
00623 /*   routine for the > function.     */
00624 /*************************************/
00625 globle intBool GreaterThanFunction(
00626   void *theEnv)
00627   {
00628    EXPRESSION *theArgument;
00629    DATA_OBJECT rv1, rv2;
00630    int pos = 1;
00631 
00632    /*=========================*/
00633    /* Get the first argument. */
00634    /*=========================*/
00635 
00636    theArgument = GetFirstArgument();
00637    if (theArgument == NULL) { return(TRUE); }
00638    if (! GetNumericArgument(theEnv,theArgument,">",&rv1,FALSE,pos)) return(FALSE);
00639    pos++;
00640 
00641    /*==========================================*/
00642    /* Compare each of the subsequent arguments */
00643    /* to its predecessor. If any is lesser or  */
00644    /* equal, then return FALSE.                */
00645    /*==========================================*/
00646 
00647    for (theArgument = GetNextArgument(theArgument);
00648         theArgument != NULL;
00649         theArgument = GetNextArgument(theArgument), pos++)
00650      {
00651       if (! GetNumericArgument(theEnv,theArgument,">",&rv2,FALSE,pos)) return(FALSE);
00652       if (rv1.type == INTEGER)
00653         {
00654          if (rv2.type == INTEGER)
00655            {
00656             if (ValueToLong(rv1.value) <= ValueToLong(rv2.value))
00657               { return(FALSE); }
00658            }
00659          else
00660            {
00661             if ((double) ValueToLong(rv1.value) <= ValueToDouble(rv2.value))
00662               { return(FALSE); }
00663            }
00664         }
00665       else
00666         {
00667          if (rv2.type == INTEGER)
00668            {
00669             if (ValueToDouble(rv1.value) <= (double) ValueToLong(rv2.value))
00670               { return(FALSE); }
00671            }
00672          else
00673            {
00674             if (ValueToDouble(rv1.value) <= ValueToDouble(rv2.value))
00675               { return(FALSE); }
00676            }
00677         }
00678 
00679       rv1.type = rv2.type;
00680       rv1.value = rv2.value;
00681      }
00682 
00683    /*================================*/
00684    /* Each argument was greater than */
00685    /* its predecessor. Return TRUE.  */
00686    /*================================*/
00687 
00688    return(TRUE);
00689   }
00690 
00691 /**************************************/
00692 /* NumericEqualFunction: H/L access   */
00693 /*   routine for the = function.      */
00694 /**************************************/
00695 globle intBool NumericEqualFunction(
00696   void *theEnv)
00697   {
00698    EXPRESSION *theArgument;
00699    DATA_OBJECT rv1, rv2;
00700    int pos = 1;
00701 
00702    /*=========================*/
00703    /* Get the first argument. */
00704    /*=========================*/
00705 
00706    theArgument = GetFirstArgument();
00707 
00708    if (theArgument == NULL) { return(TRUE); }
00709    if (! GetNumericArgument(theEnv,theArgument,"=",&rv1,FALSE,pos)) return(FALSE);
00710    pos++;
00711 
00712    /*=================================================*/
00713    /* Compare each of the subsequent arguments to the */
00714    /* first. If any is unequal, then return FALSE.    */
00715    /*=================================================*/
00716 
00717    for (theArgument = GetNextArgument(theArgument);
00718         theArgument != NULL;
00719         theArgument = GetNextArgument(theArgument), pos++)
00720      {
00721       if (! GetNumericArgument(theEnv,theArgument,"=",&rv2,FALSE,pos)) return(FALSE);
00722       if (rv1.type == INTEGER)
00723         {
00724          if (rv2.type == INTEGER)
00725            {
00726             if (ValueToLong(rv1.value) != ValueToLong(rv2.value))
00727               { return(FALSE); }
00728            }
00729          else
00730            {
00731             if ((double) ValueToLong(rv1.value) != ValueToDouble(rv2.value))
00732               { return(FALSE); }
00733            }
00734         }
00735       else
00736         {
00737          if (rv2.type == INTEGER)
00738            {
00739             if (ValueToDouble(rv1.value) != (double) ValueToLong(rv2.value))
00740               { return(FALSE); }
00741            }
00742          else
00743            {
00744             if (ValueToDouble(rv1.value) != ValueToDouble(rv2.value))
00745               { return(FALSE); }
00746            }
00747         }
00748      }
00749 
00750    /*=================================*/
00751    /* All arguments were equal to the */
00752    /* first argument. Return TRUE.    */
00753    /*=================================*/
00754 
00755    return(TRUE);
00756   }
00757 
00758 /*****************************************/
00759 /* NumericNotEqualFunction: H/L access   */
00760 /*   routine for the <> function.        */
00761 /*****************************************/
00762 globle intBool NumericNotEqualFunction(
00763   void *theEnv)
00764   {
00765    EXPRESSION *theArgument;
00766    DATA_OBJECT rv1, rv2;
00767    int pos = 1;
00768 
00769    /*=========================*/
00770    /* Get the first argument. */
00771    /*=========================*/
00772 
00773    theArgument = GetFirstArgument();
00774    if (theArgument == NULL) { return(TRUE); }
00775    if (! GetNumericArgument(theEnv,theArgument,"<>",&rv1,FALSE,pos)) return(FALSE);
00776    pos++;
00777 
00778    /*=================================================*/
00779    /* Compare each of the subsequent arguments to the */
00780    /* first. If any is equal, then return FALSE.      */
00781    /*=================================================*/
00782 
00783    for (theArgument = GetNextArgument(theArgument);
00784         theArgument != NULL;
00785         theArgument = GetNextArgument(theArgument), pos++)
00786      {
00787       if (! GetNumericArgument(theEnv,theArgument,"<>",&rv2,FALSE,pos)) return(FALSE);
00788       if (rv1.type == INTEGER)
00789         {
00790          if (rv2.type == INTEGER)
00791            {
00792             if (ValueToLong(rv1.value) == ValueToLong(rv2.value))
00793               { return(FALSE); }
00794            }
00795          else
00796            {
00797             if ((double) ValueToLong(rv1.value) == ValueToDouble(rv2.value))
00798               { return(FALSE); }
00799            }
00800         }
00801       else
00802         {
00803          if (rv2.type == INTEGER)
00804            {
00805             if (ValueToDouble(rv1.value) == (double) ValueToLong(rv2.value))
00806               { return(FALSE); }
00807            }
00808          else
00809            {
00810             if (ValueToDouble(rv1.value) == ValueToDouble(rv2.value))
00811               { return(FALSE); }
00812            }
00813         }
00814      }
00815 
00816    /*===================================*/
00817    /* All arguments were unequal to the */
00818    /* first argument. Return TRUE.      */
00819    /*===================================*/
00820 
00821    return(TRUE);
00822   }
00823 
00824 /**************************************/
00825 /* OddpFunction: H/L access routine   */
00826 /*   for the oddp function.           */
00827 /**************************************/
00828 globle intBool OddpFunction(
00829   void *theEnv)
00830   {
00831    DATA_OBJECT item;
00832    long long num, halfnum;
00833 
00834    if (EnvArgCountCheck(theEnv,"oddp",EXACTLY,1) == -1) return(FALSE);
00835    if (EnvArgTypeCheck(theEnv,"oddp",1,INTEGER,&item) == FALSE) return(FALSE);
00836 
00837    num = DOToLong(item);
00838 
00839    halfnum = (num / 2) * 2;
00840    if (num == halfnum) return(FALSE);
00841 
00842    return(TRUE);
00843   }
00844 
00845 /***************************************/
00846 /* EvenpFunction: H/L access routine   */
00847 /*   for the evenp function.           */
00848 /***************************************/
00849 globle intBool EvenpFunction(
00850   void *theEnv)
00851   {
00852    DATA_OBJECT item;
00853    long long num, halfnum;
00854 
00855    if (EnvArgCountCheck(theEnv,"evenp",EXACTLY,1) == -1) return(FALSE);
00856    if (EnvArgTypeCheck(theEnv,"evenp",1,INTEGER,&item) == FALSE) return(FALSE);
00857 
00858    num = DOToLong(item);
00859 
00860    halfnum = (num / 2) * 2;
00861    if (num != halfnum) return(FALSE);
00862 
00863    return(TRUE);
00864   }
00865 
00866 
00867