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
parent
05ef9f42a5
commit
d81e6c2d57
|
|
@ -26,16 +26,6 @@ size_t llength(value_t v)
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ static fltype_t *floattype, *doubletype;
|
|||
|
||||
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 @@ static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
|
|||
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 @@ static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
|
|||
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 @@ size_t cvalue_arraylen(value_t v)
|
|||
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,7 +510,7 @@ value_t cvalue_relocate(value_t v)
|
|||
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)
|
||||
{
|
||||
value_t fld = car(cdr_(type));
|
||||
|
|
@ -904,7 +901,7 @@ static builtinspec_t cvalues_builtin_info[] = {
|
|||
#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 @@ value_t return_from_int64(int64_t Saccum)
|
|||
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 @@ value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
|
|||
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 @@ value_t fl_neg(value_t 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;
|
||||
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);
|
||||
}
|
||||
|
||||
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 @@ static void *int_data_ptr(value_t a, int *pnumtype, char *fname)
|
|||
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 @@ value_t fl_bitwise_not(value_t a)
|
|||
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 @@ value_t fl_bitwise_not(value_t a)
|
|||
}
|
||||
|
||||
#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,23 +1314,23 @@ value_t fl_##name(value_t a, int n) \
|
|||
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); \
|
||||
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 @@ value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
|
|||
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 @@ value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
|
|||
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 @@ value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
|
|||
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);
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ static char *builtin_names[] =
|
|||
"eval", "eval*", "apply", "prog1", "raise",
|
||||
|
||||
// arithmetic
|
||||
"+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor",
|
||||
"+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor", "ash",
|
||||
"compare",
|
||||
|
||||
// sequences
|
||||
|
|
@ -1173,6 +1173,20 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
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 assign_global_builtins(builtinspec_t *b)
|
|||
}
|
||||
}
|
||||
|
||||
void lisp_init(void)
|
||||
static void lisp_init(void)
|
||||
{
|
||||
int i;
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ typedef struct _symbol_t {
|
|||
#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 @@ enum {
|
|||
|
||||
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 @@ value_t fl_gensym();
|
|||
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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
@ -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];
|
||||
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);
|
||||
}
|
||||
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 @@ 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);
|
||||
void *data = cptr(v);
|
||||
|
|
|
|||
Loading…
Reference in New Issue