lassik
/
upscheme
1
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

37
femtolisp/builtins.c
View File

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

150
femtolisp/cvalues.c
View File

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

57
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); ptrhash_put(table, (void*)b, (void*)ca);
} }
// a is a fixnum, b is a cvalue // a is a fixnum, b is a cprim
static value_t compare_num_cvalue(value_t a, value_t b, int eq) static value_t compare_num_cprim(value_t a, value_t b, int eq)
{ {
cvalue_t *bcv = (cvalue_t*)ptr(b); cprim_t *bcp = (cprim_t*)ptr(b);
numerictype_t bt; numerictype_t bt = cp_numtype(bcp);
if (valid_numtype(bt=cv_numtype(bcv))) {
fixnum_t ia = numval(a); fixnum_t ia = numval(a);
void *bptr = cv_data(bcv); void *bptr = cp_data(bcp);
if (cmp_eq(&ia, T_FIXNUM, bptr, bt)) if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
return fixnum(0); return fixnum(0);
if (eq) return fixnum(1); if (eq) return fixnum(1);
if (cmp_lt(&ia, T_FIXNUM, bptr, bt)) if (cmp_lt(&ia, T_FIXNUM, bptr, bt))
return fixnum(-1); return fixnum(-1);
}
else {
return fixnum(-1);
}
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. // 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) static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
{ {
value_t d; 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)) { if (isfixnum(b)) {
return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1); return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
} }
if (iscvalue(b)) { if (iscprim(b)) {
return compare_num_cvalue(a, b, eq); return compare_num_cprim(a, b, eq);
} }
return fixnum(-1); return fixnum(-1);
case TAG_SYM: case TAG_SYM:
@ -104,14 +99,11 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
if (isvector(b)) if (isvector(b))
return bounded_vector_compare(a, b, bound, eq); return bounded_vector_compare(a, b, bound, eq);
break; break;
case TAG_CVALUE: case TAG_CPRIM:
if (iscvalue(b)) { if (iscprim(b)) {
cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b); cprim_t *acp=(cprim_t*)ptr(a), *bcp=(cprim_t*)ptr(b);
numerictype_t at, bt; numerictype_t at=cp_numtype(acp), bt=cp_numtype(bcp);
if (valid_numtype(at=cv_numtype(acv)) && void *aptr=cp_data(acp), *bptr=cp_data(bcp);
valid_numtype(bt=cv_numtype(bcv))) {
void *aptr = cv_data(acv);
void *bptr = cv_data(bcv);
if (cmp_eq(aptr, at, bptr, bt)) if (cmp_eq(aptr, at, bptr, bt))
return fixnum(0); return fixnum(0);
if (eq) return fixnum(1); if (eq) return fixnum(1);
@ -119,12 +111,14 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
return fixnum(-1); return fixnum(-1);
return fixnum(1); return fixnum(1);
} }
return cvalue_compare(a, b);
}
else if (isfixnum(b)) { else if (isfixnum(b)) {
return fixnum(-numval(compare_num_cvalue(b, a, eq))); return fixnum(-numval(compare_num_cprim(b, a, eq)));
} }
break; break;
case TAG_CVALUE:
if (iscvalue(b))
return cvalue_compare(a, b);
break;
case TAG_BUILTIN: case TAG_BUILTIN:
if (tagb == TAG_BUILTIN) { if (tagb == TAG_BUILTIN) {
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1); 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; numerictype_t nt;
size_t i, len; size_t i, len;
cvalue_t *cv; cvalue_t *cv;
cprim_t *cp;
void *data; void *data;
if (bound <= 0) return 0; if (bound <= 0) return 0;
uptrint_t h = 0; uptrint_t h = 0;
@ -301,17 +296,17 @@ static uptrint_t bounded_hash(value_t a, int bound)
return inthash(a); return inthash(a);
case TAG_SYM: case TAG_SYM:
return ((symbol_t*)ptr(a))->hash; return ((symbol_t*)ptr(a))->hash;
case TAG_CVALUE: case TAG_CPRIM:
cv = (cvalue_t*)ptr(a); cp = (cprim_t*)ptr(a);
data = cv_data(cv); data = cp_data(cp);
if (valid_numtype(nt=cv_numtype(cv))) { nt = cp_numtype(cp);
d = conv_to_double(data, nt); d = conv_to_double(data, nt);
if (d==0) d = 0.0; // normalize -0 if (d==0) d = 0.0; // normalize -0
return doublehash(*(int64_t*)&d); return doublehash(*(int64_t*)&d);
} case TAG_CVALUE:
else { cv = (cvalue_t*)ptr(a);
data = cv_data(cv);
return memhash(data, cv_len(cv)); return memhash(data, cv_len(cv));
}
case TAG_VECTOR: case TAG_VECTOR:
len = vector_size(a); len = vector_size(a);
for(i=0; i < len; i++) { 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->binding = UNBOUND;
sym->syntax = 0; sym->syntax = 0;
} }
sym->type = NULL; sym->type = sym->dlcache = NULL;
sym->hash = memhash32(str, len)^0xAAAAAAAA; sym->hash = memhash32(str, len)^0xAAAAAAAA;
strcpy(&sym->name[0], str); strcpy(&sym->name[0], str);
return sym; return sym;
@ -351,8 +351,9 @@ static int symchar(char c);
static value_t relocate(value_t v) static value_t relocate(value_t v)
{ {
value_t a, d, nc, first, *pcdr; 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 // iterative implementation allows arbitrarily long cons chains
pcdr = &first; pcdr = &first;
do { do {
@ -370,11 +371,12 @@ static value_t relocate(value_t v)
*pcdr = (d==NIL) ? NIL : relocate(d); *pcdr = (d==NIL) ? NIL : relocate(d);
return first; return first;
} }
uptrint_t t = tag(v);
if ((t&(t-1)) == 0) return v; // tags 0,1,2,4 if ((t&3) == 0) return v;
if (isforwarded(v)) if (!ismanaged(v)) return v;
return forwardloc(v); if (isforwarded(v)) return forwardloc(v);
if (isvector(v)) {
if (t == TAG_VECTOR) {
// N.B.: 0-length vectors secretly have space for a first element // N.B.: 0-length vectors secretly have space for a first element
size_t i, newsz, sz = vector_size(v); size_t i, newsz, sz = vector_size(v);
newsz = sz; newsz = sz;
@ -393,11 +395,20 @@ static value_t relocate(value_t v)
vector_elt(nc,i) = NIL; vector_elt(nc,i) = NIL;
return nc; 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); return cvalue_relocate(v);
} }
else if (ismanaged(v)) { else if (t == TAG_SYM) {
assert(issymbol(v));
gensym_t *gs = (gensym_t*)ptr(v); gensym_t *gs = (gensym_t*)ptr(v);
gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
ng->id = gs->id; ng->id = gs->id;
@ -571,9 +582,7 @@ static value_t vector_grow(value_t v)
int isnumber(value_t v) int isnumber(value_t v)
{ {
return (isfixnum(v) || return (isfixnum(v) || iscprim(v));
(iscvalue(v) &&
valid_numtype(cv_numtype((cvalue_t*)ptr(v)))));
} }
// read ----------------------------------------------------------------------- // 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])); v = fixnum(vector_size(Stack[SP-1]));
break; break;
} }
else if (iscvalue(Stack[SP-1])) { else if (iscprim(Stack[SP-1])) {
cv = (cvalue_t*)ptr(Stack[SP-1]); cv = (cvalue_t*)ptr(Stack[SP-1]);
v = cv_type(cv); if (cp_class(cv) == bytetype) {
if (iscons(v) && car_(v) == arraysym) {
v = size_wrap(cvalue_arraylen(Stack[SP-1]));
break;
}
else if (v == bytesym) {
v = fixnum(1); v = fixnum(1);
break; break;
} }
else if (v == wcharsym) { else if (cp_class(cv) == wchartype) {
v = fixnum(u8_charlen(*(uint32_t*)cv_data(cv))); 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; break;
} }
} }
@ -999,10 +1010,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_NUMBERP: case F_NUMBERP:
argcount("numberp", nargs, 1); argcount("numberp", nargs, 1);
v = ((isfixnum(Stack[SP-1]) || v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? T : NIL);
(iscvalue(Stack[SP-1]) &&
valid_numtype(cv_numtype((cvalue_t*)ptr(Stack[SP-1]))) ))
? T : NIL);
break; break;
case F_FIXNUMP: case F_FIXNUMP:
argcount("fixnump", nargs, 1); argcount("fixnump", nargs, 1);

