ref: 5681745bc3eff5ebcaa2986137c1df63ae920a7e
parent: dceced2bb0caf0328d4ac8db87c2015bdee22b02
author: JeffBezanson <[email protected]>
date: Fri Mar 13 18:26:44 EDT 2009
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
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -334,7 +334,7 @@
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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -1303,32 +1303,39 @@
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)<<n);
+ int64_t i64 = conv_to_int64(aptr, ta);
+ return return_from_int64(i64<<n);
+ }
+ }
+ type_error("ash", "integer", a);+ return NIL;
}
-BITSHIFT_OP(shl,<<)
-BITSHIFT_OP(shr,>>)
static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
{--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -280,7 +280,7 @@
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 value_t special_apply_form;
+static value_t apply1_args;
static value_t memory_exception_value;
void gc(int mustgrow)
@@ -476,6 +477,7 @@
}
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 @@
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 @@
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 @@
}
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]))<<i;
+ if (fits_fixnum(accum))
+ v = fixnum(accum);
+ else
+ v = return_from_int64(accum);
+ }
+ }
else
- v = fixnum(numval(Stack[SP-2])<<i);
- }
- else if (i < 0)
- v = fl_shr(Stack[SP-2], -i);
- else
- v = fl_shl(Stack[SP-2], i);
- break;
+ v = fl_ash(Stack[SP-2], i);
+ break;
case F_COMPARE:
argcount("compare", nargs, 2);v = compare(Stack[SP-2], Stack[SP-1]);
@@ -1520,6 +1529,7 @@
set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));lasterror = NIL;
special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);
+ apply1_args = fl_cons(NIL, NIL);
i = 0;
while (isspecial(builtin(i))) {if (i != F_SPECIAL_APPLY)
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -125,6 +125,7 @@
void print(ios_t *f, value_t v, int princ);
value_t toplevel_eval(value_t expr);
value_t apply(value_t f, value_t l);
+value_t apply1(value_t f, value_t a0);
value_t load_file(char *fname);
/* object model manipulation */
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -295,11 +295,16 @@
if (nargs < 1 || nargs > 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 @@
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);
}
--- a/llt/int2str.c
+++ b/llt/int2str.c
@@ -1,15 +1,11 @@
#include <stdlib.h>
#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 @@
if (num == 0)
break;
}
- if (i >= 0 && neg)
- dest[i--] = '-';
return &dest[i+1];
}
--- a/llt/utils.h
+++ b/llt/utils.h
@@ -45,7 +45,7 @@
// 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);