diff options
Diffstat (limited to 'arith.txr')
-rw-r--r-- | arith.txr | 163 |
1 files changed, 163 insertions, 0 deletions
diff --git a/arith.txr b/arith.txr new file mode 100644 index 00000000..9c746802 --- /dev/null +++ b/arith.txr @@ -0,0 +1,163 @@ +@(bind add-fname ("plus" "minus")) +@(bind add-mp-op ("add" "sub")) +@(bind add-mp-neg ("NOOP" "mp_neg")) +@(bind add-c-op ("+" "-")) +@(output) +/* This file is generated using txr arith.txr > arith.c! + * + * Copyright 2011 + * Kaz Kylheku <kaz@@kylheku.com> + * Vancouver, Canada + * All rights reserved. + * + * BSD License: + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * 3. The name of the author may not be used to endorse or promote + * products derived from this software without specific prior + * written permission. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + */ + + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <wctype.h> +#include <assert.h> +#include <limits.h> +#include <stdarg.h> +#include <dirent.h> +#include <setjmp.h> +#include <wchar.h> +#include "config.h" +#include "lib.h" +#include "unwind.h" +#include "gc.h" +#include "arith.h" + +#define TAG_PAIR(A, B) ((A) << TAG_SHIFT | (B)) +#define NOOP(A, B) + +static mp_int NUM_MAX_MP; + +val make_bignum(void) +{ + val n = make_obj(); + n->bn.type = BGNUM; + mp_init(&n->bn.mp); + return n; +} + +static val normalize(val bignum) +{ + switch (mp_cmp_mag(mp(bignum), &NUM_MAX_MP)) { + case MP_EQ: + case MP_GT: + return bignum; + default: + { + cnum fixnum; + mp_get_intptr(mp(bignum), &fixnum); + return num(fixnum); + } + } +} + +@(repeat) +val @{add-fname}(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): + { + cnum a = c_num(anum); + cnum b = c_num(bnum); + cnum sum = a @{add-c-op} b; + + if (sum < NUM_MIN || sum > NUM_MAX) { + val n = make_bignum(); + mp_set_intptr(mp(n), sum); + return n; + } + + return num(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)) { + mp_@{add-mp-op}_d(mp(bnum), c_num(anum), mp(n)); + @{add-mp-neg}(mp(n), mp(n)); + } else { + mp_int tmp; + mp_init(&tmp); + mp_set_intptr(&tmp, c_num(anum)); + mp_@{add-mp-op}(mp(bnum), &tmp, mp(n)); + } + return normalize(n); + } + case TAG_PAIR(TAG_PTR, TAG_NUM): + { + val n; + type_check(anum, BGNUM); + n = make_bignum(); + if (sizeof (int_ptr_t) <= sizeof (mp_digit)) { + mp_@{add-mp-op}_d(mp(anum), c_num(bnum), mp(n)); + } else { + mp_int tmp; + mp_init(&tmp); + mp_set_intptr(&tmp, c_num(bnum)); + mp_@{add-mp-op}(mp(anum), &tmp, mp(n)); + } + return normalize(n); + } + case TAG_PAIR(TAG_PTR, TAG_PTR): + { + val n; + type_check(anum, BGNUM); + type_check(bnum, BGNUM); + n = make_bignum(); + mp_@{add-mp-op}(mp(anum), mp(bnum), mp(n)); + return normalize(n); + } + } + uw_throwf(error_s, lit("@{add-fname}: invalid operands ~s ~s"), anum, bnum, nao); + abort(); +} + +@(end) +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); + } +} + +void arith_init(void) +{ + mp_init(&NUM_MAX_MP); + mp_set_intptr(&NUM_MAX_MP, NUM_MAX); +} +@(end) |