12
femtolisp/flisp.h
View File

@ -30,7 +30,7 @@ typedef struct _symbol_t {
} symbol_t; } symbol_t;
#define TAG_NUM 0x0 #define TAG_NUM 0x0
//0x1 unused #define TAG_CPRIM 0x1
#define TAG_BUILTIN 0x2 #define TAG_BUILTIN 0x2
#define TAG_VECTOR 0x3 #define TAG_VECTOR 0x3
#define TAG_NUM1 0x4 #define TAG_NUM1 0x4
@ -61,6 +61,7 @@ typedef struct _symbol_t {
#define isbuiltinish(x) (tag(x) == TAG_BUILTIN) #define isbuiltinish(x) (tag(x) == TAG_BUILTIN)
#define isvector(x) (tag(x) == TAG_VECTOR) #define isvector(x) (tag(x) == TAG_VECTOR)
#define iscvalue(x) (tag(x) == TAG_CVALUE) #define iscvalue(x) (tag(x) == TAG_CVALUE)
#define iscprim(x) (tag(x) == TAG_CPRIM)
#define selfevaluating(x) (tag(x)<6) #define selfevaluating(x) (tag(x)<6)
// comparable with == // comparable with ==
#define eq_comparable(a,b) (!(((a)|(b))&1)) #define eq_comparable(a,b) (!(((a)|(b))&1))
@ -212,12 +213,19 @@ typedef struct {
#define cv_len(cv) ((cv)->len) #define cv_len(cv) ((cv)->len)
#define cv_type(cv) (cv_class(cv)->type) #define cv_type(cv) (cv_class(cv)->type)
#define cv_data(cv) ((cv)->data) #define cv_data(cv) ((cv)->data)
#define cv_numtype(cv) (cv_class(cv)->numtype)
#define cv_isstr(cv) (cv_class(cv)->eltype == bytetype) #define cv_isstr(cv) (cv_class(cv)->eltype == bytetype)
#define cvalue_data(v) cv_data((cvalue_t*)ptr(v)) #define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
#define valid_numtype(v) ((v) < N_NUMTYPES) #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 */ /* C type names corresponding to cvalues type names */
typedef unsigned long ulong; 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++) for(i=0; i < vector_size(v); i++)
print_traverse(vector_elt(v,i)); print_traverse(vector_elt(v,i));
} }
else if (iscprim(v)) {
mark_cons(v);
}
else { else {
assert(iscvalue(v)); assert(iscvalue(v));
cvalue_t *cv = (cvalue_t*)ptr(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; break;
case TAG_CVALUE: case TAG_CVALUE:
case TAG_CPRIM:
case TAG_VECTOR: case TAG_VECTOR:
case TAG_CONS: case TAG_CONS:
if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) != 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); outc(']', f);
break; break;
} }
if (iscvalue(v)) { if (iscvalue(v) || iscprim(v)) {
unmark_cons(v); unmark_cons(v);
cvalue_print(f, v, princ); cvalue_print(f, v, princ);
break; 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) 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 = cv_data(cv); void *data = cptr(v);
if (cv_class(cv) == builtintype) { if (cv_class(cv) == builtintype) {
HPOS+=ios_printf(f, "#<builtin @0x%08lx>", 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); cv_class(cv)->vtable->print(v, f, princ);
} }
else { 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);
} }
} }

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

