summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog261
-rw-r--r--Makefile2
-rw-r--r--arith.c1102
-rwxr-xr-xconfigure8
-rw-r--r--eval.c18
-rw-r--r--gc.c19
-rw-r--r--hash.c22
-rw-r--r--lib.c62
-rw-r--r--lib.h29
-rw-r--r--mpi-patches/mpi-to-double58
-rw-r--r--mpi-patches/series1
-rw-r--r--parser.l33
-rw-r--r--parser.y1
-rw-r--r--stream.c105
-rw-r--r--txr.116
-rw-r--r--txr.vim9
16 files changed, 1322 insertions, 424 deletions
diff --git a/ChangeLog b/ChangeLog
index 715cee67..e02f8863 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,264 @@
+2012-03-22 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (expo): New function.
+
+ * eval.c (eval_init): expo registered as intrinsic exp.
+
+ * lib.h (expo): Declared.
+
+ * txr.1: Added to stub heading.
+
+ * txr.vim: Highlighting for exp.
+
+2012-03-22 Kaz Kylheku <kaz@kylheku.com>
+
+ * eval.c (transform_op): use integerp instead of numberp.
+ Not all numbers are integers now, and that situation
+ requires an integer.
+
+2012-03-22 Kaz Kylheku <kaz@kylheku.com>
+
+ * parser.l: Bugfix: was not allowing e-notation floats
+ with no decimal point like 1E1.
+
+ * stream.c: (vformat): Keep track of whether or not precision was
+ given in precision_p local variable.
+ When printing #<bad-float> pass a precision of 0
+ to vformat_str, not precision, since precision does not apply.
+ In ~f and ~e, if the precision was not given, default
+ it to 3.
+ Restructured float printing in ~a and ~s. It now just uses sprintf's %g
+ with a precision. If user does not specify precision, it defaults
+ to DBL_DIG to print the number with reasonable accuracy.
+ A .0 is added if it sprintf produces an integer, and the conversion
+ is ~s rather than ~a.
+
+2012-03-22 Kaz Kylheku <kaz@kylheku.com>
+
+ Fix sqrt confusion. There must be a separate isqrt
+ for the integer square root.
+
+ * arith.c (sqroot_fixnum): Renamed back to isqrt_fixnum.
+ (sqroot): Rewritten to handle only floating-point square root.
+ (isqrt): New function, based on previous sqroot,
+ handles only integers.
+
+ * eval.c (eval_init): New intrinsic, isqrt.
+
+ * lib.h (isqrt): New declaration.
+
+ * txr.1: Doc stubs.
+
+ * txr.vim: Highlighting for isqrt.
+
+2012-03-22 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (floorf, ceili, sine, cosi, atang, loga): New functions.
+
+ * eval.c (eval_init): New intrinsic functions registered:
+ floor, ceil, sin, cons, atan, log.
+
+ * lib.h (floorf, ceili, sine, cosi, atang, loga): Declared.
+
+ * txr.1: Doc stub section for new functions.
+
+ * txr.vim: Highighting added.
+
+2012-03-22 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (int_flo): If sprintf produces something
+ that doesn't begin with a digit, it's most likely NaN or Inf.
+ We can turn that into an exception.
+
+ * stream.c (vformat): If sprintf produces a non-number,
+ turn it into the printed representation #<bad-float>.
+
+2012-03-22 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (to_float): New static function.
+ (divi): Uses to_float.
+ (zerop, gt, lt, ge, le, expt): Floating support.
+ (isqrt_fixnum): Static function renamed to sqroot_fixnum.
+ (isqrt): Renamed to sqroot. Floating support.
+ (evenp, oddp, exptmod, gcd): Work with integers, not floats.
+
+ * eval.c (eval_init): intrinsic registration of sqrt follows rename of
+ isqrt to sqroot.
+
+ * lib.h (isqrt): Declaration replaced.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (divi): New function.
+
+ * eval.c (eval_init): divi registered as / intrinsic.
+
+ * lib.h (divi): Declared.
+
+ * txr.1: divi added to stub heading.
+
+ * txr.vim: / operator highlighted.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (mod): Floating support.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (trunc): Floating support.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (plus, minus, mul): Removing unnecessary type checks,
+ which are already implied by the switch case.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * txr.1: Doc stubs for new functions floatp, integerp,
+ float-str, int-flo and flo-int.
+
+ * txr.vim: Highlighting for new functions.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * Makefile: link in -lm, which is needed now on some systems.
+
+ * arith.c (plus, minus): Eliminated some unnecessary (double) casts.
+ (abso, mul): Floating support.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (neg): Floating-point support.
+
+ * parser.l: FLO and FLODOT cases had to be reordered because
+ the lex trailing context counts as part of the match length,
+ causing 3.0 to be matched as three characters with 0 as
+ the trailing context. The cases are split up to eliminate
+ a flex warning.
+
+ * stream.c (vformat): Support bignum in floating point
+ conversion. Bugfixes: floating point conversion was
+ accessing obj->fl.n instead of using n.
+ Changed some if/else ladders to switches.
+
+2012-03-21 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (plus): Minor code simplification.
+ (minus): Floating point support.
+
+ * mpi-patches/mpi-to-double (mp_to_double): Re-apply lost
+ bugfix: index incremented instead of decremented.
+ Didn't refresh patch last time, then did a make distclean.
+
+2012-03-20 Kaz Kylheku <kaz@kylheku.com>
+
+ Regression fix: 1..3 scans incorrectly into 1. .3 tokens.
+
+ * parser.l (SGN, EXP, DIG): New regex definitions.
+ (FLO): Do not recognize numbers of the form 123.
+ Decimal point must be followed either by exponent, or digits
+ (which may then be followed by an exponent).
+ (FLODOT): New token type, recognizes 123.
+ (grammar): Recognize FLODOT as a floating point number,
+ only if it not trailed by another dot, and
+ recognize FLO unconditionally.
+
+2012-03-20 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (plus): Completed implementation of bignum-float
+ and float-bignum cases.
+
+2012-03-20 Kaz Kylheku <kaz@kylheku.com>
+
+ * stream.c (vformat): Use larger num_buf buffer so we don't
+ overrun. IEEE double floats can go to e+-308.
+
+2012-03-20 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (flo_int): New function.
+
+ * eval.c (eval_init): flo-int registered as intrinsic.
+
+ * lib.h (flo_int): Declared.
+
+ * mpi-patches/series: Added mpi-to-double to patch stack.
+ (mp_to_double): New MPI function.
+
+ * mpi-patches/mpi-to-double: New file.
+
+2012-03-20 Kaz Kylheku <kaz@kylheku.com>
+
+ * arith.c (plus): Optimization: use num_fast when
+ result is in the fixnum range.
+ Implemented FLNUM cases, except for adding a FLNUM
+ to BGNUM.
+ (minus, mul): Use num_fast when the cnum value is in the fixnum range.
+ (int_flo): New function.
+
+ * eval.c (eval_init): Register int-flo intrinsic.
+
+ * lib.c (c_flo): New function.
+
+ * lib.h (TYPE_SHIFT, TYPE_PAIR): New macros, carried over
+ from the lazy strings branch.
+ (c_flo, int_flo): Declared.
+
+2012-03-20 Kaz Kylheku <kaz@kylheku.com>
+
+ * parser.l (FLO): Adjusted syntax of floating point numbers
+ to allow leading or trailing decimal.
+
+2012-03-19 Kaz Kylheku <kaz@kylheku.com>
+
+ * stream.c (vformat): num_buf increased to 256 because we
+ are now printing floating point numbers into it, letting
+ the C library handle precision which can generate many digits.
+ We cap the precision at at 128. New format specifiers ~e
+ and ~f implemented, which loosely correspond to those of printf.
+ The ~s and ~a directives handle floats similarly to ~g in
+ printf, except that they ensure that a decimal point is printed
+ for the non-exponential notation.
+
+2012-03-19 Kaz Kylheku <kaz@kylheku.com>
+
+ * configure (uintptr): New variable. Indicates whether unsigned
+ version of intptr_t is available and should be generated in config.h
+ as uintptr_t.
+
+ * eval.c (eval_init): New intrinsic functions floatp,
+ integerp, flo-str.
+
+ * gc.c (finalize): Handle FLNUM case. Rearranged
+ cases so that all trivially returning cases are
+ together.
+ (mark): Handle FLNUM case.
+
+ * hash.c (hash_double): New function.
+ (equal_hash): Handle FLNUM via hash_double.
+ (eql_hash): Likewise.
+
+ * lib.c: <math.h> is included.
+ (float_s): New symbol variable.
+ (code2type, equal): Handle FLNUM case in switch.
+ (integerp): New function; does the same thing
+ as integerp before.
+ (numberp): Returns t for floats.
+ (flo, floatp, flo_str): New functions.
+ (obj_init): Initialize new float_s variable.
+ (obj_print, obj_pprint): Handle FLNUM case in switch.
+ Printing does not work yet; needs work in stream.c.
+
+ * lib.h (enum type): New enumeration FLNUM.
+ (struct flonum): New struct type.
+ (union obj): New member, fl.
+ (float_s, flo, floatp, integerp, flo_str): Declared.
+
+ * parser.l (FLO): New token pattern definition.
+ Scans to a NUMBER token.
+ Corrected uses of yylval.num to yylval.val.
+
+ * parser.y (%union): Removed num member from yystype.
+
2012-03-20 Kaz Kylheku <kaz@kylheku.com>
* debug.c (debug): Breakpointing now takes into account
diff --git a/Makefile b/Makefile
index c8244ea4..4125484a 100644
--- a/Makefile
+++ b/Makefile
@@ -52,7 +52,7 @@ OBJS += $(MPI_OBJS)
PROG := ./txr
$(PROG): $(OBJS) $(OBJS-y)
- $(CC) $(CFLAGS) -o $@ $^ $(LEXLIB)
+ $(CC) $(CFLAGS) -o $@ $^ -lm $(LEXLIB)
VPATH := $(top_srcdir)
diff --git a/arith.c b/arith.c
index 450b4e38..4ee87055 100644
--- a/arith.c
+++ b/arith.c
@@ -38,6 +38,8 @@
#include <setjmp.h>
#include <wchar.h>
#include <limits.h>
+#include <math.h>
+#include <ctype.h>
#include "config.h"
#include "lib.h"
#include "unwind.h"
@@ -259,10 +261,8 @@ int highest_bit(int_ptr_t n)
val plus(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
+tail:
+ switch (TAG_PAIR(tag(anum), tag(bnum))) {
case TAG_PAIR(TAG_NUM, TAG_NUM):
{
cnum a = c_num(anum);
@@ -271,58 +271,85 @@ val plus(val anum, val bnum)
if (sum < NUM_MIN || sum > NUM_MAX)
return bignum(sum);
- return num(sum);
+ return num_fast(sum);
}
case TAG_PAIR(TAG_NUM, TAG_PTR):
- {
- val n;
- type_check(bnum, BGNUM);
- n = make_bignum();
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum a = c_num(anum);
- cnum ap = ABS(a);
- if (a > 0)
- mp_add_d(mp(bnum), ap, mp(n));
- else
- mp_sub_d(mp(bnum), ap, mp(n));
- } else {
- mp_int tmp;
- mp_init(&tmp);
- mp_set_intptr(&tmp, c_num(anum));
- mp_add(mp(bnum), &tmp, mp(n));
- mp_clear(&tmp);
+ switch (type(bnum)) {
+ case BGNUM:
+ {
+ val n;
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum a = c_num(anum);
+ cnum ap = ABS(a);
+ if (a > 0)
+ mp_add_d(mp(bnum), ap, mp(n));
+ else
+ mp_sub_d(mp(bnum), ap, mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(anum));
+ mp_add(mp(bnum), &tmp, mp(n));
+ mp_clear(&tmp);
+ }
+ return normalize(n);
}
- return normalize(n);
+ case FLNUM:
+ return flo(c_num(anum) + c_flo(bnum));
+ default:
+ break;
}
+ break;
case TAG_PAIR(TAG_PTR, TAG_NUM):
- {
- val n;
- type_check(anum, BGNUM);
- n = make_bignum();
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum b = c_num(bnum);
- cnum bp = ABS(b);
- if (b > 0)
- mp_add_d(mp(anum), bp, mp(n));
- else
- mp_sub_d(mp(anum), bp, mp(n));
- } else {
- mp_int tmp;
- mp_init(&tmp);
- mp_set_intptr(&tmp, c_num(bnum));
- mp_add(mp(anum), &tmp, mp(n));
- mp_clear(&tmp);
+ switch (type(anum)) {
+ case BGNUM:
+ {
+ val n;
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum b = c_num(bnum);
+ cnum bp = ABS(b);
+ if (b > 0)
+ mp_add_d(mp(anum), bp, mp(n));
+ else
+ mp_sub_d(mp(anum), bp, mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(bnum));
+ mp_add(mp(anum), &tmp, mp(n));
+ mp_clear(&tmp);
+ }
+ return normalize(n);
}
- return normalize(n);
+ case FLNUM:
+ return flo(c_num(bnum) + c_flo(anum));
+ default:
+ break;
}
+ break;
case TAG_PAIR(TAG_PTR, TAG_PTR):
- {
- val n;
- type_check(anum, BGNUM);
- type_check(bnum, BGNUM);
- n = make_bignum();
- mp_add(mp(anum), mp(bnum), mp(n));
- return normalize(n);
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(BGNUM, BGNUM):
+ {
+ val n;
+ n = make_bignum();
+ mp_add(mp(anum), mp(bnum), mp(n));
+ return normalize(n);
+ }
+ case TYPE_PAIR(FLNUM, FLNUM):
+ {
+ return flo(c_flo(anum) + c_flo(bnum));
+ }
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
+ default:
+ break;
}
case TAG_PAIR(TAG_CHR, TAG_NUM):
{
@@ -354,10 +381,8 @@ char_range:
val minus(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
+tail:
+ switch (TAG_PAIR(tag(anum), tag(bnum))) {
case TAG_PAIR(TAG_NUM, TAG_NUM):
case TAG_PAIR(TAG_CHR, TAG_CHR):
{
@@ -367,59 +392,82 @@ val minus(val anum, val bnum)
if (sum < NUM_MIN || sum > NUM_MAX)
return bignum(sum);
- return num(sum);
+ return num_fast(sum);
}
case TAG_PAIR(TAG_NUM, TAG_PTR):
- {
- val n;
- type_check(bnum, BGNUM);
- n = make_bignum();
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum a = c_num(anum);
- cnum ap = ABS(a);
- if (ap > 0)
- mp_sub_d(mp(bnum), ap, mp(n));
- else
- mp_add_d(mp(bnum), ap, mp(n));
- mp_neg(mp(n), mp(n));
- } else {
- mp_int tmp;
- mp_init(&tmp);
- mp_set_intptr(&tmp, c_num(anum));
- mp_sub(mp(bnum), &tmp, mp(n));
- mp_clear(&tmp);
+ switch (type(bnum)) {
+ case BGNUM:
+ {
+ val n;
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum a = c_num(anum);
+ cnum ap = ABS(a);
+ if (ap > 0)
+ mp_sub_d(mp(bnum), ap, mp(n));
+ else
+ mp_add_d(mp(bnum), ap, mp(n));
+ mp_neg(mp(n), mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(anum));
+ mp_sub(mp(bnum), &tmp, mp(n));
+ mp_clear(&tmp);
+ }
+ return normalize(n);
}
- return normalize(n);
+ case FLNUM:
+ return flo(c_num(anum) - c_flo(bnum));
+ default:
+ break;
}
case TAG_PAIR(TAG_PTR, TAG_NUM):
- {
- val n;
- type_check(anum, BGNUM);
- n = make_bignum();
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum b = c_num(bnum);
- cnum bp = ABS(b);
- if (b > 0)
- mp_sub_d(mp(anum), bp, mp(n));
- else
- mp_add_d(mp(anum), bp, mp(n));
- } else {
- mp_int tmp;
- mp_init(&tmp);
- mp_set_intptr(&tmp, c_num(bnum));
- mp_sub(mp(anum), &tmp, mp(n));
- mp_clear(&tmp);
+ switch (type(anum)) {
+ case BGNUM:
+ {
+ val n;
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum b = c_num(bnum);
+ cnum bp = ABS(b);
+ if (b > 0)
+ mp_sub_d(mp(anum), bp, mp(n));
+ else
+ mp_add_d(mp(anum), bp, mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(bnum));
+ mp_sub(mp(anum), &tmp, mp(n));
+ mp_clear(&tmp);
+ }
+ return normalize(n);
}
- return normalize(n);
+ case FLNUM:
+ return flo(c_flo(anum) - c_num(bnum));
+ default:
+ break;
}
case TAG_PAIR(TAG_PTR, TAG_PTR):
- {
- val n;
- type_check(anum, BGNUM);
- type_check(bnum, BGNUM);
- n = make_bignum();
- mp_sub(mp(anum), mp(bnum), mp(n));
- return normalize(n);
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(BGNUM, BGNUM):
+ {
+ val n;
+ n = make_bignum();
+ mp_sub(mp(anum), mp(bnum), mp(n));
+ return normalize(n);
+ }
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return flo(c_flo(anum) - c_flo(bnum));
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
+ default:
+ break;
}
case TAG_PAIR(TAG_CHR, TAG_NUM):
{
@@ -439,34 +487,47 @@ val minus(val anum, val bnum)
val neg(val anum)
{
- if (bignump(anum)) {
- val n = make_bignum();
- mp_neg(mp(anum), mp(n));
- return n;
- } else {
- cnum n = c_num(anum);
- return num(-n);
+ switch (type(anum)) {
+ case BGNUM:
+ {
+ val n = make_bignum();
+ mp_neg(mp(anum), mp(n));
+ return n;
+ }
+ case FLNUM:
+ return flo(-c_flo(anum));
+ case NUM:
+ return num(-c_num(anum));
+ default:
+ uw_throwf(error_s, lit("neg: ~s is not a number"), anum, nao);
}
}
val abso(val anum)
{
- if (bignump(anum)) {
- val n = make_bignum();
- mp_abs(mp(anum), mp(n));
- return n;
- } else {
- cnum n = c_num(anum);
- return num(n < 0 ? -n : n);
+ switch (type(anum)) {
+ case BGNUM:
+ {
+ val n = make_bignum();
+ mp_abs(mp(anum), mp(n));
+ return n;
+ }
+ case FLNUM:
+ return flo(fabs(c_flo(anum)));
+ case NUM:
+ {
+ cnum n = c_num(anum);
+ return num(n < 0 ? -n : n);
+ }
+ default:
+ uw_throwf(error_s, lit("abso: ~s is not a number"), anum, nao);
}
}
val mul(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
+tail:
+ switch (TAG_PAIR(tag(anum), tag(bnum))) {
case TAG_PAIR(TAG_NUM, TAG_NUM):
{
cnum a = c_num(anum);
@@ -475,15 +536,15 @@ val mul(val anum, val bnum)
double_intptr_t product = a * (double_intptr_t) b;
if (product < NUM_MIN || product > NUM_MAX)
return bignum_dbl_ipt(product);
- return num(product);
+ return num_fast(product);
#else
cnum ap = ABS(a);
cnum bp = ABS(b);
if (highest_bit(ap) + highest_bit(bp) < CNUM_BIT - 1) {
cnum product = a * b;
if (product >= NUM_MIN && product <= NUM_MAX)
- return num(a * b);
- return bignum(a * b);
+ return num_fast(product);
+ return bignum(product);
} else {
val n = make_bignum();
mp_int tmpb;
@@ -497,53 +558,76 @@ val mul(val anum, val bnum)
#endif
}
case TAG_PAIR(TAG_NUM, TAG_PTR):
- {
- val n;
- type_check(bnum, BGNUM);
- n = make_bignum();
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum a = c_num(anum);
- cnum ap = ABS(a);
- mp_mul_d(mp(bnum), ap, mp(n));
- if (ap < 0)
- mp_neg(mp(n), mp(n));
- } else {
- mp_int tmp;
- mp_init(&tmp);
- mp_set_intptr(&tmp, c_num(anum));
- mp_mul(mp(bnum), &tmp, mp(n));
- mp_clear(&tmp);
+ switch (type(bnum)) {
+ case BGNUM:
+ {
+ val n;
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum a = c_num(anum);
+ cnum ap = ABS(a);
+ mp_mul_d(mp(bnum), ap, mp(n));
+ if (ap < 0)
+ mp_neg(mp(n), mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(anum));
+ mp_mul(mp(bnum), &tmp, mp(n));
+ mp_clear(&tmp);
+ }
+ return n;
}
- return n;
+ case FLNUM:
+ return flo(c_num(anum) * c_flo(bnum));
+ default:
+ break;
}
case TAG_PAIR(TAG_PTR, TAG_NUM):
- {
- val n;
- type_check(anum, BGNUM);
- n = make_bignum();
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum b = c_num(bnum);
- cnum bp = ABS(b);
- mp_mul_d(mp(anum), bp, mp(n));
- if (b < 0)
- mp_neg(mp(n), mp(n));
- } else {
- mp_int tmp;
- mp_init(&tmp);
- mp_set_intptr(&tmp, c_num(bnum));
- mp_mul(mp(anum), &tmp, mp(n));
- mp_clear(&tmp);
+ switch (type(anum)) {
+ case BGNUM:
+ {
+ val n;
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum b = c_num(bnum);
+ cnum bp = ABS(b);
+ mp_mul_d(mp(anum), bp, mp(n));
+ if (b < 0)
+ mp_neg(mp(n), mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(bnum));
+ mp_mul(mp(anum), &tmp, mp(n));
+ mp_clear(&tmp);
+ }
+ return n;
}
- return n;
+ case FLNUM:
+ return flo(c_flo(anum) * c_num(bnum));
+ default:
+ break;
}
case TAG_PAIR(TAG_PTR, TAG_PTR):
- {
- val n;
- type_check(anum, BGNUM);
- type_check(bnum, BGNUM);
- n = make_bignum();
- mp_mul(mp(anum), mp(bnum), mp(n));
- return n;
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(BGNUM, BGNUM):
+ {
+ val n;
+ n = make_bignum();
+ mp_mul(mp(anum), mp(bnum), mp(n));
+ return n;
+ }
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return flo(c_flo(anum) * c_flo(bnum));
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
+ default:
+ break;
}
}
uw_throwf(error_s, lit("mul: invalid operands ~s ~s"), anum, bnum, nao);
@@ -551,10 +635,8 @@ val mul(val anum, val bnum)
val trunc(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
+tail:
+ switch (TAG_PAIR(tag(anum), tag(bnum))) {
case TAG_PAIR(TAG_NUM, TAG_NUM):
{
cnum a = c_num(anum);
@@ -572,41 +654,82 @@ val trunc(val anum, val bnum)
}
}
case TAG_PAIR(TAG_NUM, TAG_PTR):
- type_check(bnum, BGNUM);
- return zero;
- case TAG_PAIR(TAG_PTR, TAG_NUM):
- {
- val n;
- type_check(anum, BGNUM);
- n = make_bignum();
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum b = c_num(bnum);
- cnum bp = ABS(b);
- if (mp_div_d(mp(anum), bp, mp(n), 0) != MP_OKAY)
+ switch (type(bnum)) {
+ case BGNUM:
+ return zero;
+ case FLNUM:
+ {
+ double x = c_num(anum), y = c_flo(bnum);
+ if (y == 0.0)
goto divzero;
- if (b < 0)
- mp_neg(mp(n), mp(n));
- } else {
- int err;
- mp_int tmp;
- mp_init(&tmp);
- mp_set_intptr(&tmp, c_num(bnum));
- err = mp_div(mp(anum), &tmp, mp(n), 0);
- mp_clear(&tmp);
- if (err != MP_OKAY)
+ else
+ return flo((x - fmod(x, y))/y);
+ }
+ default:
+ break;
+ }
+ break;
+ case TAG_PAIR(TAG_PTR, TAG_NUM):
+ switch (type(anum)) {
+ case BGNUM:
+ {
+ val n;
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum b = c_num(bnum);
+ cnum bp = ABS(b);
+ if (mp_div_d(mp(anum), bp, mp(n), 0) != MP_OKAY)
+ goto divzero;
+ if (b < 0)
+ mp_neg(mp(n), mp(n));
+ } else {
+ int err;
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(bnum));
+ err = mp_div(mp(anum), &tmp, mp(n), 0);
+ mp_clear(&tmp);
+ if (err != MP_OKAY)
+ goto divzero;
+ }
+ return normalize(n);
+ }
+ case FLNUM:
+ {
+ double x = c_flo(anum), y = c_num(bnum);
+ if (y == 0.0)
goto divzero;
+ else
+ return flo((x - fmod(x, y))/y);
}
- return normalize(n);
+ default:
+ break;
}
+ break;
case TAG_PAIR(TAG_PTR, TAG_PTR):
- {
- val n;
- type_check(anum, BGNUM);
- type_check(bnum, BGNUM);
- n = make_bignum();
- if (mp_div(mp(anum), mp(bnum), mp(n), 0) != MP_OKAY)
- goto divzero;
- return normalize(n);
+ switch (TYPE_PAIR(type(anum), type (bnum))) {
+ case TYPE_PAIR(BGNUM, BGNUM):
+ {
+ val n;
+ n = make_bignum();
+ if (mp_div(mp(anum), mp(bnum), mp(n), 0) != MP_OKAY)
+ goto divzero;
+ return normalize(n);
+ }
+ case TYPE_PAIR(FLNUM, FLNUM):
+ {
+ double x = c_flo(anum), y = c_flo(bnum);
+ if (y == 0.0)
+ goto divzero;
+ else
+ return flo((x - fmod(x, y))/y);
+ }
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
}
}
uw_throwf(error_s, lit("trunc: invalid operands ~s ~s"), anum, bnum, nao);
@@ -616,10 +739,8 @@ divzero:
val mod(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
+tail:
+ switch (TAG_PAIR(tag(anum), tag(bnum))) {
case TAG_PAIR(TAG_NUM, TAG_NUM):
{
cnum a = c_num(anum);
@@ -638,98 +759,121 @@ val mod(val anum, val bnum)
}
}
case TAG_PAIR(TAG_NUM, TAG_PTR):
- {
- val n;
- mp_int tmpa;
- mp_err err;
- type_check(bnum, BGNUM);
- n = make_bignum();
- mp_init(&tmpa);
- if (mp_cmp_z(mp(bnum)) == MP_LT) {
- mp_int tmpb;
- mp_init(&tmpb);
- mp_neg(mp(bnum), &tmpb);
- mp_set_intptr(&tmpa, -c_num(anum));
- err = mp_mod(&tmpa, &tmpb, mp(n));
- mp_clear(&tmpb);
- mp_neg(mp(n), mp(n));
- } else {
- mp_set_intptr(&tmpa, c_num(anum));
- err = mp_mod(&tmpa, mp(bnum), mp(n));
- }
- mp_clear(&tmpa);
- if (err != MP_OKAY)
- goto divzero;
- return normalize(n);
- }
- case TAG_PAIR(TAG_PTR, TAG_NUM):
- {
- type_check(anum, BGNUM);
- if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
- cnum b = c_num(bnum);
- mp_digit n;
+ switch (type(bnum)) {
+ case BGNUM:
+ {
+ val n;
+ mp_int tmpa;
mp_err err;
- if (b < 0) {
- mp_int tmpa;
- mp_init(&tmpa);
- mp_neg(mp(anum), &tmpa);
- err = mp_mod_d(&tmpa, -b, &n);
- mp_clear(&tmpa);
- n = -n;
+ n = make_bignum();
+ mp_init(&tmpa);
+ if (mp_cmp_z(mp(bnum)) == MP_LT) {
+ mp_int tmpb;
+ mp_init(&tmpb);
+ mp_neg(mp(bnum), &tmpb);
+ mp_set_intptr(&tmpa, -c_num(anum));
+ err = mp_mod(&tmpa, &tmpb, mp(n));
+ mp_clear(&tmpb);
+ mp_neg(mp(n), mp(n));
} else {
- err = mp_mod_d(mp(anum), b, &n);
+ mp_set_intptr(&tmpa, c_num(anum));
+ err = mp_mod(&tmpa, mp(bnum), mp(n));
}
+ mp_clear(&tmpa);
if (err != MP_OKAY)
goto divzero;
- return num(n);
- } else {
- val n = make_bignum();
- mp_int tmpb;
- mp_err err;
- cnum b = c_num(bnum);
- mp_init(&tmpb);
- if (b < 0) {
- mp_int tmpa;
+ return normalize(n);
+ }
+ case FLNUM:
+ return flo(fmod(c_num(anum), c_flo(bnum)));
+ default:
+ break;
+ }
+ break;
+ case TAG_PAIR(TAG_PTR, TAG_NUM):
+ switch (type(anum)) {
+ case BGNUM:
+ {
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ cnum b = c_num(bnum);
+ mp_digit n;
+ mp_err err;
+ if (b < 0) {
+ mp_int tmpa;
+ mp_init(&tmpa);
+ mp_neg(mp(anum), &tmpa);
+ err = mp_mod_d(&tmpa, -b, &n);
+ mp_clear(&tmpa);
+ n = -n;
+ } else {
+ err = mp_mod_d(mp(anum), b, &n);
+ }
+ if (err != MP_OKAY)
+ goto divzero;
+ return num(n);
+ } else {
+ val n = make_bignum();
+ mp_int tmpb;
+ mp_err err;
+ cnum b = c_num(bnum);
+ mp_init(&tmpb);
+ if (b < 0) {
+ mp_int tmpa;
+ mp_init(&tmpa);
+ mp_neg(mp(anum), &tmpa);
+ mp_set_intptr(&tmpb, -b);
+ err = mp_mod(&tmpa, &tmpb, mp(n));
+ mp_clear(&tmpa);
+ mp_neg(mp(n), mp(n));
+ } else {
+ mp_set_intptr(&tmpb, b);
+ err = mp_mod(mp(anum), &tmpb, mp(n));
+ }
+ mp_clear(&tmpb);
+ if (err != MP_OKAY)
+ goto divzero;
+ return normalize(n);
+ }
+ }
+ case FLNUM:
+ return flo(fmod(c_flo(anum), c_num(bnum)));
+ default:
+ break;
+ }
+ break;
+ case TAG_PAIR(TAG_PTR, TAG_PTR):
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case (TYPE_PAIR(BGNUM, BGNUM)):
+ {
+ val n;
+ n = make_bignum();
+ if (mp_cmp_z(mp(bnum)) == MP_LT) {
+ mp_int tmpa, tmpb;
+ mp_err err;
mp_init(&tmpa);
+ mp_init(&tmpb);
mp_neg(mp(anum), &tmpa);
- mp_set_intptr(&tmpb, -b);
+ mp_neg(mp(bnum), &tmpb);
err = mp_mod(&tmpa, &tmpb, mp(n));
mp_clear(&tmpa);
+ mp_clear(&tmpb);
+ if (err != MP_OKAY)
+ goto divzero;
mp_neg(mp(n), mp(n));
} else {
- mp_set_intptr(&tmpb, b);
- err = mp_mod(mp(anum), &tmpb, mp(n));
+ if (mp_mod(mp(anum), mp(bnum), mp(n)) != MP_OKAY)
+ goto divzero;
}
- mp_clear(&tmpb);
- if (err != MP_OKAY)
- goto divzero;
return normalize(n);
}
- }
- case TAG_PAIR(TAG_PTR, TAG_PTR):
- {
- val n;
- type_check(anum, BGNUM);
- type_check(bnum, BGNUM);
- n = make_bignum();
- if (mp_cmp_z(mp(bnum)) == MP_LT) {
- mp_int tmpa, tmpb;
- mp_err err;
- mp_init(&tmpa);
- mp_init(&tmpb);
- mp_neg(mp(anum), &tmpa);
- mp_neg(mp(bnum), &tmpb);
- err = mp_mod(&tmpa, &tmpb, mp(n));
- mp_clear(&tmpa);
- mp_clear(&tmpb);
- if (err != MP_OKAY)
- goto divzero;
- mp_neg(mp(n), mp(n));
- } else {
- if (mp_mod(mp(anum), mp(bnum), mp(n)) != MP_OKAY)
- goto divzero;
- }
- return normalize(n);
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return flo(fmod(c_flo(anum), c_flo(bnum)));
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
}
}
uw_throwf(error_s, lit("mod: invalid operands ~s ~s"), anum, bnum, nao);
@@ -737,68 +881,103 @@ divzero:
uw_throw(numeric_error_s, lit("mod: division by zero"));
}
+static val to_float(val func, val num)
+{
+ switch (type(num)) {
+ case NUM:
+ case BGNUM:
+ return flo_int(num);
+ case FLNUM:
+ return num;
+ default:
+ uw_throwf(error_s, lit("~s: invalid operand ~s"), func, num);
+ }
+}
+
+val divi(val anum, val bnum)
+{
+ double a = c_flo(to_float(lit("divi"), anum));
+ double b = c_flo(to_float(lit("divi"), bnum));
+
+ if (b == 0.0)
+ uw_throw(numeric_error_s, lit("divi: division by zero"));
+
+ return flo(a / b);
+}
+
val zerop(val num)
{
if (num == zero)
return t;
- if (!fixnump(num) && !bignump(num))
+ switch (type(num)) {
+ case NUM:
+ case BGNUM:
+ return nil;
+ case FLNUM:
+ return if2(c_flo(num) == 0.0, t);
+ default:
uw_throwf(error_s, lit("zerop: ~s is not a number"), num, nao);
- return nil;
+ }
}
val evenp(val num)
{
- switch (tag(num)) {
- case TAG_NUM:
+ switch (type(num)) {
+ case NUM:
return (c_num(num) % 2 == 0) ? t : nil;
- case TAG_PTR:
- if (num->t.type == BGNUM)
- return mp_iseven(mp(num)) ? t : nil;
- /* fallthrough */
+ case BGNUM:
+ return mp_iseven(mp(num)) ? t : nil;
default:
- uw_throwf(error_s, lit("evenp: ~s is not a number"), num, nao);
+ uw_throwf(error_s, lit("evenp: ~s is not an integer"), num, nao);
return nil;
}
}
val oddp(val num)
{
- switch (tag(num)) {
- case TAG_NUM:
+ switch (type(num)) {
+ case NUM:
return (c_num(num) % 2 != 0) ? t : nil;
- case TAG_PTR:
- if (num->t.type == BGNUM)
- return mp_isodd(mp(num)) ? t : nil;
- /* fallthrough */
+ case BGNUM:
+ return mp_isodd(mp(num)) ? t : nil;
default:
- uw_throwf(error_s, lit("oddp: ~s is not a number"), num, nao);
+ uw_throwf(error_s, lit("oddp: ~s is not an integer"), num, nao);
return nil;
}
}
val gt(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
- case TAG_PAIR(TAG_NUM, TAG_NUM):
- case TAG_PAIR(TAG_CHR, TAG_CHR):
- case TAG_PAIR(TAG_NUM, TAG_CHR):
- case TAG_PAIR(TAG_CHR, TAG_NUM):
+tail:
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(NUM, NUM):
+ case TYPE_PAIR(CHR, CHR):
+ case TYPE_PAIR(NUM, CHR):
+ case TYPE_PAIR(CHR, NUM):
return c_num(anum) > c_num(bnum) ? t : nil;
- case TAG_PAIR(TAG_NUM, TAG_PTR):
- case TAG_PAIR(TAG_CHR, TAG_PTR):
- type_check(bnum, BGNUM);
+ case TYPE_PAIR(NUM, BGNUM):
+ case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_LT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_NUM):
- case TAG_PAIR(TAG_PTR, TAG_CHR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, NUM):
+ case TYPE_PAIR(BGNUM, CHR):
return mp_cmp_z(mp(anum)) == MP_GT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_PTR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, BGNUM):
return mp_cmp(mp(anum), mp(bnum)) == MP_GT ? t : nil;
+ case TYPE_PAIR(NUM, FLNUM):
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_num(anum) > c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, NUM):
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum) > c_num(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return c_flo(anum) > c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
}
uw_throwf(error_s, lit("gt: invalid operands ~s ~s"), anum, bnum, nao);
@@ -806,26 +985,35 @@ val gt(val anum, val bnum)
val lt(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
- case TAG_PAIR(TAG_NUM, TAG_NUM):
- case TAG_PAIR(TAG_CHR, TAG_CHR):
- case TAG_PAIR(TAG_NUM, TAG_CHR):
- case TAG_PAIR(TAG_CHR, TAG_NUM):
+tail:
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(NUM, NUM):
+ case TYPE_PAIR(CHR, CHR):
+ case TYPE_PAIR(NUM, CHR):
+ case TYPE_PAIR(CHR, NUM):
return c_num(anum) < c_num(bnum) ? t : nil;
- case TAG_PAIR(TAG_NUM, TAG_PTR):
- case TAG_PAIR(TAG_CHR, TAG_PTR):
- type_check(bnum, BGNUM);
+ case TYPE_PAIR(NUM, BGNUM):
+ case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_GT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_NUM):
- case TAG_PAIR(TAG_PTR, TAG_CHR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, NUM):
+ case TYPE_PAIR(BGNUM, CHR):
return mp_cmp_z(mp(anum)) == MP_LT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_PTR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, BGNUM):
return mp_cmp(mp(anum), mp(bnum)) == MP_LT ? t : nil;
+ case TYPE_PAIR(NUM, FLNUM):
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_num(anum) < c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, NUM):
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum) < c_num(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return c_flo(anum) < c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
}
uw_throwf(error_s, lit("lt: invalid operands ~s ~s"), anum, bnum, nao);
@@ -833,31 +1021,40 @@ val lt(val anum, val bnum)
val ge(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
- case TAG_PAIR(TAG_NUM, TAG_NUM):
- case TAG_PAIR(TAG_CHR, TAG_CHR):
- case TAG_PAIR(TAG_NUM, TAG_CHR):
- case TAG_PAIR(TAG_CHR, TAG_NUM):
+tail:
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(NUM, NUM):
+ case TYPE_PAIR(CHR, CHR):
+ case TYPE_PAIR(NUM, CHR):
+ case TYPE_PAIR(CHR, NUM):
return c_num(anum) >= c_num(bnum) ? t : nil;
- case TAG_PAIR(TAG_NUM, TAG_PTR):
- case TAG_PAIR(TAG_CHR, TAG_PTR):
- type_check(bnum, BGNUM);
+ case TYPE_PAIR(NUM, BGNUM):
+ case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_LT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_NUM):
- case TAG_PAIR(TAG_PTR, TAG_CHR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, NUM):
+ case TYPE_PAIR(BGNUM, CHR):
return mp_cmp_z(mp(anum)) == MP_GT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_PTR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, BGNUM):
switch (mp_cmp(mp(anum), mp(bnum))) {
case MP_GT: case MP_EQ:
return t;
default:
return nil;
}
+ case TYPE_PAIR(NUM, FLNUM):
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_num(anum) >= c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, NUM):
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum) >= c_num(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return c_flo(anum) >= c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
}
uw_throwf(error_s, lit("ge: invalid operands ~s ~s"), anum, bnum, nao);
@@ -865,31 +1062,40 @@ val ge(val anum, val bnum)
val le(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
- case TAG_PAIR(TAG_NUM, TAG_NUM):
- case TAG_PAIR(TAG_CHR, TAG_CHR):
- case TAG_PAIR(TAG_NUM, TAG_CHR):
- case TAG_PAIR(TAG_CHR, TAG_NUM):
+tail:
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(NUM, NUM):
+ case TYPE_PAIR(CHR, CHR):
+ case TYPE_PAIR(NUM, CHR):
+ case TYPE_PAIR(CHR, NUM):
return c_num(anum) <= c_num(bnum) ? t : nil;
- case TAG_PAIR(TAG_NUM, TAG_PTR):
- case TAG_PAIR(TAG_CHR, TAG_PTR):
- type_check(bnum, BGNUM);
+ case TYPE_PAIR(NUM, BGNUM):
+ case TYPE_PAIR(CHR, BGNUM):
return mp_cmp_z(mp(bnum)) == MP_GT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_NUM):
- case TAG_PAIR(TAG_PTR, TAG_CHR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, NUM):
+ case TYPE_PAIR(BGNUM, CHR):
return mp_cmp_z(mp(anum)) == MP_LT ? t : nil;
- case TAG_PAIR(TAG_PTR, TAG_PTR):
- type_check(anum, BGNUM);
+ case TYPE_PAIR(BGNUM, BGNUM):
switch (mp_cmp(mp(anum), mp(bnum))) {
case MP_LT: case MP_EQ:
return t;
default:
return nil;
}
+ case TYPE_PAIR(NUM, FLNUM):
+ case TYPE_PAIR(CHR, FLNUM):
+ return c_num(anum) <= c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, NUM):
+ case TYPE_PAIR(FLNUM, CHR):
+ return c_flo(anum) <= c_num(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return c_flo(anum) <= c_flo(bnum) ? t : nil;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
}
uw_throwf(error_s, lit("lt: invalid operands ~s ~s"), anum, bnum, nao);
@@ -897,11 +1103,9 @@ val le(val anum, val bnum)
val expt(val anum, val bnum)
{
- int tag_a = tag(anum);
- int tag_b = tag(bnum);
-
- switch (TAG_PAIR(tag_a, tag_b)) {
- case TAG_PAIR(TAG_NUM, TAG_NUM):
+tail:
+ switch (TYPE_PAIR(type(anum), type(bnum))) {
+ case TYPE_PAIR(NUM, NUM):
{
cnum a = c_num(anum);
cnum b = c_num(bnum);
@@ -928,12 +1132,11 @@ val expt(val anum, val bnum)
mp_clear(&tmpa);
return normalize(n);
}
- case TAG_PAIR(TAG_NUM, TAG_PTR):
+ case TYPE_PAIR(NUM, BGNUM):
{
cnum a = c_num(anum);
mp_int tmpa;
val n;
- type_check(bnum, BGNUM);
if (mp_cmp_z(mp(bnum)) == MP_LT)
goto negexp;
n = make_bignum();
@@ -943,11 +1146,10 @@ val expt(val anum, val bnum)
mp_clear(&tmpa);
return normalize(n);
}
- case TAG_PAIR(TAG_PTR, TAG_NUM):
+ case TYPE_PAIR(BGNUM, NUM):
{
cnum b = c_num(bnum);
val n;
- type_check(anum, BGNUM);
if (b < 0)
goto negexp;
if (bnum == zero)
@@ -966,11 +1168,9 @@ val expt(val anum, val bnum)
}
return normalize(n);
}
- case TAG_PAIR(TAG_PTR, TAG_PTR):
+ case TYPE_PAIR(BGNUM, BGNUM):
{
val n;
- type_check(anum, BGNUM);
- type_check(bnum, BGNUM);
if (mp_cmp_z(mp(bnum)) == MP_LT)
goto negexp;
n = make_bignum();
@@ -978,6 +1178,19 @@ val expt(val anum, val bnum)
normalize(n);
return n;
}
+ case TYPE_PAIR(NUM, FLNUM):
+ /* TODO: error checking */
+ return flo(pow(c_num(anum), c_flo(bnum)));
+ case TYPE_PAIR(FLNUM, NUM):
+ return flo(pow(c_flo(anum), c_num(bnum)));
+ case TYPE_PAIR(FLNUM, FLNUM):
+ return flo(pow(c_flo(anum), c_flo(bnum)));
+ case TYPE_PAIR(BGNUM, FLNUM):
+ anum = flo_int(anum);
+ goto tail;
+ case TYPE_PAIR(FLNUM, BGNUM):
+ bnum = flo_int(bnum);
+ goto tail;
}
uw_throwf(error_s, lit("expt: invalid operands ~s ~s"), anum, bnum, nao);
@@ -989,7 +1202,7 @@ val exptmod(val base, val exp, val mod)
{
val n;
- if (!numberp(base) || !numberp(exp) || !numberp(mod))
+ if (!integerp(base) || !integerp(exp) || !integerp(mod))
goto inval;
if (fixnump(base))
@@ -1008,7 +1221,7 @@ val exptmod(val base, val exp, val mod)
return n;
inval:
- uw_throwf(error_s, lit("exptmod: invalid operands ~s ~s ~s"),
+ uw_throwf(error_s, lit("exptmod: non-integral operands ~s ~s ~s"),
base, exp, mod, nao);
}
@@ -1028,27 +1241,35 @@ static int_ptr_t isqrt_fixnum(int_ptr_t a)
val isqrt(val anum)
{
- if (fixnump(anum)) {
- cnum a = c_num(anum);
- if (a < 0)
- goto negop;
- return num_fast(isqrt_fixnum(c_num(anum)));
- } else if (bignump(anum)) {
- val n = make_bignum();
- if (mp_sqrt(mp(anum), mp(n)) != MP_OKAY)
- goto negop;
- return normalize(n);
+ switch (type(anum)) {
+ case NUM:
+ {
+ cnum a = c_num(anum);
+ if (a < 0)
+ goto negop;
+ return num_fast(isqrt_fixnum(c_num(anum)));
+ }
+ case BGNUM:
+ {
+ val n = make_bignum();
+ if (mp_sqrt(mp(anum), mp(n)) != MP_OKAY)
+ goto negop;
+ return normalize(n);
+ }
+ default:
+ break;
}
- uw_throwf(error_s, lit("sqrt: invalid operand ~s"), anum, nao);
+
+ uw_throwf(error_s, lit("isqrt: non-integer operand ~s"), anum, nao);
negop:
- uw_throw(error_s, lit("sqrt: negative operand"));
+ uw_throw(error_s, lit("isqrt: negative operand"));
}
val gcd(val anum, val bnum)
{
val n;
- if (!numberp(anum) || !numberp(bnum))
+ if (!integerp(anum) || !integerp(bnum))
goto inval;
if (fixnump(anum))
@@ -1064,10 +1285,125 @@ val gcd(val anum, val bnum)
return n;
inval:
- uw_throwf(error_s, lit("gcd: invalid operands ~s ~s ~s"),
+ uw_throwf(error_s, lit("gcd: non-integral operands ~s ~s"),
anum, bnum, nao);
}
+val floorf(val num)
+{
+ return flo(floor(c_flo(to_float(lit("floor"), num))));
+}
+
+val ceili(val num)
+{
+ return flo(ceil(c_flo(to_float(lit("ceil"), num))));
+}
+
+val sine(val num)
+{
+ return flo(sin(c_flo(to_float(lit("sin"), num))));
+}
+
+val cosi(val num)
+{
+ return flo(cos(c_flo(to_float(lit("cos"), num))));
+}
+
+val atang(val num)
+{
+ return flo(atan(c_flo(to_float(lit("atan"), num))));
+}
+
+val loga(val num)
+{
+ return flo(log(c_flo(to_float(lit("log"), num))));
+}
+
+val expo(val num)
+{
+ return flo(exp(c_flo(to_float(lit("exp"), num))));
+}
+
+val sqroot(val num)
+{
+ return flo(sqrt(c_flo(to_float(lit("sqrt"), num))));
+}
+
+/*
+ * TODO: replace this text-based hack!
+ */
+val int_flo(val f)
+{
+ double d = c_flo(f);
+
+ if (d >= INT_PTR_MAX && d <= INT_PTR_MIN) {
+ cnum n = d;
+ if (n < NUM_MIN || n > NUM_MAX)
+ return bignum(n);
+ return num_fast(n);
+ } else {
+ char text[128];
+ char mint[128] = "", mfrac[128] = "", *pint = mint;
+ int have_point, have_exp;
+ int exp = 0, fdigs;
+
+ sprintf(text, "%.64g", d);
+
+ if (!isdigit(text[0]))
+ uw_throwf(error_s,
+ lit("int-flo: cannot convert #<bad-float> to integer"),
+ nao);
+
+ have_exp = (strchr(text, 'e') != 0);
+ have_point = (strchr(text, '.') != 0);
+
+ if (have_exp && have_point)
+ sscanf(text, "%127[0-9].%127[0-9]e%d", mint, mfrac, &exp);
+ else if (have_exp)
+ sscanf(text, "%127[0-9]e%d", mint, &exp);
+ else if (have_point)
+ sscanf(text, "%127[0-9].%127[0-9]", mint, mfrac);
+ else
+ return int_str(string_utf8(text), nil);
+
+ if (have_exp && exp < 0)
+ return zero;
+
+ fdigs = have_point ? strlen(mfrac) : 0;
+
+ if (exp <= fdigs) {
+ fdigs = exp;
+ exp = 0;
+ } else {
+ exp -= fdigs;
+ }
+
+ {
+ char mintfrac[256];
+ val out;
+ val e10 = (exp == 0) ? one : expt(num_fast(10), num(exp));
+ sprintf(mintfrac, "%s%.*s", pint, fdigs, mfrac);
+ out = int_str(string_utf8(mintfrac), nil);
+ return mul(out, e10);
+ }
+ }
+}
+
+val flo_int(val i)
+{
+ if (fixnump(i))
+ return flo(c_num(i));
+
+ {
+ double d;
+ type_check(i, BGNUM);
+ if (mp_to_double(mp(i), &d) != MP_OKAY)
+ uw_throwf(error_s, lit("flo-int: bignum to float conversion failed"),
+ nao);
+ return flo(d);
+ }
+}
+
void arith_init(void)
{
mp_init(&NUM_MAX_MP);
diff --git a/configure b/configure
index 042a736a..76c47d47 100755
--- a/configure
+++ b/configure
@@ -757,12 +757,16 @@ char SIZEOF_SUPERLONG_T[sizeof (superlong_t)];
if [ $SIZEOF_PTR -eq $SIZEOF_SHORT ] ; then
intptr="short"
+ uintptr=y
elif [ $SIZEOF_PTR -eq $SIZEOF_INT ] ; then
intptr="int"
+ uintptr=y
elif [ $SIZEOF_PTR -eq $SIZEOF_LONG ] ; then
intptr="long"
+ uintptr=y
elif [ $SIZEOF_PTR -eq $SIZEOF_LONG_LONG_T ] ; then
intptr="longlong_t"
+ uintptr=$ulonglong
fi
if [ -z "$intptr" ] ; then
@@ -773,6 +777,10 @@ fi
printf '"%s"\n' "$intptr"
printf "typedef $intptr int_ptr_t;\n" >> config.h
+if [ -n "$uintptr" ] ; then
+ printf "#define HAVE_UINTPTR_T 1\n" >> config.h
+ printf "typedef unsigned $intptr uint_ptr_t;\n" >> config.h
+fi
intptr_max_expr="((((($intptr) 1 << $((SIZEOF_PTR * 8 - 2))) - 1) << 1) + 1)"
printf "#define INT_PTR_MAX %s\n" "$intptr_max_expr" >> config.h
printf "#define INT_PTR_MIN (-INT_PTR_MAX)\n" >> config.h
diff --git a/eval.c b/eval.c
index 74acb79f..fbe63d3a 100644
--- a/eval.c
+++ b/eval.c
@@ -1496,7 +1496,7 @@ static val transform_op(val forms, val syms, val rg)
if (consp(fi) && car(fi) == var_s && consp(cdr(fi))) {
val vararg = car(cdr(fi));
- if (numberp(vararg)) {
+ if (integerp(vararg)) {
val prefix = format(nil, lit("arg-~,02s-"), vararg, nao);
val newsyms = syms;
val new_p;
@@ -2182,12 +2182,23 @@ void eval_init(void)
reg_fun(intern(lit("abs"), user_package), func_n1(abso));
reg_fun(intern(lit("trunc"), user_package), func_n2(trunc));
reg_fun(intern(lit("mod"), user_package), func_n2(mod));
+ reg_fun(intern(lit("/"), user_package), func_n2(divi));
reg_fun(intern(lit("expt"), user_package), func_n0v(exptv));
reg_fun(intern(lit("exptmod"), user_package), func_n3(exptmod));
- reg_fun(intern(lit("sqrt"), user_package), func_n1(isqrt));
+ reg_fun(intern(lit("isqrt"), user_package), func_n1(isqrt));
reg_fun(intern(lit("gcd"), user_package), func_n2(gcd));
+ reg_fun(intern(lit("floor"), user_package), func_n1(floorf));
+ reg_fun(intern(lit("ceil"), user_package), func_n1(ceili));
+ reg_fun(intern(lit("sin"), user_package), func_n1(sine));
+ reg_fun(intern(lit("cos"), user_package), func_n1(cosi));
+ reg_fun(intern(lit("atan"), user_package), func_n1(atang));
+ reg_fun(intern(lit("log"), user_package), func_n1(loga));
+ reg_fun(intern(lit("exp"), user_package), func_n1(expo));
+ reg_fun(intern(lit("sqrt"), user_package), func_n1(sqroot));
reg_fun(intern(lit("fixnump"), user_package), func_n1(fixnump));
reg_fun(intern(lit("bignump"), user_package), func_n1(bignump));
+ reg_fun(intern(lit("floatp"), user_package), func_n1(floatp));
+ reg_fun(intern(lit("integerp"), user_package), func_n1(integerp));
reg_fun(intern(lit("numberp"), user_package), func_n1(numberp));
reg_fun(intern(lit("zerop"), user_package), func_n1(zerop));
@@ -2288,6 +2299,9 @@ void eval_init(void)
reg_fun(intern(lit("trim-str"), user_package), func_n1(trim_str));
reg_fun(intern(lit("string-lt"), user_package), func_n2(string_lt));
reg_fun(intern(lit("int-str"), user_package), func_n2o(int_str, 1));
+ reg_fun(intern(lit("flo-str"), user_package), func_n1(flo_str));
+ reg_fun(intern(lit("int-flo"), user_package), func_n1(int_flo));
+ reg_fun(intern(lit("flo-int"), user_package), func_n1(flo_int));
reg_fun(intern(lit("chrp"), user_package), func_n1(chrp));
reg_fun(intern(lit("chr-isalnum"), user_package), func_n1(chr_isalnum));
reg_fun(intern(lit("chr-isalpha"), user_package), func_n1(chr_isalpha));
diff --git a/gc.c b/gc.c
index b2247a9b..2b2567b9 100644
--- a/gc.c
+++ b/gc.c
@@ -186,30 +186,28 @@ static void finalize(val obj)
switch (obj->t.type) {
case NIL:
case CONS:
- return;
- case STR:
- free(obj->st.str);
- obj->st.str = 0;
- return;
case CHR:
case NUM:
case LIT:
case SYM:
case PKG:
case FUN:
+ case LCONS:
+ case LSTR:
+ case ENV:
+ case FLNUM:
+ return;
+ case STR:
+ free(obj->st.str);
+ obj->st.str = 0;
return;
case VEC:
free(obj->v.vec-2);
obj->v.vec = 0;
return;
- case LCONS:
- case LSTR:
- return;
case COBJ:
obj->co.ops->destroy(obj);
return;
- case ENV:
- return;
case BGNUM:
mp_clear(mp(obj));
return;
@@ -262,6 +260,7 @@ tail_call:
case NUM:
case LIT:
case BGNUM:
+ case FLNUM:
return;
case CONS:
mark_obj(obj->c.car);
diff --git a/hash.c b/hash.c
index c9e69261..f6c5a69c 100644
--- a/hash.c
+++ b/hash.c
@@ -90,6 +90,24 @@ static unsigned long hash_c_str(const wchar_t *str)
return h;
}
+static cnum hash_double(double n)
+{
+#ifdef HAVE_UINTPTR_T
+ uint_ptr_t h = 0;
+#else
+ unsigned long h = 0;
+#endif
+
+ mem_t *p = (mem_t *) &n, *q = p + sizeof(double);
+
+ while (p < q) {
+ h = h << 8 | h >> (8 * sizeof h - 1);
+ h += *p++;
+ }
+
+ return h & NUM_MAX;
+}
+
static cnum equal_hash(val obj)
{
switch (type(obj)) {
@@ -135,6 +153,8 @@ static cnum equal_hash(val obj)
return equal_hash(obj->ls.prefix);
case BGNUM:
return mp_hash(mp(obj)) & NUM_MAX;
+ case FLNUM:
+ return hash_double(obj->fl.n);
case COBJ:
return obj->co.ops->hash(obj) & NUM_MAX;
}
@@ -150,6 +170,8 @@ static cnum eql_hash(val obj)
return NUM_MAX;
if (obj->t.type == BGNUM)
return mp_hash(mp(obj)) & NUM_MAX;
+ if (obj->t.type == FLNUM)
+ return hash_double(obj->fl.n);
switch (sizeof (mem_t *)) {
case 4:
return (((cnum) obj) >> 4) & NUM_MAX;
diff --git a/lib.c b/lib.c
index ec72754f..21b87fed 100644
--- a/lib.c
+++ b/lib.c
@@ -35,6 +35,7 @@
#include <setjmp.h>
#include <errno.h>
#include <wchar.h>
+#include <math.h>
#include "config.h"
#ifdef HAVE_GETENVIRONMENTSTRINGS
#define NOMINMAX
@@ -61,7 +62,7 @@ val system_package, keyword_package, user_package;
val null, t, cons_s, str_s, chr_s, fixnum_s, sym_s, pkg_s, fun_s, vec_s;
val stream_s, hash_s, hash_iter_s, lcons_s, lstr_s, cobj_s, cptr_s;
-val env_s, bignum_s;
+val env_s, bignum_s, float_s;
val var_s, expr_s, regex_s, chset_s, set_s, cset_s, wild_s, oneplus_s;
val nongreedy_s, compiled_regex_s;
val quote_s, qquote_s, unquote_s, splice_s;
@@ -116,6 +117,7 @@ static val code2type(int code)
case COBJ: return cobj_s;
case ENV: return env_s;
case BGNUM: return bignum_s;
+ case FLNUM: return float_s;
}
return nil;
}
@@ -909,6 +911,10 @@ val equal(val left, val right)
if (type(right) == BGNUM && mp_cmp(mp(left), mp(right)) == MP_EQ)
return t;
return nil;
+ case FLNUM:
+ if (type(right) == FLNUM && left->fl.n == right->fl.n)
+ return t;
+ return nil;
case COBJ:
if (type(right) == COBJ)
return left->co.ops->equal(left, right);
@@ -1121,6 +1127,20 @@ cnum c_num(val num)
}
}
+val flo(double n)
+{
+ val obj = make_obj();
+ obj->fl.type = FLNUM;
+ obj->fl.n = n;
+ return obj;
+}
+
+double c_flo(val num)
+{
+ type_check(num, FLNUM);
+ return num->fl.n;
+}
+
val fixnump(val num)
{
return (is_num(num)) ? t : nil;
@@ -1131,7 +1151,7 @@ val bignump(val num)
return (type(num) == BGNUM) ? t : nil;
}
-val numberp(val num)
+val integerp(val num)
{
switch (tag(num)) {
case TAG_NUM:
@@ -1147,6 +1167,27 @@ val numberp(val num)
}
}
+val floatp(val num)
+{
+ return (type(num) == FLNUM) ? t : nil;
+}
+
+val numberp(val num)
+{
+ switch (tag(num)) {
+ case TAG_NUM:
+ return t;
+ case TAG_PTR:
+ if (num == nil)
+ return nil;
+ if (num->t.type == BGNUM || num->t.type == FLNUM)
+ return t;
+ /* fallthrough */
+ default:
+ return nil;
+ }
+}
+
val plusv(val nlist)
{
if (!nlist)
@@ -1916,6 +1957,20 @@ val int_str(val str, val base)
return num(value);
}
+val flo_str(val str)
+{
+ const wchar_t *wcs = c_str(str);
+ wchar_t *ptr;
+
+ /* TODO: detect if we have wcstod */
+ double value = wcstod(wcs, &ptr);
+ if (value == 0 && ptr == wcs)
+ return nil;
+ if ((value == HUGE_VAL || value == -HUGE_VAL) && errno == ERANGE)
+ return nil;
+ return flo(value);
+}
+
val chrp(val chr)
{
return (is_chr(chr)) ? t : nil;
@@ -3978,6 +4033,7 @@ static void obj_init(void)
cptr_s = intern(lit("cptr"), user_package);
env_s = intern(lit("env"), user_package);
bignum_s = intern(lit("bignum"), user_package);
+ float_s = intern(lit("float"), user_package);
var_s = intern(lit("var"), system_package);
expr_s = intern(lit("expr"), system_package);
regex_s = intern(lit("regex"), system_package);
@@ -4169,6 +4225,7 @@ val obj_print(val obj, val out)
return obj;
case NUM:
case BGNUM:
+ case FLNUM:
format(out, lit("~s"), obj, nao);
return obj;
case SYM:
@@ -4272,6 +4329,7 @@ val obj_pprint(val obj, val out)
return obj;
case NUM:
case BGNUM:
+ case FLNUM:
format(out, lit("~s"), obj, nao);
return obj;
case SYM:
diff --git a/lib.h b/lib.h
index e33667a4..7c197e0a 100644
--- a/lib.h
+++ b/lib.h
@@ -40,9 +40,12 @@ typedef int_ptr_t cnum;
typedef enum type {
NIL, NUM = TAG_NUM, CHR = TAG_CHR, LIT = TAG_LIT, CONS,
STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, ENV,
- BGNUM
+ BGNUM, FLNUM
} type_t;
+#define TYPE_SHIFT 4
+#define TYPE_PAIR(A, B) ((A) << TYPE_SHIFT | (B))
+
typedef enum functype
{
FINTERP, /* Interpreted function. */
@@ -193,6 +196,11 @@ struct bignum {
mp_int mp;
};
+struct flonum {
+ type_t type;
+ double n;
+};
+
union obj {
struct any t;
struct cons c;
@@ -206,6 +214,7 @@ union obj {
struct cobj co;
struct env e;
struct bignum bn;
+ struct flonum fl;
};
INLINE cnum tag(val obj) { return ((cnum) obj) & TAG_MASK; }
@@ -280,7 +289,7 @@ INLINE val chr(wchar_t ch)
extern val keyword_package, system_package, user_package;
extern val null, t, cons_s, str_s, chr_s, fixnum_s, sym_s, pkg_s, fun_s, vec_s;
extern val stream_s, hash_s, hash_iter_s, lcons_s, lstr_s, cobj_s, cptr_s;
-extern val env_s, bignum_s;
+extern val env_s, bignum_s, float_s;
extern val var_s, expr_s, regex_s, chset_s, set_s, cset_s, wild_s, oneplus_s;
extern val nongreedy_s, compiled_regex_s;
extern val quote_s, qquote_s, unquote_s, splice_s;
@@ -378,9 +387,13 @@ val getplist_f(val list, val key, val *found);
val proper_plist_to_alist(val list);
val improper_plist_to_alist(val list, val boolean_keys);
val num(cnum val);
+val flo(double val);
cnum c_num(val num);
+double c_flo(val num);
val fixnump(val num);
val bignump(val num);
+val floatp(val num);
+val integerp(val num);
val numberp(val num);
val plus(val anum, val bnum);
val plusv(val nlist);
@@ -392,6 +405,7 @@ val mul(val anum, val bnum);
val mulv(val nlist);
val trunc(val anum, val bnum);
val mod(val anum, val bnum);
+val divi(val anum, val bnum);
val zerop(val num);
val evenp(val num);
val oddp(val num);
@@ -410,8 +424,16 @@ val minv(val first, val rest);
val expt(val base, val exp);
val exptv(val nlist);
val exptmod(val base, val exp, val mod);
+val sqroot(val anum);
val isqrt(val anum);
val gcd(val anum, val bnum);
+val floorf(val);
+val ceili(val);
+val sine(val);
+val cosi(val);
+val atang(val);
+val loga(val);
+val expo(val);
val string_own(wchar_t *str);
val string(const wchar_t *str);
val string_utf8(const char *str);
@@ -439,6 +461,9 @@ val list_str(val str);
val trim_str(val str);
val string_lt(val astr, val bstr);
val int_str(val str, val base);
+val flo_str(val str);
+val int_flo(val f);
+val flo_int(val i);
val chrp(val chr);
wchar_t c_chr(val chr);
val chr_isalnum(val ch);
diff --git a/mpi-patches/mpi-to-double b/mpi-patches/mpi-to-double
new file mode 100644
index 00000000..608e9dc3
--- /dev/null
+++ b/mpi-patches/mpi-to-double
@@ -0,0 +1,58 @@
+Index: mpi-1.8.6/mpi.c
+===================================================================
+--- mpi-1.8.6.orig/mpi.c 2012-03-20 22:20:10.242815758 -0700
++++ mpi-1.8.6/mpi.c 2012-03-21 06:48:36.401050757 -0700
+@@ -14,6 +14,7 @@
+ #include <stdlib.h>
+ #include <string.h>
+ #include <ctype.h>
++#include <math.h>
+
+ typedef unsigned char mem_t;
+ extern mem_t *chk_malloc(size_t size);
+@@ -2329,6 +2330,29 @@
+
+ /* }}} */
+
++mp_err mp_to_double(mp_int *mp, double *d)
++{
++ int ix;
++ mp_size used = USED(mp);
++ mp_digit *dp = DIGITS(mp);
++ static double mult;
++ double out = dp[used - 1];
++
++ if (!mult)
++ mult = pow(2.0, MP_DIGIT_BIT);
++
++ for (ix = (int) used - 2; ix >= 0; ix--) {
++ out = out * mult;
++ out += (double) dp[ix];
++ }
++
++ if (SIGN(mp) == MP_NEG)
++ out = -out;
++
++ *d = out;
++ return MP_OKAY;
++}
++
+ /*------------------------------------------------------------------------*/
+ /* {{{ mp_print(mp, ofp) */
+
+Index: mpi-1.8.6/mpi.h
+===================================================================
+--- mpi-1.8.6.orig/mpi.h 2012-03-20 22:20:09.994676258 -0700
++++ mpi-1.8.6/mpi.h 2012-03-20 22:20:10.498959758 -0700
+@@ -187,6 +187,11 @@
+ #endif /* end MP_NUMTH */
+
+ /*------------------------------------------------------------------------*/
++/* Conversions */
++
++mp_err mp_to_double(mp_int *mp, double *d);
++
++/*------------------------------------------------------------------------*/
+ /* Input and output */
+
+ #if MP_IOFUNC
diff --git a/mpi-patches/series b/mpi-patches/series
index 0181c920..c880ab60 100644
--- a/mpi-patches/series
+++ b/mpi-patches/series
@@ -12,3 +12,4 @@ fix-bad-shifts
bit-search-optimizations
shrink-mpi-int
faster-square-root
+mpi-to-double
diff --git a/parser.l b/parser.l
index 76ba8203..52aab27c 100644
--- a/parser.l
+++ b/parser.l
@@ -149,7 +149,12 @@ static wchar_t num_esc(char *num)
%option noinput
SYM [a-zA-Z0-9_]+
-NUM [+\-]?[0-9]+
+SGN [+\-]
+EXP [eE][+\-]?[0-9]+
+DIG [0-9]
+NUM {SGN}?{DIG}+
+FLO {SGN}?({DIG}*[.]{DIG}+{EXP}?|{DIG}+[.]?{EXP})
+FLODOT {SGN}?{DIG}+[.]
BSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~]
BSYM {BSCHR}({BSCHR}|#)*
NSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~/]
@@ -185,7 +190,29 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
|| yy_top_state() == QSILIT)
yy_pop_state();
- yylval.num = int_str(str, num(10));
+ yylval.val = int_str(str, num(10));
+ return NUMBER;
+}
+
+<SPECIAL,NESTED,BRACED>{FLO} {
+ val str = string_own(utf8_dup_from(yytext));
+
+ if (yy_top_state() == INITIAL
+ || yy_top_state() == QSILIT)
+ yy_pop_state();
+
+ yylval.val = flo_str(str);
+ return NUMBER;
+}
+
+<SPECIAL,NESTED,BRACED>{FLODOT}/[^.] {
+ val str = string_own(utf8_dup_from(yytext));
+
+ if (yy_top_state() == INITIAL
+ || yy_top_state() == QSILIT)
+ yy_pop_state();
+
+ yylval.val = flo_str(str);
return NUMBER;
}
@@ -195,7 +222,7 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
if (yy_top_state() == INITIAL
|| yy_top_state() == QSILIT)
yy_pop_state();
- yylval.num = int_str(str, num(10));
+ yylval.val = int_str(str, num(10));
return METANUM;
}
diff --git a/parser.y b/parser.y
index 29e678d5..7a058d60 100644
--- a/parser.y
+++ b/parser.y
@@ -63,7 +63,6 @@ static val parsed_spec;
wchar_t *lexeme;
union obj *val;
wchar_t chr;
- union obj *num;
cnum lineno;
}
diff --git a/stream.c b/stream.c
index 4a2e4e7f..a4b7863d 100644
--- a/stream.c
+++ b/stream.c
@@ -32,8 +32,10 @@
#include <assert.h>
#include <setjmp.h>
#include <errno.h>
+#include <ctype.h>
#include <wchar.h>
#include <unistd.h>
+#include <float.h>
#include "config.h"
#if HAVE_SYS_WAIT
#include <sys/wait.h>
@@ -959,7 +961,7 @@ val vformat(val stream, val fmtstr, va_list vl)
enum {
vf_init, vf_width, vf_digits, vf_precision, vf_spec
} state = vf_init, saved_state = vf_init;
- int width = 0, precision = 0, digits = 0;
+ int width = 0, precision = 0, precision_p = 0, digits = 0;
int left = 0, sign = 0, zeropad = 0;
cnum value;
void *ptr;
@@ -967,7 +969,7 @@ val vformat(val stream, val fmtstr, va_list vl)
for (;;) {
val obj;
wchar_t ch = *fmt++;
- char num_buf[64], *pnum = num_buf;
+ char num_buf[512], *pnum = num_buf;
switch (state) {
case vf_init:
@@ -980,6 +982,7 @@ val vformat(val stream, val fmtstr, va_list vl)
left = 0;
zeropad = 0;
precision = 0;
+ precision_p = 0;
digits = 0;
continue;
default:
@@ -1034,6 +1037,7 @@ val vformat(val stream, val fmtstr, va_list vl)
obj = va_arg(vl, val);
width = c_num(obj);
precision = vf_precision;
+ precision_p = 1;
continue;
default:
state = vf_spec;
@@ -1066,6 +1070,7 @@ val vformat(val stream, val fmtstr, va_list vl)
continue;
case vf_precision:
precision = digits;
+ precision_p = 1;
state = vf_spec;
--fmt;
continue;
@@ -1113,25 +1118,99 @@ val vformat(val stream, val fmtstr, va_list vl)
sprintf(num_buf, num_fmt->oct, value);
}
goto output_num;
+ case 'f': case 'e':
+ obj = va_arg(vl, val);
+
+ if (obj == nao)
+ goto premature;
+
+ {
+ double n;
+
+ switch (type(obj)) {
+ case BGNUM:
+ obj = flo_int(obj);
+ /* fallthrough */
+ case FLNUM:
+ n = c_flo(obj);
+ break;
+ case NUM:
+ n = (double) c_num(obj);
+ break;
+ default:
+ uw_throwf(error_s, lit("format: ~~~a conversion requires "
+ "numeric arg: ~s given\n"),
+ chr(ch), obj, nao);
+ }
+
+ if (!precision_p)
+ precision = 3;
+
+ /* guard against num_buf overflow */
+ if (precision > 128)
+ uw_throwf(error_s, lit("excessive precision in format: ~s\n"),
+ num(precision), nao);
+
+ if (ch == 'e')
+ sprintf(num_buf, "%.*e", precision, n);
+ else
+ sprintf(num_buf, "%.*f", precision, n);
+ if (!isdigit(num_buf[0])) {
+ if (!vformat_str(stream, lit("#<bad-float>"),
+ width, left, 0))
+ return nil;
+ continue;
+ }
+ precision = 0;
+ goto output_num;
+ }
case 'a': case 's':
obj = va_arg(vl, val);
if (obj == nao)
goto premature;
- if (fixnump(obj)) {
+ switch (type(obj)) {
+ case NUM:
value = c_num(obj);
sprintf(num_buf, num_fmt->dec, value);
goto output_num;
- } else if (bignump(obj)) {
- int nchars = mp_radix_size(mp(obj), 10);
- if (nchars >= (int) sizeof (num_buf))
- pnum = (char *) chk_malloc(nchars + 1);
- mp_toradix(mp(obj), (unsigned char *) pnum, 10);
+ case BGNUM:
+ {
+ int nchars = mp_radix_size(mp(obj), 10);
+ if (nchars >= (int) sizeof (num_buf))
+ pnum = (char *) chk_malloc(nchars + 1);
+ mp_toradix(mp(obj), (unsigned char *) pnum, 10);
+ }
goto output_num;
- } else if (width != 0) {
- val str = format(nil, ch == 'a' ? lit("~a") : lit("~s"), obj, nao);
- if (!vformat_str(stream, str, width, left, precision))
- return nil;
- continue;
+ case FLNUM:
+ if (!precision_p)
+ precision = DBL_DIG;
+
+ if (precision > 500)
+ uw_throwf(error_s, lit("excessive precision in format: ~s\n"),
+ num(precision), nao);
+
+ sprintf(num_buf, "%.*g", precision, obj->fl.n);
+
+ if (ch == 's' && !precision_p && !strpbrk(num_buf, "e."))
+ strcat(num_buf, ".0");
+
+ if (!isdigit(num_buf[0]) && !isdigit(num_buf[1])) {
+ if (!vformat_str(stream, lit("#<bad-float>"),
+ width, left, 0))
+ return nil;
+ continue;
+ }
+
+ precision = 0;
+ goto output_num;
+ default:
+ if (width != 0) {
+ val str = format(nil, ch == 'a' ? lit("~a") : lit("~s"),
+ obj, nao);
+ if (!vformat_str(stream, str, width, left, precision))
+ return nil;
+ continue;
+ }
}
if (ch == 'a')
obj_pprint(obj, stream);
diff --git a/txr.1 b/txr.1
index a95f23b7..af743a4b 100644
--- a/txr.1
+++ b/txr.1
@@ -6641,15 +6641,21 @@ symbols, packages, or streams are equal if they are the same hash.
Certain object types have a custom equal function.
-.SS Arithmetic functions +, -, *, trunc, mod, expt, sqrt
+.SS Arithmetic functions +, -, *
-.SS Arithmetic function exptmod
+.SS Arithmetic function /, trunc, mod
.SS Arithmetic function gcd
.SS Arithmetic function abs
-.SS Functions fixnump, bignump, numberp
+.SS Arithmetic functions floor, ceil, sin, cos, atan, log, exp
+
+.SS Arithmetic functions expt, sqrt, isqrt
+
+.SS Arithmetic function exptmod
+
+.SS Functions fixnump, bignump, integerp, floatp, numberp
.SS Functions zerop, evenp, oddp
@@ -6771,7 +6777,9 @@ Certain object types have a custom equal function.
.SS Function string-lt
-.SS Function int-str
+.SS Functions int-str and float-str
+
+.SS Functions int-flo and flo-int
.SS Function chrp
diff --git a/txr.vim b/txr.vim
index d80f24f5..88313eb8 100644
--- a/txr.vim
+++ b/txr.vim
@@ -42,8 +42,10 @@ syn keyword txl_keyword contained second third fourth fifth sixth copy-list nrev
syn keyword txl_keyword contained reverse ldiff flatten lazy-flatten
syn keyword txl_keyword contained memq memql memqual tree-find some
syn keyword txl_keyword contained remq remql remqual
-syn keyword txl_keyword contained all none eq eql equal + - * abs trunc mod
-syn keyword txl_keyword contained expt exptmod sqrt gcd fixnump bignump
+syn keyword txl_keyword contained all none eq eql equal + - * / abs trunc mod
+syn keyword txl_keyword contained expt exptmod sqrt isqrt gcd
+syn keyword txl_keyword contained floor ceil sin cos atan log exp
+syn keyword txl_keyword contained fixnump bignump integerp floatp
syn keyword txl_keyword contained numberp zerop evenp oddp >
syn keyword txl_keyword contained zerop evenp oddp > < >= <= max min
syn keyword txl_keyword contained search-regex match-regex regsub
@@ -65,7 +67,8 @@ syn keyword txl_keyword contained mkstring copy-str upcase-str downcase-str stri
syn keyword txl_keyword contained stringp lazy-stringp length-str search-str search-str-tree
syn keyword txl_keyword contained sub-str cat-str split-str replace-str
syn keyword txl_keyword contained split-str-set list-str trim-str
-syn keyword txl_keyword contained string-lt int-str chrp chr-isalnum chr-isalpha
+syn keyword txl_keyword contained string-lt int-str flo-str int-flo flo-int
+syn keyword txl_keyword contained chrp chr-isalnum chr-isalpha
syn keyword txl_keyword contained chr-isascii chr-iscntrl chr-isdigit chr-isgraph
syn keyword txl_keyword contained chr-islower chr-isprint chr-ispunct chr-isspace chr-isupper
syn keyword txl_keyword contained chr-isxdigit chr-toupper chr-tolower chr-str
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-09 17:48:31 +0000