home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / flonum.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  9KB  |  265 lines
  1. /* -*-C-*-
  2.  
  3. $Id: flonum.c,v 9.43 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Floating Point Arithmetic */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "zones.h"
  27. #include <errno.h>
  28.  
  29. double
  30. DEFUN (arg_flonum, (arg_number), int arg_number)
  31. {
  32.   SCHEME_OBJECT argument = (ARG_REF (arg_number));
  33.   if (! (FLONUM_P (argument)))
  34.     error_wrong_type_arg (arg_number);
  35.   return (FLONUM_TO_DOUBLE (argument));
  36. }
  37.  
  38. #define FLONUM_RESULT(x) PRIMITIVE_RETURN (double_to_flonum (x))
  39. #define BOOLEAN_RESULT(x) PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (x))
  40.  
  41. SCHEME_OBJECT
  42. DEFUN (double_to_flonum, (value), double value)
  43. {
  44.   ALIGN_FLOAT (Free);
  45.   Primitive_GC_If_Needed (FLONUM_SIZE + 1);
  46.   {
  47.     SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, Free));
  48.     (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, FLONUM_SIZE));
  49.     (*((double *) Free)) = value;
  50.     Free += FLONUM_SIZE;
  51.     return (result);
  52.   }
  53. }
  54.  
  55. #define FLONUM_BINARY_OPERATION(operator)                \
  56. {                                    \
  57.   PRIMITIVE_HEADER (2);                            \
  58.   Set_Time_Zone (Zone_Math);                        \
  59.   FLONUM_RESULT ((arg_flonum (1)) operator (arg_flonum (2)));        \
  60. }
  61.  
  62. DEFINE_PRIMITIVE ("FLONUM-ADD", Prim_flonum_add, 2, 2, 0)
  63.      FLONUM_BINARY_OPERATION (+)
  64. DEFINE_PRIMITIVE ("FLONUM-SUBTRACT", Prim_flonum_subtract, 2, 2, 0)
  65.      FLONUM_BINARY_OPERATION (-)
  66. DEFINE_PRIMITIVE ("FLONUM-MULTIPLY", Prim_flonum_multiply, 2, 2, 0)
  67.      FLONUM_BINARY_OPERATION (*)
  68.  
  69. DEFINE_PRIMITIVE ("FLONUM-DIVIDE", Prim_flonum_divide, 2, 2, 0)
  70. {
  71.   PRIMITIVE_HEADER (2);
  72.   Set_Time_Zone (Zone_Math);
  73.   {
  74.     fast double denominator = (arg_flonum (2));
  75.     if (denominator == 0)
  76.       error_bad_range_arg (2);
  77.     FLONUM_RESULT ((arg_flonum (1)) / denominator);
  78.   }
  79. }
  80.  
  81. DEFINE_PRIMITIVE ("FLONUM-NEGATE", Prim_flonum_negate, 1, 1, 0)
  82. {
  83.   PRIMITIVE_HEADER (1);
  84.   Set_Time_Zone (Zone_Math);
  85.   FLONUM_RESULT (- (arg_flonum (1)));
  86. }
  87.  
  88. DEFINE_PRIMITIVE ("FLONUM-ABS", Prim_flonum_abs, 1, 1, 0)
  89. {
  90.   PRIMITIVE_HEADER (1);
  91.   Set_Time_Zone (Zone_Math);
  92.   {
  93.     fast double x = (arg_flonum (1));
  94.     FLONUM_RESULT ((x < 0) ? (-x) : x);
  95.   }
  96. }
  97.  
  98. #define FLONUM_BINARY_PREDICATE(operator)                \
  99. {                                    \
  100.   PRIMITIVE_HEADER (2);                            \
  101.   Set_Time_Zone (Zone_Math);                        \
  102.   BOOLEAN_RESULT ((arg_flonum (1)) operator (arg_flonum (2)));        \
  103. }
  104.  
  105. DEFINE_PRIMITIVE ("FLONUM-EQUAL?", Prim_flonum_equal_p, 2, 2, 0)
  106.      FLONUM_BINARY_PREDICATE (==)
  107. DEFINE_PRIMITIVE ("FLONUM-LESS?", Prim_flonum_less_p, 2, 2, 0)
  108.      FLONUM_BINARY_PREDICATE (<)
  109. DEFINE_PRIMITIVE ("FLONUM-GREATER?", Prim_flonum_greater_p, 2, 2, 0)
  110.      FLONUM_BINARY_PREDICATE (>)
  111.  
  112. #define FLONUM_UNARY_PREDICATE(operator)                \
  113. {                                    \
  114.   PRIMITIVE_HEADER (1);                            \
  115.   Set_Time_Zone (Zone_Math);                        \
  116.   BOOLEAN_RESULT ((arg_flonum (1)) operator 0);                \
  117. }
  118.  
  119. DEFINE_PRIMITIVE ("FLONUM-ZERO?", Prim_flonum_zero_p, 1, 1, 0)
  120.      FLONUM_UNARY_PREDICATE (==)
  121. DEFINE_PRIMITIVE ("FLONUM-POSITIVE?", Prim_flonum_positive_p, 1, 1, 0)
  122.      FLONUM_UNARY_PREDICATE (>)
  123. DEFINE_PRIMITIVE ("FLONUM-NEGATIVE?", Prim_flonum_negative_p, 1, 1, 0)
  124.      FLONUM_UNARY_PREDICATE (<)
  125.  
  126. #define SIMPLE_TRANSCENDENTAL_FUNCTION(function)            \
  127. {                                    \
  128.   extern double EXFUN (function, (double));                \
  129.   double result;                            \
  130.   PRIMITIVE_HEADER (1);                            \
  131.   Set_Time_Zone (Zone_Math);                        \
  132.   errno = 0;                                \
  133.   result = (function (arg_flonum (1)));                    \
  134.   if (errno != 0)                            \
  135.     error_bad_range_arg (1);                        \
  136.   FLONUM_RESULT (result);                        \
  137. }
  138.  
  139. #define RESTRICTED_TRANSCENDENTAL_FUNCTION(function, restriction)    \
  140. {                                    \
  141.   extern double EXFUN (function, (double));                \
  142.   double x;                                \
  143.   double result;                            \
  144.   PRIMITIVE_HEADER (1);                            \
  145.   Set_Time_Zone (Zone_Math);                        \
  146.   x = (arg_flonum (1));                            \
  147.   if (! (restriction))                            \
  148.     error_bad_range_arg (1);                        \
  149.   errno = 0;                                \
  150.   result = (function (x));                        \
  151.   if (errno != 0)                            \
  152.     error_bad_range_arg (1);                        \
  153.   FLONUM_RESULT (result);                        \
  154. }
  155.  
  156. DEFINE_PRIMITIVE ("FLONUM-EXP", Prim_flonum_exp, 1, 1, 0)
  157.      SIMPLE_TRANSCENDENTAL_FUNCTION (exp)
  158. DEFINE_PRIMITIVE ("FLONUM-LOG", Prim_flonum_log, 1, 1, 0)
  159.      RESTRICTED_TRANSCENDENTAL_FUNCTION (log, (x > 0))
  160. DEFINE_PRIMITIVE ("FLONUM-SIN", Prim_flonum_sin, 1, 1, 0)
  161.      SIMPLE_TRANSCENDENTAL_FUNCTION (sin)
  162. DEFINE_PRIMITIVE ("FLONUM-COS", Prim_flonum_cos, 1, 1, 0)
  163.      SIMPLE_TRANSCENDENTAL_FUNCTION (cos)
  164. DEFINE_PRIMITIVE ("FLONUM-TAN", Prim_flonum_tan, 1, 1, 0)
  165.      SIMPLE_TRANSCENDENTAL_FUNCTION (tan)
  166. DEFINE_PRIMITIVE ("FLONUM-ASIN", Prim_flonum_asin, 1, 1, 0)
  167.      RESTRICTED_TRANSCENDENTAL_FUNCTION (asin, ((x >= -1) && (x <= 1)))
  168. DEFINE_PRIMITIVE ("FLONUM-ACOS", Prim_flonum_acos, 1, 1, 0)
  169.      RESTRICTED_TRANSCENDENTAL_FUNCTION (acos, ((x >= -1) && (x <= 1)))
  170. DEFINE_PRIMITIVE ("FLONUM-ATAN", Prim_flonum_atan, 1, 1, 0)
  171.      SIMPLE_TRANSCENDENTAL_FUNCTION (atan)
  172.  
  173. DEFINE_PRIMITIVE ("FLONUM-ATAN2", Prim_flonum_atan2, 2, 2, 0)
  174. {
  175.   extern double EXFUN (atan2, (double, double));
  176.   PRIMITIVE_HEADER (2);
  177.   {
  178.     fast double y = (arg_flonum (1));
  179.     fast double x = (arg_flonum (2));
  180.     if ((x == 0) && (y == 0))
  181.       error_bad_range_arg (2);
  182.     FLONUM_RESULT (atan2 (y, x));
  183.   }
  184. }
  185.  
  186. DEFINE_PRIMITIVE ("FLONUM-SQRT", Prim_flonum_sqrt, 1, 1, 0)
  187.      RESTRICTED_TRANSCENDENTAL_FUNCTION (sqrt, (x >= 0))
  188.  
  189. DEFINE_PRIMITIVE ("FLONUM-EXPT", Prim_flonum_expt, 2, 2, 0)
  190. {
  191.   extern double EXFUN (pow, (double, double));
  192.   PRIMITIVE_HEADER (2);
  193.   FLONUM_RESULT (pow ((arg_flonum (1)), (arg_flonum (2))));
  194. }
  195.  
  196. DEFINE_PRIMITIVE ("FLONUM?", Prim_flonum_p, 1, 1, 0)
  197. {
  198.   PRIMITIVE_HEADER (1);
  199.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FLONUM_P (ARG_REF (1))));
  200. }
  201.  
  202. DEFINE_PRIMITIVE ("FLONUM-INTEGER?", Prim_flonum_integer_p, 1, 1, 0)
  203. {
  204.   extern Boolean EXFUN (flonum_integer_p, (SCHEME_OBJECT));
  205.   PRIMITIVE_HEADER (1);
  206.   CHECK_ARG (1, FLONUM_P);
  207.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (flonum_integer_p (ARG_REF (1))));
  208. }
  209.  
  210. #define FLONUM_CONVERSION(converter)                    \
  211. {                                    \
  212.   PRIMITIVE_HEADER (1);                            \
  213.   Set_Time_Zone (Zone_Math);                        \
  214.   CHECK_ARG (1, FLONUM_P);                        \
  215.   PRIMITIVE_RETURN (converter (ARG_REF (1)));                \
  216. }
  217.  
  218. DEFINE_PRIMITIVE ("FLONUM-FLOOR", Prim_flonum_floor, 1, 1, 0)
  219.      FLONUM_CONVERSION (flonum_floor)
  220. DEFINE_PRIMITIVE ("FLONUM-CEILING", Prim_flonum_ceiling, 1, 1, 0)
  221.      FLONUM_CONVERSION (flonum_ceiling)
  222. DEFINE_PRIMITIVE ("FLONUM-TRUNCATE", Prim_flonum_truncate, 1, 1, 0)
  223.      FLONUM_CONVERSION (FLONUM_TRUNCATE)
  224. DEFINE_PRIMITIVE ("FLONUM-ROUND", Prim_flonum_round, 1, 1, 0)
  225.      FLONUM_CONVERSION (flonum_round)
  226.  
  227. DEFINE_PRIMITIVE ("FLONUM-TRUNCATE->EXACT", Prim_flonum_truncate_to_exact, 1, 1, 0)
  228. {
  229.   PRIMITIVE_HEADER (1);
  230.   Set_Time_Zone (Zone_Math);
  231.   CHECK_ARG (1, FLONUM_P);
  232.   PRIMITIVE_RETURN (FLONUM_TO_INTEGER (ARG_REF (1))); 
  233. }
  234.  
  235. #define FLONUM_EXACT_CONVERSION(converter)                \
  236. {                                    \
  237.   PRIMITIVE_HEADER (1);                            \
  238.   Set_Time_Zone (Zone_Math);                        \
  239.   CHECK_ARG (1, FLONUM_P);                        \
  240.   PRIMITIVE_RETURN (FLONUM_TO_INTEGER (converter (ARG_REF (1))));    \
  241. }
  242. DEFINE_PRIMITIVE ("FLONUM-FLOOR->EXACT", Prim_flonum_floor_to_exact, 1, 1, 0)
  243.      FLONUM_EXACT_CONVERSION (flonum_floor)
  244. DEFINE_PRIMITIVE ("FLONUM-CEILING->EXACT", Prim_flonum_ceiling_to_exact, 1, 1, 0)
  245.      FLONUM_EXACT_CONVERSION (flonum_ceiling)
  246. DEFINE_PRIMITIVE ("FLONUM-ROUND->EXACT", Prim_flonum_round_to_exact, 1, 1, 0)
  247.      FLONUM_EXACT_CONVERSION (flonum_round)
  248.  
  249. DEFINE_PRIMITIVE ("FLONUM-NORMALIZE", Prim_flonum_normalize, 1, 1, 0)
  250. {
  251.   PRIMITIVE_HEADER (1);
  252.   Set_Time_Zone (Zone_Math);
  253.   CHECK_ARG (1, FLONUM_P);
  254.   PRIMITIVE_RETURN (flonum_normalize (ARG_REF (1)));
  255. }
  256.  
  257. DEFINE_PRIMITIVE ("FLONUM-DENORMALIZE", Prim_flonum_denormalize, 2, 2, 0)
  258. {
  259.   PRIMITIVE_HEADER (2);
  260.   Set_Time_Zone (Zone_Math);
  261.   CHECK_ARG (1, FLONUM_P);
  262.   CHECK_ARG (2, INTEGER_P);
  263.   PRIMITIVE_RETURN (flonum_denormalize ((ARG_REF (1)), (ARG_REF (2))));
  264. }
  265.