12
femtolisp/todo
View File

@ -12,8 +12,9 @@
* read support for #' for compatibility * read support for #' for compatibility
* #\c read character as code (including UTF-8 support!) * #\c read character as code (including UTF-8 support!)
* #| |# block comments * #| |# block comments
- here-data for binary serialization. proposed syntax: ? here-data for binary serialization. proposed syntax:
#>size:data, e.g. #>6:000000 #>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 * use syntax environment concept for user-defined macros to plug
that hole in the semantics that hole in the semantics
* make more builtins generic. if typecheck fails, call out to the * make more builtins generic. if typecheck fails, call out to the
@ -102,9 +103,10 @@ possible optimizations:
env in-place in tail position env in-place in tail position
- allocate memory by mmap'ing a large uncommitted block that we cut - allocate memory by mmap'ing a large uncommitted block that we cut
in half. then each half heap can be grown without moving addresses. 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. a static function, see if vararg call performance is affected.
- try making foldl a builtin, implement table iterator as table.foldl - 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) * represent lambda environment as a vector (in lispv)
x setq builtin (didn't help) x setq builtin (didn't help)
(- list builtin, to use cons_reserve) (- list builtin, to use cons_reserve)
@ -131,6 +133,10 @@ for internal use:
improve by making lambda lists vectors somehow? improve by making lambda lists vectors somehow?
* fast builtin bounded iteration construct (for lo hi (lambda (x) ...)) * fast builtin bounded iteration construct (for lo hi (lambda (x) ...))
* represent guest function as a tagged function pointer; allocate nothing * 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: bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains * 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: consolidated todo list as of 8/30:
* new cvalues, types representation * 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 * finalizers in gc
* hashtable * hashtable
* generic aref/aset * 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, fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
cvinitfunc_t init) 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)); fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t));
ft->type = sym; ft->type = sym;
((symbol_t*)ptr(sym))->type = ft;
ft->size = sz; ft->size = sz;
ft->numtype = N_NUMTYPES; ft->numtype = N_NUMTYPES;
ft->vtable = vtab; 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->elsz = 0;
ft->marked = 1; ft->marked = 1;
ft->init = init; ft->init = init;
*bp = ft;
return ft; return ft;
} }