Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-16 17:27:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'bignum2-dev'

Browse source
This commit is contained in:
Justin Ethier 2017-02-21 17:58:45 -05:00
commit bc9c041d88
12 changed files with 897 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile.config
View file

@ -11,7 +11,7 @@ COMP_CFLAGS ?= -O2 -Wall -I$(PREFIX)/include -L$(PREFIX)/lib
#CFLAGS = -g -Wall
#CFLAGS = -g -pg -Wall
CC ?= cc
LIBS = -pthread -lcyclone -lck -lm
LIBS = -pthread -lcyclone -lck -lm -ltommath
# Commands "baked into" cyclone for invoking the C compiler
CC_PROG ?= "$(CC) ~src-file~ $(COMP_CFLAGS) -c -o ~exec-file~.o"

56
bignum-test.scm Normal file
View file

@ -0,0 +1,56 @@
;; A temporary test file
;; TODO: create a test suite
(import (scheme base) (scheme write))
(define x (exact (expt 2 29)))
(write (bignum? x))
(write (bignum? (+ x x)))
(write (+ x x))
(newline)
(set! x (+ x x))
(write
(list x (+ x ) (+ 1 x)))
(newline)
(write
(list
x
(+ 1.0 x )
(+ x x)
(+ x 1.0)
(+ x 1)
))
(newline)
(write
(list
x
(- 1.0 x )
(- x x)
(- x 1.0)
(- x 1)
))
(newline)
(write
(list
x
(* 1.0 x )
(* x x)
(* x 1.0)
(* x 1)
))
(newline)
(write
(list
x
(/ 1.0 x )
(/ x x)
(/ x 1.0)
(/ x 1)
))
(newline)
(write
(equal?
;; pi input:
'((314159265358979323846264338327950288419716939937507 -54 124) (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170673 -51 -417) (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408122 -57 -819) (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038195 -76 332) (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019089 -83 477) (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141268 -72 -2981) (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536431 -70 -2065) (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116089 -79 1687) (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273724587006606315588174881520920962829254091715364367892590360011330530548820466521384146951941511609433057270365759591953092186117381932611793105118542 -92 -2728) (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536436789259036001133053054882046652138414695194151160943305727036575959195309218611738193261179310511854807446237996274956735188575272489122793818301194907 -76 -3726))
'((314159265358979323846264338327950288419716939937507 -54 124) (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170673 -51 -417) (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408122 -57 -819) (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038195 -76 332) (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019089 -83 477) (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141268 -72 -2981) (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536431 -70 -2065) (31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116089 -79 1687) (3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273724587006606315588174881520920962829254091715364367892590360011330530548820466521384146951941511609433057270365759591953092186117381932611793105118542 -92 -2728) (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536436789259036001133053054882046652138414695194151160943305727036575959195309218611738193261179310511854807446237996274956735188575272489122793818301194907 -76 -3726))))

4
docs/User-Manual.md
View file

@ -45,6 +45,10 @@ The following packages are required:
tar xfz ck-0.5.0.tar.gz ; cd ck-0.5.0 ; ./configure && make all && sudo make install
sudo ldconfig
- [LibTomMath](https://github.com/libtom/libtommath)
Again, the best way to install `libtommath` is via your system's package manager.
# Installation
Cyclone cannot be built directly on a system that does not have Cyclone binaries installed because the compiler is [self-hosting](https://en.wikipedia.org/wiki/Self-hosting). The easiest way to install Cyclone binaries is to build from source using [cyclone-bootstrap](https://github.com/justinethier/cyclone-bootstrap):

44
gc.c
View file

@ -417,6 +417,16 @@ char *gc_copy_obj(object dest, char *obj, gc_thread_data * thd)
hp->value = ((integer_type *) obj)->value;
return (char *)hp;
}
case bignum_tag:{
bignum_type *hp = dest;
mark(hp) = thd->gc_alloc_color;
type_of(hp) = bignum_tag;
((bignum_type *)hp)->bn.used = ((bignum_type *)obj)->bn.used;
((bignum_type *)hp)->bn.alloc = ((bignum_type *)obj)->bn.alloc;
((bignum_type *)hp)->bn.sign = ((bignum_type *)obj)->bn.sign;
((bignum_type *)hp)->bn.dp = ((bignum_type *)obj)->bn.dp;
return (char *)hp;
}
case double_tag:{
double_type *hp = dest;
mark(hp) = thd->gc_alloc_color;
@ -577,6 +587,31 @@ void *gc_try_alloc(gc_heap * h, int heap_type, size_t size, char *obj,
return NULL;
}
// A convenience function for allocating bignums
void *gc_alloc_bignum(gc_thread_data *data)
{
int heap_grown, result;
bignum_type *bn;
bignum_type tmp;
tmp.hdr.mark = gc_color_red;
tmp.hdr.grayed = 0;
tmp.tag = bignum_tag;
bn = gc_alloc(((gc_thread_data *)data)->heap, sizeof(bignum_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
if ((result = mp_init(&bignum_value(bn))) != MP_OKAY) {
fprintf(stderr, "Error initializing number %s",
mp_error_to_string(result));
exit(1);
}
return bn;
}
void *gc_alloc_from_bignum(gc_thread_data *data, bignum_type *src)
{
int heap_grown;
return gc_alloc(((gc_thread_data *)data)->heap, sizeof(bignum_type), (char *)(src), (gc_thread_data *)data, &heap_grown);
}
void *gc_alloc(gc_heap_root * hrt, size_t size, char *obj, gc_thread_data * thd,
int *heap_grown)
{
@ -674,6 +709,8 @@ size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r)
}
if (t == integer_tag)
return gc_heap_align(sizeof(integer_type));
if (t == bignum_tag)
return gc_heap_align(sizeof(bignum_type));
if (t == double_tag)
return gc_heap_align(sizeof(double_type));
if (t == port_tag)
@ -869,6 +906,13 @@ size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr, gc_thread_da
fprintf(stderr, "Error destroying condition variable\n");
exit(1);
}
} else if (type_of(p) == bignum_tag) {
// TODO: this is no good if we abandon bignum's on the stack
// in that case the finalizer is never called
#if GC_DEBUG_VERBOSE
fprintf(stderr, "mp_clear from sweep\n");
#endif
mp_clear(&(((bignum_type *)p)->bn));
}
// free p
heap_freed += size;

7
include/cyclone/runtime.h
View file

@ -100,6 +100,8 @@ object Cyc_global_set(void *thd, object * glo, object value);
d.value = OP(obj_obj2int(z)); \
} else if (type_of(z) == integer_tag) { \
d.value = OP(((integer_type *)z)->value); \
} else if (type_of(z) == bignum_tag) { \
d.value = OP(mp_get_double(&bignum_value(z))); \
} else { \
d.value = OP(((double_type *)z)->value); \
} \
@ -112,6 +114,8 @@ object Cyc_global_set(void *thd, object * glo, object value);
i = obj_obj2int(z); \
} else if (type_of(z) == integer_tag) { \
i = (int)OP(((integer_type *)z)->value); \
} else if (type_of(z) == bignum_tag) { \
return_closcall1(data, cont, z); \
} else { \
i = (int)OP(((double_type *)z)->value); \
} \
@ -174,6 +178,8 @@ object Cyc_num_fast_lte_op(void *data, object x, object y);
object Cyc_num_cmp_va_list(void *data, int argc,
int (fn_op(void *, object, object)), object n,
va_list ns);
void Cyc_expt(void *data, object cont, object x, object y);
void Cyc_remainder(void *data, object cont, object num1, object num2);
object Cyc_eq(object x, object y);
object Cyc_set_cell(void *, object l, object val);
object Cyc_set_car(void *, object l, object val);
@ -246,6 +252,7 @@ object Cyc_is_null(object o);
object Cyc_is_number(object o);
object Cyc_is_real(object o);
object Cyc_is_integer(object o);
object Cyc_is_bignum(object o);
object Cyc_is_vector(object o);
object Cyc_is_bytevector(object o);
object Cyc_is_port(object o);

47
include/cyclone/types.h
View file

@ -18,6 +18,7 @@
#include <time.h>
#include <pthread.h>
#include <stdint.h>
#include "tommath.h"
// Maximum number of args that GC will accept
#define NUM_GC_ARGS 128
@ -87,14 +88,15 @@ enum object_tag {
, eof_tag // 9
, forward_tag // 10
, integer_tag // 11
, macro_tag // 12
, mutex_tag // 13
, pair_tag // 14
, port_tag // 15
, primitive_tag // 16
, string_tag // 17
, symbol_tag // 18
, vector_tag // 19
, bignum_tag // 12
, macro_tag // 13
, mutex_tag // 14
, pair_tag // 15
, port_tag // 16
, primitive_tag // 17
, string_tag // 18
, symbol_tag // 19
, vector_tag // 20
};
#define type_is_pair_prim(clo) \
@ -268,6 +270,9 @@ struct gc_thread_data_t {
#define is_value_type(x) ((unsigned long)(x) & (unsigned long)3)
#define is_object_type(x) (x && !is_value_type(x))
#define CYC_FIXNUM_MAX 1073741823
#define CYC_FIXNUM_MIN -1073741824
/* Function type */
typedef void (*function_type) ();
@ -356,6 +361,15 @@ typedef struct {
int padding; // Prevent mem corruption if sizeof(int) < sizeof(ptr)
} integer_type;
typedef struct {
gc_header_type hdr;
tag_type tag;
mp_int bn;
} bignum_type;
#define alloc_bignum(data, p) \
bignum_type *p = gc_alloc_bignum((gc_thread_data *)data);
typedef struct {
gc_header_type hdr;
tag_type tag;
@ -376,6 +390,15 @@ typedef struct {
#define integer_value(x) (((integer_type *) x)->value)
#define double_value(x) (((double_type *) x)->value)
#define bignum_value(x) (((bignum_type *) x)->bn)
typedef enum {
CYC_BN_LTE = -2
, CYC_BN_LT = MP_LT
, CYC_BN_EQ = MP_EQ
, CYC_BN_GT = MP_GT
, CYC_BN_GTE = 2
} bn_cmp_type;
/* Define string type */
typedef struct {
@ -643,6 +666,7 @@ typedef union {
primitive_type primitive_t;
integer_type integer_t;
double_type double_t;
bignum_type bignum_t;
} common_type;
/* Utility functions */
@ -650,6 +674,11 @@ void **vpbuffer_realloc(void **buf, int *len);
void **vpbuffer_add(void **buf, int *len, int i, void *obj);
void vpbuffer_free(void **buf);
/* Bignum utility functions */
double mp_get_double(mp_int *a);
int Cyc_bignum_cmp(bn_cmp_type type, object x, int tx, object y, int ty);
void Cyc_int2bignum(int n, mp_int *bn);
/* GC prototypes */
void gc_initialize();
void gc_add_mutator(gc_thread_data * thd);
@ -666,6 +695,8 @@ void *gc_try_alloc(gc_heap * h, int heap_type, size_t size, char *obj,
gc_thread_data * thd);
void *gc_alloc(gc_heap_root * h, size_t size, char *obj, gc_thread_data * thd,
int *heap_grown);
void *gc_alloc_bignum(gc_thread_data *data);
void *gc_alloc_from_bignum(gc_thread_data *data, bignum_type *src);
size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r);
gc_heap *gc_heap_last(gc_heap * h);
size_t gc_heap_total_size(gc_heap * h);

704
runtime.c
View file

@ -43,6 +43,7 @@ const char *tag_names[] = {
/*eof_tag */ , "eof"
/*forward_tag */ , ""
/*integer_tag */ , "number"
/*bignum_tag */ , "bignum"
/*macro_tag */ , "macro"
/*mutex_tag */ , "mutex"
/*pair_tag */ , "pair"
@ -543,21 +544,19 @@ int equal(object x, object y)
if (obj_is_int(x))
return (obj_is_int(y) && x == y) ||
(is_object_type(y) &&
type_of(y) == integer_tag && integer_value(y) == obj_obj2int(x));
(
(type_of(y) == integer_tag && integer_value(y) == obj_obj2int(x)) ||
(type_of(y) == bignum_tag && Cyc_bignum_cmp(MP_EQ, x, -1, y, bignum_tag))
));
switch (type_of(x)) {
case integer_tag:
return (obj_is_int(y) && obj_obj2int(y) == integer_value(x)) ||
(is_object_type(y) &&
type_of(y) == integer_tag &&
((integer_type *) x)->value == ((integer_type *) y)->value);
case double_tag:
return (is_object_type(y) &&
type_of(y) == double_tag &&
((double_type *) x)->value == ((double_type *) y)->value);
case string_tag:
return (is_object_type(y) &&
type_of(y) == string_tag &&
strcmp(((string_type *) x)->str, ((string_type *) y)->str) == 0);
case double_tag:
return (is_object_type(y) &&
type_of(y) == double_tag &&
((double_type *) x)->value == ((double_type *) y)->value);
case vector_tag:
if (is_object_type(y) &&
type_of(y) == vector_tag &&
@ -584,6 +583,26 @@ int equal(object x, object y)
return 1;
}
return 0;
case bignum_tag: {
int ty = -1;
if (is_value_type(y)) {
if (!obj_is_int(y)) {
return 0;
}
} else {
ty = type_of(y);
}
return Cyc_bignum_cmp(MP_EQ, x, bignum_tag, y, ty);
// return (is_object_type(y) &&
// type_of(y) == bignum_tag &&
// MP_EQ == mp_cmp(&bignum_value(x), &bignum_value(y)));
}
case integer_tag:
return (obj_is_int(y) && obj_obj2int(y) == integer_value(x)) ||
(is_object_type(y) &&
type_of(y) == integer_tag &&
((integer_type *) x)->value == ((integer_type *) y)->value);
default:
return x == y;
}
@ -830,6 +849,19 @@ object Cyc_display(void *data, object x, FILE * port)
}
fprintf(port, ")");
break;
case bignum_tag: {
int bufsz;
char *buf;
// TODO: check return value
mp_radix_size(&bignum_value(x), 10, &bufsz);
buf = alloca(bufsz);
// TODO: check return value
mp_toradix_n(&bignum_value(x), buf, 10, bufsz);
fprintf(port, "%s", buf);
break;
}
default:
fprintf(port, "Cyc_display: bad tag x=%d\n", ((closure) x)->tag);
exit(1);
@ -1147,7 +1179,95 @@ object Cyc_num_cmp_va_list(void *data, int argc,
return boolean_t;
}
#define declare_num_cmp(FUNC, FUNC_OP, FUNC_FAST_OP, FUNC_APPLY, OP) \
/**
* Convert from a bignum to a double
* Code is from: https://github.com/libtom/libtommath/issues/3
*/
#define PRECISION 53
double mp_get_double(mp_int *a)
{
static const int NEED_DIGITS = (PRECISION + 2 * DIGIT_BIT - 2) / DIGIT_BIT;
static const double DIGIT_MULTI = (mp_digit)1 << DIGIT_BIT;
int i, limit;
double d = 0.0;
mp_clamp(a);
i = USED(a);
limit = i <= NEED_DIGITS ? 0 : i - NEED_DIGITS;
while (i-- > limit) {
d += DIGIT(a, i);
d *= DIGIT_MULTI;
}
if(SIGN(a) == MP_NEG)
d *= -1.0;
d *= pow(2.0, i * DIGIT_BIT);
return d;
}
// Convert a bignum back to fixnum if possible
object Cyc_bignum_normalize(void *data, object n)
{
mp_int bn;
object result;
int i;
if (!is_object_type(n) || type_of(n) != bignum_tag) {
return n;
}
mp_init(&bn);
mp_set_int(&bn, CYC_FIXNUM_MAX);
if (mp_cmp_mag(&bignum_value(n), &bn) == MP_GT) {
result = n;
} else {
i = mp_get_int(&bignum_value(n));
if (SIGN(&bignum_value(n)) == MP_NEG) {
i = -i;
}
result = obj_int2obj(i);
}
mp_clear(&bn);
return result;
}
void Cyc_int2bignum(int n, mp_int *bn)
{
mp_set_int(bn, abs(n));
if (n < 0) {
mp_neg(bn, bn);
}
}
int Cyc_bignum_cmp(bn_cmp_type type, object x, int tx, object y, int ty)
{
mp_int tmp;
int cmp = 0;
if (tx == bignum_tag && ty == bignum_tag) {
cmp = mp_cmp(&bignum_value(x), &bignum_value(y));
} else if (tx == bignum_tag && ty == -1) { \
mp_init(&tmp);
Cyc_int2bignum(obj_obj2int(y), &tmp);
cmp = mp_cmp(&bignum_value(x), &tmp);
mp_clear(&tmp);
} else if (tx == -1 && ty == bignum_tag) { \
mp_init(&tmp);
Cyc_int2bignum(obj_obj2int(x), &tmp);
cmp = mp_cmp(&tmp, &bignum_value(y));
mp_clear(&tmp);
} else {
return 0;
}
return (cmp == type) ||
((type == CYC_BN_GTE && cmp > MP_LT) ||
(type == CYC_BN_LTE && cmp < MP_GT));
}
#define declare_num_cmp(FUNC, FUNC_OP, FUNC_FAST_OP, FUNC_APPLY, OP, BN_CMP) \
int FUNC_OP(void *data, object x, object y) { \
int result = 0, \
tx = (obj_is_int(x) ? -1 : type_of(x)), \
@ -1170,6 +1290,16 @@ int FUNC_OP(void *data, object x, object y) { \
result = (double_value(x)) OP (integer_value(y)); \
} else if (tx == double_tag && ty == double_tag) { \
result = (double_value(x)) OP (double_value(y)); \
} else if (tx == bignum_tag && ty == -1) { \
result = Cyc_bignum_cmp(BN_CMP, x, tx, y, ty); \
} else if (tx == bignum_tag && ty == double_tag) { \
result = mp_get_double(&bignum_value(x)) OP (double_value(y)); \
} else if (tx == bignum_tag && ty == bignum_tag) { \
result = Cyc_bignum_cmp(BN_CMP, x, tx, y, ty); \
} else if (tx == -1 && ty == bignum_tag) { \
result = Cyc_bignum_cmp(BN_CMP, x, tx, y, ty); \
} else if (tx == double_tag && ty == bignum_tag) { \
result = (double_value(x)) OP mp_get_double(&bignum_value(y)); \
} else { \
make_string(s, "Bad argument type"); \
make_pair(c1, y, NULL); \
@ -1237,6 +1367,16 @@ object FUNC_FAST_OP(void *data, object x, object y) { \
} else if (tx == double_tag && ty == double_tag) { \
return ((double_value(x)) OP (double_value(y))) \
? boolean_t : boolean_f; \
} else if (tx == bignum_tag && ty == -1) { \
return Cyc_bignum_cmp(BN_CMP, x, tx, y, ty) ? boolean_t : boolean_f; \
} else if (tx == bignum_tag && ty == double_tag) { \
return mp_get_double(&bignum_value(x)) OP (double_value(y)) ? boolean_t : boolean_f; \
} else if (tx == bignum_tag && ty == bignum_tag) { \
return Cyc_bignum_cmp(BN_CMP, x, tx, y, ty) ? boolean_t : boolean_f; \
} else if (tx == -1 && ty == bignum_tag) { \
return Cyc_bignum_cmp(BN_CMP, x, tx, y, ty) ? boolean_t : boolean_f; \
} else if (tx == double_tag && ty == bignum_tag) { \
return (double_value(x)) OP mp_get_double(&bignum_value(x)) ? boolean_t : boolean_f; \
} else { \
goto bad_arg_type_error; \
} \
@ -1252,11 +1392,11 @@ bad_arg_type_error: \
} \
}
declare_num_cmp(Cyc_num_eq, Cyc_num_eq_op, Cyc_num_fast_eq_op, dispatch_num_eq, ==);
declare_num_cmp(Cyc_num_gt, Cyc_num_gt_op, Cyc_num_fast_gt_op, dispatch_num_gt, >);
declare_num_cmp(Cyc_num_lt, Cyc_num_lt_op, Cyc_num_fast_lt_op, dispatch_num_lt, <);
declare_num_cmp(Cyc_num_gte, Cyc_num_gte_op, Cyc_num_fast_gte_op, dispatch_num_gte, >=);
declare_num_cmp(Cyc_num_lte, Cyc_num_lte_op, Cyc_num_fast_lte_op, dispatch_num_lte, <=);
declare_num_cmp(Cyc_num_eq, Cyc_num_eq_op, Cyc_num_fast_eq_op, dispatch_num_eq, ==, CYC_BN_EQ);
declare_num_cmp(Cyc_num_gt, Cyc_num_gt_op, Cyc_num_fast_gt_op, dispatch_num_gt, >, CYC_BN_GT);
declare_num_cmp(Cyc_num_lt, Cyc_num_lt_op, Cyc_num_fast_lt_op, dispatch_num_lt, <, CYC_BN_LT);
declare_num_cmp(Cyc_num_gte, Cyc_num_gte_op, Cyc_num_fast_gte_op, dispatch_num_gte, >=, CYC_BN_GTE);
declare_num_cmp(Cyc_num_lte, Cyc_num_lte_op, Cyc_num_fast_lte_op, dispatch_num_lte, <=, CYC_BN_LTE);
object Cyc_is_boolean(object o)
{
@ -1285,6 +1425,7 @@ object Cyc_is_number(object o)
{
if ((o != NULL) && (obj_is_int(o) || (!is_value_type(o)
&& (type_of(o) == integer_tag
|| type_of(o) == bignum_tag
|| type_of(o) == double_tag))))
return boolean_t;
return boolean_f;
@ -1298,7 +1439,15 @@ object Cyc_is_real(object o)
object Cyc_is_integer(object o)
{
if ((o != NULL) && (obj_is_int(o) ||
(!is_value_type(o) && type_of(o) == integer_tag)))
(!is_value_type(o) && type_of(o) == integer_tag) ||
(!is_value_type(o) && type_of(o) == bignum_tag)))
return boolean_t;
return boolean_f;
}
object Cyc_is_bignum(object o)
{
if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == bignum_tag)
return boolean_t;
return boolean_f;
}
@ -1529,7 +1678,7 @@ char *int_to_binary(char *b, int x)
object Cyc_number2string2(void *data, object cont, int argc, object n, ...)
{
object base = NULL;
int base_num = 10, val;
int base_num = 10, val, sz;
char buffer[1024];
va_list ap;
va_start(ap, n);
@ -1543,30 +1692,42 @@ object Cyc_number2string2(void *data, object cont, int argc, object n, ...)
base_num = unbox_number(base);
}
if (base_num == 2) {
val = obj_is_int(n) ?
obj_obj2int(n) :
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
int_to_binary(buffer, val);
} else if (base_num == 8) {
val = obj_is_int(n) ?
obj_obj2int(n) :
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
snprintf(buffer, 1024, "%o", val);
} else if (base_num == 16) {
val = obj_is_int(n) ?
obj_obj2int(n) :
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
snprintf(buffer, 1024, "%X", val);
if (is_object_type(n) && type_of(n) == bignum_tag) {
if (base_num > 64 || base_num < 2) {
Cyc_rt_raise2(data, "number->string - invalid radix for bignum", base);
}
mp_radix_size(&bignum_value(n), base_num, &sz);
if (sz > 1024) {
// TODO: just temporary, need to handle this better
Cyc_rt_raise2(data, "number->string - bignum is too large to convert", n);
}
mp_toradix(&bignum_value(n), buffer, base_num);
} else {
if (obj_is_int(n)) {
snprintf(buffer, 1024, "%ld", obj_obj2int(n));
} else if (type_of(n) == integer_tag) {
snprintf(buffer, 1024, "%d", ((integer_type *) n)->value);
} else if (type_of(n) == double_tag) {
double2buffer(buffer, 1024, ((double_type *) n)->value);
if (base_num == 2) {
val = obj_is_int(n) ?
obj_obj2int(n) :
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
int_to_binary(buffer, val);
} else if (base_num == 8) {
val = obj_is_int(n) ?
obj_obj2int(n) :
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
snprintf(buffer, 1024, "%o", val);
} else if (base_num == 16) {
val = obj_is_int(n) ?
obj_obj2int(n) :
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
snprintf(buffer, 1024, "%X", val);
} else {
Cyc_rt_raise2(data, "number->string - Unexpected object", n);
if (obj_is_int(n)) {
snprintf(buffer, 1024, "%ld", obj_obj2int(n));
} else if (type_of(n) == integer_tag) {
snprintf(buffer, 1024, "%d", ((integer_type *) n)->value);
} else if (type_of(n) == double_tag) {
double2buffer(buffer, 1024, ((double_type *) n)->value);
} else {
Cyc_rt_raise2(data, "number->string - Unexpected object", n);
}
}
}
make_string(str, buffer);
@ -1638,14 +1799,22 @@ object Cyc_string2number2_(void *data, object cont, int argc, object str, ...)
if (base) {
base_num = unbox_number(base);
Cyc_check_str(data, str);
result = -1;
if (base_num == 2) {
result = (int)strtol(string_str(str), NULL, 2);
_return_closcall1(data, cont, obj_int2obj(result));
} else if (base_num == 8) {
result = (int)strtol(string_str(str), NULL, 8);
_return_closcall1(data, cont, obj_int2obj(result));
} else if (base_num == 16) {
result = (int)strtol(string_str(str), NULL, 16);
}
if (result <= 0 || result > CYC_FIXNUM_MAX) {
alloc_bignum(data, bn);
if (MP_OKAY != mp_read_radix(&(bignum_value(bn)), string_str(str), base_num)) {
Cyc_rt_raise2(data, "Error converting string to bignum", str);
}
_return_closcall1(data, cont, bn);
} else {
_return_closcall1(data, cont, obj_int2obj(result));
}
}
@ -1688,9 +1857,9 @@ str2int_errno str2int(int *out, char *s, int base)
errno = 0;
long l = strtol(s, &end, base);
/* Both checks are needed because INT_MAX == LONG_MAX is possible. */
if (l > INT_MAX || (errno == ERANGE && l == LONG_MAX))
if (l > CYC_FIXNUM_MAX /*INT_MAX*/ || (errno == ERANGE && l == LONG_MAX))
return STR2INT_OVERFLOW;
if (l < INT_MIN || (errno == ERANGE && l == LONG_MIN))
if (l < CYC_FIXNUM_MIN /*INT_MIN*/ || (errno == ERANGE && l == LONG_MIN))
return STR2INT_UNDERFLOW;
if (*end != '\0')
return STR2INT_INCONVERTIBLE;
@ -1698,6 +1867,18 @@ str2int_errno str2int(int *out, char *s, int base)
return STR2INT_SUCCESS;
}
int str_is_bignum(str2int_errno errnum, char *c)
{
if (errnum == STR2INT_INCONVERTIBLE) return 0; // Unexpected chars for int
for (;*c; c++) {
if (!isdigit(*c) && *c != '-') {
return 0;
}
}
return 1;
}
object Cyc_string2number_(void *data, object cont, object str)
{
int result, rv;
@ -1711,6 +1892,12 @@ object Cyc_string2number_(void *data, object cont, object str)
rv = str2int(&result, s, 10);
if (rv == STR2INT_SUCCESS) {
_return_closcall1(data, cont, obj_int2obj(result));
} else if (str_is_bignum(rv, s)) {
alloc_bignum(data, bn);
if (MP_OKAY != mp_read_radix(&(bignum_value(bn)), s, 10)) {
Cyc_rt_raise2(data, "Error converting string to bignum", str);
}
_return_closcall1(data, cont, bn);
} else {
char *str_end;
n = strtold(s, &str_end);
@ -2344,8 +2531,32 @@ object __halt(object obj)
return NULL;
}
#define declare_num_op(FUNC, FUNC_OP, FUNC_APPLY, OP, NO_ARG, ONE_ARG, DIV) \
// Signed arithmetic overflow checks, based on code from CHICKEN:
static int Cyc_checked_add(int x, int y, int *result)
{
*result = x + y;
return ((((*result ^ x) & (*result ^ y)) >> 30) != 0);
}
static int Cyc_checked_sub(int x, int y, int *result)
{
*result = x - y;
return ((((*result ^ x) & ~(*result ^ y)) >> 30) != 0);
}
// Code from http://stackoverflow.com/q/1815367/101258
static int Cyc_checked_mul(int x, int y, int *result)
{
*result = x * y;
return (*result != 0 && (*result)/x != y) || // Overflow
(*result > CYC_FIXNUM_MAX) ||
(*result < CYC_FIXNUM_MIN);
}
#define declare_num_op(FUNC, FUNC_OP, FUNC_APPLY, OP, INT_OP, BN_OP, NO_ARG, ONE_ARG, DIV) \
object FUNC_OP(void *data, common_type *x, object y) { \
mp_int bn_tmp, bn_tmp2; \
int tx, ty; \
tx = type_of(x); \
if (obj_is_int(y)) { \
@ -2362,7 +2573,22 @@ object FUNC_OP(void *data, common_type *x, object y) { \
Cyc_rt_raise_msg(data, "Divide by zero"); \
} \
if (tx == integer_tag && ty == -1) { \
x->integer_t.value = (x->integer_t.value) OP (obj_obj2int(y)); \
int result; \
if (INT_OP(x->integer_t.value, obj_obj2int(y), &result) == 0) { \
x->integer_t.value = result; \
} else { \
mp_init(&bn_tmp); \
mp_init(&bn_tmp2); \
Cyc_int2bignum(x->integer_t.value, &bn_tmp); \
Cyc_int2bignum(obj_obj2int(y), &bn_tmp2); \
x->bignum_t.hdr.mark = gc_color_red; \
x->bignum_t.hdr.grayed = 0; \
x->bignum_t.tag = bignum_tag; \
mp_init(&(x->bignum_t.bn)); \
BN_OP(&bn_tmp, &bn_tmp2, &(x->bignum_t.bn)); \
mp_clear(&bn_tmp); \
mp_clear(&bn_tmp2); \
} \
} else if (tx == double_tag && ty == -1) { \
x->double_t.value = x->double_t.value OP (obj_obj2int(y)); \
} else if (tx == integer_tag && ty == integer_tag) { \
@ -2376,6 +2602,31 @@ object FUNC_OP(void *data, common_type *x, object y) { \
x->double_t.value = x->integer_t.value OP ((double_type *)y)->value; \
} else if (tx == double_tag && ty == double_tag) { \
x->double_t.value = x->double_t.value OP ((double_type *)y)->value; \
} else if (tx == integer_tag && ty == bignum_tag) { \
mp_init(&bn_tmp2); \
Cyc_int2bignum(x->integer_t.value, &bn_tmp2); \
x->bignum_t.hdr.mark = gc_color_red; \
x->bignum_t.hdr.grayed = 0; \
x->bignum_t.tag = bignum_tag; \
mp_init(&(x->bignum_t.bn)); \
BN_OP(&bn_tmp2, &bignum_value(y), &(x->bignum_t.bn)); \
mp_clear(&bn_tmp2); \
} else if (tx == double_tag && ty == bignum_tag) { \
x->double_t.value = x->double_t.value OP mp_get_double(&bignum_value(y)); \
} else if (tx == bignum_tag && ty == -1) { \
mp_init(&bn_tmp2); \
Cyc_int2bignum(obj_obj2int(y), &bn_tmp2); \
BN_OP(&(x->bignum_t.bn), &bn_tmp2, &(x->bignum_t.bn)); \
mp_clear(&bn_tmp2); \
} else if (tx == bignum_tag && ty == double_tag) { \
double d = mp_get_double(&(x->bignum_t.bn)); \
mp_clear(&(x->bignum_t.bn)); \
x->double_t.hdr.mark = gc_color_red; \
x->double_t.hdr.grayed = 0; \
x->double_t.tag = double_tag; \
x->double_t.value = d OP ((double_type *)y)->value; \
} else if (tx == bignum_tag && ty == bignum_tag) { \
BN_OP(&(x->bignum_t.bn), &bignum_value(y), &(x->bignum_t.bn)); \
} else { \
goto bad_arg_type_error; \
} \
@ -2414,15 +2665,33 @@ object Cyc_fast_sum(void *data, object ptr, object x, object y) {
if (obj_is_int(y)){
int xx = obj_obj2int(x),
yy = obj_obj2int(y),
z = xx + yy;
//if((((z ^ xx) & (z ^ yy)) >> 30) != 0) { // overflow
// assign_double(ptr, (double)xx + (double)yy);
// return ptr;
//}
return obj_int2obj(z);
z;
if (Cyc_checked_add(xx, yy, &z) == 0) {
return obj_int2obj(z);
} else {
mp_int bnx, bny;
mp_init(&bnx);
mp_init(&bny);
Cyc_int2bignum(xx, &bnx);
Cyc_int2bignum(yy, &bny);
alloc_bignum(data, bn);
mp_add(&bnx, &bny, &bignum_value(bn));
mp_clear(&bnx);
mp_clear(&bny);
return bn;
}
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, (double)(obj_obj2int(x)) + double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
mp_int bnx;
mp_init(&bnx);
Cyc_int2bignum(obj_obj2int(x), &bnx);
alloc_bignum(data, bn);
mp_add(&bnx, &bignum_value(y), &bignum_value(bn));
mp_clear(&bnx);
return bn;
}
}
// x is double
@ -2433,6 +2702,28 @@ object Cyc_fast_sum(void *data, object ptr, object x, object y) {
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, double_value(x) + double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
assign_double(ptr, double_value(x) + mp_get_double(&bignum_value(y)));
return ptr;
}
}
// x is bignum
if (is_object_type(x) && type_of(x) == bignum_tag) {
if (obj_is_int(y)){
mp_int bny;
mp_init(&bny);
Cyc_int2bignum(obj_obj2int(y), &bny);
alloc_bignum(data, bn);
mp_add(&bignum_value(x), &bny, &bignum_value(bn));
mp_clear(&bny);
return bn;
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, mp_get_double(&bignum_value(x)) + double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
alloc_bignum(data, bn);
mp_add(&bignum_value(x), &bignum_value(y), &bignum_value(bn));
return bn;
}
}
// still here, raise an error
@ -2448,11 +2739,34 @@ object Cyc_fast_sub(void *data, object ptr, object x, object y) {
// x is int (assume value types for integers)
if (obj_is_int(x)){
if (obj_is_int(y)){
int z = obj_obj2int(x) - obj_obj2int(y);
return obj_int2obj(z);
int xx = obj_obj2int(x),
yy = obj_obj2int(y),
z;
if (Cyc_checked_sub(xx, yy, &z) == 0) {
return obj_int2obj(z);
} else {
mp_int bnx, bny;
mp_init(&bnx);
mp_init(&bny);
Cyc_int2bignum(xx, &bnx);
Cyc_int2bignum(yy, &bny);
alloc_bignum(data, bn);
mp_sub(&bnx, &bny, &bignum_value(bn));
mp_clear(&bnx);
mp_clear(&bny);
return bn;
}
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, (double)(obj_obj2int(x)) - double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
mp_int bnx;
mp_init(&bnx);
Cyc_int2bignum(obj_obj2int(x), &bnx);
alloc_bignum(data, bn);
mp_sub(&bnx, &bignum_value(y), &bignum_value(bn));
mp_clear(&bnx);
return bn;
}
}
// x is double
@ -2463,6 +2777,28 @@ object Cyc_fast_sub(void *data, object ptr, object x, object y) {
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, double_value(x) - double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
assign_double(ptr, double_value(x) - mp_get_double(&bignum_value(y)));
return ptr;
}
}
// x is bignum
if (is_object_type(x) && type_of(x) == bignum_tag) {
if (obj_is_int(y)){
mp_int bny;
mp_init(&bny);
Cyc_int2bignum(obj_obj2int(y), &bny);
alloc_bignum(data, bn);
mp_sub(&bignum_value(x), &bny, &bignum_value(bn));
mp_clear(&bny);
return bn;
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, mp_get_double(&bignum_value(x)) - double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
alloc_bignum(data, bn);
mp_sub(&bignum_value(x), &bignum_value(y), &bignum_value(bn));
return bn;
}
}
// still here, raise an error
@ -2478,11 +2814,34 @@ object Cyc_fast_mul(void *data, object ptr, object x, object y) {
// x is int (assume value types for integers)
if (obj_is_int(x)){
if (obj_is_int(y)){
int z = obj_obj2int(x) * obj_obj2int(y);
return obj_int2obj(z);
int xx = obj_obj2int(x),
yy = obj_obj2int(y),
z;
if (Cyc_checked_mul(xx, yy, &z) == 0) {
return obj_int2obj(z);
} else {
mp_int bnx, bny;
mp_init(&bnx);
mp_init(&bny);
Cyc_int2bignum(xx, &bnx);
Cyc_int2bignum(yy, &bny);
alloc_bignum(data, bn);
mp_mul(&bnx, &bny, &bignum_value(bn));
mp_clear(&bnx);
mp_clear(&bny);
return bn;
}
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, (double)(obj_obj2int(x)) * double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
mp_int bnx;
mp_init(&bnx);
Cyc_int2bignum(obj_obj2int(x), &bnx);
alloc_bignum(data, bn);
mp_mul(&bnx, &bignum_value(y), &bignum_value(bn));
mp_clear(&bnx);
return bn;
}
}
// x is double
@ -2493,6 +2852,28 @@ object Cyc_fast_mul(void *data, object ptr, object x, object y) {
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, double_value(x) * double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
assign_double(ptr, double_value(x) * mp_get_double(&bignum_value(y)));
return ptr;
}
}
// x is bignum
if (is_object_type(x) && type_of(x) == bignum_tag) {
if (obj_is_int(y)){
mp_int bny;
mp_init(&bny);
Cyc_int2bignum(obj_obj2int(y), &bny);
alloc_bignum(data, bn);
mp_mul(&bignum_value(x), &bny, &bignum_value(bn));
mp_clear(&bny);
return bn;
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, mp_get_double(&bignum_value(x)) * double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
alloc_bignum(data, bn);
mp_mul(&bignum_value(x), &bignum_value(y), &bignum_value(bn));
return bn;
}
}
// still here, raise an error
@ -2510,11 +2891,22 @@ object Cyc_fast_div(void *data, object ptr, object x, object y) {
if (obj_is_int(x)){
if (obj_is_int(y)){
if (obj_obj2int(y) == 0) { goto divbyzero; }
// Overflow can occur if y = 0 || (x = 0x80000000 && y = -1)
// We already check for 0 above and the value of x above is a
// bignum, so no futher checks are required.
z = obj_obj2int(x) / obj_obj2int(y);
return obj_int2obj(z);
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, (double)(obj_obj2int(x)) / double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
mp_int bnx;
mp_init(&bnx);
Cyc_int2bignum(obj_obj2int(x), &bnx);
alloc_bignum(data, bn);
mp_div(&bnx, &bignum_value(y), &bignum_value(bn), NULL);
mp_clear(&bnx);
return bn;
}
}
// x is double
@ -2525,6 +2917,28 @@ object Cyc_fast_div(void *data, object ptr, object x, object y) {
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, double_value(x) / double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
assign_double(ptr, double_value(x) / mp_get_double(&bignum_value(y)));
return ptr;
}
}
// x is bignum
if (is_object_type(x) && type_of(x) == bignum_tag) {
if (obj_is_int(y)){
mp_int bny;
mp_init(&bny);
Cyc_int2bignum(obj_obj2int(y), &bny);
alloc_bignum(data, bn);
mp_div(&bignum_value(x), &bny, &bignum_value(bn), NULL);
mp_clear(&bny);
return bn;
} else if (is_object_type(y) && type_of(y) == double_tag) {
assign_double(ptr, mp_get_double(&bignum_value(x)) / double_value(y));
return ptr;
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
alloc_bignum(data, bn);
mp_div(&bignum_value(x), &bignum_value(y), &bignum_value(bn), NULL);
return bn;
}
}
// still here, raise an error
@ -2540,6 +2954,7 @@ divbyzero:
object Cyc_div_op(void *data, common_type * x, object y)
{
mp_int bn_tmp2;
int tx = type_of(x), ty;
if (obj_is_int(y)) {
ty = -1;
@ -2569,6 +2984,31 @@ object Cyc_div_op(void *data, common_type * x, object y)
x->double_t.value = x->integer_t.value / ((double_type *) y)->value;
} else if (tx == double_tag && ty == double_tag) {
x->double_t.value = x->double_t.value / ((double_type *) y)->value;
} else if (tx == integer_tag && ty == bignum_tag) {
mp_init(&bn_tmp2);
Cyc_int2bignum(x->integer_t.value, &bn_tmp2);
x->bignum_t.hdr.mark = gc_color_red;
x->bignum_t.hdr.grayed = 0;
x->bignum_t.tag = bignum_tag;
mp_init(&(x->bignum_t.bn));
mp_div(&bn_tmp2, &bignum_value(y), &(x->bignum_t.bn), NULL);
mp_clear(&bn_tmp2);
} else if (tx == double_tag && ty == bignum_tag) {
x->double_t.value = x->double_t.value / mp_get_double(&bignum_value(y));
} else if (tx == bignum_tag && ty == -1) {
mp_init(&bn_tmp2);
Cyc_int2bignum(obj_obj2int(y), &bn_tmp2);
mp_div(&(x->bignum_t.bn), &bn_tmp2, &(x->bignum_t.bn), NULL);
mp_clear(&bn_tmp2);
} else if (tx == bignum_tag && ty == double_tag) {
double d = mp_get_double(&(x->bignum_t.bn));
mp_clear(&(x->bignum_t.bn));
x->double_t.hdr.mark = gc_color_red;
x->double_t.hdr.grayed = 0;
x->double_t.tag = double_tag;
x->double_t.value = d / ((double_type *)y)->value;
} else if (tx == bignum_tag && ty == bignum_tag) {
mp_div(&(x->bignum_t.bn), &bignum_value(y), &(x->bignum_t.bn), NULL);
} else {
goto bad_arg_type_error;
}
@ -2606,10 +3046,9 @@ void dispatch_div(void *data, int argc, object clo, object cont, object n, ...)
return_closcall1(data, cont, result);
}
declare_num_op(Cyc_sum, Cyc_sum_op, dispatch_sum, +, 0, 0, 0);
declare_num_op(Cyc_sub, Cyc_sub_op, dispatch_sub, -, -1, 0, 0);
declare_num_op(Cyc_mul, Cyc_mul_op, dispatch_mul, *, 1, 1, 0);
//declare_num_op(Cyc_div, Cyc_div_op2, dispatch_div, /, -1, 1, 1);
declare_num_op(Cyc_sum, Cyc_sum_op, dispatch_sum, +, Cyc_checked_add, mp_add, 0, 0, 0);
declare_num_op(Cyc_sub, Cyc_sub_op, dispatch_sub, -, Cyc_checked_sub, mp_sub, -1, 0, 0);
declare_num_op(Cyc_mul, Cyc_mul_op, dispatch_mul, *, Cyc_checked_mul, mp_mul, 1, 1, 0);
object Cyc_num_op_va_list(void *data, int argc,
object(fn_op(void *, common_type *, object)),
@ -2645,6 +3084,11 @@ object Cyc_num_op_va_list(void *data, int argc,
buf->double_t.hdr.grayed = 0;
buf->double_t.tag = double_tag;
buf->double_t.value = ((double_type *) n)->value;
} else if (type_of(n) == bignum_tag) {
buf->bignum_t.hdr.mark = gc_color_red;
buf->bignum_t.hdr.grayed = 0;
buf->bignum_t.tag = bignum_tag;
mp_init_copy(&(buf->bignum_t.bn), &bignum_value(n));
} else {
goto bad_arg_type_error;
}
@ -2660,9 +3104,15 @@ object Cyc_num_op_va_list(void *data, int argc,
if (type_of(&tmp) == integer_tag) {
buf->integer_t.tag = integer_tag;
buf->integer_t.value = integer_value(&tmp);
} else {
} else if (type_of(&tmp) == double_tag){
buf->double_t.tag = double_tag;
buf->double_t.value = double_value(&tmp);
} else {
buf->bignum_t.tag = bignum_tag;
buf->bignum_t.bn.used = tmp.bignum_t.bn.used;
buf->bignum_t.bn.alloc = tmp.bignum_t.bn.alloc;
buf->bignum_t.bn.sign = tmp.bignum_t.bn.sign;
buf->bignum_t.bn.dp = tmp.bignum_t.bn.dp;
}
} else {
for (i = 1; i < argc; i++) {
@ -2673,6 +3123,8 @@ object Cyc_num_op_va_list(void *data, int argc,
// Convert to immediate int
if (type_of(buf) == integer_tag) {
return obj_int2obj(buf->integer_t.value);
} else if (type_of(buf) == bignum_tag) {
buf = gc_alloc_from_bignum(data, &(buf->bignum_t));
}
return buf;
@ -2686,6 +3138,130 @@ bad_arg_type_error:
}
}
void Cyc_expt_double(void *data, object cont, double x, double y)
{
make_double(d, pow(x, y));
return_closcall1(data, cont, &d);
}
void Cyc_expt(void *data, object cont, object x, object y)
{
if (obj_is_int(x)){
if (obj_is_int(y)){
if (obj_obj2int(y) < 0) {
Cyc_expt_double(data, cont, (double)obj_obj2int(x), (double)obj_obj2int(y));
} else {
alloc_bignum(data, bn);
Cyc_int2bignum(obj_obj2int(x), &(bn->bn));
mp_expt_d(&bignum_value(bn), obj_obj2int(y), &bignum_value(bn));
return_closcall1(data, cont, Cyc_bignum_normalize(data, bn));
}
} else if (is_object_type(y) && type_of(y) == double_tag) {
Cyc_expt_double(data, cont, (double)obj_obj2int(x), double_value(y));
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
// Not handled at this time
}
}
if (is_object_type(x) && type_of(x) == double_tag) {
make_double(d, 0.0);
if (obj_is_int(y)){
d.value = (double)obj_obj2int(y);
} else if (is_object_type(y) && type_of(y) == double_tag) {
d.value = double_value(y);
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
d.value = mp_get_double(&bignum_value(y));
}
d.value = pow(double_value(x), d.value);
return_closcall1(data, cont, &d);
}
if (is_object_type(x) && type_of(x) == bignum_tag) {
if (obj_is_int(y)){
if (obj_obj2int(y) < 0) {
Cyc_expt_double(data, cont, mp_get_double(&bignum_value(x)), (double)obj_obj2int(y));
} else {
alloc_bignum(data, bn);
mp_expt_d(&bignum_value(x), obj_obj2int(y), &bignum_value(bn));
return_closcall1(data, cont, Cyc_bignum_normalize(data, bn));
}
} else if (is_object_type(y) && type_of(y) == double_tag) {
Cyc_expt_double(data, cont, mp_get_double(&bignum_value(x)), double_value(y));
//make_double(d, 0.0);
//d.value = pow(mp_get_double(&bignum_value(x)), double_value(y));
//return_closcall1(data, cont, &d);
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
// Not handled at this time
}
}
// still here, raise an error
make_string(s, "Bad argument type");
make_pair(c2, y, NULL);
make_pair(c1, x, &c2);
make_pair(c0, &s, &c1);
Cyc_rt_raise(data, &c0);
}
void Cyc_bignum_remainder(void *data, object cont, object num1, object num2, object rem)
{
mp_div(&bignum_value(num1), &bignum_value(num2), NULL, &bignum_value(rem));
return_closcall1(data, cont, Cyc_bignum_normalize(data, rem));
}
void Cyc_remainder(void *data, object cont, object num1, object num2)
{
int i = 0, j = 0;
object result;
Cyc_check_num(data, num1);
Cyc_check_num(data, num2);
if (obj_is_int(num1)) {
if (obj_is_int(num2)){
i = obj_obj2int(num1);
j = obj_obj2int(num2);
}
else if (is_object_type(num2) && type_of(num2) == bignum_tag){
alloc_bignum(data, bn);
Cyc_int2bignum(obj_obj2int(num1), &(bn->bn));
Cyc_bignum_remainder(data, cont, bn, num2, bn);
}
else {
i = obj_obj2int(num1);
j = ((double_type *)num2)->value;
}
} else if (is_object_type(num1) && type_of(num1) == bignum_tag) {
if (obj_is_int(num2)){
alloc_bignum(data, bn);
Cyc_int2bignum(obj_obj2int(num2), &(bn->bn));
Cyc_bignum_remainder(data, cont, num1, bn, bn);
}
else if (is_object_type(num2) && type_of(num2) == bignum_tag){
alloc_bignum(data, rem);
Cyc_bignum_remainder(data, cont, num1, num2, rem);
}
else {
j = ((double_type *)num2)->value;
alloc_bignum(data, bn);
Cyc_int2bignum(obj_obj2int(j), &(bn->bn));
Cyc_bignum_remainder(data, cont, num1, bn, bn);
}
} else { // num1 is double...
if (obj_is_int(num2)){
i = ((double_type *)num1)->value;
j = obj_obj2int(num2);
}
else if (is_object_type(num2) && type_of(num2) == bignum_tag){
i = ((double_type *)num1)->value;
alloc_bignum(data, bn);
Cyc_int2bignum(obj_obj2int(i), &(bn->bn));
Cyc_bignum_remainder(data, cont, bn, num2, bn);
}
else {
i = ((double_type *)num1)->value;
j = ((double_type *)num2)->value;
}
}
result = obj_int2obj(i % j);
return_closcall1(data, cont, result);
}
/* I/O functions */
port_type Cyc_stdout()
@ -4078,6 +4654,11 @@ char *gc_move(char *obj, gc_thread_data * thd, int *alloci, int *heap_grown)
gc_alloc(heap, sizeof(integer_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case bignum_tag:{
bignum_type *hp =
gc_alloc(heap, sizeof(bignum_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case double_tag:{
double_type *hp =
gc_alloc(heap, sizeof(double_type), obj, thd, heap_grown);
@ -4235,6 +4816,7 @@ int gc_minor(void *data, object low_limit, object high_limit, closure cont,
case bytevector_tag:
case string_tag:
case integer_tag:
case bignum_tag:
case double_tag:
case port_tag:
case cvar_tag:

46
scheme/base.sld
View file

@ -41,6 +41,7 @@
odd?
complex?
rational?
bignum?
gcd
lcm
quotient
@ -1060,6 +1061,10 @@
" Cyc_check_num(data, num);
if (obj_is_int(num)) {
return_closcall1(data, k, obj_int2obj( abs( obj_obj2int(num))));
} else if (is_object_type(num) && type_of(num) == bignum_tag){
alloc_bignum(data, bn);
mp_abs(&bignum_value(num), &bignum_value(bn));
return_closcall1(data, k, bn);
} else {
make_double(d, fabs(((double_type *)num)->value));
return_closcall1(data, k, &d);
@ -1067,23 +1072,7 @@
;; Apparently C % is actually the remainder, not modulus
(define-c remainder
"(void *data, int argc, closure _, object k, object num1, object num2)"
" int i, j;
Cyc_check_num(data, num1);
Cyc_check_num(data, num2);
if (obj_is_int(num1)) {
i = obj_obj2int(num1);
} else /* Must be double: if (type_of(num1) == double_tag)*/ {
i = ((double_type *)num1)->value;
}
if (obj_is_int(num2)) {
j = obj_obj2int(num2);
} else /* Must be double: if (type_of(num2) == double_tag)*/ {
j = ((double_type *)num2)->value;
}
{
object result = obj_int2obj(i % j);
return_closcall1(data, k, result);
}")
" Cyc_remainder(data, k, num1, num2); ")
;; From chibi scheme. Cannot use C % operator
(define (modulo a b)
(let ((res (remainder a b)))
@ -1092,13 +1081,25 @@
(if (>= res 0) res (+ res b)))))
(define (odd? num) (= (modulo num 2) 1))
(define (even? num) (= (modulo num 2) 0))
(define-c bignum?
"(void *data, int argc, closure _, object k, object obj)"
" return_closcall1(data, k, Cyc_is_bignum(obj)); ")
(define-c bignum-sqrt
"(void *data, int argc, closure _, object k, object obj)"
" alloc_bignum(data, bn);
if (MP_OKAY != mp_sqrt(&(bignum_value(obj)), &bignum_value(bn))) {
Cyc_rt_raise2(data, \"Error computing sqrt\", obj);
}
return_closcall1(data, k, bn); ")
;; from mosh
(define (exact-integer-sqrt k)
(unless (and (exact? k)
(integer? k)
(not (negative? k)))
(error "exact non-negative integer required" k))
(let* ((s (exact (truncate (sqrt k))))
(let* ((s (if (bignum? k)
(bignum-sqrt k)
(exact (truncate (sqrt k)))))
(r (- k (* s s))))
(values s r)))
(define-c sqrt
@ -1109,7 +1110,8 @@
(define-c exact?
"(void *data, int argc, closure _, object k, object num)"
" Cyc_check_num(data, num);
if (obj_is_int(num) || type_of(num) == integer_tag)
if (obj_is_int(num) || type_of(num) == integer_tag
|| type_of(num) == bignum_tag)
return_closcall1(data, k, boolean_t);
return_closcall1(data, k, boolean_f); ")
(define (inexact? num) (not (exact? num)))
@ -1172,11 +1174,7 @@
(define (square z) (* z z))
(define-c expt
"(void *data, int argc, closure _, object k, object z1, object z2)"
" make_double(d, 0.0);
Cyc_check_num(data, z1);
Cyc_check_num(data, z2);
d.value = pow( unbox_number(z1), unbox_number(z2) );
return_closcall1(data, k, &d); ")
" Cyc_expt(data, k, z1, z2); ")
(define-c eof-object
"(void *data, int argc, closure _, object k)"
" return_closcall1(data, k, Cyc_EOF); ")

13
scheme/cyclone/cgen.sld
View file

@ -472,6 +472,19 @@
(c-compile-vector exp))
((bytevector? exp)
(c-compile-bytevector exp))
((bignum? exp)
(let ((cvar-name (mangle (gensym 'c)))
(num2str (cond
(else
(number->string exp)))))
(c-code/vars
(string-append "" cvar-name) ; Code is just the variable name
(list ; Allocate pointer on the C stack
(string-append
"alloc_bignum(data, " cvar-name "); "
;; TODO: need error checking, this is just a first cut:
"mp_read_radix(&bignum_value(" cvar-name "), \"" num2str "\", 10);"))))
)
((integer? exp)
; (let ((cvar-name (mangle (gensym 'c))))
; (c-code/vars

14
scheme/inexact.sld
View file

@ -27,6 +27,7 @@
" Cyc_check_num(data, z);
if (obj_is_int(z) ||
type_of(z) == integer_tag ||
type_of(z) == bignum_tag ||
!isnan(((double_type *)z)->value))
{
return_closcall1(data, k, boolean_f);
@ -37,21 +38,14 @@
" Cyc_check_num(data, z);
if (obj_is_int(z) ||
type_of(z) == integer_tag ||
type_of(z) == bignum_tag ||
!isinf(((double_type *)z)->value))
{
return_closcall1(data, k, boolean_f);
}
return_closcall1(data, k, boolean_t);")
(define-c finite?
"(void *data, int argc, closure _, object k, object z)"
" Cyc_check_num(data, z);
if (obj_is_int(z) ||
type_of(z) == integer_tag ||
!isfinite(((double_type *)z)->value))
{
return_closcall1(data, k, boolean_f);
}
return_closcall1(data, k, boolean_t);")
(define (finite? z)
(if (infinite? z) #f #t))
(define-c acos
"(void *data, int argc, closure _, object k, object z)"
" return_inexact_double_op(data, k, acos, z);")

2
scheme/read.sld
View file

@ -593,7 +593,7 @@
(string->number (list->string a))
(if (or (equal? a '(#\+ #\i #\n #\f #\. #\0))
(equal? a '(#\- #\i #\n #\f #\. #\0)))
(expt 2 1000000)
(expt 2.0 1000000)
(if (or (equal? a '(#\+ #\n #\a #\n #\. #\0))
(equal? a '(#\- #\n #\a #\n #\. #\0)))
(/ 0.0 0.0)

63
srfi/143.sld Normal file
View file

@ -0,0 +1,63 @@
;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module is (currently) a stub of SRFI 143.
;;;; Note the SRFI is still in DRAFT status.
;;;;
(define-library (srfi 143)
(import (scheme base))
(export
fx-width
fx-greatest
fx-least
fixnum?
fxzero? fxpositive? fxnegative? fxodd? fxeven?
fx= fx< fx> fx<= fx>=
fxmax fxmin
fx+ fx- fx*
fxabs fxsquare fxsqrt fxexpt
fx+/carry
fx-/carry
fx*+/carry
fxfloor/ fxfloor-quotient fxfloor-remainder
fxceiling/ fxceiling-quotient fxceiling-remainder
fxtruncate/ fxtruncate-quotient fxtruncate-remainder
fxround/ fxround-quotient fxround-remainder
fxeuclidean/ fxeuclidean-quotient fxeuclidean-remainder
fxbalanced/ fxbalanced-quotient fxbalanced-remainder
fxnot
fxand fxior fxxor fxeqv
fxnand fxnor
fxandc1 fxandc2 fxorc1 fxorc2
farithmetic-shift fxbit-count fxinteger-length
fxif
fxbit-set? fxcopy-bit fxbit-swap
fxany-bit-set? fxevery-bit-set?
fxfirst-set-bit
fxbit-field fxbit-field-any? fxbit-field-every?
fxbit-field-clear fxbit-field-set
fxbit-field-replace fbit-field-replace-same
fxbit-field-rotate fxbit-field-reverse
fxbit-field-append
fixnum->list list->fixnum
fixnum->vector vector->fixnum
fxbits
fxfold fxfor-each fxunfold
fxlogical-shift
)
(begin
(define (fx-width) 31)
(define (fx-greatest) 1073741823)
(define (fx-least) -1073741824)
(define-c fixnum?
"(void *data, int argc, closure _, object k, object obj)"
" return_closcall1(data, k,
obj_is_int(obj) ? boolean_t : boolean_f); ")
))