ref: d81e6c2d57c8d38c7ce80ede40734ba52bc0dffd
parent: 05ef9f42a52c48e951e8dc21b5b37126008658f2
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Mar 11 15:16:40 EDT 2009
adding ash function making more functions static removing list_nth, using vectors for enums instead making more operators return fixnums where possible
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -26,16 +26,6 @@
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)
{if (nargs > 0)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -30,7 +30,6 @@
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
value_t cvalue_new(value_t *args, u_int32_t nargs);
value_t cvalue_sizeof(value_t *args, u_int32_t nargs);
@@ -340,16 +339,14 @@
value_t type = ft->type;
syms = car(cdr(type));
- if (!iscons(syms))
- type_error("enum", "cons", syms);+ if (!isvector(syms))
+ type_error("enum", "vector", syms); if (issymbol(arg)) {- while (iscons(syms)) {- if (car_(syms) == arg) {+ for(n=0; n < (int)vector_size(syms); n++) {+ if (vector_elt(syms, n) == arg) {*(int*)dest = n;
return 0;
}
- n++;
- syms = cdr_(syms);
}
lerror(ArgError, "enum: invalid enum value");
}
@@ -363,7 +360,7 @@
else { type_error("enum", "number", arg);}
- if ((unsigned)n >= llength(syms))
+ if ((unsigned)n >= vector_size(syms))
lerror(ArgError, "enum: value out of range");
*(int*)dest = n;
return 0;
@@ -493,7 +490,7 @@
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;
cvalue_t *cv = (cvalue_t*)ptr(v);
@@ -513,8 +510,8 @@
return ncv;
}
-size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
- int *palign)
+static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
+ int *palign)
{value_t fld = car(cdr_(type));
size_t fsz, ssz = 0;
@@ -904,7 +901,7 @@
#define mk_primtype_(name,ctype) \
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(&reverse_dlsym_lookup_table, 256);
@@ -1010,7 +1007,7 @@
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;
int64_t Saccum = carryIn;
@@ -1078,7 +1075,7 @@
return return_from_uint64(Uaccum);
}
-value_t fl_neg(value_t n)
+static value_t fl_neg(value_t n)
{ if (isfixnum(n)) {return fixnum(-numval(n));
@@ -1117,7 +1114,7 @@
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;
double Faccum=1;
@@ -1178,7 +1175,7 @@
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;
int_t ai, bi;
@@ -1281,7 +1278,7 @@
return NULL;
}
-value_t fl_bitwise_not(value_t a)
+static value_t fl_bitwise_not(value_t a)
{cprim_t *cp;
int ta;
@@ -1292,10 +1289,10 @@
ta = cp_numtype(cp);
aptr = cp_data(cp);
switch (ta) {- case T_INT8: return mk_int8(~*(int8_t *)aptr);
- case T_UINT8: return mk_uint8(~*(uint8_t *)aptr);
- case T_INT16: return mk_int16(~*(int16_t *)aptr);
- case T_UINT16: return mk_uint16(~*(uint16_t*)aptr);
+ case T_INT8: return fixnum(~*(int8_t *)aptr);
+ case T_UINT8: return fixnum(~*(uint8_t *)aptr);
+ case T_INT16: return fixnum(~*(int16_t *)aptr);
+ case T_UINT16: return fixnum(~*(uint16_t*)aptr);
case T_INT32: return mk_int32(~*(int32_t *)aptr);
case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
case T_INT64: return mk_int64(~*(int64_t *)aptr);
@@ -1307,7 +1304,7 @@
}
#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; \
int ta; \
@@ -1317,10 +1314,10 @@
ta = cp_numtype(cp); \
aptr = cp_data(cp); \
switch (ta) { \- case T_INT8: return mk_int8((*(int8_t *)aptr) op n); \
- case T_UINT8: return mk_uint8((*(uint8_t *)aptr) op n); \
- case T_INT16: return mk_int16((*(int16_t *)aptr) op n); \
- case T_UINT16: return mk_uint16((*(uint16_t*)aptr) op n); \
+ 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); \
@@ -1327,13 +1324,13 @@
case T_UINT64: return mk_uint64((*(uint64_t*)aptr) op n); \
} \
} \
- type_error(#op, "integer", a); \
+ type_error("ash", "integer", a); \return NIL; \
}
BITSHIFT_OP(shl,<<)
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 ta, tb, itmp;
@@ -1366,10 +1363,10 @@
switch (opcode) {case 0:
switch (ta) {- case T_INT8: return mk_int8( *(int8_t *)aptr & (int8_t )b64);
- case T_UINT8: return mk_uint8( *(uint8_t *)aptr & (uint8_t )b64);
- case T_INT16: return mk_int16( *(int16_t*)aptr & (int16_t )b64);
- case T_UINT16: return mk_uint16(*(uint16_t*)aptr & (uint16_t)b64);
+ case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr & (int16_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_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
@@ -1378,10 +1375,10 @@
break;
case 1:
switch (ta) {- case T_INT8: return mk_int8( *(int8_t *)aptr | (int8_t )b64);
- case T_UINT8: return mk_uint8( *(uint8_t *)aptr | (uint8_t )b64);
- case T_INT16: return mk_int16( *(int16_t*)aptr | (int16_t )b64);
- case T_UINT16: return mk_uint16(*(uint16_t*)aptr | (uint16_t)b64);
+ case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr | (int16_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_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
@@ -1390,10 +1387,10 @@
break;
case 2:
switch (ta) {- case T_INT8: return mk_int8( *(int8_t *)aptr ^ (int8_t )b64);
- case T_UINT8: return mk_uint8( *(uint8_t *)aptr ^ (uint8_t )b64);
- case T_INT16: return mk_int16( *(int16_t*)aptr ^ (int16_t )b64);
- case T_UINT16: return mk_uint16(*(uint16_t*)aptr ^ (uint16_t)b64);
+ case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_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_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -66,7 +66,7 @@
"eval", "eval*", "apply", "prog1", "raise",
// arithmetic
- "+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor",
+ "+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor", "ash",
"compare",
// sequences
@@ -1173,6 +1173,20 @@
else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$");
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:
argcount("compare", nargs, 2);v = compare(Stack[SP-2], Stack[SP-1]);
@@ -1425,7 +1439,7 @@
}
}
-void lisp_init(void)
+static void lisp_init(void)
{int i;
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -43,7 +43,7 @@
#define tag(x) ((x)&0x7)
#define ptr(x) ((void*)((x)&(~(value_t)0x7)))
#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)
#ifdef BITS64
#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
@@ -110,7 +110,7 @@
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
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_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_FOR,
F_TRUE, F_FALSE, F_NIL,
@@ -136,7 +136,6 @@
char *symbol_name(value_t v);
value_t alloc_vector(size_t n, int init);
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 equal(value_t a, value_t b); // T or nil
int equal_lispvalue(value_t a, value_t b);
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -325,7 +325,7 @@
}
}
-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)
{@@ -427,7 +427,7 @@
}
}
-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];
size_t i = 0;
@@ -609,17 +609,19 @@
outc(']', f);}
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) { outs("#enum(", f);- fl_print_child(f, car(cdr_(type)), princ);
+ fl_print_child(f, syms, princ);
outc(' ', f);}
- if (sym == NIL) {+ if (n >= (int)vector_size(syms)) {cvalue_printdata(f, data, len, int32sym, princ, 1);
}
else {- fl_print_child(f, sym, princ);
+ fl_print_child(f, vector_elt(syms, n), princ);
}
if (!weak)
outc(')', f);@@ -627,7 +629,7 @@
}
}
-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);
void *data = cptr(v);