ref: d8132ad204af5131c4cddcf7be4669adfc167ba7
parent: 88938bc6d17a04b7ee8988d87f81e70696679f44
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Fri Jan 2 18:00:21 EST 2009
adding CPRIM type, smaller representation for primitives bug fixes in opaque type handling
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -174,23 +174,21 @@
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 @@
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 @@
{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);
}
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -117,11 +117,21 @@
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_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 @@
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 @@
{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,12 +338,13 @@
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");
*(int*)dest = n;
@@ -354,8 +355,8 @@
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 @@
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 @@
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 @@
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 @@
{ 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 @@
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 @@
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 @@
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,7 +1092,7 @@
int_t ai, bi;
int ta, tb;
void *aptr=NULL, *bptr=NULL;
- cvalue_t *cv;
+ cprim_t *cp;
if (isfixnum(a)) {ai = numval(a);
@@ -1095,11 +1099,11 @@
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 @@
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 @@
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 @@
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 @@
#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); \
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -33,23 +33,18 @@
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 @@
}
// 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 @@
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 @@
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 @@
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 @@
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++) {--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -197,7 +197,7 @@
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 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 @@
*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 @@
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 @@
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 @@
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]));
+ if (cp_class(cv) == bytetype) {+ v = fixnum(1);
break;
}
- else if (v == bytesym) {- v = fixnum(1);
+ else if (cp_class(cv) == wchartype) {+ v = fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
break;
}
- else if (v == wcharsym) {- v = fixnum(u8_charlen(*(uint32_t*)cv_data(cv)));
+ }
+ 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 @@
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);--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -30,7 +30,7 @@
} 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 @@
#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 @@
#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;
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -68,6 +68,9 @@
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 @@
}
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 @@
outc(']', f);break;
}
- if (iscvalue(v)) {+ if (iscvalue(v) || iscprim(v)) {unmark_cons(v);
cvalue_print(f, v, princ);
break;
@@ -584,7 +588,7 @@
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 @@
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);
}
}
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -66,9 +66,8 @@
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,31 +110,33 @@
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
return args[i];
@@ -149,22 +150,26 @@
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 @@
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);
}
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -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 @@
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 @@
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 @@
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
--- a/femtolisp/types.c
+++ b/femtolisp/types.c
@@ -66,12 +66,8 @@
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 @@
ft->elsz = 0;
ft->marked = 1;
ft->init = init;
- *bp = ft;
return ft;
}