diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index c6040e6..ea8a9ee 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -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) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 0703125..dadf712 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -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,8 +510,8 @@ value_t cvalue_relocate(value_t v) 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 @@ 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); diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index eb4a3ed..a81535e 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -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])<>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); diff --git a/femtolisp/print.c b/femtolisp/print.c index 7fd06a9..b66bedf 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -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);