home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / oct93 / develop / umbscheme.lha / UMBScheme / src / fixnum.c < prev    next >
C/C++ Source or Header  |  1992-08-04  |  10KB  |  637 lines
  1. /* fixnum.c -- UMB Scheme, implementation of specific fixnum procedures. 
  2.  
  3. UMB Scheme Interpreter                  $Revision: 2.5 $
  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.  
  37.  
  38. #include "portable.h"
  39. #include "eval.h"
  40. #include "object.h"
  41. #include "architecture.h"
  42. #include "number.h"
  43. #include "fixnum.h"
  44. #include "bignum.h"
  45. #include "rational.h"
  46. #include "real.h"
  47. #include "complex.h"
  48. #include "steering.h"
  49. #include "io.h"
  50. #include <math.h>
  51. #include <errno.h>
  52.  
  53.  
  54.  
  55. /* Predicates. */
  56. Boolean Is_Fixnum_Zero()
  57. {
  58.     return ( Get_Number_Fixnum_Value(Top(1)) == 0 );
  59. }
  60.  
  61.  
  62.  
  63. Boolean Is_Fixnum_Positive()
  64. {
  65.     return ( Get_Number_Fixnum_Value(Top(1)) > 0);
  66. }
  67.  
  68.  
  69.  
  70. Boolean Is_Fixnum_Negative()
  71. {
  72.     return ( Get_Number_Fixnum_Value(Top(1)) < 0 );
  73. }
  74.  
  75.  
  76.  
  77. Boolean Is_Fixnum_Odd()
  78. {
  79.     return ( Get_Number_Fixnum_Value(Top(1)) % 2 != 0 );
  80. }
  81.  
  82.  
  83.  
  84. Boolean Is_Fixnum_Even()
  85. {
  86.     return ( Get_Number_Fixnum_Value(Top(1)) % 2 == 0 );
  87. }
  88.  
  89.  
  90.  
  91. Boolean Is_Fixnum_Exact()
  92. {
  93.     return TRUE;
  94. }
  95.  
  96.  
  97.  
  98. Boolean Is_Fixnum_Inexact()
  99. {
  100.     return FALSE;
  101. }
  102.  
  103.  
  104.  
  105.  
  106. /* Comparisons. */
  107. Boolean Fixnum_Less_Than()
  108. {
  109.     return ( Get_Number_Fixnum_Value(Top(2)) <
  110.          Get_Number_Fixnum_Value(Top(1)) );
  111. }
  112.  
  113.  
  114.  
  115. Boolean Fixnum_Greater_Than()
  116. {
  117.     return ( Get_Number_Fixnum_Value(Top(2)) > 
  118.          Get_Number_Fixnum_Value(Top(1)) );
  119. }
  120.  
  121.  
  122.  
  123. Boolean Fixnum_Equal()
  124. {
  125.     return ( Get_Number_Fixnum_Value(Top(2)) == 
  126.          Get_Number_Fixnum_Value(Top(1)));
  127. }
  128.  
  129.  
  130.  
  131. Boolean Fixnum_Less_Than_Or_Equal()
  132. {
  133.     return ( Get_Number_Fixnum_Value(Top(2)) <= 
  134.          Get_Number_Fixnum_Value(Top(1)));
  135. }
  136.  
  137.  
  138.  
  139. Boolean Fixnum_Greater_Than_Or_Equal()
  140. {
  141.     return ( Get_Number_Fixnum_Value(Top(2)) >= 
  142.          Get_Number_Fixnum_Value(Top(1)));
  143. }
  144.  
  145.  
  146.  
  147.  
  148. /* Arithmetic. */
  149. Public void Fixnum_Add()
  150. {
  151.     Integer result =  ( Get_Number_Fixnum_Value(Top(2)) +
  152.               Get_Number_Fixnum_Value(Top(1)) );
  153.  
  154.     if (abs(result) >= RADIX)
  155.     {
  156.         Make_Small_Bignum(result);
  157.     }
  158.     else
  159.     {
  160.         Make_Fixnum_Number( (Short) result);
  161.     }
  162. }
  163.  
  164.  
  165.  
  166. Public void Fixnum_Subtract()
  167. {
  168.     Integer result =  ( Get_Number_Fixnum_Value(Top(2)) -
  169.               Get_Number_Fixnum_Value(Top(1)) );
  170.  
  171.     if (abs(result) >= RADIX)
  172.     {
  173.         Make_Small_Bignum(result);
  174.     }
  175.     else
  176.     {
  177.         Make_Fixnum_Number( (Short) result);
  178.     }
  179. }
  180.  
  181.  
  182.  
  183. Public void Fixnum_Multiply()
  184. {
  185.     Integer result =  ( Get_Number_Fixnum_Value(Top(2)) *
  186.               Get_Number_Fixnum_Value(Top(1)) );
  187.  
  188.     if (abs(result) >= RADIX)
  189.     {
  190.         Make_Small_Bignum(result);
  191.     }
  192.     else
  193.     {
  194.         Make_Fixnum_Number( (Short) result);
  195.     }
  196. }
  197.  
  198.  
  199.  
  200. Public void Fixnum_Divide()
  201. {
  202.     Integer remainder = Get_Number_Fixnum_Value(Top(2)) % 
  203.               Get_Number_Fixnum_Value(Top(1));
  204.  
  205.     if (remainder)
  206.     {
  207.         Make_Rational_Number();
  208.     }
  209.     else
  210.     {
  211.         Make_Fixnum_Number( (Short) (Get_Number_Fixnum_Value(Top(2)) /
  212.             Get_Number_Fixnum_Value(Top(1))));
  213.     }
  214. }
  215.  
  216.  
  217.  
  218. Public void Fixnum_Quotient()
  219. {
  220.     Make_Fixnum_Number( (Short) ( Get_Number_Fixnum_Value(Top(2)) /
  221.         Get_Number_Fixnum_Value(Top(1)) ) );
  222. }
  223.  
  224.  
  225.  
  226. Public void Fixnum_Remainder()
  227. {
  228.     Make_Fixnum_Number( (Short) ( Get_Number_Fixnum_Value(Top(2)) %
  229.         Get_Number_Fixnum_Value(Top(1)) ) );
  230. }
  231.  
  232.  
  233.  
  234. Public void Fixnum_Modulo()
  235. {
  236.     Short dividend = Get_Number_Fixnum_Value(Top(2));
  237.     Short divisor = Get_Number_Fixnum_Value(Top(1));
  238.  
  239.     Integer remainder = dividend % divisor;
  240.  
  241.     if( (divisor*dividend) >= 0 )
  242.     {
  243.         Make_Fixnum_Number( (Short) remainder );
  244.     }
  245.  
  246.     else
  247.     {
  248.         Make_Fixnum_Number( (Short) (remainder + divisor) );    
  249.     }
  250. }
  251.  
  252.  
  253.  
  254.  
  255. Public void Fixnum_Negate()
  256. {
  257.     Value_Register = Copy_Object(Top(1), Fixnum_Size);
  258.  
  259.     Get_Number_Fixnum_Value(Value_Register) = 
  260.          - Get_Number_Fixnum_Value(Value_Register);
  261. }        
  262.  
  263.  
  264.     
  265. Public void Fixnum_Abs()
  266. {
  267.     if (Is_Fixnum_Negative())
  268.     {
  269.         Fixnum_Negate();
  270.     }
  271.     else
  272.     {
  273.         Value_Register = Top(1);
  274.     }
  275. }
  276.  
  277.  
  278.  
  279. Public void Fixnum_Numerator()
  280. {
  281.     Value_Register = Top(1);
  282. }
  283.  
  284.  
  285.  
  286. Public void Fixnum_Denominator()
  287. {
  288.     Make_Fixnum_Number(1);
  289. }
  290.  
  291.  
  292.  
  293. Public void Fixnum_Rationalize()
  294. {
  295.     Error("Rationalize makes no sense on fixnums");
  296. }
  297.  
  298.  
  299.  
  300.  
  301. Public void Fixnum_Max()
  302. {
  303.     Make_Fixnum_Number( 
  304.         (Get_Number_Fixnum_Value(Top(2)) > Get_Number_Fixnum_Value(Top(1))
  305.         ? Get_Number_Fixnum_Value(Top(2))
  306.         : Get_Number_Fixnum_Value(Top(1))) );
  307. }
  308.  
  309.  
  310.  
  311. Public void Fixnum_Min()
  312. {
  313.     Make_Fixnum_Number( 
  314.         (Get_Number_Fixnum_Value(Top(2)) < Get_Number_Fixnum_Value(Top(1))
  315.         ? Get_Number_Fixnum_Value(Top(2))
  316.         : Get_Number_Fixnum_Value(Top(1))) );
  317. }
  318.  
  319.  
  320.  
  321. Public void Fixnum_GCD()
  322. {
  323.     
  324.     /* make arguments positive since GCD is always positive */
  325.  
  326.     Push(Top(2));
  327.     Fixnum_Abs();
  328.     Replace( 1 , Value_Register );
  329.  
  330.     Push(Top(2));
  331.     Fixnum_Abs();
  332.     Replace( 1 , Value_Register );
  333.  
  334.     while (! Is_Fixnum_Zero() )
  335.     {
  336.         Fixnum_Remainder();
  337.         Top(2) = Top(1);
  338.         Top(1) = Value_Register;
  339.     }
  340.  
  341.     Value_Register  = Top(2);
  342.     Pop(2);
  343. }
  344.  
  345.  
  346.  
  347. Public void Fixnum_LCM()
  348. {
  349.     /*  LCM(a,b) = (a*b)/GCD(a,b)  */
  350.     
  351.     Fixnum_Multiply();
  352.     Push(Value_Register);
  353.  
  354.     Push(Top(3));
  355.     Push(Top(3));
  356.  
  357.     Fixnum_GCD();
  358.     Push(Value_Register);
  359.  
  360.     Top(2) = Top(4);
  361.     Number_Divide();
  362.  
  363.     Push(Value_Register);
  364.     Number_Abs();
  365.  
  366.     Pop(5);
  367.  
  368. }
  369.  
  370.  
  371.  
  372.  
  373. Public void Fixnum_Floor()
  374. {
  375.     Value_Register = Top(1);
  376. }
  377.  
  378.  
  379.  
  380. Public void Fixnum_Ceiling()
  381. {
  382.     Value_Register = Top(1);
  383. }
  384.  
  385.  
  386.  
  387. Public void Fixnum_Truncate()
  388. {
  389.     Value_Register = Top(1);
  390. }
  391.  
  392.  
  393.  
  394. Public void Fixnum_Round()
  395. {
  396.     Value_Register = Top(1);
  397. }
  398.  
  399.  
  400.  
  401.  
  402. Public void Fixnum_Sqrt()
  403. {
  404.     if(Get_Number_Fixnum_Value(Top(1)) < 0 )
  405.     {
  406.         Error("Argument of sqrt must be nonnegative");
  407.     }
  408.  
  409.     Promote(1, REAL_LEVEL);
  410.  
  411.     Make_Real_Number( sqrt (Get_Number_Real_Value(Top(1))) );
  412. }
  413.  
  414.  
  415.  
  416. Public void Fixnum_Exp()
  417. {
  418.     Promote(1, REAL_LEVEL);
  419.  
  420.     Make_Real_Number( exp (Get_Number_Real_Value(Top(1))) );
  421. }
  422.  
  423.  
  424.  
  425. Public void Fixnum_Log()
  426. {
  427.     if(Get_Number_Fixnum_Value(Top(1)) <= 0 )
  428.     {
  429.         Error("Argument of log must be positive");
  430.     }
  431.         
  432.     Promote(1, REAL_LEVEL);
  433.  
  434.     Make_Real_Number( log (Get_Number_Real_Value(Top(1))) );
  435. }
  436.  
  437.  
  438.  
  439. Public void Fixnum_Expt()
  440. {
  441.     Push( Top(2) );
  442.     Is_Number_Zero();
  443.     Pop(1);
  444.  
  445.     if((Value_Register == The_True_Object) &&
  446.         (Get_Number_Fixnum_Value(Top(1)) <  0))
  447.     {
  448.         Error("Domain error for expt");
  449.     }
  450.     else if (Get_Number_Fixnum_Value(Top(1)) >= 0 )
  451.     {
  452.         Integer index = Get_Number_Fixnum_Value( Top(1) );
  453.         
  454.         Make_Fixnum_Number( 1 );
  455.  
  456.         while (index--)
  457.         {
  458.             Push( Top(2) );
  459.             Push( Value_Register );
  460.             Number_Multiply();
  461.             Pop(2);
  462.         }
  463.     }
  464.     else
  465.     {
  466.         /* Negative Exponent */
  467.  
  468.         Promote(1, REAL_LEVEL);
  469.         Promote(2, REAL_LEVEL);
  470.  
  471.  
  472.         Make_Real_Number( pow (Get_Number_Real_Value(Top(2)),
  473.                     Get_Number_Real_Value(Top(1))) );
  474.  
  475.     }
  476. }
  477.  
  478. Public void Fixnum_Sin()
  479. {
  480.     Promote(1, REAL_LEVEL);
  481.  
  482.     Make_Real_Number( sin (Get_Number_Real_Value(Top(1))) );
  483. }
  484.  
  485.  
  486.  
  487. Public void Fixnum_Cos()
  488. {
  489.     Promote(1, REAL_LEVEL);
  490.  
  491.     Make_Real_Number( cos (Get_Number_Real_Value(Top(1))) );
  492. }
  493.  
  494.  
  495.  
  496. Public void Fixnum_Tan()
  497. {
  498.     Promote(1, REAL_LEVEL);
  499.  
  500.     Make_Real_Number( tan (Get_Number_Real_Value(Top(1))) );
  501. }
  502.  
  503.  
  504.  
  505. Public void Fixnum_Asin()
  506. {
  507.     if( (Get_Number_Fixnum_Value(Top(1)) < -1) ||
  508.         (Get_Number_Fixnum_Value(Top(1)) > 1) )
  509.     {
  510.         Error("Argument to asin must lie between -1 and 1, inclusive");
  511.     }
  512.      
  513.     Promote(1, REAL_LEVEL);
  514.  
  515.     Make_Real_Number( asin (Get_Number_Real_Value(Top(1))) );
  516. }
  517.  
  518.  
  519.  
  520. Public void Fixnum_Acos()
  521. {
  522.     if( (Get_Number_Fixnum_Value(Top(1)) < -1) ||
  523.         (Get_Number_Fixnum_Value(Top(1)) > 1) )
  524.     {
  525.         Error("Argument to acos must lie between -1 and 1, inclusive");
  526.     }
  527.      
  528.     Promote(1, REAL_LEVEL);
  529.  
  530.     Make_Real_Number( acos (Get_Number_Real_Value(Top(1))) );
  531. }
  532.  
  533.  
  534.  
  535. Public void Fixnum_Atan()
  536. {
  537.     Promote(1, REAL_LEVEL);
  538.  
  539.     Make_Real_Number( atan (Get_Number_Real_Value(Top(1))) );
  540. }
  541.  
  542.  
  543.  
  544. Public void Fixnum_Atan2()
  545. {
  546.     Promote(1, REAL_LEVEL);
  547.     Promote(2, REAL_LEVEL);
  548.  
  549.     Make_Real_Number( atan2 (Get_Number_Real_Value(Top(2)), 
  550.                     Get_Number_Real_Value(Top(1))) );
  551. }
  552.  
  553. /* Transfer functions */
  554.  
  555.  
  556. Public void Fixnum_Exact_To_Inexact()
  557. {
  558.     Make_Real_Number( (double) Get_Number_Fixnum_Value( Top(1) ) );
  559. }
  560.  
  561.  
  562.  
  563. Public void Fixnum_Inexact_To_Exact()
  564. {
  565.     Value_Register = Top(1);
  566. }
  567.  
  568.  
  569.  
  570.  
  571. Public void Fixnum_To_String()
  572. {
  573.     Character fixed_string[MAX_CHARS_PER_INT];
  574.     Integer    radix = Number_To_Integer( Top(1) );
  575.     Integer    value = Get_Number_Fixnum_Value( Top(2) );
  576.  
  577.     switch ( radix )
  578.     {
  579.     case 2:
  580.     case 8:
  581.     case 16:
  582.         Make_Constant_String( 
  583.             Integer_To_Cstring( value , fixed_string , radix , 0 ) );
  584.         return;
  585.     case 10:
  586.         sprintf(fixed_string, "%d", value );
  587.         Make_Constant_String( fixed_string );
  588.         return;
  589.     default:
  590.         Display_Error( "Unknown radix : " , Top(1) );
  591.     }
  592. }
  593.  
  594. Public void Fixnum_Make_Rectangular()
  595. {
  596.     Make_Complex_Number( (Double) Get_Number_Fixnum_Value(Top(2)),
  597.                  (Double) Get_Number_Fixnum_Value(Top(1)));
  598. }
  599.  
  600.  
  601.  
  602. Public void Fixnum_Make_Polar()
  603. {
  604.     Double    mag = Get_Number_Real_Value(Top(2));
  605.     Double    ang = Get_Number_Real_Value(Top(1));
  606.  
  607.     Make_Complex_Number( (mag) * cos(ang) , (mag) * sin(ang) );
  608. }
  609.  
  610.  
  611.  
  612. Public void Fixnum_Real_Part()
  613. {
  614.     Value_Register = Top(1);
  615. }
  616.  
  617.  
  618.  
  619. Public void Fixnum_Imaginary_Part()
  620. {
  621.     Make_Fixnum_Number(0);
  622. }
  623.  
  624.  
  625.  
  626. Public void Fixnum_Magnitude()
  627. {
  628.     Fixnum_Abs();
  629. }
  630.  
  631.  
  632.  
  633. Public void Fixnum_Angle()
  634. {
  635.     Make_Fixnum_Number(0);
  636. }
  637.