C:/Users/Dennis/src/lang/Life_start/Life/life-1.02/source/bi_math.c

Go to the documentation of this file.
00001 /*                                                                      tab:4
00002  *
00003  * bi_math.c - math builtins
00004  *
00005  * Copyright (c) 1992 Digital Equipment Corporation
00006  * All Rights Reserved.
00007  *
00008  * The standard digital prl copyrights exist and where compatible
00009  * the below also exists.
00010  * Permission to use, copy, modify, and distribute this
00011  * software and its documentation for any purpose and without
00012  * fee is hereby granted, provided that the above copyright
00013  * notice appear in all copies.  Copyright holder(s) make no
00014  * representation about the suitability of this software for
00015  * any purpose. It is provided "as is" without express or
00016  * implied warranty.
00017  */
00018 /*      $Id: bi_math.c,v 1.2 1994/12/08 23:07:37 duchier Exp $   */
00019 
00020 #ifndef lint
00021 static char vcid[] = "$Id: bi_math.c,v 1.2 1994/12/08 23:07:37 duchier Exp $";
00022 #endif /* lint */
00023 
00024 #include "extern.h"
00025 #include "trees.h"
00026 #include "login.h"
00027 #include "parser.h"
00028 #include "copy.h"
00029 #include "token.h"
00030 #include "print.h"
00031 #include "lefun.h"
00032 #include "memory.h"
00033 #include "modules.h"
00034 #ifndef OS2_PORT
00035 #include "built_ins.h"
00036 #else
00037 #include "built_in.h"
00038 #endif
00039 #include "error.h"
00040 
00041 
00042 /* Incorrect when long conversion causes overflow: */
00043 /* #define trunc(x) ((double)((long)(x))) */
00044 
00045 /* For machines that do not have a 'trunc(x)' function: */
00046 #ifdef NEED_TRUNC
00047 double trunc(x)
00048 double x;
00049 {
00050   return ((x>=0)?floor(x):ceil(x));
00051 }
00052 #endif
00053 
00054 
00055 
00056 /******** C_MULT
00057   Multiplication is considered as a 3-variable relation as in Prolog:
00058   
00059   arg1 * arg2 = arg3
00060   
00061   Only it may residuate or curry.
00062 */
00063 static long c_mult()
00064 {
00065   long success=TRUE;
00066   ptr_psi_term arg1,arg2,arg3,t;
00067   long num1,num2,num3;
00068   REAL val1,val2,val3;
00069   
00070   t=aim->a;
00071   deref_ptr(t);
00072   get_two_args(t->attr_list,&arg1,&arg2);
00073   arg3=aim->b;
00074   
00075   if(arg1) {
00076     deref(arg1);
00077     success=get_real_value(arg1,&val1,&num1);
00078     if(success && arg2) {
00079       deref(arg2);
00080       deref_args(t,set_1_2);
00081       success=get_real_value(arg2,&val2,&num2);
00082     }
00083   }
00084   
00085   if(success)
00086     if(arg1 && arg2) {
00087       deref(arg3);
00088       success=get_real_value(arg3,&val3,&num3);
00089       if(success)
00090         switch(num1+num2*2+num3*4) {
00091         case 0:
00092           residuate3(arg1,arg2,arg3);
00093 
00094           /* if(arg1==arg3)
00095             success=unify_real_result(arg2,(REAL)1);
00096           else
00097             if(arg2==arg3)
00098               success=unify_real_result(arg1,(REAL)1);
00099             else
00100               residuate2(arg1,arg3);
00101           */
00102           break;
00103         case 1:
00104           if (val1==1.0)
00105             push_goal(unify,arg2,arg3,NULL);
00106           else if (val1==0.0)
00107             success=unify_real_result(arg3,(REAL)0);
00108           else if (val1!=1.0 && arg2==arg3) /* 9.9 */
00109             success=unify_real_result(arg3,(REAL)0);
00110           else
00111             residuate2(arg2,arg3);
00112           break;
00113         case 2:
00114           if (val2==1.0)
00115             push_goal(unify,arg1,arg3,NULL);
00116           else if (val2==0.0)
00117             success=unify_real_result(arg3,(REAL)0);
00118           else if (val2!=1.0 && arg1==arg3) /* 9.9 */
00119             success=unify_real_result(arg3,(REAL)0);
00120           else
00121             residuate2(arg1,arg3);
00122           break;
00123         case 3:
00124           success=unify_real_result(arg3,val1*val2);
00125           break;
00126         case 4:
00127           if (arg1==arg2) {
00128             if (val3==0.0) /* 8.9 */
00129               success=unify_real_result(arg1,(REAL)0);
00130             else if (val3>0.0)
00131               residuate(arg1);
00132             else
00133               success=FALSE;
00134           }
00135           else {
00136             /* Case A*B=0 is not dealt with because it is nondeterministic */
00137             residuate2(arg1,arg2);
00138           }
00139           break;
00140         case 5:
00141           if(val1)
00142             success=unify_real_result(arg2,val3/val1);
00143           else
00144             success=(val3==0);
00145           break;
00146         case 6:
00147           if(val2)
00148             success=unify_real_result(arg1,val3/val2);
00149           else
00150             success=(val3==0);
00151           break;
00152         case 7:
00153           success=(val3==val1*val2);
00154           break;
00155         }
00156       
00157     }
00158     else
00159       curry();
00160   
00161   nonnum_warning(t,arg1,arg2);
00162   return success;
00163 }
00164 
00165 
00166 
00167 /******** C_DIV
00168   Similar to multiply.
00169 */
00170 static long c_div()
00171 {
00172   long success=TRUE;
00173   ptr_psi_term arg1,arg2,arg3,t;
00174   long num1,num2,num3;
00175   REAL val1,val2,val3;
00176   
00177   t=aim->a;
00178   deref_ptr(t);
00179   get_two_args(t->attr_list,&arg1,&arg2);
00180   arg3=aim->b;
00181   
00182   if (arg1) {
00183     deref(arg1);
00184     success=get_real_value(arg1,&val1,&num1);
00185     if (success && arg2) {
00186       deref(arg2);
00187       deref_args(t,set_1_2);
00188       success=get_real_value(arg2,&val2,&num2);
00189     }
00190   }
00191   
00192   if (success)
00193     if (arg1 && arg2) {
00194       deref(arg3);
00195       success=get_real_value(arg3,&val3,&num3);
00196       if (success)
00197         switch(num1+num2*2+num3*4) {
00198         case 0:
00199           residuate3(arg1,arg2,arg3);
00200           break;
00201         case 1:
00202           if (val1) {
00203             if (arg2==arg3) {
00204               if (val1>0.0)
00205                 residuate(arg2);
00206               else
00207                 success=FALSE; /* A/B=B where A<0 */
00208             }
00209             else
00210               residuate2(arg2,arg3);
00211           }
00212           else if (arg2==arg3) /* 9.9 */
00213             success=unify_real_result(arg2,(REAL)0);
00214           else
00215             residuate2(arg2,arg3);
00216           break;
00217         case 2:
00218           if (val2) {
00219             if (val2==1.0) /* 8.9 */
00220               push_goal(unify,arg1,arg3,NULL);
00221             else if (arg1==arg3) /* 9.9 */
00222               success=unify_real_result(arg1,(REAL)0);
00223             else
00224               residuate2(arg1,arg3);
00225           }
00226           else {
00227             success=FALSE;
00228             Errorline("division by zero in %P.\n",t); /* 8.9 */
00229           }
00230           break;
00231         case 3:
00232           if (val2)
00233             success=unify_real_result(arg3,val1/val2);
00234           else {
00235             success=FALSE;
00236             Errorline("division by zero in %P.\n",t); /* 8.9 */
00237           }
00238           break;
00239         case 4:
00240           if (val3) {
00241             if (val3==1.0 && arg1!=arg2) { /* 9.9 */
00242               push_goal(unify,arg1,arg2,NULL);
00243             }
00244             else if (val3!=1.0 && arg1==arg2) /* 9.9 */
00245               success=unify_real_result(arg1,(REAL)0);
00246             else
00247               residuate2(arg1,arg2);
00248           }
00249           else
00250             success=unify_real_result(arg1,(REAL)0);
00251           break;
00252         case 5:
00253           if (val3)
00254             success=unify_real_result(arg2,val1/val3);
00255           else
00256             success=(val1==0);
00257           break;
00258         case 6:
00259           if (val2)
00260             success=unify_real_result(arg1,val3*val2);
00261           else {
00262             if (val3) {
00263               success=FALSE;
00264               Errorline("division by zero in %P.\n",t); /* 8.9 */
00265             }
00266             else
00267               success=unify_real_result(arg1,(REAL)0);
00268           }
00269           break;
00270         case 7:
00271           if (val2)
00272             success=(val3==val1/val2);
00273           else {
00274             success=FALSE;
00275             Errorline("division by zero in %P.\n",t); /* 8.9 */
00276           }
00277           break;
00278         }
00279       
00280     }
00281     else
00282       curry();
00283   
00284   nonnum_warning(t,arg1,arg2);
00285   return success;
00286 }
00287 
00288 
00289 
00290 
00291 /******** C_INTDIV
00292   Similar to division, but arguments and result must be integers.
00293   Does all deterministic local inversions that can be determined in
00294   constant-time independent of argument values.
00295 */
00296 static long c_intdiv()
00297 {
00298   long success=TRUE;
00299   ptr_psi_term arg1,arg2,arg3,t;
00300   long num1,num2,num3;
00301   REAL val1,val2,val3;
00302   
00303   t=aim->a;
00304   deref_ptr(t);
00305   get_two_args(t->attr_list,&arg1,&arg2);
00306   arg3=aim->b;
00307   
00308   if (arg1) {
00309     deref(arg1);
00310     success=get_real_value(arg1,&val1,&num1);
00311     if (success && arg2) {
00312       deref(arg2);
00313       deref_args(t,set_1_2);
00314       success=get_real_value(arg2,&val2,&num2);
00315     }
00316   }
00317   
00318   if (success)
00319     if (arg1 && arg2) {
00320       deref(arg3);
00321       success=get_real_value(arg3,&val3,&num3);
00322       if (success)
00323         switch(num1+num2*2+num3*4) {
00324         case 0:
00325           residuate3(arg1,arg2,arg3);
00326           break;
00327         case 1:
00328           if (val1) {
00329             if (int_div_warning(arg1,val1)) return FALSE;
00330             if (arg2==arg3) {
00331               if (val1>0.0)
00332                 residuate(arg2);
00333               else
00334                 success=FALSE; /* A/B=B where A<0 */
00335             }
00336             else
00337               residuate2(arg2,arg3);
00338           }
00339           else if (arg2==arg3) /* 9.9 */
00340             success=unify_real_result(arg2,(REAL)0);
00341           else
00342             residuate2(arg2,arg3);
00343           break;
00344         case 2:
00345           if (val2) {
00346             if (int_div_warning(arg2,val2)) return FALSE;
00347             if (val2==1.0) /* 8.9 */
00348               push_goal(unify,arg1,arg3,NULL);
00349             else if (arg1==arg3) /* 9.9 */
00350               success=unify_real_result(arg1,(REAL)0);
00351             else
00352               residuate2(arg1,arg3);
00353           }
00354           else {
00355             success=FALSE;
00356             Errorline("division by zero in %P.\n",t); /* 8.9 */
00357           }
00358           break;
00359         case 3:
00360           if (int_div_warning(arg1,val1)) return FALSE;
00361           if (int_div_warning(arg2,val2)) return FALSE;
00362           if (val2)
00363             success=unify_real_result(arg3,trunc(val1/val2));
00364           else {
00365             success=FALSE;
00366             Errorline("division by zero in %P.\n",t); /* 8.9 */
00367           }
00368           break;
00369         case 4:
00370           if (val3) {
00371             /* if (int_div_warning(arg3,val3)) return FALSE; */
00372             if (val3!=floor(val3)) return FALSE;
00373             if (val3==1.0 && arg1!=arg2) { /* 9.9 */
00374               push_goal(unify,arg1,arg2,NULL);
00375             }
00376             else if (val3!=1.0 && arg1==arg2) /* 9.9 */
00377               success=unify_real_result(arg1,(REAL)0);
00378             else
00379               residuate2(arg1,arg2);
00380           }
00381           else
00382             success=unify_real_result(arg1,(REAL)0);
00383           break;
00384         case 5:
00385           if (int_div_warning(arg1,val1)) return FALSE;
00386           if (val3) {
00387             /* if (int_div_warning(arg3,val3)) return FALSE; */
00388             if (val3!=floor(val3)) return FALSE;
00389             if (arg1==arg3) {
00390               success=unify_real_result(arg2,(REAL)1);
00391             }
00392             else if (val1==0) {
00393               success=unify_real_result(arg2,(REAL)0);
00394             }
00395             else {
00396               double tmp;
00397               tmp=trunc(val1/val3); /* Possible solution */
00398               if (tmp==0)
00399                 success=FALSE;
00400               else if (val3==trunc(val1/tmp)) { /* It is a solution */
00401                 /* Check uniqueness */
00402                 if ((tmp>  1 && val3==trunc(val1/(tmp-1))) ||
00403                     (tmp< -1 && val3==trunc(val1/(tmp+1))))
00404                   /* Solution is not unique */
00405                   residuate(arg2);
00406                 else /* Solution is unique */
00407                   success=unify_real_result(arg2,tmp);
00408               }
00409               else
00410                 success=FALSE;
00411             }
00412           }
00413           else
00414             success=(val1==0);
00415           break;
00416         case 6:
00417           if (int_div_warning(arg2,val2)) return FALSE;
00418           /* if (int_div_warning(arg3,val3)) return FALSE; */
00419           if (val3!=floor(val3)) return FALSE;
00420           if (val2) {
00421             if (val3) 
00422               residuate(arg1);
00423             else
00424               success=unify_real_result(arg1,(REAL)0);
00425           }
00426           else {
00427             if (val3) {
00428               success=FALSE;
00429               Errorline("division by zero in %P.\n",t); /* 8.9 */
00430             }
00431             else
00432               success=unify_real_result(arg1,(REAL)0);
00433           }
00434           break;
00435         case 7:
00436           if (int_div_warning(arg1,val1)) return FALSE;
00437           if (int_div_warning(arg2,val2)) return FALSE;
00438           /* if (int_div_warning(arg3,val3)) return FALSE; */
00439           if (val2)
00440             success=(val3==trunc(val1/val2));
00441           else {
00442             success=FALSE;
00443             Errorline("division by zero in %P.\n",t); /* 8.9 */
00444           }
00445           break;
00446         }
00447       
00448     }
00449     else
00450       curry();
00451   
00452   nonnum_warning(t,arg1,arg2);
00453   return success;
00454 }
00455 
00456 
00457 
00458 /* Main routine for floor & ceiling functions */
00459 static long c_floor_ceiling(floorflag)
00460 long floorflag;
00461 {
00462   long success=TRUE;
00463   ptr_psi_term arg1,arg2,arg3,t;
00464   long num1,num3;
00465   REAL val1,val3;
00466   
00467   t=aim->a;
00468   deref_ptr(t);
00469   get_two_args(t->attr_list,&arg1,&arg2);
00470   arg3=aim->b;
00471   
00472   if(arg1) {
00473     deref(arg1);
00474     deref_args(t,set_1);
00475     success=get_real_value(arg1,&val1,&num1);
00476     if(success) {
00477       deref(arg3);
00478       success=get_real_value(arg3,&val3,&num3);
00479       if(success)
00480         switch(num1+num3*4) {
00481         case 0:
00482           residuate(arg1);
00483           break;
00484         case 1:
00485           success=unify_real_result(arg3,(floorflag?floor(val1):ceil(val1)));
00486           break;
00487         case 4:
00488           residuate(arg1); 
00489           break;
00490         case 5:
00491           success=(val3==(floorflag?floor(val1):ceil(val1)));
00492         }
00493     }
00494   }
00495   else
00496     curry();
00497 
00498   nonnum_warning(t,arg1,NULL);
00499   return success;
00500 }
00501 
00502 
00503 
00504 /******** C_FLOOR
00505   Return the largest integer inferior or equal to the argument
00506 */
00507 static long c_floor()
00508 {
00509   return c_floor_ceiling(TRUE);
00510 }
00511 
00512 
00513 
00514 
00515 /******** C_CEILING
00516   Return the smallest integer larger or equal to the argument
00517 */
00518 static long c_ceiling()
00519 {
00520   return c_floor_ceiling(FALSE);
00521 }
00522 
00523 
00524 
00525 /******** C_SQRT
00526   Return the square root of the argument
00527 */
00528 static long c_sqrt()
00529 {
00530   long success=TRUE;
00531   ptr_psi_term arg1,arg3,t;
00532   long num1,num3;
00533   REAL val1,val3;
00534   
00535   t=aim->a;
00536   deref_ptr(t);
00537   get_one_arg(t->attr_list,&arg1);
00538   arg3=aim->b;
00539   
00540   if (arg1) {
00541     deref(arg1);
00542     deref_args(t,set_1);
00543     success=get_real_value(arg1,&val1,&num1);
00544     if (success) {
00545       deref(arg3);
00546       success=get_real_value(arg3,&val3,&num3);
00547       if (success)
00548         switch(num1+num3*4) {
00549         case 0:
00550           residuate2(arg1,arg3);
00551           break;
00552         case 1:
00553           if (val1>=0)
00554             success=unify_real_result(arg3,sqrt(val1));
00555           else {
00556             success=FALSE;
00557             Errorline("square root of negative number in %P.\n",t);
00558           }
00559           break;
00560         case 4:
00561           success=unify_real_result(arg1,val3*val3);
00562           break;
00563         case 5:
00564           success=(val3*val3==val1 || (val1>=0 && val3==sqrt(val1)));
00565           if (val1<0) Errorline("square root of negative number in %P.\n",t);
00566         }
00567     }
00568   }
00569   else
00570     curry();
00571 
00572   nonnum_warning(t,arg1,NULL);
00573   return success;
00574 }
00575 
00576 
00577 #define SINFLAG 1
00578 #define COSFLAG 2
00579 #define TANFLAG 3
00580 
00581 
00582 /* Main routine for sine and cosine */
00583 static long c_trig(trigflag)
00584 long trigflag;
00585 {
00586   long success=TRUE;
00587   ptr_psi_term arg1,arg3,t; /* arg3 is result */
00588   long num1,num3;
00589   REAL val1,val3,ans;
00590 
00591   t=aim->a;
00592   deref_ptr(t);
00593   get_one_arg(t->attr_list,&arg1);
00594   arg3=aim->b;
00595 
00596   if (arg1) {
00597     deref(arg1);
00598     deref_args(t,set_1);
00599     success=get_real_value(arg1,&val1,&num1);
00600     if (success) {
00601       deref(arg3);
00602       success=get_real_value(arg3,&val3,&num3);
00603       if (success)
00604         switch(num1+num3*4) {
00605         case 0:
00606           residuate2(arg1,arg3);
00607           break;
00608         case 1:
00609           ans=(trigflag==SINFLAG?sin(val1):
00610               (trigflag==COSFLAG?cos(val1):
00611               (trigflag==TANFLAG?tan(val1):0.0)));
00612           success=unify_real_result(arg3,ans);
00613           break;
00614         case 4:
00615           if (trigflag==TANFLAG || (val3>= -1 && val3<=1)) {
00616             ans=(trigflag==SINFLAG?asin(val3):
00617                 (trigflag==COSFLAG?acos(val3):
00618                 (trigflag==TANFLAG?atan(val3):0.0)));
00619             success=unify_real_result(arg1,ans);
00620           }
00621           else
00622             success=FALSE;
00623           break;
00624         case 5:
00625           ans=(trigflag==SINFLAG?asin(val1):
00626               (trigflag==COSFLAG?acos(val1):
00627               (trigflag==TANFLAG?atan(val1):0.0)));
00628           success=(val3==ans);
00629         }
00630     }
00631   }
00632   else
00633     curry();
00634 
00635   nonnum_warning(t,arg1,NULL);
00636   return success;
00637 }
00638 
00639 
00640 /******** C_COSINE
00641   Return the cosine of the argument (in radians).
00642 */
00643 static long c_cos()
00644 {
00645   return (c_trig(COSFLAG));
00646 }
00647 
00648 
00649 
00650 
00651 /******** C_SINE
00652   Return the sine of the argument
00653 */
00654 static long c_sin()
00655 {
00656   return (c_trig(SINFLAG));
00657 }
00658 
00659 
00660 
00661 /******** C_TAN
00662   Return the tangent of the argument
00663 */
00664 static long c_tan()
00665 {
00666   return (c_trig(TANFLAG));
00667 }
00668 
00669 
00670 
00671 static long c_bit_not()
00672 {
00673   long success=TRUE;
00674   ptr_psi_term arg1,arg3,t; /* arg3 is result */
00675   long num1,num3;
00676   REAL val1,val3;
00677 
00678   t=aim->a;
00679   deref_ptr(t);
00680   get_one_arg(t->attr_list,&arg1);
00681   arg3=aim->b;
00682 
00683   if (arg1) {
00684     deref(arg1);
00685     deref_args(t,set_1);
00686     success=get_real_value(arg1,&val1,&num1);
00687     if (success) {
00688       deref(arg3);
00689       success=get_real_value(arg3,&val3,&num3);
00690       if (success)
00691         switch(num1+num3*4) {
00692         case 0:
00693           if (arg1==arg3) return FALSE;
00694           residuate2(arg1,arg3);
00695           break;
00696         case 1:
00697           if (bit_not_warning(arg1,val1)) return FALSE;
00698           success=unify_real_result(arg3,(REAL)~(long)val1);
00699           break;
00700         case 4:
00701           if (bit_not_warning(arg3,val3)) return FALSE;
00702           success=unify_real_result(arg1,(REAL)~(long)val3);
00703           break;
00704         case 5:
00705           if (bit_not_warning(arg1,val1)) return FALSE;
00706           if (bit_not_warning(arg3,val3)) return FALSE;
00707           success=(val3==val1);
00708           break;
00709         }
00710     }
00711   }
00712   else
00713     curry();
00714 
00715   nonnum_warning(t,arg1,NULL);
00716   return success;
00717 }
00718 
00719 
00720 
00721 
00722 /******** C_BIT_AND
00723   Return the bitwise operation: ARG1 and ARG2.
00724 */
00725 static long c_bit_and()
00726 {
00727   long success=TRUE;
00728   ptr_psi_term arg1,arg2,arg3,t;
00729   long num1,num2,num3;
00730   REAL val1,val2,val3;
00731   
00732   t=aim->a;
00733   deref_ptr(t);
00734   get_two_args(t->attr_list,&arg1,&arg2);
00735   arg3=aim->b;
00736   
00737   if(arg1) {
00738     deref(arg1);
00739     success=get_real_value(arg1,&val1,&num1);
00740     if(success && arg2) {
00741       deref(arg2);
00742       deref_args(t,set_1_2);
00743       success=get_real_value(arg2,&val2,&num2);
00744     }
00745   }
00746   
00747   if(success)
00748     if(arg1 && arg2) {
00749       deref(arg3);
00750       success=get_real_value(arg3,&val3,&num3);
00751       if(success)
00752         switch(num1+num2*2+num3*4) {
00753         case 0:
00754           residuate2(arg1,arg2);
00755           break;
00756         case 1:
00757           if (bit_and_warning(arg1,val1)) return FALSE;
00758           if(val1)
00759             residuate(arg2);
00760           else
00761             success=unify_real_result(arg3,(REAL)0);
00762           break;
00763         case 2:
00764           if (bit_and_warning(arg2,val2)) return FALSE;
00765           if(val2)
00766             residuate(arg1);
00767           else
00768             success=unify_real_result(arg3,(REAL)0);
00769           break;
00770         case 3:
00771           if (bit_and_warning(arg1,val1)||bit_and_warning(arg2,val2))
00772             return FALSE;
00773           success=unify_real_result(arg3,(REAL)(((unsigned long)val1) & ((unsigned long)val2)));
00774           break;
00775         case 4:
00776           residuate2(arg1,arg2);
00777           break;
00778         case 5:
00779           if (bit_and_warning(arg1,val1)) return FALSE;
00780           residuate(arg2);
00781           break;
00782         case 6:
00783           if (bit_and_warning(arg2,val2)) return FALSE;
00784           residuate(arg1);
00785           break;
00786         case 7:
00787           if (bit_and_warning(arg1,val1)||bit_and_warning(arg2,val2))
00788             return FALSE;
00789           success=(val3==(REAL)(((unsigned long)val1) & ((unsigned long)val2)));
00790           break;
00791         }
00792       
00793     }
00794     else
00795       curry();
00796   
00797   nonnum_warning(t,arg1,arg2);
00798   return success;
00799 }
00800 
00801 
00802 
00803 /******** C_BIT_OR
00804   Return the bitwise operation: ARG1 or ARG2.
00805 */
00806 static long c_bit_or()
00807 {
00808   long success=TRUE;
00809   ptr_psi_term arg1,arg2,arg3,t;
00810   long num1,num2,num3;
00811   REAL val1,val2,val3;
00812   
00813   t=aim->a;
00814   deref_ptr(t);
00815   get_two_args(t->attr_list,&arg1,&arg2);
00816   arg3=aim->b;
00817   
00818   if(arg1) {
00819     deref(arg1);
00820     success=get_real_value(arg1,&val1,&num1);
00821     if(success && arg2) {
00822       deref(arg2);
00823       deref_args(t,set_1_2);
00824       success=get_real_value(arg2,&val2,&num2);
00825     }
00826   }
00827   
00828   if(success)
00829     if(arg1 && arg2) {
00830       deref(arg3);
00831       success=get_real_value(arg3,&val3,&num3);
00832       if(success)
00833         switch(num1+num2*2+num3*4) {
00834         case 0:
00835         case 4:
00836           residuate2(arg1,arg2);
00837           break;
00838         case 1:
00839         case 5:
00840           if (bit_or_warning(arg1,val1)) return FALSE;
00841           residuate(arg2);
00842           break;
00843         case 2:
00844         case 6:
00845           if (bit_or_warning(arg2,val2)) return FALSE;
00846           residuate(arg1);
00847           break;
00848         case 3:
00849           if (bit_or_warning(arg1,val1)||bit_or_warning(arg2,val2))
00850             return FALSE;
00851           success=unify_real_result(arg3,(REAL)(((unsigned long)val1) | ((unsigned long)val2)));
00852           break;
00853         case 7:
00854           if (bit_or_warning(arg1,val1)||bit_or_warning(arg2,val2))
00855             return FALSE;
00856           success=(val3==(REAL)(((unsigned long)val1) | ((unsigned long)val2)));
00857           break;
00858         }      
00859     }
00860     else
00861       curry();
00862   
00863   nonnum_warning(t,arg1,arg2);
00864   return success;
00865 }
00866 
00867 
00868 /******** C_SHIFT
00869   Return the bitwise shift left or shift right.
00870 */
00871 
00872 static long c_shift();
00873 
00874 
00875 static long c_shift_left()
00876 {
00877   return (c_shift(FALSE));
00878 }
00879 
00880 static long c_shift_right()
00881 {
00882   return (c_shift(TRUE));
00883 }
00884 
00885 static long c_shift(dir)
00886 long dir;
00887 {
00888   long success=TRUE;
00889   ptr_psi_term arg1,arg2,arg3,t;
00890   long num1,num2,num3;
00891   REAL val1,val2,val3,ans;
00892   
00893   t=aim->a;
00894   deref_ptr(t);
00895   get_two_args(t->attr_list,&arg1,&arg2);
00896   arg3=aim->b;
00897   
00898   if(arg1) {
00899     deref(arg1);
00900     success=get_real_value(arg1,&val1,&num1);
00901     if(success && arg2) {
00902       deref(arg2);
00903       deref_args(t,set_1_2);
00904       success=get_real_value(arg2,&val2,&num2);
00905     }
00906   }
00907   
00908   if(success)
00909     if(arg1 && arg2) {
00910       deref(arg3);
00911       success=get_real_value(arg3,&val3,&num3);
00912       if (success)
00913         switch(num1+num2*2+num3*4) {
00914         case 0:
00915         case 4:
00916           residuate2(arg1,arg2);
00917           break;
00918         case 1:
00919         case 5:
00920           if (shift_warning(dir,arg1,val1)) return FALSE;
00921           residuate(arg2);
00922           break;
00923         case 2:
00924         case 6:
00925           if (shift_warning(dir,arg2,val2)) return FALSE;
00926           residuate(arg1);
00927           break;
00928         case 3:
00929           if (shift_warning(dir,arg1,val1)||shift_warning(dir,arg2,val2))
00930             return FALSE;
00931           ans=(REAL)(dir?(long)val1>>(long)val2:(long)val1<<(long)val2);
00932           success=unify_real_result(arg3,ans);
00933           break;
00934         case 7:
00935           if (shift_warning(dir,arg1,val1)||shift_warning(dir,arg2,val2))
00936             return FALSE;
00937           ans=(REAL)(dir?(long)val1>>(long)val2:(long)val1<<(long)val2);
00938           success=(val3==ans);
00939           break;
00940         }      
00941     }
00942     else
00943       curry();
00944   
00945   nonnum_warning(t,arg1,arg2);
00946   return success;
00947 }
00948 
00949 
00950 /******** C_MOD
00951   The modulo operation.
00952 */
00953 static long c_mod()
00954 {
00955   long success=TRUE;
00956   ptr_psi_term arg1,arg2,arg3,t;
00957   long num1,num2,num3;
00958   REAL val1,val2,val3;
00959   
00960   t=aim->a;
00961   deref_ptr(t);
00962   get_two_args(t->attr_list,&arg1,&arg2);
00963   arg3=aim->b;
00964   
00965   if(arg1) {
00966     deref(arg1);
00967     success=get_real_value(arg1,&val1,&num1);
00968     if(success && arg2) {
00969       deref(arg2);
00970       deref_args(t,set_1_2);
00971       success=get_real_value(arg2,&val2,&num2);
00972     }
00973   }
00974   
00975   if(success)
00976     if(arg1 && arg2) {
00977       deref(arg3);
00978       success=get_real_value(arg3,&val3,&num3);
00979       if(success)
00980         switch(num1+num2*2+num3*4) {
00981         case 0:
00982         case 4:
00983           residuate2(arg1,arg2);
00984           break;
00985         case 1:
00986         case 5:
00987           if (mod_warning(arg1,val1,0)) return FALSE;
00988           residuate(arg2);
00989           break;
00990         case 2:
00991         case 6:
00992           if (mod_warning(arg2,val2,1)) return FALSE;
00993           residuate(arg1);
00994           break;
00995         case 3:
00996           if (mod_warning(arg1,val1,0)||mod_warning(arg2,val2,1))
00997             return FALSE;
00998           success=unify_real_result(arg3,(REAL)((unsigned long)val1 % (unsigned long)val2));
00999           break;
01000         case 7:
01001           if (mod_warning(arg1,val1,0)||mod_warning(arg2,val2,1))
01002             return FALSE;
01003           success=(val3==(REAL)((unsigned long)val1 % (unsigned long)val2));
01004           break;
01005         }      
01006     }
01007     else
01008       curry();
01009   
01010   nonnum_warning(t,arg1,arg2);
01011   return success;
01012 }
01013 
01014 /******** C_ADD
01015   Addition is considered as a 3-variable relation as in Prolog:
01016   
01017   arg1 + arg2 = arg3
01018   
01019   Only it may residuate or curry.
01020 
01021   Addition is further complicated by the fact that it is both a unary and
01022   binary function.
01023 */
01024 static long c_add()
01025 {
01026   long success=TRUE;
01027   ptr_psi_term arg1,arg2,arg3,t;
01028   long num1,num2,num3;
01029   REAL val1,val2,val3;
01030   
01031   t=aim->a;
01032   deref_ptr(t);
01033   get_two_args(t->attr_list,&arg1,&arg2);
01034   arg3=aim->b;
01035   
01036   if(arg1) {
01037     deref(arg1);
01038     success=get_real_value(arg1,&val1,&num1);
01039     if(success && arg2) {
01040       deref(arg2);
01041       deref_args(t,set_1_2);
01042       success=get_real_value(arg2,&val2,&num2);
01043     }
01044   }
01045   
01046   if(success)
01047     if(arg1 && arg2) {
01048       deref(arg3);
01049       success=get_real_value(arg3,&val3,&num3);
01050       if(success)
01051         switch(num1+num2*2+num3*4) {
01052         case 0:
01053           if (arg1==arg3)
01054             success=unify_real_result(arg2,(REAL)0);
01055           else if (arg2==arg3)
01056             success=unify_real_result(arg1,(REAL)0);
01057           else
01058             residuate3(arg1,arg2,arg3);
01059           break;
01060         case 1:
01061           if (val1) {
01062             if (arg2==arg3) /* 8.9 */
01063               success=FALSE;
01064             else
01065               residuate2(arg2,arg3);
01066           }
01067           else
01068             push_goal(unify,arg2,arg3,NULL);
01069           break;
01070         case 2:
01071           if (val2) {
01072             if (arg1==arg3) /* 8.9 */
01073               success=FALSE;
01074             else
01075               residuate2(arg1,arg3);
01076           }
01077           else
01078             push_goal(unify,arg1,arg3,NULL);
01079           break;
01080         case 3:
01081           success=unify_real_result(arg3,val1+val2);
01082           break;
01083         case 4:
01084           if (arg1==arg2)
01085             success=unify_real_result(arg1,val3/2);
01086           else
01087             residuate2(arg1,arg2);
01088           break;
01089         case 5:
01090           success=unify_real_result(arg2,val3-val1);
01091           break;
01092         case 6:
01093           success=unify_real_result(arg1,val3-val2);
01094           break;
01095         case 7:
01096           success=(val3==val1+val2);
01097           break;
01098         }
01099     }
01100     else
01101       curry(); 
01102 /*
01103 '+' is no longer a function of a single argument:
01104       if(arg1) {
01105         deref(arg3);
01106         success=get_real_value(arg3,&val3,&num3);
01107         if(success)
01108           switch(num1+4*num3) {
01109           case 0:
01110             residuate2(arg1,arg3);
01111             break;
01112           case 1:
01113             success=unify_real_result(arg3,val1);
01114             break;
01115           case 4:
01116             success=unify_real_result(arg1,val3);
01117             break;
01118           case 5:
01119             success=(val1==val3);
01120           }
01121       }
01122       else
01123         curry();
01124 */
01125   
01126   nonnum_warning(t,arg1,arg2);
01127   return success;
01128 }
01129 
01130 
01131 
01132 
01133 /******** C_SUB
01134   Identical (nearly) to C_ADD
01135 */
01136 static long c_sub()
01137 {
01138   long success=TRUE;
01139   ptr_psi_term arg1,arg2,arg3,t;
01140   long num1,num2,num3;
01141   REAL val1,val2,val3;
01142   
01143   t=aim->a;
01144   deref_ptr(t);
01145   get_two_args(t->attr_list,&arg1,&arg2);
01146   arg3=aim->b;
01147   
01148   if(arg1) {
01149     deref(arg1);
01150     success=get_real_value(arg1,&val1,&num1);
01151     if(success && arg2) {
01152       deref(arg2);
01153       deref_args(t,set_1_2);
01154       success=get_real_value(arg2,&val2,&num2);
01155     }
01156   }
01157   
01158   if(success)
01159     if(arg1 && arg2) {
01160       deref(arg3);
01161       success=get_real_value(arg3,&val3,&num3);
01162       if(success)
01163         switch(num1+num2*2+num3*4) {
01164         case 0:
01165           if (arg1==arg3)
01166             success=unify_real_result(arg2,(REAL)0);
01167           else if (arg1==arg2)
01168             success=unify_real_result(arg3,(REAL)0);
01169           else
01170             residuate3(arg1,arg2,arg3);
01171           break;
01172         case 1:
01173           if (arg2==arg3)
01174             success=unify_real_result(arg3,val1/2);
01175           else
01176             residuate2(arg2,arg3);
01177           break;
01178         case 2:
01179           if (val2) {
01180             if (arg1==arg3) /* 9.9 */
01181               success=FALSE;
01182             else
01183               residuate2(arg1,arg3);
01184           }
01185           else
01186             push_goal(unify,arg1,arg3,NULL);
01187           break;
01188         case 3:
01189           success=unify_real_result(arg3,val1-val2);
01190           break;
01191         case 4:
01192           if (arg1==arg2)
01193             success=(val3==0);
01194           else if (val3)
01195             residuate2(arg1,arg2);
01196           else
01197             push_goal(unify,arg1,arg2,NULL);
01198           break;
01199         case 5:
01200           success=unify_real_result(arg2,val1-val3);
01201           break;
01202         case 6:
01203           success=unify_real_result(arg1,val3+val2);
01204           break;
01205         case 7:
01206           success=(val3==val1-val2);
01207           break;
01208         }
01209     }
01210     else
01211       if(arg1) {
01212         deref(arg3);
01213         success=get_real_value(arg3,&val3,&num3);
01214         if(success)
01215           switch(num1+4*num3) {
01216           case 0:
01217             residuate2(arg1,arg3);
01218             break;
01219           case 1:
01220             success=unify_real_result(arg3,-val1);
01221             break;
01222           case 4:
01223             success=unify_real_result(arg1,-val3);
01224             break;
01225           case 5:
01226             success=(val1== -val3);
01227           }
01228       }
01229       else
01230         curry();
01231   
01232   nonnum_warning(t,arg1,arg2);
01233   return success;
01234 }
01235 
01236 /******** C_LOG
01237   Natural logarithm.
01238 */
01239 static long c_log()
01240 {
01241   long success=TRUE;
01242   ptr_psi_term arg1,arg3,t;
01243   long num1,num3;
01244   REAL val1,val3;
01245   
01246   t=aim->a;
01247   deref_ptr(t);
01248   get_one_arg(t->attr_list,&arg1);
01249   arg3=aim->b;
01250   
01251   if(arg1) {
01252     deref(arg1);
01253     deref_args(t,set_1);
01254     success=get_real_value(arg1,&val1,&num1);
01255     if(success) {
01256       deref(arg3);
01257       success=get_real_value(arg3,&val3,&num3);
01258       if(success)
01259         switch(num1+num3*4) {
01260         case 0:
01261           residuate2(arg1,arg3);
01262           break;
01263         case 1:
01264           if (val1>0)
01265             success=unify_real_result(arg3,log(val1));
01266           else {
01267             success=FALSE;
01268             Errorline("logarithm of %s in %P.\n",
01269                       (val1==0)?"zero":"a negative number",t);
01270           }
01271           break;
01272         case 4:
01273           success=unify_real_result(arg1,exp(val3));
01274           break;
01275         case 5:
01276           success=(exp(val3)==val1 || (val1>0 && val3==log(val1)));
01277           if (val1<=0)
01278             Errorline("logarithm of %s in %P.\n",
01279                       (val1==0)?"zero":"a negative number",t);
01280         }
01281     }
01282   }
01283   else
01284     curry();
01285 
01286   nonnum_warning(t,arg1,NULL);
01287   return success;
01288 }
01289 
01290 
01291 
01292 
01293 /******** C_EXP
01294   Exponential.
01295 */
01296 static long c_exp()
01297 {
01298   long success=TRUE;
01299   ptr_psi_term arg1,arg2,arg3,t;
01300   long num1,num3;
01301   REAL val1,val3;
01302   
01303   t=aim->a;
01304   deref_ptr(t);
01305   get_two_args(t->attr_list,&arg1,&arg2);
01306   arg3=aim->b;
01307   
01308   if(arg1) {
01309     deref(arg1);
01310     deref_args(t,set_1);
01311     success=get_real_value(arg1,&val1,&num1);
01312     if(success) {
01313       deref(arg3);
01314       success=get_real_value(arg3,&val3,&num3);
01315       if(success)
01316         switch(num1+num3*4) {
01317         case 0:
01318           residuate2(arg1,arg3);
01319           break;
01320         case 1:
01321           success=unify_real_result(arg3,exp(val1));
01322           break;
01323         case 4:
01324           if(val3>0)
01325             success=unify_real_result(arg1,log(val3));
01326           else
01327             success=FALSE;
01328           break;
01329         case 5:
01330           success=(exp(val1)==val3 || (val3>0 && val1==log(val3)));
01331         }
01332     }
01333   }
01334   else
01335     curry();
01336 
01337   nonnum_warning(t,arg1,NULL);
01338   return success;
01339 }
01340 
01341 void insert_math_builtins()
01342 {
01343   new_built_in(syntax_module,"*",function,c_mult);
01344   new_built_in(syntax_module,"+",function,c_add);
01345   new_built_in(syntax_module,"-",function,c_sub);
01346   new_built_in(syntax_module,"/",function,c_div);  
01347   new_built_in(syntax_module,"//",function,c_intdiv);  
01348   new_built_in(syntax_module,"mod",function,c_mod); /* PVR 24.2.94 */
01349   new_built_in(syntax_module,"/\\",function,c_bit_and);
01350   new_built_in(syntax_module,"\\/",function,c_bit_or);
01351   new_built_in(syntax_module,"\\",function,c_bit_not);
01352   new_built_in(syntax_module,">>",function,c_shift_right);
01353   new_built_in(syntax_module,"<<",function,c_shift_left);
01354   new_built_in(bi_module,"floor",function,c_floor);
01355   new_built_in(bi_module,"ceiling",function,c_ceiling);
01356   new_built_in(bi_module,"exp",function,c_exp);
01357   new_built_in(bi_module,"log",function,c_log);
01358   new_built_in(bi_module,"cos",function,c_cos);
01359   new_built_in(bi_module,"sin",function,c_sin);
01360   new_built_in(bi_module,"tan",function,c_tan);
01361   new_built_in(bi_module,"sqrt",function,c_sqrt);
01362 }
01363
Generated on Sat Jan 26 08:48:06 2008 for WildLife by  doxygen 1.5.4