home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD2.bin / bbs / dev / umbscheme-2.12.lha / UMBScheme / src / real.c < prev    next >
C/C++ Source or Header  |  1993-11-29  |  10KB  |  617 lines
  1. /* real.c -- UMB Scheme, specific realnum procedures.
  2.  
  3. UMB Scheme Interpreter                  $Revision: 2.12 $
  4. Copyright (C) 1988, 1991 William R Campbell
  5.  
  6. This program is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. This program is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with this program; if not, write to the Free Software
  18. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. UMB Scheme was written by Bill Campbell with help from Karl Berry,
  21. Barbara Dixey, Ira Gerstein, Mary Glaser, Kathy Hargreaves, Bill McCabe,
  22. Long Nguyen, Susan Quina, Jeyashree Sivasubram, Bela Sohoni and Thang Quoc Tran.
  23.  
  24. For additional information about UMB Scheme, contact the author:
  25.  
  26.     Bill Campbell
  27.     Department of Mathematics and Computer Science
  28.     University of Massachusetts at Boston
  29.     Harbor Campus
  30.     Boston, MA 02125
  31.  
  32.     Telephone: 617-287-6449        Internet: bill@cs.umb.edu
  33.  
  34. */
  35.  
  36. /* Reals are implemented as the native double precision floating
  37. point type. As a result, all the operations can use native (C)
  38. functions.  */
  39.  
  40. #include "portable.h"
  41. #include "eval.h"
  42. #include "object.h"
  43. #include "architecture.h"
  44. #include "number.h"
  45. #include "fixnum.h"
  46. #include "bignum.h"
  47. #include "rational.h"
  48. #include "real.h"
  49. #include "complex.h"
  50. #include "steering.h"
  51. #include "io.h"
  52.  
  53.  
  54.  
  55. /* Predicates. */
  56. Public Boolean Is_Real_Zero()
  57. {
  58.     return Get_Number_Real_Value(Top(1)) == 0.0;
  59. }
  60.  
  61. Public Boolean Is_Real_Positive()
  62. {
  63.     return Get_Number_Real_Value(Top(1)) > 0.0;
  64. }
  65.  
  66. Public Boolean Is_Real_Negative()
  67. {
  68.     return Get_Number_Real_Value(Top(1)) < 0.0;
  69. }
  70.  
  71. Public Boolean Is_Real_Odd()
  72. {
  73.     Error("Reals aren't odd or even");
  74.     return FALSE;
  75. }
  76.  
  77. Public Boolean Is_Real_Even()
  78. {
  79.     Error("Reals aren't even or odd");
  80.     return FALSE;
  81. }
  82.  
  83. Public Boolean Is_Real_Exact()
  84. {
  85.     return FALSE;
  86. }
  87.  
  88. Public Boolean Is_Real_Inexact()
  89. {
  90.     return TRUE;
  91. }
  92.  
  93.  
  94.  
  95.  
  96. /* Comparisons. */
  97. Public Boolean Real_Less_Than()
  98. {
  99.     return Get_Number_Real_Value(Top(2)) < Get_Number_Real_Value(Top(1));
  100. }
  101.  
  102. Public Boolean Real_Greater_Than()
  103. {
  104.     return Get_Number_Real_Value(Top(2)) > Get_Number_Real_Value(Top(1));
  105. }
  106.  
  107. Public Boolean Real_Equal()
  108. {
  109.     return Get_Number_Real_Value(Top(2)) == Get_Number_Real_Value(Top(1));
  110. }
  111.  
  112. Public Boolean Real_Less_Than_Or_Equal()
  113. {
  114.     return Get_Number_Real_Value(Top(2)) <= Get_Number_Real_Value(Top(1));
  115. }
  116.  
  117. Public Boolean Real_Greater_Than_Or_Equal()
  118. {
  119.     return Get_Number_Real_Value(Top(2)) >= Get_Number_Real_Value(Top(1));
  120. }
  121.  
  122.  
  123.  
  124.  
  125. /* Arithmetic. */
  126. Public void Real_Add()
  127. {
  128.     Make_Real_Number(Get_Number_Real_Value(Top(2))+
  129.     Get_Number_Real_Value(Top(1)));
  130. }
  131.  
  132.  
  133.  
  134. Public void Real_Subtract()
  135. {
  136.     Make_Real_Number(Get_Number_Real_Value(Top(2))-
  137.     Get_Number_Real_Value(Top(1)));
  138. }
  139.  
  140.  
  141.  
  142. Public void Real_Multiply()
  143. {
  144.     Make_Real_Number(Get_Number_Real_Value(Top(2))*
  145.     Get_Number_Real_Value(Top(1)));
  146. }
  147.  
  148.  
  149.  
  150. Public void Real_Divide()
  151. {
  152.     Make_Real_Number(Get_Number_Real_Value(Top(2))/
  153.     Get_Number_Real_Value(Top(1)));
  154. }
  155.  
  156.  
  157.  
  158. Public void Real_Quotient()
  159. {
  160.     Error("Quotient makes no sense on reals");
  161. }
  162.  
  163.  
  164.  
  165. Public void Real_Remainder()
  166. {
  167.     Error("Remainder makes no sense on reals");
  168. }
  169.  
  170.  
  171.  
  172. Public void Real_Modulo()
  173. {
  174.     Error("Modulo makes no sense on reals");
  175. }
  176.  
  177.  
  178.  
  179. Public void Real_Negate()
  180. {
  181.     Value_Register = Copy_Object(Top(1), Real_Size);
  182.  
  183.     Get_Number_Real_Value(Value_Register) =
  184.         - Get_Number_Real_Value(Value_Register);
  185. }
  186.  
  187.  
  188.  
  189. Public void Real_Abs()
  190. {
  191.     if (Is_Real_Negative())
  192.     {
  193.         Real_Negate();        
  194.     }
  195.     else
  196.     {
  197.         Value_Register = Top(1);
  198.     }
  199. }
  200.  
  201.  
  202.  
  203. Public void Real_Numerator()
  204. {
  205.     Error("Numerator makes no sense on reals");
  206. }
  207.  
  208.  
  209.  
  210. Public void Real_Denominator()
  211. {
  212.     Error("Denominator makes no sense on reals");
  213. }
  214.  
  215.  
  216.  
  217. Public void Real_Rationalize()
  218. {
  219.     Error("Real_Rationaize is not yet implemented");
  220. }
  221.  
  222. /* And other operations. */
  223.  
  224. Public void Real_Max()
  225. {
  226.     Value_Register =
  227.         (Get_Number_Real_Value(Top(2)) > Get_Number_Real_Value(Top(1)))
  228.         ? Top(2)
  229.         : Top(1) ;
  230. }
  231.  
  232.  
  233.  
  234. Public void Real_Min()
  235. {
  236.     Value_Register =
  237.         (Get_Number_Real_Value(Top(2)) < Get_Number_Real_Value(Top(1)))
  238.         ? Top(2)
  239.         : Top(1) ;
  240. }
  241.  
  242.  
  243.  
  244. Public void Real_GCD()
  245. {
  246.     Error("GCD makes no sense on reals");
  247. }
  248.  
  249.  
  250.  
  251. Public void Real_LCM()
  252. {
  253.     Error("LCM makes no sense on reals");
  254. }
  255.  
  256.  
  257.  
  258.  
  259. Public void Real_Floor()
  260. {
  261.     Make_Real_Number( floor( Get_Number_Real_Value(Top(1))));
  262. }
  263.  
  264.  
  265.  
  266. Public void Real_Ceiling()
  267. {
  268.     Make_Real_Number( ceil( Get_Number_Real_Value(Top(1))));
  269. }
  270.  
  271.  
  272.  
  273. Public void Real_Truncate()
  274. {
  275.     if (Is_Real_Positive())
  276.     {
  277.         Real_Floor();
  278.     }
  279.     else
  280.     {
  281.         Real_Ceiling();
  282.     }
  283.  
  284. }
  285.  
  286.  
  287.  
  288. Public void Real_Round()
  289. {
  290.     /* Compare real to average of floor and ceiling and
  291.        choose either floor or ceiling depending on result;
  292.        reals ending in .5 round to even */
  293.  
  294.     Double input = Get_Number_Real_Value(Top(1));
  295.  
  296.     if (input < (floor(input) + ceil(input))/2 )
  297.     {
  298.         Real_Floor();
  299.     }
  300.     else if (input > (floor(input) + ceil(input))/2 )
  301.     {
  302.         Real_Ceiling();
  303.     }
  304.     else
  305.     {
  306.         Number_Floor();
  307.         Push(Value_Register);
  308.         Number_Inexact_To_Exact(); 
  309.         Push( Value_Register );
  310.         Is_Number_Even(); Pop(1);
  311.         if (Value_Register == The_True_Object)
  312.         {
  313.             Value_Register = Top(1);
  314.             Pop(1);
  315.         }
  316.         else
  317.         {
  318.             Pop(1);
  319.             Real_Ceiling();
  320.         }
  321.     }
  322. }
  323.  
  324.  
  325.  
  326.  
  327. Public void Real_Sqrt()
  328. {
  329.     if( Get_Number_Real_Value(Top(1)) < 0 )
  330.     {
  331.         Make_Complex_Number( (Double) 0.0 ,
  332.                      sqrt( - Get_Number_Real_Value(Top(1))) );
  333.         }
  334.     else
  335.     {
  336.         Make_Real_Number( sqrt (Get_Number_Real_Value(Top(1))) );
  337.     }
  338. }
  339.  
  340.  
  341.  
  342. Public void Real_Exp()
  343. {
  344.     Make_Real_Number( exp( Get_Number_Real_Value(Top(1))));
  345. }
  346.  
  347.  
  348.  
  349. Public void Real_Log()
  350. {
  351.     if(Get_Number_Real_Value(Top(1)) <= 0)
  352.     {
  353.         Error("Argument of log must be positive");
  354.     }
  355.  
  356.     Make_Real_Number( log( Get_Number_Real_Value(Top(1))));
  357. }
  358.  
  359.  
  360.  
  361. Public void Real_Expt()
  362. {
  363.     Promote( 2 , REAL_LEVEL );
  364.     Make_Real_Number( pow( Get_Number_Real_Value(Top(2)),
  365.                 Get_Number_Real_Value(Top(1))));
  366. }
  367.  
  368.  
  369.  
  370.  
  371. Public void Real_Sin()
  372. {
  373.     Make_Real_Number( sin( Get_Number_Real_Value(Top(1))));
  374. }
  375.  
  376.  
  377.  
  378. Public void Real_Cos()
  379. {
  380.     Make_Real_Number( cos( Get_Number_Real_Value(Top(1))));
  381. }
  382.  
  383.  
  384.  
  385. Public void Real_Tan()
  386. {
  387.     Make_Real_Number( tan( Get_Number_Real_Value(Top(1))));
  388. }
  389.  
  390.  
  391.  
  392. Public void Real_Asin()
  393. {
  394.     if( (Get_Number_Real_Value(Top(1)) < -1) ||
  395.         (Get_Number_Real_Value(Top(1)) > 1) )
  396.     {
  397.         Error("Argument of asin must lie between -1 and 1, inclusive");
  398.     }
  399.  
  400.     Make_Real_Number( asin( Get_Number_Real_Value(Top(1))));
  401. }
  402.  
  403.  
  404.  
  405. Public void Real_Acos()
  406. {
  407.     if( (Get_Number_Real_Value(Top(1)) < -1) ||
  408.         (Get_Number_Real_Value(Top(1)) > 1) )
  409.     {
  410.         Error("Argument of acos must lie between -1 and 1, inclusive");
  411.     }
  412.  
  413.     Make_Real_Number( acos( Get_Number_Real_Value(Top(1))));
  414. }
  415.  
  416.  
  417.  
  418. Public void Real_Atan()
  419. {
  420.     Make_Real_Number( atan( Get_Number_Real_Value(Top(1))));
  421. }
  422.  
  423.  
  424.  
  425. Public void Real_Atan2()
  426. {
  427.     Make_Real_Number( atan2( Get_Number_Real_Value(Top(2)),
  428.                 Get_Number_Real_Value(Top(1))));
  429. }
  430.  
  431.  
  432.  
  433.  
  434. /* Transfer functions */
  435.  
  436.  
  437. Public void Real_Exact_To_Inexact()
  438. {
  439.     Value_Register = Top(1);
  440. }
  441.  
  442.  
  443. Public    void Real_Inexact_To_Exact()
  444. {
  445.     Push( Top(1) );
  446.     Make_Real_Number( DBL_MIN );
  447.     Push( Value_Register );
  448.     Number_Rationalize(); Pop(2);
  449.     Is_Exact_Number( Value_Register ) = TRUE;
  450. }
  451.  
  452.  
  453. Public void XReal_Inexact_To_Exact()
  454. {
  455.     Double     whole;
  456.     Double    fraction;
  457.  
  458.     Double  quotient;
  459.     Integer remainder;
  460.  
  461.  
  462.     whole = floor( fabs( Get_Number_Real_Value( Top(1) ) ) );
  463.     fraction = fabs( Get_Number_Real_Value( Top(1) ) ) - whole;
  464.  
  465.     /* The whole part */
  466.  
  467.     quotient = floor( whole / RADIX );
  468.     remainder = whole - (quotient * RADIX);
  469.     whole = quotient;
  470.  
  471.     Integer_To_Number( remainder );
  472.     Push( Value_Register );
  473.  
  474.     if ( whole > 0.0 )
  475.     {
  476.         Integer_To_Number( 1 );
  477.         Push( Value_Register );
  478.  
  479.         while ( whole > 0.0 )
  480.         {
  481.             Push( Top(1) );
  482.             Integer_To_Number( RADIX );
  483.             Push( Value_Register );
  484.             Number_Multiply(); Pop(2);
  485.             Replace( 1 , Value_Register );
  486.  
  487.             quotient = floor( whole / RADIX );
  488.             remainder = whole - (quotient * RADIX);
  489.             whole = quotient;
  490.             Push( Top(1) );
  491.             Integ