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