home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / SOURCE / BI_MATH.C < prev    next >
C/C++ Source or Header  |  1996-06-14  |  31KB  |  1,364 lines
  1. /*                                    tab:4
  2.  *
  3.  * bi_math.c - math builtins
  4.  *
  5.  * Copyright (c) 1992 Digital Equipment Corporation
  6.  * All Rights Reserved.
  7.  *
  8.  * The standard digital prl copyrights exist and where compatible
  9.  * the below also exists.
  10.  * Permission to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose and without
  12.  * fee is hereby granted, provided that the above copyright
  13.  * notice appear in all copies.  Copyright holder(s) make no
  14.  * representation about the suitability of this software for
  15.  * any purpose. It is provided "as is" without express or
  16.  * implied warranty.
  17.  */
  18. /*     $Id: bi_math.c,v 1.2 1994/12/08 23:07:37 duchier Exp $     */
  19.  
  20. #ifndef lint
  21. static char vcid[] = "$Id: bi_math.c,v 1.2 1994/12/08 23:07:37 duchier Exp $";
  22. #endif /* lint */
  23.  
  24. #include "extern.h"
  25. #include "trees.h"
  26. #include "login.h"
  27. #include "parser.h"
  28. #include "copy.h"
  29. #include "token.h"
  30. #include "print.h"
  31. #include "lefun.h"
  32. #include "memory.h"
  33. #include "modules.h"
  34. #ifndef OS2_PORT
  35. #include "built_ins.h"
  36. #else
  37. #include "built_in.h"
  38. #endif
  39. #include "error.h"
  40.  
  41.  
  42. /* Incorrect when long conversion causes overflow: */
  43. /* #define trunc(x) ((double)((long)(x))) */
  44.  
  45. /* For machines that do not have a 'trunc(x)' function: */
  46. #ifdef NEED_TRUNC
  47. double trunc(x)
  48. double x;
  49. {
  50.   return ((x>=0)?floor(x):ceil(x));
  51. }
  52. #endif
  53.  
  54.  
  55.  
  56. /******** C_MULT
  57.   Multiplication is considered as a 3-variable relation as in Prolog:
  58.   
  59.   arg1 * arg2 = arg3
  60.   
  61.   Only it may residuate or curry.
  62. */
  63. static long c_mult()
  64. {
  65.   long success=TRUE;
  66.   ptr_psi_term arg1,arg2,arg3,t;
  67.   long num1,num2,num3;
  68.   REAL val1,val2,val3;
  69.   
  70.   t=aim->a;
  71.   deref_ptr(t);
  72.   get_two_args(t->attr_list,&arg1,&arg2);
  73.   arg3=aim->b;
  74.   
  75.   if(arg1) {
  76.     deref(arg1);
  77.     success=get_real_value(arg1,&val1,&num1);
  78.     if(success && arg2) {
  79.       deref(arg2);
  80.       deref_args(t,set_1_2);
  81.       success=get_real_value(arg2,&val2,&num2);
  82.     }
  83.   }
  84.   
  85.   if(success)
  86.     if(arg1 && arg2) {
  87.       deref(arg3);
  88.       success=get_real_value(arg3,&val3,&num3);
  89.       if(success)
  90.     switch(num1+num2*2+num3*4) {
  91.     case 0:
  92.           residuate3(arg1,arg2,arg3);
  93.  
  94.       /* if(arg1==arg3)
  95.         success=unify_real_result(arg2,(REAL)1);
  96.       else
  97.         if(arg2==arg3)
  98.           success=unify_real_result(arg1,(REAL)1);
  99.         else
  100.           residuate2(arg1,arg3);
  101.       */
  102.       break;
  103.     case 1:
  104.       if (val1==1.0)
  105.         push_goal(unify,arg2,arg3,NULL);
  106.           else if (val1==0.0)
  107.         success=unify_real_result(arg3,(REAL)0);
  108.           else if (val1!=1.0 && arg2==arg3) /* 9.9 */
  109.         success=unify_real_result(arg3,(REAL)0);
  110.       else
  111.         residuate2(arg2,arg3);
  112.       break;
  113.     case 2:
  114.       if (val2==1.0)
  115.         push_goal(unify,arg1,arg3,NULL);
  116.       else if (val2==0.0)
  117.         success=unify_real_result(arg3,(REAL)0);
  118.           else if (val2!=1.0 && arg1==arg3) /* 9.9 */
  119.         success=unify_real_result(arg3,(REAL)0);
  120.       else
  121.         residuate2(arg1,arg3);
  122.       break;
  123.     case 3:
  124.       success=unify_real_result(arg3,val1*val2);
  125.       break;
  126.     case 4:
  127.       if (arg1==arg2) {
  128.             if (val3==0.0) /* 8.9 */
  129.           success=unify_real_result(arg1,(REAL)0);
  130.             else if (val3>0.0)
  131.           residuate(arg1);
  132.         else
  133.           success=FALSE;
  134.           }
  135.       else {
  136.             /* Case A*B=0 is not dealt with because it is nondeterministic */
  137.         residuate2(arg1,arg2);
  138.           }
  139.       break;
  140.     case 5:
  141.       if(val1)
  142.         success=unify_real_result(arg2,val3/val1);
  143.       else
  144.         success=(val3==0);
  145.       break;
  146.     case 6:
  147.       if(val2)
  148.         success=unify_real_result(arg1,val3/val2);
  149.       else
  150.         success=(val3==0);
  151.       break;
  152.     case 7:
  153.       success=(val3==val1*val2);
  154.       break;
  155.     }
  156.       
  157.     }
  158.     else
  159.       curry();
  160.   
  161.   nonnum_warning(t,arg1,arg2);
  162.   return success;
  163. }
  164.  
  165.  
  166.  
  167. /******** C_DIV
  168.   Similar to multiply.
  169. */
  170. static long c_div()
  171. {
  172.   long success=TRUE;
  173.   ptr_psi_term arg1,arg2,arg3,t;
  174.   long num1,num2,num3;
  175.   REAL val1,val2,val3;
  176.   
  177.   t=aim->a;
  178.   deref_ptr(t);
  179.   get_two_args(t->attr_list,&arg1,&arg2);
  180.   arg3=aim->b;
  181.   
  182.   if (arg1) {
  183.     deref(arg1);
  184.     success=get_real_value(arg1,&val1,&num1);
  185.     if (success && arg2) {
  186.       deref(arg2);
  187.       deref_args(t,set_1_2);
  188.       success=get_real_value(arg2,&val2,&num2);
  189.     }
  190.   }
  191.   
  192.   if (success)
  193.     if (arg1 && arg2) {
  194.       deref(arg3);
  195.       success=get_real_value(arg3,&val3,&num3);
  196.       if (success)
  197.     switch(num1+num2*2+num3*4) {
  198.     case 0:
  199.       residuate3(arg1,arg2,arg3);
  200.       break;
  201.     case 1:
  202.       if (val1) {
  203.         if (arg2==arg3) {
  204.           if (val1>0.0)
  205.             residuate(arg2);
  206.           else
  207.         success=FALSE; /* A/B=B where A<0 */
  208.             }
  209.         else
  210.           residuate2(arg2,arg3);
  211.           }
  212.           else if (arg2==arg3) /* 9.9 */
  213.             success=unify_real_result(arg2,(REAL)0);
  214.           else
  215.             residuate2(arg2,arg3);
  216.       break;
  217.     case 2:
  218.       if (val2) {
  219.             if (val2==1.0) /* 8.9 */
  220.               push_goal(unify,arg1,arg3,NULL);
  221.             else if (arg1==arg3) /* 9.9 */
  222.               success=unify_real_result(arg1,(REAL)0);
  223.             else
  224.           residuate2(arg1,arg3);
  225.           }
  226.       else {
  227.         success=FALSE;
  228.             Errorline("division by zero in %P.\n",t); /* 8.9 */
  229.           }
  230.       break;
  231.     case 3:
  232.       if (val2)
  233.         success=unify_real_result(arg3,val1/val2);
  234.       else {
  235.         success=FALSE;
  236.             Errorline("division by zero in %P.\n",t); /* 8.9 */
  237.           }
  238.       break;
  239.     case 4:
  240.       if (val3) {
  241.             if (val3==1.0 && arg1!=arg2) { /* 9.9 */
  242.               push_goal(unify,arg1,arg2,NULL);
  243.             }
  244.             else if (val3!=1.0 && arg1==arg2) /* 9.9 */
  245.               success=unify_real_result(arg1,(REAL)0);
  246.             else
  247.           residuate2(arg1,arg2);
  248.           }
  249.           else
  250.             success=unify_real_result(arg1,(REAL)0);
  251.       break;
  252.     case 5:
  253.       if (val3)
  254.         success=unify_real_result(arg2,val1/val3);
  255.       else
  256.         success=(val1==0);
  257.       break;
  258.     case 6:
  259.           if (val2)
  260.         success=unify_real_result(arg1,val3*val2);
  261.           else {
  262.             if (val3) {
  263.           success=FALSE;
  264.               Errorline("division by zero in %P.\n",t); /* 8.9 */
  265.             }
  266.             else
  267.               success=unify_real_result(arg1,(REAL)0);
  268.           }
  269.       break;
  270.     case 7:
  271.       if (val2)
  272.         success=(val3==val1/val2);
  273.       else {
  274.         success=FALSE;
  275.             Errorline("division by zero in %P.\n",t); /* 8.9 */
  276.           }
  277.       break;
  278.     }
  279.       
  280.     }
  281.     else
  282.       curry();
  283.   
  284.   nonnum_warning(t,arg1,arg2);
  285.   return success;
  286. }
  287.  
  288.  
  289.  
  290.  
  291. /******** C_INTDIV
  292.   Similar to division, but arguments and result must be integers.
  293.   Does all deterministic local inversions that can be determined in
  294.   constant-time independent of argument values.
  295. */
  296. static long c_intdiv()
  297. {
  298.   long success=TRUE;
  299.   ptr_psi_term arg1,arg2,arg3,t;
  300.   long num1,num2,num3;
  301.   REAL val1,val2,val3;
  302.   
  303.   t=aim->a;
  304.   deref_ptr(t);
  305.   get_two_args(t->attr_list,&arg1,&arg2);
  306.   arg3=aim->b;
  307.   
  308.   if (arg1) {
  309.     deref(arg1);
  310.     success=get_real_value(arg1,&val1,&num1);
  311.     if (success && arg2) {
  312.       deref(arg2);
  313.       deref_args(t,set_1_2);
  314.       success=get_real_value(arg2,&val2,&num2);
  315.     }
  316.   }
  317.   
  318.   if (success)
  319.     if (arg1 && arg2) {
  320.       deref(arg3);
  321.       success=get_real_value(arg3,&val3,&num3);
  322.       if (success)
  323.     switch(num1+num2*2+num3*4) {
  324.     case 0:
  325.       residuate3(arg1,arg2,arg3);
  326.       break;
  327.     case 1:
  328.       if (val1) {
  329.         if (int_div_warning(arg1,val1)) return FALSE;
  330.         if (arg2==arg3) {
  331.           if (val1>0.0)
  332.             residuate(arg2);
  333.           else
  334.         success=FALSE; /* A/B=B where A<0 */
  335.             }
  336.         else
  337.           residuate2(arg2,arg3);
  338.           }
  339.           else if (arg2==arg3) /* 9.9 */
  340.             success=unify_real_result(arg2,(REAL)0);
  341.           else
  342.             residuate2(arg2,arg3);
  343.       break;
  344.     case 2:
  345.       if (val2) {
  346.         if (int_div_warning(arg2,val2)) return FALSE;
  347.             if (val2==1.0) /* 8.9 */
  348.               push_goal(unify,arg1,arg3,NULL);
  349.             else if (arg1==arg3) /* 9.9 */
  350.               success=unify_real_result(arg1,(REAL)0);
  351.             else
  352.           residuate2(arg1,arg3);
  353.           }
  354.       else {
  355.         success=FALSE;
  356.             Errorline("division by zero in %P.\n",t); /* 8.9 */
  357.           }
  358.       break;
  359.     case 3:
  360.       if (int_div_warning(arg1,val1)) return FALSE;
  361.       if (int_div_warning(arg2,val2)) return FALSE;
  362.       if (val2)
  363.         success=unify_real_result(arg3,trunc(val1/val2));
  364.       else {
  365.         success=FALSE;
  366.             Errorline("division by zero in %P.\n",t); /* 8.9 */
  367.           }
  368.       break;
  369.     case 4:
  370.       if (val3) {
  371.         /* if (int_div_warning(arg3,val3)) return FALSE; */
  372.         if (val3!=floor(val3)) return FALSE;
  373.             if (val3==1.0 && arg1!=arg2) { /* 9.9 */
  374.               push_goal(unify,arg1,arg2,NULL);
  375.             }
  376.             else if (val3!=1.0 && arg1==arg2) /* 9.9 */
  377.               success=unify_real_result(arg1,(REAL)0);
  378.             else
  379.           residuate2(arg1,arg2);
  380.           }
  381.           else
  382.             success=unify_real_result(arg1,(REAL)0);
  383.       break;
  384.     case 5:
  385.       if (int_div_warning(arg1,val1)) return FALSE;
  386.       if (val3) {
  387.         /* if (int_div_warning(arg3,val3)) return FALSE; */
  388.         if (val3!=floor(val3)) return FALSE;
  389.         if (arg1==arg3) {
  390.           success=unify_real_result(arg2,(REAL)1);
  391.         }
  392.         else if (val1==0) {
  393.           success=unify_real_result(arg2,(REAL)0);
  394.         }
  395.         else {
  396.           double tmp;
  397.           tmp=trunc(val1/val3); /* Possible solution */
  398.           if (tmp==0)
  399.         success=FALSE;
  400.           else if (val3==trunc(val1/tmp)) { /* It is a solution */
  401.                 /* Check uniqueness */
  402.         if ((tmp>  1 && val3==trunc(val1/(tmp-1))) ||
  403.             (tmp< -1 && val3==trunc(val1/(tmp+1))))
  404.           /* Solution is not unique */
  405.           residuate(arg2);
  406.         else /* Solution is unique */
  407.           success=unify_real_result(arg2,tmp);
  408.           }
  409.           else
  410.         success=FALSE;
  411.         }
  412.       }
  413.       else
  414.         success=(val1==0);
  415.       break;
  416.     case 6:
  417.       if (int_div_warning(arg2,val2)) return FALSE;
  418.       /* if (int_div_warning(arg3,val3)) return FALSE; */
  419.       if (val3!=floor(val3)) return FALSE;
  420.           if (val2) {
  421.         if (val3) 
  422.           residuate(arg1);
  423.         else
  424.           success=unify_real_result(arg1,(REAL)0);
  425.       }
  426.           else {
  427.             if (val3) {
  428.           success=FALSE;
  429.               Errorline("division by zero in %P.\n",t); /* 8.9 */
  430.             }
  431.             else
  432.               success=unify_real_result(arg1,(REAL)0);
  433.           }
  434.       break;
  435.     case 7:
  436.       if (int_div_warning(arg1,val1)) return FALSE;
  437.       if (int_div_warning(arg2,val2)) return FALSE;
  438.       /* if (int_div_warning(arg3,val3)) return FALSE; */
  439.       if (val2)
  440.         success=(val3==trunc(val1/val2));
  441.       else {
  442.         success=FALSE;
  443.             Errorline("division by zero in %P.\n",t); /* 8.9 */
  444.           }
  445.       break;
  446.     }
  447.       
  448.     }
  449.     else
  450.       curry();
  451.   
  452.   nonnum_warning(t,arg1,arg2);
  453.   return success;
  454. }
  455.  
  456.  
  457.  
  458. /* Main routine for floor & ceiling functions */
  459. static long c_floor_ceiling(floorflag)
  460. long floorflag;
  461. {
  462.   long success=TRUE;
  463.   ptr_psi_term arg1,arg2,arg3,t;
  464.   long num1,num3;
  465.   REAL val1,val3;
  466.   
  467.   t=aim->a;
  468.   deref_ptr(t);
  469.   get_two_args(t->attr_list,&arg1,&arg2);
  470.   arg3=aim->b;
  471.   
  472.   if(arg1) {
  473.     deref(arg1);
  474.     deref_args(t,set_1);
  475.     success=get_real_value(arg1,&val1,&num1);
  476.     if(success) {
  477.       deref(arg3);
  478.       success=get_real_value(arg3,&val3,&num3);
  479.       if(success)
  480.     switch(num1+num3*4) {
  481.     case 0:
  482.       residuate(arg1);
  483.       break;
  484.     case 1:
  485.       success=unify_real_result(arg3,(floorflag?floor(val1):ceil(val1)));
  486.       break;
  487.     case 4:
  488.       residuate(arg1); 
  489.       break;
  490.     case 5:
  491.       success=(val3==(floorflag?floor(val1):ceil(val1)));
  492.     }
  493.     }
  494.   }
  495.   else
  496.     curry();
  497.  
  498.   nonnum_warning(t,arg1,NULL);
  499.   return success;
  500. }
  501.  
  502.  
  503.  
  504. /******** C_FLOOR
  505.   Return the largest integer inferior or equal to the argument
  506. */
  507. static long c_floor()
  508. {
  509.   return c_floor_ceiling(TRUE);
  510. }
  511.  
  512.  
  513.  
  514.  
  515. /******** C_CEILING
  516.   Return the smallest integer larger or equal to the argument
  517. */
  518. static long c_ceiling()
  519. {
  520.   return c_floor_ceiling(FALSE);
  521. }
  522.  
  523.  
  524.  
  525. /******** C_SQRT
  526.   Return the square root of the argument
  527. */
  528. static long c_sqrt()
  529. {
  530.   long success=TRUE;
  531.   ptr_psi_term arg1,arg3,t;
  532.   long num1,num3;
  533.   REAL val1,val3;
  534.   
  535.   t=aim->a;
  536.   deref_ptr(t);
  537.   get_one_arg(t->attr_list,&arg1);
  538.   arg3=aim->b;
  539.   
  540.   if (arg1) {
  541.     deref(arg1);
  542.     deref_args(t,set_1);
  543.     success=get_real_value(arg1,&val1,&num1);
  544.     if (success) {
  545.       deref(arg3);
  546.       success=get_real_value(arg3,&val3,&num3);
  547.       if (success)
  548.     switch(num1+num3*4) {
  549.     case 0:
  550.       residuate2(arg1,arg3);
  551.       break;
  552.     case 1:
  553.       if (val1>=0)
  554.         success=unify_real_result(arg3,sqrt(val1));
  555.       else {
  556.         success=FALSE;
  557.             Errorline("square root of negative number in %P.\n",t);
  558.           }
  559.       break;
  560.     case 4:
  561.       success=unify_real_result(arg1,val3*val3);
  562.       break;
  563.     case 5:
  564.       success=(val3*val3==val1 || (val1>=0 && val3==sqrt(val1)));
  565.           if (val1<0) Errorline("square root of negative number in %P.\n",t);
  566.     }
  567.     }
  568.   }
  569.   else
  570.     curry();
  571.  
  572.   nonnum_warning(t,arg1,NULL);
  573.   return success;
  574. }
  575.  
  576.  
  577. #define SINFLAG 1
  578. #define COSFLAG 2
  579. #define TANFLAG 3
  580.  
  581.  
  582. /* Main routine for sine and cosine */
  583. static long c_trig(trigflag)
  584. long trigflag;
  585. {
  586.   long success=TRUE;
  587.   ptr_psi_term arg1,arg3,t; /* arg3 is result */
  588.   long num1,num3;
  589.   REAL val1,val3,ans;
  590.  
  591.   t=aim->a;
  592.   deref_ptr(t);
  593.   get_one_arg(t->attr_list,&arg1);
  594.   arg3=aim->b;
  595.  
  596.   if (arg1) {
  597.     deref(arg1);
  598.     deref_args(t,set_1);
  599.     success=get_real_value(arg1,&val1,&num1);
  600.     if (success) {
  601.       deref(arg3);
  602.       success=get_real_value(arg3,&val3,&num3);
  603.       if (success)
  604.         switch(num1+num3*4) {
  605.         case 0:
  606.           residuate2(arg1,arg3);
  607.           break;
  608.         case 1:
  609.           ans=(trigflag==SINFLAG?sin(val1):
  610.               (trigflag==COSFLAG?cos(val1):
  611.               (trigflag==TANFLAG?tan(val1):0.0)));
  612.           success=unify_real_result(arg3,ans);
  613.           break;
  614.         case 4:
  615.           if (trigflag==TANFLAG || (val3>= -1 && val3<=1)) {
  616.             ans=(trigflag==SINFLAG?asin(val3):
  617.                 (trigflag==COSFLAG?acos(val3):
  618.                 (trigflag==TANFLAG?atan(val3):0.0)));
  619.             success=unify_real_result(arg1,ans);
  620.           }
  621.           else
  622.             success=FALSE;
  623.           break;
  624.         case 5:
  625.           ans=(trigflag==SINFLAG?asin(val1):
  626.               (trigflag==COSFLAG?acos(val1):
  627.               (trigflag==TANFLAG?atan(val1):0.0)));
  628.           success=(val3==ans);
  629.         }
  630.     }
  631.   }
  632.   else
  633.     curry();
  634.  
  635.   nonnum_warning(t,arg1,NULL);
  636.   return success;
  637. }
  638.  
  639.  
  640. /******** C_COSINE
  641.   Return the cosine of the argument (in radians).
  642. */
  643. static long c_cos()
  644. {
  645.   return (c_trig(COSFLAG));
  646. }
  647.  
  648.  
  649.  
  650.  
  651. /******** C_SINE
  652.   Return the sine of the argument
  653. */
  654. static long c_sin()
  655. {
  656.   return (c_trig(SINFLAG));
  657. }
  658.  
  659.  
  660.  
  661. /******** C_TAN
  662.   Return the tangent of the argument
  663. */
  664. static long c_tan()
  665. {
  666.   return (c_trig(TANFLAG));
  667. }
  668.  
  669.  
  670.  
  671. static long c_bit_not()
  672. {
  673.   long success=TRUE;
  674.   ptr_psi_term arg1,arg3,t; /* arg3 is result */
  675.   long num1,num3;
  676.   REAL val1,val3;
  677.  
  678.   t=aim->a;
  679.   deref_ptr(t);
  680.   get_one_arg(t->attr_list,&arg1);
  681.   arg3=aim->b;
  682.  
  683.   if (arg1) {
  684.     deref(arg1);
  685.     deref_args(t,set_1);
  686.     success=get_real_value(arg1,&val1,&num1);
  687.     if (success) {
  688.       deref(arg3);
  689.       success=get_real_value(arg3,&val3,&num3);
  690.       if (success)
  691.         switch(num1+num3*4) {
  692.         case 0:
  693.       if (arg1==arg3) return FALSE;
  694.           residuate2(arg1,arg3);
  695.           break;
  696.         case 1:
  697.       if (bit_not_warning(arg1,val1)) return FALSE;
  698.           success=unify_real_result(arg3,(REAL)~(long)val1);
  699.           break;
  700.         case 4:
  701.       if (bit_not_warning(arg3,val3)) return FALSE;
  702.           success=unify_real_result(arg1,(REAL)~(long)val3);
  703.           break;
  704.         case 5:
  705.       if (bit_not_warning(arg1,val1)) return FALSE;
  706.       if (bit_not_warning(arg3,val3)) return FALSE;
  707.           success=(val3==val1);
  708.       break;
  709.         }
  710.     }
  711.   }
  712.   else
  713.     curry();
  714.  
  715.   nonnum_warning(t,arg1,NULL);
  716.   return success;
  717. }
  718.  
  719.  
  720.  
  721.  
  722. /******** C_BIT_AND
  723.   Return the bitwise operation: ARG1 and ARG2.
  724. */
  725. static long c_bit_and()
  726. {
  727.   long success=TRUE;
  728.   ptr_psi_term arg1,arg2,arg3,t;
  729.   long num1,num2,num3;
  730.   REAL val1,val2,val3;
  731.   
  732.   t=aim->a;
  733.   deref_ptr(t);
  734.   get_two_args(t->attr_list,&arg1,&arg2);
  735.   arg3=aim->b;
  736.   
  737.   if(arg1) {
  738.     deref(arg1);
  739.     success=get_real_value(arg1,&val1,&num1);
  740.     if(success && arg2) {
  741.       deref(arg2);
  742.       deref_args(t,set_1_2);
  743.       success=get_real_value(arg2,&val2,&num2);
  744.     }
  745.   }
  746.   
  747.   if(success)
  748.     if(arg1 && arg2) {
  749.       deref(arg3);
  750.       success=get_real_value(arg3,&val3,&num3);
  751.       if(success)
  752.     switch(num1+num2*2+num3*4) {
  753.     case 0:
  754.       residuate2(arg1,arg2);
  755.       break;
  756.     case 1:
  757.           if (bit_and_warning(arg1,val1)) return FALSE;
  758.       if(val1)
  759.         residuate(arg2);
  760.       else
  761.         success=unify_real_result(arg3,(REAL)0);
  762.       break;
  763.     case 2:
  764.           if (bit_and_warning(arg2,val2)) return FALSE;
  765.       if(val2)
  766.         residuate(arg1);
  767.       else
  768.         success=unify_real_result(arg3,(REAL)0);
  769.       break;
  770.     case 3:
  771.           if (bit_and_warning(arg1,val1)||bit_and_warning(arg2,val2))
  772.             return FALSE;
  773.       success=unify_real_result(arg3,(REAL)(((unsigned long)val1) & ((unsigned long)val2)));
  774.       break;
  775.     case 4:
  776.       residuate2(arg1,arg2);
  777.       break;
  778.     case 5:
  779.           if (bit_and_warning(arg1,val1)) return FALSE;
  780.       residuate(arg2);
  781.       break;
  782.     case 6:
  783.           if (bit_and_warning(arg2,val2)) return FALSE;
  784.       residuate(arg1);
  785.       break;
  786.     case 7:
  787.           if (bit_and_warning(arg1,val1)||bit_and_warning(arg2,val2))
  788.             return FALSE;
  789.       success=(val3==(REAL)(((unsigned long)val1) & ((unsigned long)val2)));
  790.       break;
  791.     }
  792.       
  793.     }
  794.     else
  795.       curry();
  796.   
  797.   nonnum_warning(t,arg1,arg2);
  798.   return success;
  799. }
  800.  
  801.  
  802.  
  803. /******** C_BIT_OR
  804.   Return the bitwise operation: ARG1 or ARG2.
  805. */
  806. static long c_bit_or()
  807. {
  808.   long success=TRUE;
  809.   ptr_psi_term arg1,arg2,arg3,t;
  810.   long num1,num2,num3;
  811.   REAL val1,val2,val3;
  812.   
  813.   t=aim->a;
  814.   deref_ptr(t);
  815.   get_two_args(t->attr_list,&arg1,&arg2);
  816.   arg3=aim->b;
  817.   
  818.   if(arg1) {
  819.     deref(arg1);
  820.     success=get_real_value(arg1,&val1,&num1);
  821.     if(success && arg2) {
  822.       deref(arg2);
  823.       deref_args(t,set_1_2);
  824.       success=get_real_value(arg2,&val2,&num2);
  825.     }
  826.   }
  827.   
  828.   if(success)
  829.     if(arg1 && arg2) {
  830.       deref(arg3);
  831.       success=get_real_value(arg3,&val3,&num3);
  832.       if(success)
  833.     switch(num1+num2*2+num3*4) {
  834.     case 0:
  835.         case 4:
  836.       residuate2(arg1,arg2);
  837.       break;
  838.     case 1:
  839.         case 5:
  840.           if (bit_or_warning(arg1,val1)) return FALSE;
  841.       residuate(arg2);
  842.       break;
  843.     case 2:
  844.         case 6:
  845.           if (bit_or_warning(arg2,val2)) return FALSE;
  846.       residuate(arg1);
  847.       break;
  848.     case 3:
  849.           if (bit_or_warning(arg1,val1)||bit_or_warning(arg2,val2))
  850.             return FALSE;
  851.       success=unify_real_result(arg3,(REAL)(((unsigned long)val1) | ((unsigned long)val2)));
  852.       break;
  853.     case 7:
  854.           if (bit_or_warning(arg1,val1)||bit_or_warning(arg2,val2))
  855.             return FALSE;
  856.       success=(val3==(REAL)(((unsigned long)val1) | ((unsigned long)val2)));
  857.       break;
  858.     }      
  859.     }
  860.     else
  861.       curry();
  862.   
  863.   nonnum_warning(t,arg1,arg2);
  864.   return success;
  865. }
  866.  
  867.  
  868. /******** C_SHIFT
  869.   Return the bitwise shift left or shift right.
  870. */
  871.  
  872. static long c_shift();
  873.  
  874.  
  875. static long c_shift_left()
  876. {
  877.   return (c_shift(FALSE));
  878. }
  879.  
  880. static long c_shift_right()
  881. {
  882.   return (c_shift(TRUE));
  883. }
  884.  
  885. static long c_shift(dir)
  886. long dir;
  887. {
  888.   long success=TRUE;
  889.   ptr_psi_term arg1,arg2,arg3,t;
  890.   long num1,num2,num3;
  891.   REAL val1,val2,val3,ans;
  892.   
  893.   t=aim->a;
  894.   deref_ptr(t);
  895.   get_two_args(t->attr_list,&arg1,&arg2);
  896.   arg3=aim->b;
  897.   
  898.   if(arg1) {
  899.     deref(arg1);
  900.     success=get_real_value(arg1,&val1,&num1);
  901.     if(success && arg2) {
  902.       deref(arg2);
  903.       deref_args(t,set_1_2);
  904.       success=get_real_value(arg2,&val2,&num2);
  905.     }
  906.   }
  907.   
  908.   if(success)
  909.     if(arg1 && arg2) {
  910.       deref(arg3);
  911.       success=get_real_value(arg3,&val3,&num3);
  912.       if (success)
  913.     switch(num1+num2*2+num3*4) {
  914.     case 0:
  915.         case 4:
  916.       residuate2(arg1,arg2);
  917.       break;
  918.     case 1:
  919.         case 5:
  920.           if (shift_warning(dir,arg1,val1)) return FALSE;
  921.       residuate(arg2);
  922.       break;
  923.     case 2:
  924.         case 6:
  925.           if (shift_warning(dir,arg2,val2)) return FALSE;
  926.       residuate(arg1);
  927.       break;
  928.     case 3:
  929.           if (shift_warning(dir,arg1,val1)||shift_warning(dir,arg2,val2))
  930.             return FALSE;
  931.           ans=(REAL)(dir?(long)val1>>(long)val2:(long)val1<<(long)val2);
  932.       success=unify_real_result(arg3,ans);
  933.       break;
  934.         case 7:
  935.           if (shift_warning(dir,arg1,val1)||shift_warning(dir,arg2,val2))
  936.             return FALSE;
  937.           ans=(REAL)(dir?(long)val1>>(long)val2:(long)val1<<(long)val2);
  938.       success=(val3==ans);
  939.       break;
  940.     }      
  941.     }
  942.     else
  943.       curry();
  944.   
  945.   nonnum_warning(t,arg1,arg2);
  946.   return success;
  947. }
  948.  
  949.  
  950. /******** C_MOD
  951.   The modulo operation.
  952. */
  953. static long c_mod()
  954. {
  955.   long success=TRUE;
  956.   ptr_psi_term arg1,arg2,arg3,t;
  957.   long num1,num2,num3;
  958.   REAL val1,val2,val3;
  959.   
  960.   t=aim->a;
  961.   deref_ptr(t);
  962.   get_two_args(t->attr_list,&arg1,&arg2);
  963.   arg3=aim->b;
  964.   
  965.   if(arg1) {
  966.     deref(arg1);
  967.     success=get_real_value(arg1,&val1,&num1);
  968.     if(success && arg2) {
  969.       deref(arg2);
  970.       deref_args(t,set_1_2);
  971.       success=get_real_value(arg2,&val2,&num2);
  972.     }
  973.   }
  974.   
  975.   if(success)
  976.     if(arg1 && arg2) {
  977.       deref(arg3);
  978.       success=get_real_value(arg3,&val3,&num3);
  979.       if(success)
  980.     switch(num1+num2*2+num3*4) {
  981.     case 0:
  982.     case 4:
  983.       residuate2(arg1,arg2);
  984.       break;
  985.     case 1:
  986.     case 5:
  987.           if (mod_warning(arg1,val1,0)) return FALSE;
  988.       residuate(arg2);
  989.       break;
  990.     case 2:
  991.     case 6:
  992.           if (mod_warning(arg2,val2,1)) return FALSE;
  993.       residuate(arg1);
  994.       break;
  995.     case 3:
  996.           if (mod_warning(arg1,val1,0)||mod_warning(arg2,val2,1))
  997.             return FALSE;
  998.       success=unify_real_result(arg3,(REAL)((unsigned long)val1 % (unsigned long)val2));
  999.       break;
  1000.     case 7:
  1001.           if (mod_warning(arg1,val1,0)||mod_warning(arg2,val2,1))
  1002.             return FALSE;
  1003.       success=(val3==(REAL)((unsigned long)val1 % (unsigned long)val2));
  1004.       break;
  1005.     }      
  1006.     }
  1007.     else
  1008.       curry();
  1009.   
  1010.   nonnum_warning(t,arg1,arg2);
  1011.   return success;
  1012. }
  1013.  
  1014. /******** C_ADD
  1015.   Addition is considered as a 3-variable relation as in Prolog:
  1016.   
  1017.   arg1 + arg2 = arg3
  1018.   
  1019.   Only it may residuate or curry.
  1020.  
  1021.   Addition is further complicated by the fact that it is both a unary and
  1022.   binary function.
  1023. */
  1024. static long c_add()
  1025. {
  1026.   long success=TRUE;
  1027.   ptr_psi_term arg1,arg2,arg3,t;
  1028.   long num1,num2,num3;
  1029.   REAL val1,val2,val3;
  1030.   
  1031.   t=aim->a;
  1032.   deref_ptr(t);
  1033.   get_two_args(t->attr_list,&arg1,&arg2);
  1034.   arg3=aim->b;
  1035.   
  1036.   if(arg1) {
  1037.     deref(arg1);
  1038.     success=get_real_value(arg1,&val1,&num1);
  1039.     if(success && arg2) {
  1040.       deref(arg2);
  1041.       deref_args(t,set_1_2);
  1042.       success=get_real_value(arg2,&val2,&num2);
  1043.     }
  1044.   }
  1045.   
  1046.   if(success)
  1047.     if(arg1 && arg2) {
  1048.       deref(arg3);
  1049.       success=get_real_value(arg3,&val3,&num3);
  1050.       if(success)
  1051.     switch(num1+num2*2+num3*4) {
  1052.     case 0:
  1053.       if (arg1==arg3)
  1054.         success=unify_real_result(arg2,(REAL)0);
  1055.           else if (arg2==arg3)
  1056.         success=unify_real_result(arg1,(REAL)0);
  1057.           else
  1058.         residuate3(arg1,arg2,arg3);
  1059.       break;
  1060.     case 1:
  1061.       if (val1) {
  1062.             if (arg2==arg3) /* 8.9 */
  1063.               success=FALSE;
  1064.             else
  1065.           residuate2(arg2,arg3);
  1066.           }
  1067.           else
  1068.         push_goal(unify,arg2,arg3,NULL);
  1069.       break;
  1070.     case 2:
  1071.       if (val2) {
  1072.             if (arg1==arg3) /* 8.9 */
  1073.               success=FALSE;
  1074.             else
  1075.           residuate2(arg1,arg3);
  1076.           }
  1077.           else
  1078.         push_goal(unify,arg1,arg3,NULL);
  1079.       break;
  1080.     case 3:
  1081.       success=unify_real_result(arg3,val1+val2);
  1082.       break;
  1083.     case 4:
  1084.       if (arg1==arg2)
  1085.         success=unify_real_result(arg1,val3/2);
  1086.       else
  1087.         residuate2(arg1,arg2);
  1088.       break;
  1089.     case 5:
  1090.       success=unify_real_result(arg2,val3-val1);
  1091.       break;
  1092.     case 6:
  1093.       success=unify_real_result(arg1,val3-val2);
  1094.       break;
  1095.     case 7:
  1096.       success=(val3==val1+val2);
  1097.       break;
  1098.     }
  1099.     }
  1100.     else
  1101.       curry(); 
  1102. /*
  1103. '+' is no longer a function of a single argument:
  1104.       if(arg1) {
  1105.     deref(arg3);
  1106.     success=get_real_value(arg3,&val3,&num3);
  1107.     if(success)
  1108.       switch(num1+4*num3) {
  1109.       case 0:
  1110.         residuate2(arg1,arg3);
  1111.         break;
  1112.       case 1:
  1113.         success=unify_real_result(arg3,val1);
  1114.         break;
  1115.       case 4:
  1116.         success=unify_real_result(arg1,val3);
  1117.         break;
  1118.       case 5:
  1119.         success=(val1==val3);
  1120.       }
  1121.       }
  1122.       else
  1123.     curry();
  1124. */
  1125.   
  1126.   nonnum_warning(t,arg1,arg2);
  1127.   return success;
  1128. }
  1129.  
  1130.  
  1131.  
  1132.  
  1133. /******** C_SUB
  1134.   Identical (nearly) to C_ADD
  1135. */
  1136. static long c_sub()
  1137. {
  1138.   long success=TRUE;
  1139.   ptr_psi_term arg1,arg2,arg3,t;
  1140.   long num1,num2,num3;
  1141.   REAL val1,val2,val3;
  1142.   
  1143.   t=aim->a;
  1144.   deref_ptr(t);
  1145.   get_two_args(t->attr_list,&arg1,&arg2);
  1146.   arg3=aim->b;
  1147.   
  1148.   if(arg1) {
  1149.     deref(arg1);
  1150.     success=get_real_value(arg1,&val1,&num1);
  1151.     if(success && arg2) {
  1152.       deref(arg2);
  1153.       deref_args(t,set_1_2);
  1154.       success=get_real_value(arg2,&val2,&num2);
  1155.     }
  1156.   }
  1157.   
  1158.   if(success)
  1159.     if(arg1 && arg2) {
  1160.       deref(arg3);
  1161.       success=get_real_value(arg3,&val3,&num3);
  1162.       if(success)
  1163.     switch(num1+num2*2+num3*4) {
  1164.     case 0:
  1165.       if (arg1==arg3)
  1166.         success=unify_real_result(arg2,(REAL)0);
  1167.       else if (arg1==arg2)
  1168.         success=unify_real_result(arg3,(REAL)0);
  1169.       else
  1170.         residuate3(arg1,arg2,arg3);
  1171.       break;
  1172.     case 1:
  1173.       if (arg2==arg3)
  1174.         success=unify_real_result(arg3,val1/2);
  1175.           else
  1176.         residuate2(arg2,arg3);
  1177.       break;
  1178.     case 2:
  1179.       if (val2) {
  1180.             if (arg1==arg3) /* 9.9 */
  1181.               success=FALSE;
  1182.             else
  1183.           residuate2(arg1,arg3);
  1184.           }
  1185.           else
  1186.         push_goal(unify,arg1,arg3,NULL);
  1187.       break;
  1188.     case 3:
  1189.       success=unify_real_result(arg3,val1-val2);
  1190.       break;
  1191.     case 4:
  1192.       if (arg1==arg2)
  1193.         success=(val3==0);
  1194.           else if (val3)
  1195.         residuate2(arg1,arg2);
  1196.       else
  1197.         push_goal(unify,arg1,arg2,NULL);
  1198.       break;
  1199.     case 5:
  1200.       success=unify_real_result(arg2,val1-val3);
  1201.       break;
  1202.     case 6:
  1203.       success=unify_real_result(arg1,val3+val2);
  1204.       break;
  1205.     case 7:
  1206.       success=(val3==val1-val2);
  1207.       break;
  1208.     }
  1209.     }
  1210.     else
  1211.       if(arg1) {
  1212.     deref(arg3);
  1213.     success=get_real_value(arg3,&val3,&num3);
  1214.     if(success)
  1215.       switch(num1+4*num3) {
  1216.       case 0:
  1217.         residuate2(arg1,arg3);
  1218.         break;
  1219.       case 1:
  1220.         success=unify_real_result(arg3,-val1);
  1221.         break;
  1222.       case 4:
  1223.         success=unify_real_result(arg1,-val3);
  1224.         break;
  1225.       case 5:
  1226.         success=(val1== -val3);
  1227.       }
  1228.       }
  1229.       else
  1230.     curry();
  1231.   
  1232.   nonnum_warning(t,arg1,arg2);
  1233.   return success;
  1234. }
  1235.  
  1236. /******** C_LOG
  1237.   Natural logarithm.
  1238. */
  1239. static long c_log()
  1240. {
  1241.   long success=TRUE;
  1242.   ptr_psi_term arg1,arg3,t;
  1243.   long num1,num3;
  1244.   REAL val1,val3;
  1245.   
  1246.   t=aim->a;
  1247.   deref_ptr(t);
  1248.   get_one_arg(t->attr_list,&arg1);
  1249.   arg3=aim->b;
  1250.   
  1251.   if(arg1) {
  1252.     deref(arg1);
  1253.     deref_args(t,set_1);
  1254.     success=get_real_value(arg1,&val1,&num1);
  1255.     if(success) {
  1256.       deref(arg3);
  1257.       success=get_real_value(arg3,&val3,&num3);
  1258.       if(success)
  1259.     switch(num1+num3*4) {
  1260.     case 0:
  1261.       residuate2(arg1,arg3);
  1262.       break;
  1263.     case 1:
  1264.       if (val1>0)
  1265.         success=unify_real_result(arg3,log(val1));
  1266.       else {
  1267.         success=FALSE;
  1268.             Errorline("logarithm of %s in %P.\n",
  1269.                       (val1==0)?"zero":"a negative number",t);
  1270.           }
  1271.       break;
  1272.     case 4:
  1273.       success=unify_real_result(arg1,exp(val3));
  1274.       break;
  1275.     case 5:
  1276.       success=(exp(val3)==val1 || (val1>0 && val3==log(val1)));
  1277.           if (val1<=0)
  1278.             Errorline("logarithm of %s in %P.\n",
  1279.                       (val1==0)?"zero":"a negative number",t);
  1280.     }
  1281.     }
  1282.   }
  1283.   else
  1284.     curry();
  1285.  
  1286.   nonnum_warning(t,arg1,NULL);
  1287.   return success;
  1288. }
  1289.  
  1290.  
  1291.  
  1292.  
  1293. /******** C_EXP
  1294.   Exponential.
  1295. */
  1296. static long c_exp()
  1297. {
  1298.   long success=TRUE;
  1299.   ptr_psi_term arg1,arg2,arg3,t;
  1300.   long num1,num3;
  1301.   REAL val1,val3;
  1302.   
  1303.   t=aim->a;
  1304.   deref_ptr(t);
  1305.   get_two_args(t->attr_list,&arg1,&arg2);
  1306.   arg3=aim->b;
  1307.   
  1308.   if(arg1) {
  1309.     deref(arg1);
  1310.     deref_args(t,set_1);
  1311.     success=get_real_value(arg1,&val1,&num1);
  1312.     if(success) {
  1313.       deref(arg3);
  1314.       success=get_real_value(arg3,&val3,&num3);
  1315.       if(success)
  1316.     switch(num1+num3*4) {
  1317.     case 0:
  1318.       residuate2(arg1,arg3);
  1319.       break;
  1320.     case 1:
  1321.       success=unify_real_result(arg3,exp(val1));
  1322.       break;
  1323.     case 4:
  1324.       if(val3>0)
  1325.         success=unify_real_result(arg1,log(val3));
  1326.       else
  1327.         success=FALSE;
  1328.       break;
  1329.     case 5:
  1330.       success=(exp(val1)==val3 || (val3>0 && val1==log(val3)));
  1331.     }
  1332.     }
  1333.   }
  1334.   else
  1335.     curry();
  1336.  
  1337.   nonnum_warning(t,arg1,NULL);
  1338.   return success;
  1339. }
  1340.  
  1341. void insert_math_builtins()
  1342. {
  1343.   new_built_in(syntax_module,"*",function,c_mult);
  1344.   new_built_in(syntax_module,"+",function,c_add);
  1345.   new_built_in(syntax_module,"-",function,c_sub);
  1346.   new_built_in(syntax_module,"/",function,c_div);  
  1347.   new_built_in(syntax_module,"//",function,c_intdiv);  
  1348.   new_built_in(syntax_module,"mod",function,c_mod); /* PVR 24.2.94 */
  1349.   new_built_in(syntax_module,"/\\",function,c_bit_and);
  1350.   new_built_in(syntax_module,"\\/",function,c_bit_or);
  1351.   new_built_in(syntax_module,"\\",function,c_bit_not);
  1352.   new_built_in(syntax_module,">>",function,c_shift_right);
  1353.   new_built_in(syntax_module,"<<",function,c_shift_left);
  1354.   new_built_in(bi_module,"floor",function,c_floor);
  1355.   new_built_in(bi_module,"ceiling",function,c_ceiling);
  1356.   new_built_in(bi_module,"exp",function,c_exp);
  1357.   new_built_in(bi_module,"log",function,c_log);
  1358.   new_built_in(bi_module,"cos",function,c_cos);
  1359.   new_built_in(bi_module,"sin",function,c_sin);
  1360.   new_built_in(bi_module,"tan",function,c_tan);
  1361.   new_built_in(bi_module,"sqrt",function,c_sqrt);
  1362. }
  1363.  
  1364.