From 5681745bc3eff5ebcaa2986137c1df63ae920a7e Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Fri, 13 Mar 2009 22:26:44 +0000 Subject: [PATCH] adding apply1, using it in trycatch (avoids consing) allowing left bit shift to overflow to larger types fixing bug in number->string on uint64 fixing bug in rand.uint64 --- femtolisp/builtins.c | 2 +- femtolisp/cvalues.c | 57 +++++++++++++++++++++++++------------------- femtolisp/flisp.c | 44 +++++++++++++++++++++------------- femtolisp/flisp.h | 1 + femtolisp/string.c | 15 ++++++++---- llt/int2str.c | 12 +++------- llt/utils.h | 2 +- 7 files changed, 76 insertions(+), 57 deletions(-) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index ea8a9ee..0a53615 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -334,7 +334,7 @@ value_t fl_rand32(value_t *args, u_int32_t nargs) value_t fl_rand64(value_t *args, u_int32_t nargs) { (void)args; (void)nargs; - ulong r = (((uint64_t)random())<<32) | random(); + uint64_t r = (((uint64_t)random())<<32) | random(); return mk_uint64(r); } value_t fl_randd(value_t *args, u_int32_t nargs) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 5024a3f..0ade7d4 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -1303,32 +1303,39 @@ static value_t fl_bitwise_not(value_t a) return NIL; } -#define BITSHIFT_OP(name, op) \ -static value_t fl_##name(value_t a, int n) \ -{ \ - cprim_t *cp; \ - int ta; \ - void *aptr; \ - if (iscprim(a)) { \ - cp = (cprim_t*)ptr(a); \ - ta = cp_numtype(cp); \ - aptr = cp_data(cp); \ - switch (ta) { \ - case T_INT8: return fixnum((*(int8_t *)aptr) op n); \ - case T_UINT8: return fixnum((*(uint8_t *)aptr) op n); \ - case T_INT16: return fixnum((*(int16_t *)aptr) op n); \ - case T_UINT16: return fixnum((*(uint16_t*)aptr) op n); \ - case T_INT32: return mk_int32((*(int32_t *)aptr) op n); \ - case T_UINT32: return mk_uint32((*(uint32_t*)aptr) op n); \ - case T_INT64: return mk_int64((*(int64_t *)aptr) op n); \ - case T_UINT64: return mk_uint64((*(uint64_t*)aptr) op n); \ - } \ - } \ - type_error("ash", "integer", a); \ - return NIL; \ +static value_t fl_ash(value_t a, int n) +{ + cprim_t *cp; + int ta; + void *aptr; + if (iscprim(a)) { + if (n == 0) return a; + cp = (cprim_t*)ptr(a); + ta = cp_numtype(cp); + aptr = cp_data(cp); + if (n < 0) { + n = -n; + switch (ta) { + case T_INT8: return fixnum((*(int8_t *)aptr) >> n); + case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n); + case T_INT16: return fixnum((*(int16_t *)aptr) >> n); + case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n); + case T_INT32: return mk_int32((*(int32_t *)aptr) >> n); + case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n); + case T_INT64: return mk_int64((*(int64_t *)aptr) >> n); + case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n); + } + } + else { + if (ta == T_UINT64) + return return_from_uint64((*(uint64_t*)aptr)<>) static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname) { diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 0edd219..d7a6283 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -280,7 +280,7 @@ char *symbol_name(value_t v) if (ismanaged(v)) { gensym_t *gs = (gensym_t*)ptr(v); gsnameno = 1-gsnameno; - char *n = int2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10); + char *n = uint2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10); *(--n) = 'g'; return n; } @@ -449,6 +449,7 @@ static void trace_globals(symbol_t *root) } static value_t special_apply_form; +static value_t apply1_args; static value_t memory_exception_value; void gc(int mustgrow) @@ -476,6 +477,7 @@ void gc(int mustgrow) } lasterror = relocate(lasterror); special_apply_form = relocate(special_apply_form); + apply1_args = relocate(apply1_args); memory_exception_value = relocate(memory_exception_value); sweep_finalizers(); @@ -522,6 +524,12 @@ value_t apply(value_t f, value_t l) return v; } +value_t apply1(value_t f, value_t a0) +{ + car_(apply1_args) = a0; + return apply(f, apply1_args); +} + value_t listn(size_t n, ...) { va_list ap; @@ -658,10 +666,8 @@ static value_t do_trycatch(value_t expr, uint32_t penv) v = FL_F; // 1-argument form } else { - Stack[SP-1] = car_(v); - value_t quoted = list2(QUOTE, lasterror); - expr = list2(Stack[SP-1], quoted); - v = eval(expr); + Stack[SP-1] = eval(car_(v)); + v = apply1(Stack[SP-1], lasterror); } } return v; @@ -1202,19 +1208,22 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } break; case F_ASH: - argcount("ash", nargs, 2); - i = tofixnum(Stack[SP-1], "ash"); - if (isfixnum(Stack[SP-2])) { - if (i < 0) - v = fixnum(numval(Stack[SP-2])>>(-i)); + argcount("ash", nargs, 2); + i = tofixnum(Stack[SP-1], "ash"); + if (isfixnum(Stack[SP-2])) { + if (i <= 0) + v = fixnum(numval(Stack[SP-2])>>(-i)); + else { + accum = ((int64_t)numval(Stack[SP-2]))< 2) argcount("number->string", nargs, 2); value_t n = args[0]; - int64_t num; + int neg = 0; + uint64_t num; if (isfixnum(n)) num = numval(n); else if (!iscprim(n)) type_error("number->string", "integer", n); - else num = conv_to_int64(cp_data((cprim_t*)ptr(n)), - cp_numtype((cprim_t*)ptr(n))); + else num = conv_to_uint64(cp_data((cprim_t*)ptr(n)), + cp_numtype((cprim_t*)ptr(n))); + if (numval(compare(args[0],fixnum(0))) < 0) { + num = -num; + neg = 1; + } ulong radix = 10; if (nargs == 2) { radix = toulong(args[1], "number->string"); @@ -307,7 +312,9 @@ value_t fl_numbertostring(value_t *args, u_int32_t nargs) lerror(ArgError, "number->string: invalid radix"); } char buf[128]; - char *str = int2str(buf, sizeof(buf), num, radix); + char *str = uint2str(buf, sizeof(buf), num, radix); + if (neg && str > &buf[0]) + *(--str) = '-'; return string_from_cstr(str); } diff --git a/llt/int2str.c b/llt/int2str.c index a288ccc..2210fde 100644 --- a/llt/int2str.c +++ b/llt/int2str.c @@ -1,15 +1,11 @@ #include #include "dtypes.h" -char *int2str(char *dest, size_t len, int64_t num, uint32_t base) +char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base) { - int i = len-1, neg = 0; - int64_t b = (int64_t)base; + int i = len-1; + uint64_t b = (uint64_t)base; char ch; - if (num < 0) { - num = -num; - neg = 1; - } dest[i--] = '\0'; while (i >= 0) { ch = (char)(num % b); @@ -22,8 +18,6 @@ char *int2str(char *dest, size_t len, int64_t num, uint32_t base) if (num == 0) break; } - if (i >= 0 && neg) - dest[i--] = '-'; return &dest[i+1]; } diff --git a/llt/utils.h b/llt/utils.h index b707211..2d9d16f 100644 --- a/llt/utils.h +++ b/llt/utils.h @@ -45,7 +45,7 @@ void snprint_cplx(char *s, size_t cnt, double re, double im, // print spaces around sign in a+bi int spflag); -char *int2str(char *dest, size_t len, int64_t num, uint32_t base); +char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base); int str2int(char *str, size_t len, int64_t *res, uint32_t base); int isdigit_base(char c, int base);