lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

adding ash function 

making more functions static
removing list_nth, using vectors for enums instead
making more operators return fixnums where possible
This commit is contained in:
JeffBezanson 2009-03-11 19:16:40 +00:00
parent 05ef9f42a5
commit d81e6c2d57
5 changed files with 64 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
femtolisp/builtins.c
View File

@ -26,16 +26,6 @@ size_t llength(value_t v)
return n; return n;
} }
value_t list_nth(value_t l, size_t n)
{
while (n && iscons(l)) {
l = cdr_(l);
n--;
}
if (iscons(l)) return car_(l);
return NIL;
}
value_t fl_exit(value_t *args, u_int32_t nargs) value_t fl_exit(value_t *args, u_int32_t nargs)
{ {
if (nargs > 0) if (nargs > 0)

77
femtolisp/cvalues.c
View File

@ -30,7 +30,6 @@ static fltype_t *floattype, *doubletype;
static void cvalue_init(fltype_t *type, value_t v, void *dest); static void cvalue_init(fltype_t *type, value_t v, void *dest);
void cvalue_print(ios_t *f, value_t v, int princ);
// cvalues-specific builtins // cvalues-specific builtins
value_t cvalue_new(value_t *args, u_int32_t nargs); value_t cvalue_new(value_t *args, u_int32_t nargs);
value_t cvalue_sizeof(value_t *args, u_int32_t nargs); value_t cvalue_sizeof(value_t *args, u_int32_t nargs);
@ -340,16 +339,14 @@ static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
value_t type = ft->type; value_t type = ft->type;
syms = car(cdr(type)); syms = car(cdr(type));
if (!iscons(syms)) if (!isvector(syms))
type_error("enum", "cons", syms); type_error("enum", "vector", syms);
if (issymbol(arg)) { if (issymbol(arg)) {
while (iscons(syms)) { for(n=0; n < (int)vector_size(syms); n++) {
if (car_(syms) == arg) { if (vector_elt(syms, n) == arg) {
*(int*)dest = n; *(int*)dest = n;
return 0; return 0;
} }
n++;
syms = cdr_(syms);
} }
lerror(ArgError, "enum: invalid enum value"); lerror(ArgError, "enum: invalid enum value");
} }
@ -363,7 +360,7 @@ static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
else { else {
type_error("enum", "number", arg); type_error("enum", "number", arg);
} }
if ((unsigned)n >= llength(syms)) if ((unsigned)n >= vector_size(syms))
lerror(ArgError, "enum: value out of range"); lerror(ArgError, "enum: value out of range");
*(int*)dest = n; *(int*)dest = n;
return 0; return 0;
@ -493,7 +490,7 @@ size_t cvalue_arraylen(value_t v)
return cv_len(cv)/(cv_class(cv)->elsz); return cv_len(cv)/(cv_class(cv)->elsz);
} }
value_t cvalue_relocate(value_t v) static value_t cvalue_relocate(value_t v)
{ {
size_t nw; size_t nw;
cvalue_t *cv = (cvalue_t*)ptr(v); cvalue_t *cv = (cvalue_t*)ptr(v);
@ -513,8 +510,8 @@ value_t cvalue_relocate(value_t v)
return ncv; return ncv;
} }
size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal, static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
int *palign) int *palign)
{ {
value_t fld = car(cdr_(type)); value_t fld = car(cdr_(type));
size_t fsz, ssz = 0; size_t fsz, ssz = 0;
@ -904,7 +901,7 @@ static builtinspec_t cvalues_builtin_info[] = {
#define mk_primtype_(name,ctype) \ #define mk_primtype_(name,ctype) \
name##type=get_type(name##sym);name##type->init = &cvalue_##ctype##_init name##type=get_type(name##sym);name##type->init = &cvalue_##ctype##_init
void cvalues_init() static void cvalues_init()
{ {
htable_new(&TypeTable, 256); htable_new(&TypeTable, 256);
htable_new(&reverse_dlsym_lookup_table, 256); htable_new(&reverse_dlsym_lookup_table, 256);
@ -1010,7 +1007,7 @@ value_t return_from_int64(int64_t Saccum)
RETURN_NUM_AS(Saccum, int32); RETURN_NUM_AS(Saccum, int32);
} }
value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn) static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
{ {
uint64_t Uaccum=0; uint64_t Uaccum=0;
int64_t Saccum = carryIn; int64_t Saccum = carryIn;
@ -1078,7 +1075,7 @@ value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
return return_from_uint64(Uaccum); return return_from_uint64(Uaccum);
} }
value_t fl_neg(value_t n) static value_t fl_neg(value_t n)
{ {
if (isfixnum(n)) { if (isfixnum(n)) {
return fixnum(-numval(n)); return fixnum(-numval(n));
@ -1117,7 +1114,7 @@ value_t fl_neg(value_t n)
type_error("-", "number", n); type_error("-", "number", n);
} }
value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum) static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
{ {
uint64_t Uaccum=1; uint64_t Uaccum=1;
double Faccum=1; double Faccum=1;
@ -1178,7 +1175,7 @@ value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
return return_from_uint64(Uaccum); return return_from_uint64(Uaccum);
} }
value_t fl_div2(value_t a, value_t b) static value_t fl_div2(value_t a, value_t b)
{ {
double da, db; double da, db;
int_t ai, bi; int_t ai, bi;
@ -1281,7 +1278,7 @@ static void *int_data_ptr(value_t a, int *pnumtype, char *fname)
return NULL; return NULL;
} }
value_t fl_bitwise_not(value_t a) static value_t fl_bitwise_not(value_t a)
{ {
cprim_t *cp; cprim_t *cp;
int ta; int ta;
@ -1292,10 +1289,10 @@ value_t fl_bitwise_not(value_t a)
ta = cp_numtype(cp); ta = cp_numtype(cp);
aptr = cp_data(cp); aptr = cp_data(cp);
switch (ta) { switch (ta) {
case T_INT8: return mk_int8(~*(int8_t *)aptr); case T_INT8: return fixnum(~*(int8_t *)aptr);
case T_UINT8: return mk_uint8(~*(uint8_t *)aptr); case T_UINT8: return fixnum(~*(uint8_t *)aptr);
case T_INT16: return mk_int16(~*(int16_t *)aptr); case T_INT16: return fixnum(~*(int16_t *)aptr);
case T_UINT16: return mk_uint16(~*(uint16_t*)aptr); case T_UINT16: return fixnum(~*(uint16_t*)aptr);
case T_INT32: return mk_int32(~*(int32_t *)aptr); case T_INT32: return mk_int32(~*(int32_t *)aptr);
case T_UINT32: return mk_uint32(~*(uint32_t*)aptr); case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
case T_INT64: return mk_int64(~*(int64_t *)aptr); case T_INT64: return mk_int64(~*(int64_t *)aptr);
@ -1307,7 +1304,7 @@ value_t fl_bitwise_not(value_t a)
} }
#define BITSHIFT_OP(name, op) \ #define BITSHIFT_OP(name, op) \
value_t fl_##name(value_t a, int n) \ static value_t fl_##name(value_t a, int n) \
{ \ { \
cprim_t *cp; \ cprim_t *cp; \
int ta; \ int ta; \
@ -1317,23 +1314,23 @@ value_t fl_##name(value_t a, int n) \
ta = cp_numtype(cp); \ ta = cp_numtype(cp); \
aptr = cp_data(cp); \ aptr = cp_data(cp); \
switch (ta) { \ switch (ta) { \
case T_INT8: return mk_int8((*(int8_t *)aptr) op n); \ case T_INT8: return fixnum((*(int8_t *)aptr) op n); \
case T_UINT8: return mk_uint8((*(uint8_t *)aptr) op n); \ case T_UINT8: return fixnum((*(uint8_t *)aptr) op n); \
case T_INT16: return mk_int16((*(int16_t *)aptr) op n); \ case T_INT16: return fixnum((*(int16_t *)aptr) op n); \
case T_UINT16: return mk_uint16((*(uint16_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_INT32: return mk_int32((*(int32_t *)aptr) op n); \
case T_UINT32: return mk_uint32((*(uint32_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_INT64: return mk_int64((*(int64_t *)aptr) op n); \
case T_UINT64: return mk_uint64((*(uint64_t*)aptr) op n); \ case T_UINT64: return mk_uint64((*(uint64_t*)aptr) op n); \
} \ } \
} \ } \
type_error(#op, "integer", a); \ type_error("ash", "integer", a); \
return NIL; \ return NIL; \
} }
BITSHIFT_OP(shl,<<) BITSHIFT_OP(shl,<<)
BITSHIFT_OP(shr,>>) BITSHIFT_OP(shr,>>)
value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname) static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
{ {
int_t ai, bi; int_t ai, bi;
int ta, tb, itmp; int ta, tb, itmp;
@ -1366,10 +1363,10 @@ value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
switch (opcode) { switch (opcode) {
case 0: case 0:
switch (ta) { switch (ta) {
case T_INT8: return mk_int8( *(int8_t *)aptr & (int8_t )b64); case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
case T_UINT8: return mk_uint8( *(uint8_t *)aptr & (uint8_t )b64); case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
case T_INT16: return mk_int16( *(int16_t*)aptr & (int16_t )b64); case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
case T_UINT16: return mk_uint16(*(uint16_t*)aptr & (uint16_t)b64); case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64); case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64); case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64); case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
@ -1378,10 +1375,10 @@ value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
break; break;
case 1: case 1:
switch (ta) { switch (ta) {
case T_INT8: return mk_int8( *(int8_t *)aptr | (int8_t )b64); case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
case T_UINT8: return mk_uint8( *(uint8_t *)aptr | (uint8_t )b64); case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
case T_INT16: return mk_int16( *(int16_t*)aptr | (int16_t )b64); case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
case T_UINT16: return mk_uint16(*(uint16_t*)aptr | (uint16_t)b64); case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64); case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64); case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64); case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
@ -1390,10 +1387,10 @@ value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
break; break;
case 2: case 2:
switch (ta) { switch (ta) {
case T_INT8: return mk_int8( *(int8_t *)aptr ^ (int8_t )b64); case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
case T_UINT8: return mk_uint8( *(uint8_t *)aptr ^ (uint8_t )b64); case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
case T_INT16: return mk_int16( *(int16_t*)aptr ^ (int16_t )b64); case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
case T_UINT16: return mk_uint16(*(uint16_t*)aptr ^ (uint16_t)b64); case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64); case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64); case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64); case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);

18
femtolisp/flisp.c
View File

@ -66,7 +66,7 @@ static char *builtin_names[] =
"eval", "eval*", "apply", "prog1", "raise", "eval", "eval*", "apply", "prog1", "raise",
// arithmetic // arithmetic
"+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor", "+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor", "ash",
"compare", "compare",
// sequences // sequences
@ -1173,6 +1173,20 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
else else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$"); v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$");
break; 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));
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;
case F_COMPARE: case F_COMPARE:
argcount("compare", nargs, 2); argcount("compare", nargs, 2);
v = compare(Stack[SP-2], Stack[SP-1]); v = compare(Stack[SP-2], Stack[SP-1]);
@ -1425,7 +1439,7 @@ void assign_global_builtins(builtinspec_t *b)
} }
} }
void lisp_init(void) static void lisp_init(void)
{ {
int i; int i;

5
femtolisp/flisp.h
View File

@ -43,7 +43,7 @@ typedef struct _symbol_t {
#define tag(x) ((x)&0x7) #define tag(x) ((x)&0x7)
#define ptr(x) ((void*)((x)&(~(value_t)0x7))) #define ptr(x) ((void*)((x)&(~(value_t)0x7)))
#define tagptr(p,t) (((value_t)(p)) | (t)) #define tagptr(p,t) (((value_t)(p)) | (t))
#define fixnum(x) ((value_t)((x)<<2)) #define fixnum(x) ((value_t)(((fixnum_t)(x))<<2))
#define numval(x) (((fixnum_t)(x))>>2) #define numval(x) (((fixnum_t)(x))>>2)
#ifdef BITS64 #ifdef BITS64
#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0) #define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
@ -110,7 +110,7 @@ enum {
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR, F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE, F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE,
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ASH,
F_COMPARE, F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_FOR, F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_FOR,
F_TRUE, F_FALSE, F_NIL, F_TRUE, F_FALSE, F_NIL,
@ -136,7 +136,6 @@ value_t fl_gensym();
char *symbol_name(value_t v); char *symbol_name(value_t v);
value_t alloc_vector(size_t n, int init); value_t alloc_vector(size_t n, int init);
size_t llength(value_t v); size_t llength(value_t v);
value_t list_nth(value_t l, size_t n);
value_t compare(value_t a, value_t b); // -1, 0, or 1 value_t compare(value_t a, value_t b); // -1, 0, or 1
value_t equal(value_t a, value_t b); // T or nil value_t equal(value_t a, value_t b); // T or nil
int equal_lispvalue(value_t a, value_t b); int equal_lispvalue(value_t a, value_t b);

16
femtolisp/print.c
View File

@ -325,7 +325,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
} }
} }
void cvalue_print(ios_t *f, value_t v, int princ); static void cvalue_print(ios_t *f, value_t v, int princ);
void fl_print_child(ios_t *f, value_t v, int princ) void fl_print_child(ios_t *f, value_t v, int princ)
{ {
@ -427,7 +427,7 @@ void fl_print_child(ios_t *f, value_t v, int princ)
} }
} }
void print_string(ios_t *f, char *str, size_t sz) static void print_string(ios_t *f, char *str, size_t sz)
{ {
char buf[512]; char buf[512];
size_t i = 0; size_t i = 0;
@ -609,17 +609,19 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
outc(']', f); outc(']', f);
} }
else if (car_(type) == enumsym) { else if (car_(type) == enumsym) {
value_t sym = list_nth(car(cdr_(type)), *(size_t*)data); int n = *(int*)data;
value_t syms = car(cdr_(type));
assert(isvector(syms));
if (!weak) { if (!weak) {
outs("#enum(", f); outs("#enum(", f);
fl_print_child(f, car(cdr_(type)), princ); fl_print_child(f, syms, princ);
outc(' ', f); outc(' ', f);
} }
if (sym == NIL) { if (n >= (int)vector_size(syms)) {
cvalue_printdata(f, data, len, int32sym, princ, 1); cvalue_printdata(f, data, len, int32sym, princ, 1);
} }
else { else {
fl_print_child(f, sym, princ); fl_print_child(f, vector_elt(syms, n), princ);
} }
if (!weak) if (!weak)
outc(')', f); outc(')', f);
@ -627,7 +629,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
} }
} }
void cvalue_print(ios_t *f, value_t v, int princ) static void cvalue_print(ios_t *f, value_t v, int princ)
{ {
cvalue_t *cv = (cvalue_t*)ptr(v); cvalue_t *cv = (cvalue_t*)ptr(v);
void *data = cptr(v); void *data = cptr(v);