summaryrefslogtreecommitdiffstats
path: root/arith.txr
diff options
context:
space:
mode:
Diffstat (limited to 'arith.txr')
-rw-r--r--arith.txr163
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)