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

adding CPRIM type, smaller representation for primitives 

bug fixes in opaque type handling
This commit is contained in:
JeffBezanson 2009-01-02 23:00:21 +00:00
parent 88938bc6d1
commit d8132ad204
9 changed files with 246 additions and 223 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
femtolisp/builtins.c
View File

@ -174,23 +174,21 @@ value_t fl_constantp(value_t *args, u_int32_t nargs)
value_t fl_fixnum(value_t *args, u_int32_t nargs)
{
argcount("fixnum", nargs, 1);
if (isfixnum(args[0]))
if (isfixnum(args[0])) {
return args[0];
if (iscvalue(args[0])) {
}
else if (iscprim(args[0])) {
cprim_t *cp = (cprim_t*)ptr(args[0]);
return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
}
else if (isstring(args[0])) {
cvalue_t *cv = (cvalue_t*)ptr(args[0]);
long i;
if (cv_isstr(cv)) {
char *pend;
errno = 0;
i = strtol(cv_data(cv), &pend, 0);
if (*pend != '\0' || errno!=0)
lerror(ArgError, "fixnum: invalid string");
return fixnum(i);
}
else if (valid_numtype(cv_numtype(cv))) {
i = conv_to_long(cv_data(cv), cv_numtype(cv));
return fixnum(i);
}
char *pend;
errno = 0;
long i = strtol(cv_data(cv), &pend, 0);
if (*pend != '\0' || errno!=0)
lerror(ArgError, "fixnum: invalid string");
return fixnum(i);
}
lerror(ArgError, "fixnum: cannot convert argument");
}
@ -200,22 +198,20 @@ value_t fl_truncate(value_t *args, u_int32_t nargs)
argcount("truncate", nargs, 1);
if (isfixnum(args[0]))
return args[0];
if (iscvalue(args[0])) {
cvalue_t *cv = (cvalue_t*)ptr(args[0]);
void *data = cv_data(cv);
numerictype_t nt = cv_numtype(cv);
if (valid_numtype(nt)) {
double d;
if (nt == T_FLOAT)
d = (double)*(float*)data;
else if (nt == T_DOUBLE)
d = *(double*)data;
else
return args[0];
if (d > 0)
return return_from_uint64((uint64_t)d);
return return_from_int64((int64_t)d);
}
if (iscprim(args[0])) {
cprim_t *cp = (cprim_t*)ptr(args[0]);
void *data = cp_data(cp);
numerictype_t nt = cp_numtype(cp);
double d;
if (nt == T_FLOAT)
d = (double)*(float*)data;
else if (nt == T_DOUBLE)
d = *(double*)data;
else
return args[0];
if (d > 0)
return return_from_uint64((uint64_t)d);
return return_from_int64((int64_t)d);
}
type_error("truncate", "number", args[0]);
}
@ -253,11 +249,10 @@ static double todouble(value_t a, char *fname)
{
if (isfixnum(a))
return (double)numval(a);
if (iscvalue(a)) {
cvalue_t *cv = (cvalue_t*)ptr(a);
numerictype_t nt = cv_numtype(cv);
if (valid_numtype(nt))
return conv_to_double(cv_data(cv), nt);
if (iscprim(a)) {
cprim_t *cp = (cprim_t*)ptr(a);
numerictype_t nt = cp_numtype(cp);
return conv_to_double(cp_data(cp), nt);
}
type_error(fname, "number", a);
}

152
femtolisp/cvalues.c
View File

@ -117,11 +117,21 @@ void cv_autorelease(cvalue_t *cv)
autorelease(cv);
}
static value_t cprim(fltype_t *type, size_t sz)
{
cprim_t *pcp = (cprim_t*)alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
pcp->type = type;
return tagptr(pcp, TAG_CPRIM);
}
value_t cvalue(fltype_t *type, size_t sz)
{
cvalue_t *pcv;
int str=0;
if (valid_numtype(type->numtype)) {
return cprim(type, sz);
}
if (type->eltype == bytetype) {
if (sz == 0)
return symbol_value(emptystringsym);
@ -155,11 +165,9 @@ value_t cvalue(fltype_t *type, size_t sz)
value_t cvalue_from_data(fltype_t *type, void *data, size_t sz)
{
cvalue_t *pcv;
value_t cv;
cv = cvalue(type, sz);
pcv = (cvalue_t*)ptr(cv);
memcpy(cv_data(pcv), data, sz);
memcpy(cptr(cv), data, sz);
return cv;
}
@ -242,35 +250,29 @@ static void cvalue_##typenam##_init(fltype_t *type, value_t arg, \
if (isfixnum(arg)) { \
n = numval(arg); \
} \
else if (iscvalue(arg)) { \
cvalue_t *cv = (cvalue_t*)ptr(arg); \
void *p = cv_data(cv); \
if (valid_numtype(cv_numtype(cv))) \
n = (ctype##_t)conv_to_##cnvt(p, cv_numtype(cv)); \
else \
goto cnvt_error; \
else if (iscprim(arg)) { \
cprim_t *cp = (cprim_t*)ptr(arg); \
void *p = cp_data(cp); \
n = (ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
} \
else { \
goto cnvt_error; \
type_error(#typenam, "number", arg); \
} \
*((ctype##_t*)dest) = n; \
return; \
cnvt_error: \
type_error(#typenam, "number", arg); \
} \
value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
{ \
if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \
value_t cv = cvalue(typenam##type, sizeof(ctype##_t)); \
value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \
cvalue_##typenam##_init(typenam##type, \
args[0], &((cvalue_t*)ptr(cv))->_space[0]); \
return cv; \
args[0], cp_data((cprim_t*)ptr(cp))); \
return cp; \
} \
value_t mk_##typenam(ctype##_t n) \
{ \
value_t cv = cvalue(typenam##type, sizeof(ctype##_t)); \
*(ctype##_t*)&((cvalue_t*)ptr(cv))->_space[0] = n; \
return cv; \
value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \
*(ctype##_t*)cp_data((cprim_t*)ptr(cp)) = n; \
return cp; \
}
num_ctor(int8, int8, int32, T_INT8)
@ -305,11 +307,9 @@ size_t toulong(value_t n, char *fname)
{
if (isfixnum(n))
return numval(n);
if (iscvalue(n)) {
cvalue_t *cv = (cvalue_t*)ptr(n);
if (valid_numtype(cv_numtype(cv))) {
return conv_to_ulong(cv_data(cv), cv_numtype(cv));
}
if (iscprim(n)) {
cprim_t *cp = (cprim_t*)ptr(n);
return conv_to_ulong(cp_data(cp), cp_numtype(cp));
}
type_error(fname, "number", n);
return 0;
@ -338,11 +338,12 @@ static void cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
if (isfixnum(arg)) {
n = (int)numval(arg);
}
else if (iscvalue(arg)) {
cvalue_t *cv = (cvalue_t*)ptr(arg);
if (!valid_numtype(cv_numtype(cv)))
type_error("enum", "number", arg);
n = conv_to_int32(cv_data(cv), cv_numtype(cv));
else if (iscprim(arg)) {
cprim_t *cp = (cprim_t*)ptr(arg);
n = conv_to_int32(cp_data(cp), cp_numtype(cp));
}
else {
type_error("enum", "number", arg);
}
if ((unsigned)n >= llength(syms))
lerror(ArgError, "enum: value out of range");
@ -354,8 +355,8 @@ value_t cvalue_enum(value_t *args, u_int32_t nargs)
argcount("enum", nargs, 2);
value_t type = list2(enumsym, args[0]);
fltype_t *ft = get_type(type);
value_t cv = cvalue(ft, 4);
cvalue_enum_init(ft, args[1], cv_data((cvalue_t*)ptr(cv)));
value_t cv = cvalue(ft, sizeof(int32_t));
cvalue_enum_init(ft, args[1], cp_data((cprim_t*)ptr(cv)));
return cv;
}
@ -594,12 +595,15 @@ size_t ctype_sizeof(value_t type, int *palign)
value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
{
cvalue_t *cv;
argcount("sizeof", nargs, 1);
if (iscvalue(args[0])) {
cv = (cvalue_t*)ptr(args[0]);
cvalue_t *cv = (cvalue_t*)ptr(args[0]);
return size_wrap(cv_len(cv));
}
else if (iscprim(args[0])) {
cprim_t *cp = (cprim_t*)ptr(args[0]);
return fixnum(cp_class(cp)->size);
}
int a;
return size_wrap(ctype_sizeof(args[0], &a));
}
@ -720,7 +724,7 @@ value_t cvalue_new(value_t *args, u_int32_t nargs)
else {
cv = cvalue(ft, ft->size);
if (nargs == 2)
cvalue_init(ft, args[1], cv_data((cvalue_t*)ptr(cv)));
cvalue_init(ft, args[1], cptr(cv));
}
return cv;
}
@ -763,7 +767,7 @@ static value_t cvalue_array_aref(value_t *args)
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
value_t el = cvalue(eltype, eltype->size);
check_addr_args("aref", args[0], args[1], &data, &index);
char *dest = cv_data((cvalue_t*)ptr(el));
char *dest = cptr(el);
size_t sz = eltype->size;
if (sz == 1)
*dest = data[index];
@ -792,8 +796,8 @@ value_t fl_builtin(value_t *args, u_int32_t nargs)
{
argcount("builtin", nargs, 1);
symbol_t *name = tosymbol(args[0], "builtin");
builtin_t f = (builtin_t)name->dlcache;
if (f == NULL) {
builtin_t f;
if (ismanaged(args[0]) || (f=(builtin_t)name->dlcache) == NULL) {
lerror(ArgError, "builtin: function not found");
}
return tagptr(f, TAG_BUILTIN);
@ -926,11 +930,11 @@ value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
Saccum += numval(args[i]);
continue;
}
else if (iscvalue(args[i])) {
cvalue_t *cv = (cvalue_t*)ptr(args[i]);
void *a = cv_data(cv);
else if (iscprim(args[i])) {
cprim_t *cp = (cprim_t*)ptr(args[i]);
void *a = cp_data(cp);
int64_t i64;
switch(cv_numtype(cv)) {
switch(cp_numtype(cp)) {
case T_INT8: Saccum += *(int8_t*)a; break;
case T_UINT8: Saccum += *(uint8_t*)a; break;
case T_INT16: Saccum += *(int16_t*)a; break;
@ -987,13 +991,13 @@ value_t fl_neg(value_t n)
if (isfixnum(n)) {
return fixnum(-numval(n));
}
else if (iscvalue(n)) {
cvalue_t *cv = (cvalue_t*)ptr(n);
void *a = cv_data(cv);
else if (iscprim(n)) {
cprim_t *cp = (cprim_t*)ptr(n);
void *a = cp_data(cp);
uint32_t ui32;
int32_t i32;
int64_t i64;
switch(cv_numtype(cv)) {
switch(cp_numtype(cp)) {
case T_INT8: return fixnum(-(int32_t)*(int8_t*)a);
case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a);
case T_INT16: return fixnum(-(int32_t)*(int16_t*)a);
@ -1032,11 +1036,11 @@ value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
Saccum *= numval(args[i]);
continue;
}
else if (iscvalue(args[i])) {
cvalue_t *cv = (cvalue_t*)ptr(args[i]);
void *a = cv_data(cv);
else if (iscprim(args[i])) {
cprim_t *cp = (cprim_t*)ptr(args[i]);
void *a = cp_data(cp);
int64_t i64;
switch(cv_numtype(cv)) {
switch(cp_numtype(cp)) {
case T_INT8: Saccum *= *(int8_t*)a; break;
case T_UINT8: Saccum *= *(uint8_t*)a; break;
case T_INT16: Saccum *= *(int16_t*)a; break;
@ -1088,18 +1092,18 @@ value_t fl_div2(value_t a, value_t b)
int_t ai, bi;
int ta, tb;
void *aptr=NULL, *bptr=NULL;
cvalue_t *cv;
cprim_t *cp;
if (isfixnum(a)) {
ai = numval(a);
aptr = &ai;
ta = T_FIXNUM;
}
else if (iscvalue(a)) {
cv = (cvalue_t*)ptr(a);
ta = cv_numtype(cv);
else if (iscprim(a)) {
cp = (cprim_t*)ptr(a);
ta = cp_numtype(cp);
if (ta <= T_DOUBLE)
aptr = cv_data(cv);
aptr = cp_data(cp);
}
if (aptr == NULL)
type_error("/", "number", a);
@ -1108,11 +1112,11 @@ value_t fl_div2(value_t a, value_t b)
bptr = &bi;
tb = T_FIXNUM;
}
else if (iscvalue(b)) {
cv = (cvalue_t*)ptr(b);
tb = cv_numtype(cv);
else if (iscprim(b)) {
cp = (cprim_t*)ptr(b);
tb = cp_numtype(cp);
if (tb <= T_DOUBLE)
bptr = cv_data(cv);
bptr = cp_data(cp);
}
if (bptr == NULL)
type_error("/", "number", b);
@ -1174,12 +1178,12 @@ value_t fl_div2(value_t a, value_t b)
static void *int_data_ptr(value_t a, int *pnumtype, char *fname)
{
cvalue_t *cv;
if (iscvalue(a)) {
cv = (cvalue_t*)ptr(a);
*pnumtype = cv_numtype(cv);
cprim_t *cp;
if (iscprim(a)) {
cp = (cprim_t*)ptr(a);
*pnumtype = cp_numtype(cp);
if (*pnumtype < T_FLOAT)
return cv_data(cv);
return cp_data(cp);
}
type_error(fname, "integer", a);
return NULL;
@ -1187,14 +1191,14 @@ static void *int_data_ptr(value_t a, int *pnumtype, char *fname)
value_t fl_bitwise_not(value_t a)
{
cvalue_t *cv;
cprim_t *cp;
int ta;
void *aptr;
if (iscvalue(a)) {
cv = (cvalue_t*)ptr(a);
ta = cv_numtype(cv);
aptr = cv_data(cv);
if (iscprim(a)) {
cp = (cprim_t*)ptr(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);
@ -1213,13 +1217,13 @@ value_t fl_bitwise_not(value_t a)
#define BITSHIFT_OP(name, op) \
value_t fl_##name(value_t a, int n) \
{ \
cvalue_t *cv; \
cprim_t *cp; \
int ta; \
void *aptr; \
if (iscvalue(a)) { \
cv = (cvalue_t*)ptr(a); \
ta = cv_numtype(cv); \
aptr = cv_data(cv); \
if (iscprim(a)) { \
cp = (cprim_t*)ptr(a); \
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); \

81
femtolisp/equal.c
View File

@ -33,23 +33,18 @@ static void eq_union(htable_t *table, value_t a, value_t b,
ptrhash_put(table, (void*)b, (void*)ca);
}
// a is a fixnum, b is a cvalue
static value_t compare_num_cvalue(value_t a, value_t b, int eq)
// a is a fixnum, b is a cprim
static value_t compare_num_cprim(value_t a, value_t b, int eq)
{
cvalue_t *bcv = (cvalue_t*)ptr(b);
numerictype_t bt;
if (valid_numtype(bt=cv_numtype(bcv))) {
fixnum_t ia = numval(a);
void *bptr = cv_data(bcv);
if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
return fixnum(0);
if (eq) return fixnum(1);
if (cmp_lt(&ia, T_FIXNUM, bptr, bt))
return fixnum(-1);
}
else {
cprim_t *bcp = (cprim_t*)ptr(b);
numerictype_t bt = cp_numtype(bcp);
fixnum_t ia = numval(a);
void *bptr = cp_data(bcp);
if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
return fixnum(0);
if (eq) return fixnum(1);
if (cmp_lt(&ia, T_FIXNUM, bptr, bt))
return fixnum(-1);
}
return fixnum(1);
}
@ -74,7 +69,7 @@ static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
}
// strange comparisons are resolved arbitrarily but consistently.
// ordering: number < builtin < cvalue < vector < symbol < cons
// ordering: number < cprim < builtin < cvalue < vector < symbol < cons
static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
{
value_t d;
@ -91,8 +86,8 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
if (isfixnum(b)) {
return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
}
if (iscvalue(b)) {
return compare_num_cvalue(a, b, eq);
if (iscprim(b)) {
return compare_num_cprim(a, b, eq);
}
return fixnum(-1);
case TAG_SYM:
@ -104,27 +99,26 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
if (isvector(b))
return bounded_vector_compare(a, b, bound, eq);
break;
case TAG_CVALUE:
if (iscvalue(b)) {
cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b);
numerictype_t at, bt;
if (valid_numtype(at=cv_numtype(acv)) &&
valid_numtype(bt=cv_numtype(bcv))) {
void *aptr = cv_data(acv);
void *bptr = cv_data(bcv);
if (cmp_eq(aptr, at, bptr, bt))
return fixnum(0);
if (eq) return fixnum(1);
if (cmp_lt(aptr, at, bptr, bt))
return fixnum(-1);
return fixnum(1);
}
return cvalue_compare(a, b);
case TAG_CPRIM:
if (iscprim(b)) {
cprim_t *acp=(cprim_t*)ptr(a), *bcp=(cprim_t*)ptr(b);
numerictype_t at=cp_numtype(acp), bt=cp_numtype(bcp);
void *aptr=cp_data(acp), *bptr=cp_data(bcp);
if (cmp_eq(aptr, at, bptr, bt))
return fixnum(0);
if (eq) return fixnum(1);
if (cmp_lt(aptr, at, bptr, bt))
return fixnum(-1);
return fixnum(1);
}
else if (isfixnum(b)) {
return fixnum(-numval(compare_num_cvalue(b, a, eq)));
return fixnum(-numval(compare_num_cprim(b, a, eq)));
}
break;
case TAG_CVALUE:
if (iscvalue(b))
return cvalue_compare(a, b);
break;
case TAG_BUILTIN:
if (tagb == TAG_BUILTIN) {
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
@ -288,6 +282,7 @@ static uptrint_t bounded_hash(value_t a, int bound)
numerictype_t nt;
size_t i, len;
cvalue_t *cv;
cprim_t *cp;
void *data;
if (bound <= 0) return 0;
uptrint_t h = 0;
@ -301,17 +296,17 @@ static uptrint_t bounded_hash(value_t a, int bound)
return inthash(a);
case TAG_SYM:
return ((symbol_t*)ptr(a))->hash;
case TAG_CPRIM:
cp = (cprim_t*)ptr(a);
data = cp_data(cp);
nt = cp_numtype(cp);
d = conv_to_double(data, nt);
if (d==0) d = 0.0; // normalize -0
return doublehash(*(int64_t*)&d);
case TAG_CVALUE:
cv = (cvalue_t*)ptr(a);
data = cv_data(cv);
if (valid_numtype(nt=cv_numtype(cv))) {
d = conv_to_double(data, nt);
if (d==0) d = 0.0; // normalize -0
return doublehash(*(int64_t*)&d);
}
else {
return memhash(data, cv_len(cv));
}
return memhash(data, cv_len(cv));
case TAG_VECTOR:
len = vector_size(a);
for(i=0; i < len; i++) {

60
femtolisp/flisp.c
View File

@ -197,7 +197,7 @@ static symbol_t *mk_symbol(char *str)
sym->binding = UNBOUND;
sym->syntax = 0;
}
sym->type = NULL;
sym->type = sym->dlcache = NULL;
sym->hash = memhash32(str, len)^0xAAAAAAAA;
strcpy(&sym->name[0], str);
return sym;
@ -351,8 +351,9 @@ static int symchar(char c);
static value_t relocate(value_t v)
{
value_t a, d, nc, first, *pcdr;
uptrint_t t = tag(v);
if (iscons(v)) {
if (t == TAG_CONS) {
// iterative implementation allows arbitrarily long cons chains
pcdr = &first;
do {
@ -370,11 +371,12 @@ static value_t relocate(value_t v)
*pcdr = (d==NIL) ? NIL : relocate(d);
return first;
}
uptrint_t t = tag(v);
if ((t&(t-1)) == 0) return v; // tags 0,1,2,4
if (isforwarded(v))
return forwardloc(v);
if (isvector(v)) {
if ((t&3) == 0) return v;
if (!ismanaged(v)) return v;
if (isforwarded(v)) return forwardloc(v);
if (t == TAG_VECTOR) {
// N.B.: 0-length vectors secretly have space for a first element
size_t i, newsz, sz = vector_size(v);
newsz = sz;
@ -393,11 +395,20 @@ static value_t relocate(value_t v)
vector_elt(nc,i) = NIL;
return nc;
}
else if (iscvalue(v)) {
else if (t == TAG_CPRIM) {
cprim_t *pcp = (cprim_t*)ptr(v);
size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size);
cprim_t *ncp = (cprim_t*)alloc_words(nw);
while (nw--)
((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
nc = tagptr(ncp, TAG_CPRIM);
forward(v, nc);
return nc;
}
else if (t == TAG_CVALUE) {
return cvalue_relocate(v);
}
else if (ismanaged(v)) {
assert(issymbol(v));
else if (t == TAG_SYM) {
gensym_t *gs = (gensym_t*)ptr(v);
gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
ng->id = gs->id;
@ -571,9 +582,7 @@ static value_t vector_grow(value_t v)
int isnumber(value_t v)
{
return (isfixnum(v) ||
(iscvalue(v) &&
valid_numtype(cv_numtype((cvalue_t*)ptr(v)))));
return (isfixnum(v) || iscprim(v));
}
// read -----------------------------------------------------------------------
@ -928,19 +937,21 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
v = fixnum(vector_size(Stack[SP-1]));
break;
}
else if (iscvalue(Stack[SP-1])) {
else if (iscprim(Stack[SP-1])) {
cv = (cvalue_t*)ptr(Stack[SP-1]);
v = cv_type(cv);
if (iscons(v) && car_(v) == arraysym) {
v = size_wrap(cvalue_arraylen(Stack[SP-1]));
break;
}
else if (v == bytesym) {
if (cp_class(cv) == bytetype) {
v = fixnum(1);
break;
}
else if (v == wcharsym) {
v = fixnum(u8_charlen(*(uint32_t*)cv_data(cv)));
else if (cp_class(cv) == wchartype) {
v = fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
break;
}
}
else if (iscvalue(Stack[SP-1])) {
cv = (cvalue_t*)ptr(Stack[SP-1]);
if (cv_class(cv)->eltype != NULL) {
v = size_wrap(cvalue_arraylen(Stack[SP-1]));
break;
}
}
@ -999,10 +1010,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break;
case F_NUMBERP:
argcount("numberp", nargs, 1);
v = ((isfixnum(Stack[SP-1]) ||
(iscvalue(Stack[SP-1]) &&
valid_numtype(cv_numtype((cvalue_t*)ptr(Stack[SP-1]))) ))
? T : NIL);
v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? T : NIL);
break;
case F_FIXNUMP:
argcount("fixnump", nargs, 1);

12
femtolisp/flisp.h
View File

@ -30,7 +30,7 @@ typedef struct _symbol_t {
} symbol_t;
#define TAG_NUM 0x0
//0x1 unused
#define TAG_CPRIM 0x1
#define TAG_BUILTIN 0x2
#define TAG_VECTOR 0x3
#define TAG_NUM1 0x4
@ -61,6 +61,7 @@ typedef struct _symbol_t {
#define isbuiltinish(x) (tag(x) == TAG_BUILTIN)
#define isvector(x) (tag(x) == TAG_VECTOR)
#define iscvalue(x) (tag(x) == TAG_CVALUE)
#define iscprim(x) (tag(x) == TAG_CPRIM)
#define selfevaluating(x) (tag(x)<6)
// comparable with ==
#define eq_comparable(a,b) (!(((a)|(b))&1))
@ -212,12 +213,19 @@ typedef struct {
#define cv_len(cv) ((cv)->len)
#define cv_type(cv) (cv_class(cv)->type)
#define cv_data(cv) ((cv)->data)
#define cv_numtype(cv) (cv_class(cv)->numtype)
#define cv_isstr(cv) (cv_class(cv)->eltype == bytetype)
#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
#define valid_numtype(v) ((v) < N_NUMTYPES)
#define cp_class(cp) ((cp)->type)
#define cp_type(cp) (cp_class(cp)->type)
#define cp_numtype(cp) (cp_class(cp)->numtype)
#define cp_data(cp) (&(cp)->_space[0])
// WARNING: multiple evaluation!
#define cptr(v) \
(iscprim(v) ? cp_data((cprim_t*)ptr(v)) : cv_data((cvalue_t*)ptr(v)))
/* C type names corresponding to cvalues type names */
typedef unsigned long ulong;

12
femtolisp/print.c
View File

@ -68,6 +68,9 @@ void print_traverse(value_t v)
for(i=0; i < vector_size(v); i++)
print_traverse(vector_elt(v,i));
}
else if (iscprim(v)) {
mark_cons(v);
}
else {
assert(iscvalue(v));
cvalue_t *cv = (cvalue_t*)ptr(v);
@ -342,6 +345,7 @@ void fl_print_child(ios_t *f, value_t v, int princ)
}
break;
case TAG_CVALUE:
case TAG_CPRIM:
case TAG_VECTOR:
case TAG_CONS:
if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
@ -377,7 +381,7 @@ void fl_print_child(ios_t *f, value_t v, int princ)
outc(']', f);
break;
}
if (iscvalue(v)) {
if (iscvalue(v) || iscprim(v)) {
unmark_cons(v);
cvalue_print(f, v, princ);
break;
@ -584,7 +588,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)
{
cvalue_t *cv = (cvalue_t*)ptr(v);
void *data = cv_data(cv);
void *data = cptr(v);
if (cv_class(cv) == builtintype) {
HPOS+=ios_printf(f, "#<builtin @0x%08lx>",
@ -595,7 +599,9 @@ void cvalue_print(ios_t *f, value_t v, int princ)
cv_class(cv)->vtable->print(v, f, princ);
}
else {
cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0);
value_t type = cv_type(cv);
size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
cvalue_printdata(f, data, len, type, princ, 0);
}
}

68
femtolisp/string.c
View File

@ -66,9 +66,8 @@ value_t fl_string_encode(value_t *args, u_int32_t nargs)
argcount("string.encode", nargs, 1);
if (iscvalue(args[0])) {
cvalue_t *cv = (cvalue_t*)ptr(args[0]);
value_t t = cv_type(cv);
if (iscons(t) && car_(t) == arraysym &&
iscons(cdr_(t)) && car_(cdr_(t)) == wcharsym) {
fltype_t *t = cv_class(cv);
if (t->eltype == wchartype) {
size_t nc = cv_len(cv) / sizeof(uint32_t);
uint32_t *ptr = (uint32_t*)cv_data(cv);
size_t nbytes = u8_codingsize(ptr, nc);
@ -111,30 +110,32 @@ value_t fl_string(value_t *args, u_int32_t nargs)
u_int32_t i;
size_t len, sz = 0;
cvalue_t *temp;
cprim_t *cp;
char *data;
uint32_t wc;
for(i=0; i < nargs; i++) {
if (issymbol(args[i])) {
sz += strlen(symbol_name(args[i]));
cv = args[i];
if (issymbol(cv)) {
sz += strlen(symbol_name(cv));
continue;
}
else if (iscvalue(args[i])) {
temp = (cvalue_t*)ptr(args[i]);
t = cv_type(temp);
else if (iscprim(cv)) {
cp = (cprim_t*)ptr(cv);
t = cp_type(cp);
if (t == bytesym) {
sz++;
continue;
}
else if (t == wcharsym) {
wc = *(uint32_t*)cv_data(temp);
wc = *(uint32_t*)cp_data(cp);
sz += u8_charlen(wc);
continue;
}
else if (cv_isstr(temp)) {
sz += cv_len(temp);
continue;
}
}
else if (isstring(cv)) {
sz += cv_len((cvalue_t*)ptr(cv));
continue;
}
args[i] = print_to_string(args[i], 0);
if (nargs == 1) // convert single value to string
@ -149,21 +150,25 @@ value_t fl_string(value_t *args, u_int32_t nargs)
char *name = symbol_name(args[i]);
while (*name) *ptr++ = *name++;
}
else {
temp = (cvalue_t*)ptr(args[i]);
t = cv_type(temp);
data = cvalue_data(args[i]);
else if (iscprim(args[i])) {
cp = (cprim_t*)ptr(args[i]);
t = cp_type(cp);
data = cp_data(cp);
if (t == bytesym) {
*ptr++ = *(char*)data;
}
else if (t == wcharsym) {
else {
// wchar
ptr += u8_wc_toutf8(ptr, *(uint32_t*)data);
}
else {
len = cv_len(temp);
memcpy(ptr, data, len);
ptr += len;
}
}
else {
// string
temp = (cvalue_t*)ptr(args[i]);
data = cv_data(temp);
len = cv_len(temp);
memcpy(ptr, data, len);
ptr += len;
}
}
return cv;
@ -266,20 +271,21 @@ value_t fl_string_find(value_t *args, u_int32_t nargs)
if (start > len)
bounds_error("string.find", args[0], args[2]);
char *needle; size_t needlesz;
if (!iscvalue(args[1]))
type_error("string.find", "string", args[1]);
cvalue_t *cv = (cvalue_t*)ptr(args[1]);
if (cv_class(cv) == wchartype) {
uint32_t c = *(uint32_t*)cv_data(cv);
value_t v = args[1];
cprim_t *cp = (cprim_t*)ptr(v);
if (iscprim(v) && cp_class(cp) == wchartype) {
uint32_t c = *(uint32_t*)cp_data(cp);
if (c <= 0x7f)
return mem_find_byte(s, (char)c, start, len);
needlesz = u8_toutf8(cbuf, sizeof(cbuf), &c, 1);
needle = cbuf;
}
else if (cv_class(cv) == bytetype) {
return mem_find_byte(s, *(char*)cv_data(cv), start, len);
else if (iscprim(v) && cp_class(cp) == bytetype) {
return mem_find_byte(s, *(char*)cp_data(cp), start, len);
}
else if (isstring(args[1])) {
else if (isstring(v)) {
cvalue_t *cv = (cvalue_t*)ptr(v);
needlesz = cv_len(cv);
needle = (char*)cv_data(cv);
}

12
femtolisp/todo
View File

@ -12,8 +12,9 @@
* read support for #' for compatibility
* #\c read character as code (including UTF-8 support!)
* #| |# block comments
- here-data for binary serialization. proposed syntax:
? here-data for binary serialization. proposed syntax:
#>size:data, e.g. #>6:000000
? better read syntax for packed arrays, e.g. #double[3 1 4]
* use syntax environment concept for user-defined macros to plug
that hole in the semantics
* make more builtins generic. if typecheck fails, call out to the
@ -102,9 +103,10 @@ possible optimizations:
env in-place in tail position
- allocate memory by mmap'ing a large uncommitted block that we cut
in half. then each half heap can be grown without moving addresses.
- try making (list ...) a builtin by moving the list-building code to
* try making (list ...) a builtin by moving the list-building code to
a static function, see if vararg call performance is affected.
- try making foldl a builtin, implement table iterator as table.foldl
. not great, since then it can't be CPS converted
* represent lambda environment as a vector (in lispv)
x setq builtin (didn't help)
(- list builtin, to use cons_reserve)
@ -131,6 +133,10 @@ for internal use:
improve by making lambda lists vectors somehow?
* fast builtin bounded iteration construct (for lo hi (lambda (x) ...))
* represent guest function as a tagged function pointer; allocate nothing
- when an instance of (array type n) is requested, use (array type)
instead, unless the value is part of an aggregate (e.g. struct).
. this avoids allocating a new type for every size.
. and/or add function array.alloc
bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains
@ -925,7 +931,7 @@ switch to miser mode, otherwise default is ok, for example:
consolidated todo list as of 8/30:
* new cvalues, types representation
- use the unused tag for TAG_PRIM, add smaller prim representation
* use the unused tag for TAG_PRIM, add smaller prim representation
* finalizers in gc
* hashtable
* generic aref/aset

5
femtolisp/types.c
View File

@ -66,12 +66,8 @@ fltype_t *get_array_type(value_t eltype)
fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
cvinitfunc_t init)
{
void **bp = equalhash_bp(&TypeTable, (void*)sym);
if (*bp != HT_NOTFOUND)
return *bp;
fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t));
ft->type = sym;
((symbol_t*)ptr(sym))->type = ft;
ft->size = sz;
ft->numtype = N_NUMTYPES;
ft->vtable = vtab;
@ -80,7 +76,6 @@ fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
ft->elsz = 0;
ft->marked = 1;
ft->init = init;
*bp = ft;
return ft;
}