conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
JeffBezanson 2009-03-13 22:26:44 +00:00
parent dceced2bb0
commit 5681745bc3
7 changed files with 76 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/builtins.c
View File

@ -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)

57
femtolisp/cvalues.c
View File

@ -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)<<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)
{

44
femtolisp/flisp.c
View File

@ -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]))<<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 @@ static void lisp_init(void)
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)

1
femtolisp/flisp.h
View File

@ -125,6 +125,7 @@ value_t read_sexpr(value_t f);
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 */

15
femtolisp/string.c
View File

@ -295,11 +295,16 @@ value_t fl_numbertostring(value_t *args, u_int32_t nargs)
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 @@ 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);
}

12
llt/int2str.c
View File

@ -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 @@ 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];
}

2
llt/utils.h
View File

@ -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);