ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/microscheme/scheme.c
(Generate patch)

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.53 by root, Tue Dec 1 02:21:49 2015 UTC vs.
Revision 1.55 by root, Tue Dec 1 03:03:11 2015 UTC

… …
250static num num_op (enum num_op op, num a, num b); 250static num num_op (enum num_op op, num a, num b);
251static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
252static num num_rem (num a, num b); 252static num num_rem (num a, num b);
253static num num_mod (num a, num b); 253static num num_mod (num a, num b);
254 254
255#if USE_MATH
256static double round_per_R5RS (double x);
257#endif
258static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
259 256
260static num num_zero; 257static num num_zero;
261static num num_one; 258static num num_one;
262 259
… …
872 } 869 }
873 870
874 return ret; 871 return ret;
875} 872}
876 873
877#if USE_MATH
878
879/* Round to nearest. Round to even if midway */
880static double
881round_per_R5RS (double x)
882{
883 double fl = floor (x);
884 double ce = ceil (x);
885 double dfl = x - fl;
886 double dce = ce - x;
887
888 if (dfl > dce)
889 return ce;
890 else if (dfl < dce)
891 return fl;
892 else
893 {
894 if (fmod (fl, 2) == 0) /* I imagine this holds */
895 return fl;
896 else
897 return ce;
898 }
899}
900#endif
901
902static int 874static int
903is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
904{ 876{
905 return x == 0; 877 return x == 0;
906#if 0 878#if 0
… …
4027 3999
4028 switch (op) 4000 switch (op)
4029 { 4001 {
4030#if USE_MATH 4002#if USE_MATH
4031 case OP_INEX2EX: /* inexact->exact */ 4003 case OP_INEX2EX: /* inexact->exact */
4032 {
4033 if (is_integer (x)) 4004 if (!is_integer (x))
4034 s_return (x); 4005 {
4035
4036 RVALUE r = rvalue_unchecked (x); 4006 RVALUE r = rvalue_unchecked (x);
4037 4007
4038 if (r == (RVALUE)(IVALUE)r) 4008 if (r == (RVALUE)(IVALUE)r)
4039 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4009 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4040 else 4010 else
4041 Error_1 ("inexact->exact: not integral:", x); 4011 Error_1 ("inexact->exact: not integral:", x);
4042 } 4012 }
4013
4014 s_return (x);
4043 4015
4044 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4016 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4045 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4017 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4018 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4046 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4019 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4047 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4020 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4048 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4021 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4049 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4022 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4050 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4023 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4051 4024
4052 case OP_ATAN: 4025 case OP_ATAN:
4026 s_return (mk_real (SCHEME_A_
4053 if (cdr (args) == NIL) 4027 cdr (args) == NIL
4054 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4028 ? atan (rvalue (x))
4055 else 4029 : atan2 (rvalue (x), rvalue (cadr (args)))));
4056 {
4057 pointer y = cadr (args);
4058 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4059 }
4060 4030
4061 case OP_SQRT: 4031 case OP_SQRT:
4062 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); 4032 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4063 4033
4064 case OP_EXPT: 4034 case OP_EXPT:
… …
4091 s_return (mk_real (SCHEME_A_ result)); 4061 s_return (mk_real (SCHEME_A_ result));
4092 else 4062 else
4093 s_return (mk_integer (SCHEME_A_ result)); 4063 s_return (mk_integer (SCHEME_A_ result));
4094 } 4064 }
4095 4065
4096 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); 4066 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4097 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); 4067 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4098
4099 case OP_TRUNCATE:
4100 {
4101 RVALUE n = rvalue (x);
4102 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4103 }
4104
4105 case OP_ROUND:
4106 if (is_integer (x))
4107 s_return (x);
4108
4109 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); 4068 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4069 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4110#endif 4070#endif
4111 4071
4112 case OP_ADD: /* + */ 4072 case OP_ADD: /* + */
4113 v = num_zero; 4073 v = num_zero;
4114 4074

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines