From 16414f430caa17fccb2e15611a367bb9236ac0ee Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Mon, 19 Mar 2012 02:00:45 -0700 Subject: * 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: 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. --- ChangeLog | 40 ++++++++++++++++++++++++++++++++++++++++ configure | 8 ++++++++ eval.c | 3 +++ gc.c | 19 +++++++++---------- hash.c | 22 ++++++++++++++++++++++ lib.c | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-- lib.h | 14 ++++++++++++-- parser.l | 16 ++++++++++++++-- parser.y | 1 - 9 files changed, 162 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6ea80d12..f378d7ba 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,43 @@ +2012-03-19 Kaz Kylheku + + * 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: 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-18 Kaz Kylheku * eval.c (eval_init): url_decode has two parameters now, 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..26e31f59 100644 --- a/eval.c +++ b/eval.c @@ -2188,6 +2188,8 @@ void eval_init(void) reg_fun(intern(lit("gcd"), user_package), func_n2(gcd)); 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 +2290,7 @@ 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("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..306d1118 100644 --- a/lib.c +++ b/lib.c @@ -35,6 +35,7 @@ #include #include #include +#include #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,14 @@ cnum c_num(val num) } } +val flo(double n) +{ + val obj = make_obj(); + obj->fl.type = FLNUM; + obj->fl.n = n; + return obj; +} + val fixnump(val num) { return (is_num(num)) ? t : nil; @@ -1131,7 +1145,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 +1161,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 +1951,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 +4027,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 +4219,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 +4323,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..47fa3d38 100644 --- a/lib.h +++ b/lib.h @@ -40,7 +40,7 @@ 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; typedef enum functype @@ -193,6 +193,11 @@ struct bignum { mp_int mp; }; +struct flonum { + type_t type; + double n; +}; + union obj { struct any t; struct cons c; @@ -206,6 +211,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 +286,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 +384,12 @@ 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); 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); @@ -439,6 +448,7 @@ 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 chrp(val chr); wchar_t c_chr(val chr); val chr_isalnum(val ch); diff --git a/parser.l b/parser.l index 76ba8203..58276605 100644 --- a/parser.l +++ b/parser.l @@ -150,6 +150,7 @@ static wchar_t num_esc(char *num) SYM [a-zA-Z0-9_]+ NUM [+\-]?[0-9]+ +FLO [+\-]?[0-9]+([.][0-9]+)?([eE][+-]?[0-9]+)? BSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~] BSYM {BSCHR}({BSCHR}|#)* NSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~/] @@ -185,7 +186,18 @@ 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; +} + +{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; } @@ -195,7 +207,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; } -- cgit v1.2.3 From e75c5716a22e2c977648230e0d9a0917b41afe56 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Mon, 19 Mar 2012 19:31:37 -0700 Subject: * 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. --- ChangeLog | 11 +++++++++++ stream.c | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 65 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index f378d7ba..f3c1822a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2012-03-19 Kaz Kylheku + + * 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 * configure (uintptr): New variable. Indicates whether unsigned diff --git a/stream.c b/stream.c index 4a2e4e7f..2d7a6e94 100644 --- a/stream.c +++ b/stream.c @@ -967,7 +967,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[256], *pnum = num_buf; switch (state) { case vf_init: @@ -1113,6 +1113,40 @@ 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; + + if (bignump(obj)) + uw_throwf(error_s, lit("format: ~s: bignum to float " + "conversion unsupported\n"), obj, nao); + + if (fixnump(obj)) + n = (double) c_num(obj); + else if (floatp(obj)) + n = obj->fl.n; + else + uw_throwf(error_s, lit("format: ~~~a conversion requires " + "numeric arg: ~s given\n"), + chr(ch), obj, nao); + + /* 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, obj->fl.n); + else + sprintf(num_buf, "%.*f", precision, obj->fl.n); + precision = 0; + goto output_num; + } case 'a': case 's': obj = va_arg(vl, val); if (obj == nao) @@ -1127,6 +1161,25 @@ val vformat(val stream, val fmtstr, va_list vl) pnum = (char *) chk_malloc(nchars + 1); mp_toradix(mp(obj), (unsigned char *) pnum, 10); goto output_num; + } else if (floatp(obj)) { + sprintf(num_buf, "%g", obj->fl.n); + + if (!precision) { + if (!strpbrk(num_buf, "e.")) + strcat(num_buf, ".0"); + } else { + /* guard against num_buf overflow */ + if (precision > 128) + uw_throwf(error_s, lit("excessive precision in format: ~s\n"), + num(precision), nao); + + if (strchr(num_buf, 'e')) + sprintf(num_buf, "%.*e", precision, obj->fl.n); + else + sprintf(num_buf, "%.*f", precision, obj->fl.n); + precision = 0; + } + 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)) -- cgit v1.2.3 From 49b84f76e1036ebeb75b4348d1d0cf7fdf233939 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Tue, 20 Mar 2012 00:14:07 -0700 Subject: * parser.l (FLO): Adjusted syntax of floating point numbers to allow leading or trailing decimal. --- ChangeLog | 5 +++++ parser.l | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index f3c1822a..582151d3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-03-20 Kaz Kylheku + + * parser.l (FLO): Adjusted syntax of floating point numbers + to allow leading or trailing decimal. + 2012-03-19 Kaz Kylheku * stream.c (vformat): num_buf increased to 256 because we diff --git a/parser.l b/parser.l index 58276605..d8fd9150 100644 --- a/parser.l +++ b/parser.l @@ -150,7 +150,7 @@ static wchar_t num_esc(char *num) SYM [a-zA-Z0-9_]+ NUM [+\-]?[0-9]+ -FLO [+\-]?[0-9]+([.][0-9]+)?([eE][+-]?[0-9]+)? +FLO [+\-]?([0-9]+[.]?[0-9]*|[0-9]*[.][0-9]+)([eE][+-]?[0-9]+)? BSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~] BSYM {BSCHR}({BSCHR}|#)* NSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~/] -- cgit v1.2.3 From 270dcc27814f4bd80f625b85e9ff91e7c5a8e8a8 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Tue, 20 Mar 2012 12:11:38 -0700 Subject: * 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. --- ChangeLog | 17 ++++++ arith.c | 181 ++++++++++++++++++++++++++++++++++++++++++++++---------------- eval.c | 1 + lib.c | 6 +++ lib.h | 5 ++ 5 files changed, 164 insertions(+), 46 deletions(-) diff --git a/ChangeLog b/ChangeLog index 582151d3..21b6aa76 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2012-03-20 Kaz Kylheku + + * 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 * parser.l (FLO): Adjusted syntax of floating point numbers diff --git a/arith.c b/arith.c index 450b4e38..5c17048d 100644 --- a/arith.c +++ b/arith.c @@ -271,58 +271,92 @@ 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)) { + 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); + } + case FLNUM: + { 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 flo((double) a + c_flo(bnum)); } - return normalize(n); + 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)) { + switch (type(anum)) { + case BGNUM: + { + 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); + } + return normalize(n); + } + case FLNUM: + { 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 flo((double) b + c_flo(anum)); } - 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(); - 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; + type_check(anum, BGNUM); + type_check(bnum, BGNUM); + 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): + case TYPE_PAIR(FLNUM, BGNUM): + uw_throwf(error_s, lit("plus: unimplemented bignum float combo ~s ~s"), + anum, bnum, nao); + default: + break; } case TAG_PAIR(TAG_CHR, TAG_NUM): { @@ -367,7 +401,7 @@ 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): { @@ -475,15 +509,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; @@ -1068,6 +1102,61 @@ inval: anum, bnum, nao); } +/* + * 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); + + 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); + } + } +} + void arith_init(void) { mp_init(&NUM_MAX_MP); diff --git a/eval.c b/eval.c index 26e31f59..c56919a7 100644 --- a/eval.c +++ b/eval.c @@ -2291,6 +2291,7 @@ void eval_init(void) 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("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/lib.c b/lib.c index 306d1118..21b87fed 100644 --- a/lib.c +++ b/lib.c @@ -1135,6 +1135,12 @@ val flo(double 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; diff --git a/lib.h b/lib.h index 47fa3d38..211d27de 100644 --- a/lib.h +++ b/lib.h @@ -43,6 +43,9 @@ typedef enum type { BGNUM, FLNUM } type_t; +#define TYPE_SHIFT 4 +#define TYPE_PAIR(A, B) ((A) << TYPE_SHIFT | (B)) + typedef enum functype { FINTERP, /* Interpreted function. */ @@ -386,6 +389,7 @@ 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); @@ -449,6 +453,7 @@ 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 chrp(val chr); wchar_t c_chr(val chr); val chr_isalnum(val ch); -- cgit v1.2.3 From fe69004a3798e896cf7349149c6c37ec58676b45 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Tue, 20 Mar 2012 20:59:12 -0700 Subject: * 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. --- ChangeLog | 13 +++++++++++ arith.c | 15 ++++++++++++ eval.c | 1 + lib.h | 1 + mpi-patches/mpi-to-double | 58 +++++++++++++++++++++++++++++++++++++++++++++++ mpi-patches/series | 1 + 6 files changed, 89 insertions(+) create mode 100644 mpi-patches/mpi-to-double diff --git a/ChangeLog b/ChangeLog index 21b6aa76..78f6910d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2012-03-20 Kaz Kylheku + + * 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 * arith.c (plus): Optimization: use num_fast when diff --git a/arith.c b/arith.c index 5c17048d..769da0d0 100644 --- a/arith.c +++ b/arith.c @@ -1157,6 +1157,21 @@ val int_flo(val f) } } +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/eval.c b/eval.c index c56919a7..e185acb0 100644 --- a/eval.c +++ b/eval.c @@ -2292,6 +2292,7 @@ void eval_init(void) 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/lib.h b/lib.h index 211d27de..df9c2592 100644 --- a/lib.h +++ b/lib.h @@ -454,6 +454,7 @@ 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..653d612c --- /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 20:23:46.604727758 -0700 ++++ mpi-1.8.6/mpi.c 2012-03-20 20:37:28.514792258 -0700 +@@ -14,6 +14,7 @@ + #include + #include + #include ++#include + + 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 20:23:39.184556258 -0700 ++++ mpi-1.8.6/mpi.h 2012-03-20 20:25:30.018865508 -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 -- cgit v1.2.3 From 66c9a8587cb22b031b5234cc5fcc93354574ca9a Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Tue, 20 Mar 2012 21:48:13 -0700 Subject: * stream.c (vformat): Use larger num_buf buffer so we don't overrun. IEEE double floats can go to e+-308. --- ChangeLog | 5 +++++ stream.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 78f6910d..f4f4efde 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-03-20 Kaz Kylheku + + * 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 * arith.c (flo_int): New function. diff --git a/stream.c b/stream.c index 2d7a6e94..f9b1eb25 100644 --- a/stream.c +++ b/stream.c @@ -967,7 +967,7 @@ val vformat(val stream, val fmtstr, va_list vl) for (;;) { val obj; wchar_t ch = *fmt++; - char num_buf[256], *pnum = num_buf; + char num_buf[512], *pnum = num_buf; switch (state) { case vf_init: -- cgit v1.2.3 From bc665592de673232748e12f189121ee5a8360b93 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Tue, 20 Mar 2012 22:11:27 -0700 Subject: * arith.c (plus): Completed implementation of bignum-float and float-bignum cases. --- ChangeLog | 5 +++++ arith.c | 12 ++++++------ 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index f4f4efde..2c70a4e0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-03-20 Kaz Kylheku + + * arith.c (plus): Completed implementation of bignum-float + and float-bignum cases. + 2012-03-20 Kaz Kylheku * stream.c (vformat): Use larger num_buf buffer so we don't diff --git a/arith.c b/arith.c index 769da0d0..09529b43 100644 --- a/arith.c +++ b/arith.c @@ -259,10 +259,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); @@ -352,9 +350,11 @@ val plus(val anum, val bnum) return flo(c_flo(anum) + c_flo(bnum)); } case TYPE_PAIR(BGNUM, FLNUM): + anum = flo_int(anum); + goto tail; case TYPE_PAIR(FLNUM, BGNUM): - uw_throwf(error_s, lit("plus: unimplemented bignum float combo ~s ~s"), - anum, bnum, nao); + bnum = flo_int(bnum); + goto tail; default: break; } -- cgit v1.2.3 From ff8a6cce170ecb6c523b6c59a865946f402226b5 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Tue, 20 Mar 2012 23:07:10 -0700 Subject: 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. --- ChangeLog | 13 +++++++++++++ parser.l | 11 ++++++++--- 2 files changed, 21 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2c70a4e0..d0d773da 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2012-03-20 Kaz Kylheku + + 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 * arith.c (plus): Completed implementation of bignum-float diff --git a/parser.l b/parser.l index d8fd9150..449cc148 100644 --- a/parser.l +++ b/parser.l @@ -149,8 +149,12 @@ static wchar_t num_esc(char *num) %option noinput SYM [a-zA-Z0-9_]+ -NUM [+\-]?[0-9]+ -FLO [+\-]?([0-9]+[.]?[0-9]*|[0-9]*[.][0-9]+)([eE][+-]?[0-9]+)? +SGN [+\-] +EXP [eE][+\-]?[0-9]+ +DIG [0-9] +NUM {SGN}?{DIG}+ +FLO {SGN}?{DIG}*[.]({DIG}+{EXP}?|{EXP}) +FLODOT {SGN}?{DIG}+[.] BSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~] BSYM {BSCHR}({BSCHR}|#)* NSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~/] @@ -190,7 +194,8 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U} return NUMBER; } -{FLO} { +{FLODOT}/[^.] | +{FLO} { val str = string_own(utf8_dup_from(yytext)); if (yy_top_state() == INITIAL -- cgit v1.2.3 From e399295ee017de3fe490c4c952701c95baa019e9 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 06:56:22 -0700 Subject: * 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. --- ChangeLog | 9 ++++ arith.c | 129 ++++++++++++++++++++++++++-------------------- mpi-patches/mpi-to-double | 10 ++-- 3 files changed, 87 insertions(+), 61 deletions(-) diff --git a/ChangeLog b/ChangeLog index d0d773da..2fe03180 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2012-03-21 Kaz Kylheku + + * 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 Regression fix: 1..3 scans incorrectly into 1. .3 tokens. diff --git a/arith.c b/arith.c index 09529b43..f2f033ea 100644 --- a/arith.c +++ b/arith.c @@ -294,10 +294,7 @@ tail: return normalize(n); } case FLNUM: - { - cnum a = c_num(anum); - return flo((double) a + c_flo(bnum)); - } + return flo((double) c_num(anum) + c_flo(bnum)); default: break; } @@ -326,10 +323,7 @@ tail: return normalize(n); } case FLNUM: - { - cnum b = c_num(bnum); - return flo((double) b + c_flo(anum)); - } + return flo((double) c_num(bnum) + c_flo(anum)); default: break; } @@ -388,10 +382,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): { @@ -404,56 +396,81 @@ val minus(val anum, val bnum) 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((double) 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) - (double) 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; + type_check(anum, BGNUM); + type_check(bnum, BGNUM); + 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): { diff --git a/mpi-patches/mpi-to-double b/mpi-patches/mpi-to-double index 653d612c..608e9dc3 100644 --- a/mpi-patches/mpi-to-double +++ b/mpi-patches/mpi-to-double @@ -1,7 +1,7 @@ Index: mpi-1.8.6/mpi.c =================================================================== ---- mpi-1.8.6.orig/mpi.c 2012-03-20 20:23:46.604727758 -0700 -+++ mpi-1.8.6/mpi.c 2012-03-20 20:37:28.514792258 -0700 +--- 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 #include @@ -25,7 +25,7 @@ Index: mpi-1.8.6/mpi.c + if (!mult) + mult = pow(2.0, MP_DIGIT_BIT); + -+ for (ix = (int) used - 2; ix >= 0; ix++) { ++ for (ix = (int) used - 2; ix >= 0; ix--) { + out = out * mult; + out += (double) dp[ix]; + } @@ -42,8 +42,8 @@ Index: mpi-1.8.6/mpi.c Index: mpi-1.8.6/mpi.h =================================================================== ---- mpi-1.8.6.orig/mpi.h 2012-03-20 20:23:39.184556258 -0700 -+++ mpi-1.8.6/mpi.h 2012-03-20 20:25:30.018865508 -0700 +--- 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 */ -- cgit v1.2.3 From e7d17c45b37c145eff23a8fc6e602346f9b65fe3 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 07:59:24 -0700 Subject: * 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. --- ChangeLog | 15 +++++++++++++++ arith.c | 20 +++++++++++++------- parser.l | 14 ++++++++++++-- stream.c | 53 +++++++++++++++++++++++++++++++---------------------- 4 files changed, 71 insertions(+), 31 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2fe03180..160c1eb5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +2012-03-21 Kaz Kylheku + + * 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 * arith.c (plus): Minor code simplification. diff --git a/arith.c b/arith.c index f2f033ea..838d39dd 100644 --- a/arith.c +++ b/arith.c @@ -490,13 +490,19 @@ tail: 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); } } diff --git a/parser.l b/parser.l index 449cc148..7e07f79f 100644 --- a/parser.l +++ b/parser.l @@ -194,8 +194,18 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U} return NUMBER; } -{FLODOT}/[^.] | -{FLO} { +{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; +} + +{FLODOT}/[^.] { val str = string_own(utf8_dup_from(yytext)); if (yy_top_state() == INITIAL diff --git a/stream.c b/stream.c index f9b1eb25..6110e1d6 100644 --- a/stream.c +++ b/stream.c @@ -1122,18 +1122,21 @@ val vformat(val stream, val fmtstr, va_list vl) { double n; - if (bignump(obj)) - uw_throwf(error_s, lit("format: ~s: bignum to float " - "conversion unsupported\n"), obj, nao); - - if (fixnump(obj)) + switch (type(obj)) { + case BGNUM: + obj = flo_int(obj); + /* fallthrough */ + case FLNUM: + n = c_flo(obj); + break; + case NUM: n = (double) c_num(obj); - else if (floatp(obj)) - n = obj->fl.n; - else + break; + default: uw_throwf(error_s, lit("format: ~~~a conversion requires " "numeric arg: ~s given\n"), chr(ch), obj, nao); + } /* guard against num_buf overflow */ if (precision > 128) @@ -1141,9 +1144,9 @@ val vformat(val stream, val fmtstr, va_list vl) num(precision), nao); if (ch == 'e') - sprintf(num_buf, "%.*e", precision, obj->fl.n); + sprintf(num_buf, "%.*e", precision, n); else - sprintf(num_buf, "%.*f", precision, obj->fl.n); + sprintf(num_buf, "%.*f", precision, n); precision = 0; goto output_num; } @@ -1151,17 +1154,20 @@ val vformat(val stream, val fmtstr, va_list vl) 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 (floatp(obj)) { + case FLNUM: sprintf(num_buf, "%g", obj->fl.n); if (!precision) { @@ -1180,11 +1186,14 @@ val vformat(val stream, val fmtstr, va_list vl) precision = 0; } 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; + 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); -- cgit v1.2.3 From 85370261a9c374e22ab6beadcc7c53663372f03e Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 09:43:52 -0700 Subject: * Makefile: link in -lm, which is needed now on some systems. * arith.c (plus, minus): Eliminated some unnecessary (double) casts. (abso, mul): Floating support. --- ChangeLog | 7 +++ Makefile | 2 +- arith.c | 145 ++++++++++++++++++++++++++++++++++++++------------------------ 3 files changed, 97 insertions(+), 57 deletions(-) diff --git a/ChangeLog b/ChangeLog index 160c1eb5..f27fbf6d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2012-03-21 Kaz Kylheku + + * 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 * arith.c (neg): Floating-point support. 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 838d39dd..51fcaa25 100644 --- a/arith.c +++ b/arith.c @@ -38,6 +38,7 @@ #include #include #include +#include #include "config.h" #include "lib.h" #include "unwind.h" @@ -294,7 +295,7 @@ tail: return normalize(n); } case FLNUM: - return flo((double) c_num(anum) + c_flo(bnum)); + return flo(c_num(anum) + c_flo(bnum)); default: break; } @@ -323,7 +324,7 @@ tail: return normalize(n); } case FLNUM: - return flo((double) c_num(bnum) + c_flo(anum)); + return flo(c_num(bnum) + c_flo(anum)); default: break; } @@ -419,7 +420,7 @@ tail: return normalize(n); } case FLNUM: - return flo((double) c_num(anum) - c_flo(bnum)); + return flo(c_num(anum) - c_flo(bnum)); default: break; } @@ -446,7 +447,7 @@ tail: return normalize(n); } case FLNUM: - return flo(c_flo(anum) - (double) c_num(bnum)); + return flo(c_flo(anum) - c_num(bnum)); default: break; } @@ -508,22 +509,29 @@ val neg(val anum) 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); @@ -554,53 +562,78 @@ 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; + type_check(anum, BGNUM); + type_check(bnum, BGNUM); + 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); -- cgit v1.2.3 From 0ab41f3caba2bb60a876a400dbd206e73c844b29 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 15:29:31 -0700 Subject: * txr.1: Doc stubs for new functions floatp, integerp, float-str, int-flo and flo-int. * txr.vim: Highlighting for new functions. --- ChangeLog | 7 +++++++ txr.1 | 6 ++++-- txr.vim | 4 +++- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index f27fbf6d..de1ce0ca 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2012-03-21 Kaz Kylheku + + * 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 * Makefile: link in -lm, which is needed now on some systems. diff --git a/txr.1 b/txr.1 index a95f23b7..ab0fd70b 100644 --- a/txr.1 +++ b/txr.1 @@ -6649,7 +6649,7 @@ Certain object types have a custom equal function. .SS Arithmetic function abs -.SS Functions fixnump, bignump, numberp +.SS Functions fixnump, bignump, integerp, floatp, numberp .SS Functions zerop, evenp, oddp @@ -6771,7 +6771,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..0ec1dd72 100644 --- a/txr.vim +++ b/txr.vim @@ -44,6 +44,7 @@ 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 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 +66,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 -- cgit v1.2.3 From a084df5e0f237ae0e331f2fe43f850853eec5fb6 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 15:50:28 -0700 Subject: * arith.c (plus, minus, mul): Removing unnecessary type checks, which are already implied by the switch case. --- ChangeLog | 5 +++++ arith.c | 7 ------- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index de1ce0ca..0b07cdbf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-03-21 Kaz Kylheku + + * arith.c (plus, minus, mul): Removing unnecessary type checks, + which are already implied by the switch case. + 2012-03-21 Kaz Kylheku * txr.1: Doc stubs for new functions floatp, integerp, diff --git a/arith.c b/arith.c index 51fcaa25..1a5981ec 100644 --- a/arith.c +++ b/arith.c @@ -305,7 +305,6 @@ tail: case BGNUM: { val n; - type_check(anum, BGNUM); n = make_bignum(); if (sizeof (int_ptr_t) <= sizeof (mp_digit)) { cnum b = c_num(bnum); @@ -334,8 +333,6 @@ tail: case TYPE_PAIR(BGNUM, BGNUM): { val n; - type_check(anum, BGNUM); - type_check(bnum, BGNUM); n = make_bignum(); mp_add(mp(anum), mp(bnum), mp(n)); return normalize(n); @@ -456,8 +453,6 @@ tail: case TYPE_PAIR(BGNUM, BGNUM): { val n; - type_check(anum, BGNUM); - type_check(bnum, BGNUM); n = make_bignum(); mp_sub(mp(anum), mp(bnum), mp(n)); return normalize(n); @@ -618,8 +613,6 @@ tail: case TYPE_PAIR(BGNUM, BGNUM): { val n; - type_check(anum, BGNUM); - type_check(bnum, BGNUM); n = make_bignum(); mp_mul(mp(anum), mp(bnum), mp(n)); return n; -- cgit v1.2.3 From 56600f5e7ceb6339a20966b0f827634c8a7bf8ff Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 15:52:09 -0700 Subject: * arith.c (trunc): Floating support. --- ChangeLog | 4 +++ arith.c | 107 ++++++++++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 77 insertions(+), 34 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0b07cdbf..c2add367 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2012-03-21 Kaz Kylheku + + * arith.c (trunc): Floating support. + 2012-03-21 Kaz Kylheku * arith.c (plus, minus, mul): Removing unnecessary type checks, diff --git a/arith.c b/arith.c index 1a5981ec..f97a163a 100644 --- a/arith.c +++ b/arith.c @@ -634,10 +634,8 @@ tail: 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); @@ -655,41 +653,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); -- cgit v1.2.3 From 551a986c12660fa5a4b36fe22262e7d5255c9994 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 16:03:47 -0700 Subject: * arith.c (mod): Floating support. --- ChangeLog | 4 ++ arith.c | 185 ++++++++++++++++++++++++++++++++++---------------------------- 2 files changed, 107 insertions(+), 82 deletions(-) diff --git a/ChangeLog b/ChangeLog index c2add367..4ae9d8bd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2012-03-21 Kaz Kylheku + + * arith.c (mod): Floating support. + 2012-03-21 Kaz Kylheku * arith.c (trunc): Floating support. diff --git a/arith.c b/arith.c index f97a163a..f888ca6f 100644 --- a/arith.c +++ b/arith.c @@ -738,10 +738,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); @@ -760,98 +758,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); -- cgit v1.2.3 From 3f7c28ed9255ce0332b2e9214ee771c8a1a8dd1c Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 21 Mar 2012 16:47:46 -0700 Subject: * 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. --- ChangeLog | 12 ++++++++++++ arith.c | 38 ++++++++++++++++++++++++++++++++++++++ eval.c | 1 + lib.h | 1 + txr.1 | 2 +- txr.vim | 2 +- 6 files changed, 54 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4ae9d8bd..7bce62db 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2012-03-21 Kaz Kylheku + + * 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 * arith.c (mod): Floating support. diff --git a/arith.c b/arith.c index f888ca6f..87565a7e 100644 --- a/arith.c +++ b/arith.c @@ -880,6 +880,44 @@ divzero: uw_throw(numeric_error_s, lit("mod: division by zero")); } +val divi(val anum, val bnum) +{ + switch (type(anum)) { + case NUM: + case BGNUM: + anum = flo_int(anum); + case FLNUM: + break; + default: + goto type; + } + + switch (type(bnum)) { + case NUM: + case BGNUM: + bnum = flo_int(bnum); + case FLNUM: + break; + default: + goto type; + } + + { + double a = c_flo(anum); + double b = c_flo(bnum); + + if (b == 0.0) + goto divzero; + + return flo(a / b); + } + +divzero: + uw_throw(numeric_error_s, lit("divi: division by zero")); +type: + uw_throwf(error_s, lit("divi: invalid operands ~s ~s"), anum, bnum, nao); +} + val zerop(val num) { if (num == zero) diff --git a/eval.c b/eval.c index e185acb0..823a20d0 100644 --- a/eval.c +++ b/eval.c @@ -2182,6 +2182,7 @@ 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)); diff --git a/lib.h b/lib.h index df9c2592..6ce793b3 100644 --- a/lib.h +++ b/lib.h @@ -405,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); diff --git a/txr.1 b/txr.1 index ab0fd70b..685c5f82 100644 --- a/txr.1 +++ b/txr.1 @@ -6641,7 +6641,7 @@ 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 +, -, *, /, trunc, mod, expt, sqrt .SS Arithmetic function exptmod diff --git a/txr.vim b/txr.vim index 0ec1dd72..11af4e68 100644 --- a/txr.vim +++ b/txr.vim @@ -42,7 +42,7 @@ 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 all none eq eql equal + - * / abs trunc mod syn keyword txl_keyword contained expt exptmod sqrt gcd fixnump bignump syn keyword txl_keyword contained integerp floatp syn keyword txl_keyword contained numberp zerop evenp oddp > -- cgit v1.2.3 From d4a331511ffa45f41a0a619649e366905e406037 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 22 Mar 2012 01:47:23 -0700 Subject: * 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. --- ChangeLog | 14 +++ arith.c | 316 +++++++++++++++++++++++++++++++++++--------------------------- eval.c | 2 +- lib.h | 2 +- 4 files changed, 197 insertions(+), 137 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7bce62db..9ca30cf7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +2012-03-22 Kaz Kylheku + + * 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 * arith.c (divi): New function. diff --git a/arith.c b/arith.c index 87565a7e..c98d0531 100644 --- a/arith.c +++ b/arith.c @@ -880,42 +880,28 @@ divzero: uw_throw(numeric_error_s, lit("mod: division by zero")); } -val divi(val anum, val bnum) +static val to_float(val func, val num) { - switch (type(anum)) { - case NUM: - case BGNUM: - anum = flo_int(anum); - case FLNUM: - break; - default: - goto type; - } - - switch (type(bnum)) { + switch (type(num)) { case NUM: case BGNUM: - bnum = flo_int(bnum); + return flo_int(num); case FLNUM: - break; + return num; default: - goto type; + uw_throwf(error_s, lit("~s: invalid operand ~s"), func, num); } +} - { - double a = c_flo(anum); - double b = c_flo(bnum); - - if (b == 0.0) - goto divzero; +val divi(val anum, val bnum) +{ + double a = c_flo(to_float(lit("divi"), anum)); + double b = c_flo(to_float(lit("divi"), bnum)); - return flo(a / b); - } + if (b == 0.0) + uw_throw(numeric_error_s, lit("divi: division by zero")); -divzero: - uw_throw(numeric_error_s, lit("divi: division by zero")); -type: - uw_throwf(error_s, lit("divi: invalid operands ~s ~s"), anum, bnum, nao); + return flo(a / b); } val zerop(val num) @@ -923,63 +909,74 @@ 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); @@ -987,26 +984,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); @@ -1014,31 +1020,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); @@ -1046,31 +1061,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); @@ -1078,11 +1102,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); @@ -1109,12 +1131,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(); @@ -1124,11 +1145,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) @@ -1147,11 +1167,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(); @@ -1159,6 +1177,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); @@ -1170,7 +1201,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)) @@ -1189,11 +1220,11 @@ 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); } -static int_ptr_t isqrt_fixnum(int_ptr_t a) +static int_ptr_t sqroot_fixnum(int_ptr_t a) { int_ptr_t mask = (int_ptr_t) 1 << (highest_bit(a) / 2); int_ptr_t root = 0; @@ -1207,19 +1238,34 @@ static int_ptr_t isqrt_fixnum(int_ptr_t a) return root; } -val isqrt(val anum) +val sqroot(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(sqroot_fixnum(c_num(anum))); + } + case BGNUM: + { + val n = make_bignum(); + if (mp_sqrt(mp(anum), mp(n)) != MP_OKAY) + goto negop; + return normalize(n); + } + case FLNUM: + { + double a = c_flo(anum); + if (a < 0) + goto negop; + return flo(sqrt(a)); + } + default: + break; } + uw_throwf(error_s, lit("sqrt: invalid operand ~s"), anum, nao); negop: uw_throw(error_s, lit("sqrt: negative operand")); @@ -1229,7 +1275,7 @@ val gcd(val anum, val bnum) { val n; - if (!numberp(anum) || !numberp(bnum)) + if (!integerp(anum) || !integerp(bnum)) goto inval; if (fixnump(anum)) @@ -1245,7 +1291,7 @@ 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); } diff --git a/eval.c b/eval.c index 823a20d0..ba5bd6c5 100644 --- a/eval.c +++ b/eval.c @@ -2185,7 +2185,7 @@ void eval_init(void) 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("sqrt"), user_package), func_n1(sqroot)); reg_fun(intern(lit("gcd"), user_package), func_n2(gcd)); reg_fun(intern(lit("fixnump"), user_package), func_n1(fixnump)); reg_fun(intern(lit("bignump"), user_package), func_n1(bignump)); diff --git a/lib.h b/lib.h index 6ce793b3..f6deb1ce 100644 --- a/lib.h +++ b/lib.h @@ -424,7 +424,7 @@ 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 isqrt(val anum); +val sqroot(val anum); val gcd(val anum, val bnum); val string_own(wchar_t *str); val string(const wchar_t *str); -- cgit v1.2.3 From 6254e4fa987437b1d785cae66122d707c886e144 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 22 Mar 2012 10:18:33 -0700 Subject: * 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 #. --- ChangeLog | 9 +++++++++ arith.c | 6 ++++++ stream.c | 14 ++++++++++++++ 3 files changed, 29 insertions(+) diff --git a/ChangeLog b/ChangeLog index 9ca30cf7..7da801c8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2012-03-22 Kaz Kylheku + + * 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 #. + 2012-03-22 Kaz Kylheku * arith.c (to_float): New static function. diff --git a/arith.c b/arith.c index c98d0531..6bb82efd 100644 --- a/arith.c +++ b/arith.c @@ -39,6 +39,7 @@ #include #include #include +#include #include "config.h" #include "lib.h" #include "unwind.h" @@ -1315,6 +1316,11 @@ val int_flo(val f) sprintf(text, "%.64g", d); + if (!isdigit(text[0])) + uw_throwf(error_s, + lit("int-flo: cannot convert # to integer"), + nao); + have_exp = (strchr(text, 'e') != 0); have_point = (strchr(text, '.') != 0); diff --git a/stream.c b/stream.c index 6110e1d6..6761afd8 100644 --- a/stream.c +++ b/stream.c @@ -32,6 +32,7 @@ #include #include #include +#include #include #include #include "config.h" @@ -1147,6 +1148,12 @@ val vformat(val stream, val fmtstr, va_list vl) sprintf(num_buf, "%.*e", precision, n); else sprintf(num_buf, "%.*f", precision, n); + if (!isdigit(num_buf[0])) { + if (!vformat_str(stream, lit("#"), + width, left, precision)) + return nil; + continue; + } precision = 0; goto output_num; } @@ -1170,6 +1177,13 @@ val vformat(val stream, val fmtstr, va_list vl) case FLNUM: sprintf(num_buf, "%g", obj->fl.n); + if (!isdigit(num_buf[0])) { + if (!vformat_str(stream, lit("#"), + width, left, precision)) + return nil; + continue; + } + if (!precision) { if (!strpbrk(num_buf, "e.")) strcat(num_buf, ".0"); -- cgit v1.2.3 From 946c88ae095260a816aae8e1d5eacb32e4424718 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 22 Mar 2012 10:38:17 -0700 Subject: * 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. --- ChangeLog | 13 +++++++++++++ arith.c | 30 ++++++++++++++++++++++++++++++ eval.c | 6 ++++++ lib.h | 6 ++++++ txr.1 | 2 ++ txr.vim | 5 +++-- 6 files changed, 60 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7da801c8..0a264e7c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2012-03-22 Kaz Kylheku + + * 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 * arith.c (int_flo): If sprintf produces something diff --git a/arith.c b/arith.c index 6bb82efd..a820dc8e 100644 --- a/arith.c +++ b/arith.c @@ -1296,6 +1296,36 @@ inval: 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)))); +} + /* * TODO: replace this text-based hack! */ diff --git a/eval.c b/eval.c index ba5bd6c5..af3b6a22 100644 --- a/eval.c +++ b/eval.c @@ -2187,6 +2187,12 @@ void eval_init(void) reg_fun(intern(lit("exptmod"), user_package), func_n3(exptmod)); reg_fun(intern(lit("sqrt"), user_package), func_n1(sqroot)); 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("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)); diff --git a/lib.h b/lib.h index f6deb1ce..e4dbfb8d 100644 --- a/lib.h +++ b/lib.h @@ -426,6 +426,12 @@ val exptv(val nlist); val exptmod(val base, val exp, val mod); val sqroot(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 string_own(wchar_t *str); val string(const wchar_t *str); val string_utf8(const char *str); diff --git a/txr.1 b/txr.1 index 685c5f82..280da48e 100644 --- a/txr.1 +++ b/txr.1 @@ -6649,6 +6649,8 @@ Certain object types have a custom equal function. .SS Arithmetic function abs +.SS Arithmetic functions floor, ceil, sin, cos, atan, log + .SS Functions fixnump, bignump, integerp, floatp, numberp .SS Functions zerop, evenp, oddp diff --git a/txr.vim b/txr.vim index 11af4e68..95b7c0f9 100644 --- a/txr.vim +++ b/txr.vim @@ -43,8 +43,9 @@ 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 integerp floatp +syn keyword txl_keyword contained expt exptmod sqrt gcd +syn keyword txl_keyword contained floor ceil sin cos atan log +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 -- cgit v1.2.3 From 1ccc6d458fbda380233019a1d80d5aff576d9d03 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 22 Mar 2012 10:48:00 -0700 Subject: 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. --- ChangeLog | 18 ++++++++++++++++++ arith.c | 22 ++++++++++------------ eval.c | 3 ++- lib.h | 1 + txr.1 | 8 ++++++-- txr.vim | 2 +- 6 files changed, 38 insertions(+), 16 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0a264e7c..e9ad5953 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,21 @@ +2012-03-22 Kaz Kylheku + + 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 * arith.c (floorf, ceili, sine, cosi, atang, loga): New functions. diff --git a/arith.c b/arith.c index a820dc8e..27ac3faf 100644 --- a/arith.c +++ b/arith.c @@ -1225,7 +1225,7 @@ inval: base, exp, mod, nao); } -static int_ptr_t sqroot_fixnum(int_ptr_t a) +static int_ptr_t isqrt_fixnum(int_ptr_t a) { int_ptr_t mask = (int_ptr_t) 1 << (highest_bit(a) / 2); int_ptr_t root = 0; @@ -1239,7 +1239,7 @@ static int_ptr_t sqroot_fixnum(int_ptr_t a) return root; } -val sqroot(val anum) +val isqrt(val anum) { switch (type(anum)) { case NUM: @@ -1247,7 +1247,7 @@ val sqroot(val anum) cnum a = c_num(anum); if (a < 0) goto negop; - return num_fast(sqroot_fixnum(c_num(anum))); + return num_fast(isqrt_fixnum(c_num(anum))); } case BGNUM: { @@ -1256,20 +1256,13 @@ val sqroot(val anum) goto negop; return normalize(n); } - case FLNUM: - { - double a = c_flo(anum); - if (a < 0) - goto negop; - return flo(sqrt(a)); - } 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) @@ -1326,6 +1319,11 @@ val loga(val num) return flo(log(c_flo(to_float(lit("log"), num)))); } +val sqroot(val num) +{ + return flo(sqrt(c_flo(to_float(lit("sqrt"), num)))); +} + /* * TODO: replace this text-based hack! */ diff --git a/eval.c b/eval.c index af3b6a22..db568c0d 100644 --- a/eval.c +++ b/eval.c @@ -2185,7 +2185,7 @@ void eval_init(void) 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(sqroot)); + 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)); @@ -2193,6 +2193,7 @@ void eval_init(void) 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("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)); diff --git a/lib.h b/lib.h index e4dbfb8d..9876d77f 100644 --- a/lib.h +++ b/lib.h @@ -425,6 +425,7 @@ 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); diff --git a/txr.1 b/txr.1 index 280da48e..9a8e4d80 100644 --- a/txr.1 +++ b/txr.1 @@ -6641,9 +6641,9 @@ 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 @@ -6651,6 +6651,10 @@ Certain object types have a custom equal function. .SS Arithmetic functions floor, ceil, sin, cos, atan, log +.SS Arithmetic functions expt, sqrt, isqrt + +.SS Arithmetic function exptmod + .SS Functions fixnump, bignump, integerp, floatp, numberp .SS Functions zerop, evenp, oddp diff --git a/txr.vim b/txr.vim index 95b7c0f9..c219d01a 100644 --- a/txr.vim +++ b/txr.vim @@ -43,7 +43,7 @@ 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 +syn keyword txl_keyword contained expt exptmod sqrt isqrt gcd syn keyword txl_keyword contained floor ceil sin cos atan log syn keyword txl_keyword contained fixnump bignump integerp floatp syn keyword txl_keyword contained numberp zerop evenp oddp > -- cgit v1.2.3 From cffd912f512dc46b5a732068a0380c059db0f07d Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 22 Mar 2012 13:51:15 -0700 Subject: * 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 # 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. --- ChangeLog | 17 +++++++++++++++++ parser.l | 2 +- stream.c | 43 +++++++++++++++++++++++-------------------- 3 files changed, 41 insertions(+), 21 deletions(-) diff --git a/ChangeLog b/ChangeLog index e9ad5953..3a410e26 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2012-03-22 Kaz Kylheku + + * 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 # 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 Fix sqrt confusion. There must be a separate isqrt diff --git a/parser.l b/parser.l index 7e07f79f..52aab27c 100644 --- a/parser.l +++ b/parser.l @@ -153,7 +153,7 @@ SGN [+\-] EXP [eE][+\-]?[0-9]+ DIG [0-9] NUM {SGN}?{DIG}+ -FLO {SGN}?{DIG}*[.]({DIG}+{EXP}?|{EXP}) +FLO {SGN}?({DIG}*[.]{DIG}+{EXP}?|{DIG}+[.]?{EXP}) FLODOT {SGN}?{DIG}+[.] BSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~] BSYM {BSCHR}({BSCHR}|#)* diff --git a/stream.c b/stream.c index 6761afd8..a4b7863d 100644 --- a/stream.c +++ b/stream.c @@ -35,6 +35,7 @@ #include #include #include +#include #include "config.h" #if HAVE_SYS_WAIT #include @@ -960,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; @@ -981,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: @@ -1035,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; @@ -1067,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; @@ -1139,6 +1143,9 @@ val vformat(val stream, val fmtstr, va_list vl) 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"), @@ -1150,7 +1157,7 @@ val vformat(val stream, val fmtstr, va_list vl) sprintf(num_buf, "%.*f", precision, n); if (!isdigit(num_buf[0])) { if (!vformat_str(stream, lit("#"), - width, left, precision)) + width, left, 0)) return nil; continue; } @@ -1175,30 +1182,26 @@ val vformat(val stream, val fmtstr, va_list vl) } goto output_num; case FLNUM: - sprintf(num_buf, "%g", obj->fl.n); + if (!precision_p) + precision = DBL_DIG; - if (!isdigit(num_buf[0])) { + 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("#"), - width, left, precision)) + width, left, 0)) return nil; continue; } - if (!precision) { - if (!strpbrk(num_buf, "e.")) - strcat(num_buf, ".0"); - } else { - /* guard against num_buf overflow */ - if (precision > 128) - uw_throwf(error_s, lit("excessive precision in format: ~s\n"), - num(precision), nao); - - if (strchr(num_buf, 'e')) - sprintf(num_buf, "%.*e", precision, obj->fl.n); - else - sprintf(num_buf, "%.*f", precision, obj->fl.n); - precision = 0; - } + precision = 0; goto output_num; default: if (width != 0) { -- cgit v1.2.3 From 3e43fc5cd22e5293aef97cc67721d12fff9b9a84 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 22 Mar 2012 17:59:59 -0700 Subject: * eval.c (transform_op): use integerp instead of numberp. Not all numbers are integers now, and that situation requires an integer. --- ChangeLog | 6 ++++++ eval.c | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 3a410e26..3c9be325 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-03-22 Kaz Kylheku + + * 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 * parser.l: Bugfix: was not allowing e-notation floats diff --git a/eval.c b/eval.c index db568c0d..21397f1f 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; -- cgit v1.2.3 From 3979dd9d09801792e8cc4428c4cf80ec98c676a3 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 22 Mar 2012 18:27:07 -0700 Subject: * 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. --- ChangeLog | 12 ++++++++++++ arith.c | 5 +++++ eval.c | 1 + lib.h | 1 + txr.1 | 2 +- txr.vim | 2 +- 6 files changed, 21 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3c9be325..92dcb1b1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2012-03-22 Kaz Kylheku + + * 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 * eval.c (transform_op): use integerp instead of numberp. diff --git a/arith.c b/arith.c index 27ac3faf..4ee87055 100644 --- a/arith.c +++ b/arith.c @@ -1319,6 +1319,11 @@ 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)))); diff --git a/eval.c b/eval.c index 21397f1f..fbe63d3a 100644 --- a/eval.c +++ b/eval.c @@ -2193,6 +2193,7 @@ void eval_init(void) 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)); diff --git a/lib.h b/lib.h index 9876d77f..7c197e0a 100644 --- a/lib.h +++ b/lib.h @@ -433,6 +433,7 @@ 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); diff --git a/txr.1 b/txr.1 index 9a8e4d80..af743a4b 100644 --- a/txr.1 +++ b/txr.1 @@ -6649,7 +6649,7 @@ Certain object types have a custom equal function. .SS Arithmetic function abs -.SS Arithmetic functions floor, ceil, sin, cos, atan, log +.SS Arithmetic functions floor, ceil, sin, cos, atan, log, exp .SS Arithmetic functions expt, sqrt, isqrt diff --git a/txr.vim b/txr.vim index c219d01a..88313eb8 100644 --- a/txr.vim +++ b/txr.vim @@ -44,7 +44,7 @@ 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 isqrt gcd -syn keyword txl_keyword contained floor ceil sin cos atan log +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 -- cgit v1.2.3