generic aref/aset for all arrays

(string v) now works on any value, by printing to a string

some bug fixes in ios
This commit is contained in:
JeffBezanson 2008-12-27 06:02:53 +00:00
parent 7e04bb948c
commit b99d8715ce
8 changed files with 95 additions and 49 deletions

View File

@ -8,7 +8,7 @@ EXENAME = $(NAME)
LLTDIR = ../llt
LLT = $(LLTDIR)/libllt.a
FLAGS = -Wall -Wextra -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS)
FLAGS = -falign-functions -Wall -Wextra -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS)
LIBS = $(LLT) -lm
DEBUGFLAGS = -g -DDEBUG $(FLAGS)

View File

@ -1,4 +1,3 @@
#define MAX_INL_SIZE 96
#ifdef BITS64
#define NWORDS(sz) (((sz)+7)>>3)
#else
@ -113,6 +112,11 @@ static void autorelease(cvalue_t *cv)
add_finalizer(cv);
}
void cv_autorelease(cvalue_t *cv)
{
autorelease(cv);
}
value_t cvalue(fltype_t *type, size_t sz)
{
cvalue_t *pcv;
@ -369,8 +373,7 @@ static void array_init_fromargs(char *dest, value_t *vals, size_t cnt,
static int isarray(value_t v)
{
if (!iscvalue(v)) return 0;
return cv_class((cvalue_t*)ptr(v))->eltype != NULL;
return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;
}
static size_t predict_arraylen(value_t arg)
@ -756,46 +759,53 @@ value_t cvalue_compare(value_t a, value_t b)
return fixnum(diff);
}
static void check_addr_args(char *fname, size_t typesize, value_t *args,
void **data, ulong_t *index)
static void check_addr_args(char *fname, value_t arr, value_t ind,
char **data, ulong_t *index)
{
size_t sz;
if (!iscvalue(args[0]))
type_error(fname, "cvalue", args[0]);
*data = cv_data((cvalue_t*)ptr(args[0]));
sz = cv_len((cvalue_t*)ptr(args[0]));
cvalue_t *cv = (cvalue_t*)ptr(args[1]);
if (isfixnum(args[1]))
*index = numval(args[1]);
else if (!iscvalue(args[1]) || !valid_numtype(cv_numtype(cv)))
type_error(fname, "number", args[1]);
else
*index = conv_to_ulong(cv_data(cv), cv_numtype(cv));
if (*index > sz - typesize)
bounds_error(fname, args[0], args[1]);
size_t numel;
cvalue_t *cv = (cvalue_t*)ptr(arr);
*data = cv_data(cv);
numel = cv_len(cv)/(cv_class(cv)->elsz);
*index = toulong(ind, fname);
if (*index >= numel)
bounds_error(fname, arr, ind);
}
value_t cvalue_get_int8(value_t *args, u_int32_t nargs)
static value_t make_uninitialized_instance(fltype_t *t)
{
void *data; ulong_t index;
argcount("get-int8", nargs, 2);
check_addr_args("get-int8", sizeof(int8_t), args, &data, &index);
return fixnum(((int8_t*)data)[index]);
if (t->eltype != NULL)
return alloc_array(t, t->size);
return cvalue(t, t->size);
}
value_t cvalue_set_int8(value_t *args, u_int32_t nargs)
static value_t cvalue_array_aref(value_t *args)
{
void *data; ulong_t index; int32_t val=0;
argcount("set-int8", nargs, 3);
check_addr_args("set-int8", sizeof(int8_t), args, &data, &index);
cvalue_t *cv = (cvalue_t*)ptr(args[2]);
if (isfixnum(args[2]))
val = numval(args[2]);
else if (!iscvalue(args[2]) || !valid_numtype(cv_numtype(cv)))
type_error("set-int8", "number", args[2]);
char *data; ulong_t index;
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
value_t el = make_uninitialized_instance(eltype);
check_addr_args("aref", args[0], args[1], &data, &index);
char *dest = cv_data((cvalue_t*)ptr(el));
size_t sz = eltype->size;
if (sz == 1)
*dest = data[index];
else if (sz == 2)
*(int16_t*)dest = ((int16_t*)data)[index];
else if (sz == 4)
*(int32_t*)dest = ((int32_t*)data)[index];
else if (sz == 8)
*(int64_t*)dest = ((int64_t*)data)[index];
else
val = conv_to_int32(cv_data(cv), cv_numtype(cv));
((int8_t*)data)[index] = val;
memcpy(dest, data + index*sz, sz);
return el;
}
static value_t cvalue_array_aset(value_t *args)
{
char *data; ulong_t index;
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
check_addr_args("aset", args[0], args[1], &data, &index);
char *dest = data + index*eltype->size;
cvalue_init(eltype, args[2], dest);
return args[2];
}
@ -812,6 +822,7 @@ value_t fl_builtin(value_t *args, u_int32_t nargs)
value_t cbuiltin(char *name, builtin_t f)
{
assert(((uptrint_t)f & 0x7) == 0);
value_t sym = symbol(name);
((symbol_t*)ptr(sym))->dlcache = f;
ptrhash_put(&reverse_dlsym_lookup_table, f, (void*)sym);
@ -874,8 +885,6 @@ void cvalues_init()
cv_intern(void);
set(symbol("c-value"), cbuiltin("c-value", cvalue_new));
set(symbol("get-int8"), cbuiltin("get-int8", cvalue_get_int8));
set(symbol("set-int8"), cbuiltin("set-int8", cvalue_set_int8));
set(symbol("typeof"), cbuiltin("typeof", cvalue_typeof));
set(symbol("sizeof"), cbuiltin("sizeof", cvalue_sizeof));
set(symbol("builtin"), cbuiltin("builtin", fl_builtin));

View File

@ -924,12 +924,15 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
case F_AREF:
argcount("aref", nargs, 2);
v = Stack[SP-2];
i = tofixnum(Stack[SP-1], "aref");
if (isvector(v)) {
i = tofixnum(Stack[SP-1], "aref");
if ((unsigned)i >= vector_size(v))
bounds_error("aref", v, Stack[SP-1]);
v = vector_elt(v, i);
}
else if (isarray(v)) {
v = cvalue_array_aref(&Stack[SP-2]);
}
else {
// TODO other sequence types?
type_error("aref", "sequence", v);
@ -938,12 +941,15 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
case F_ASET:
argcount("aset", nargs, 3);
e = Stack[SP-3];
i = tofixnum(Stack[SP-2], "aset");
if (isvector(e)) {
i = tofixnum(Stack[SP-2], "aset");
if ((unsigned)i >= vector_size(e))
bounds_error("aref", v, Stack[SP-1]);
vector_elt(e, i) = (v=Stack[SP-1]);
}
else if (isarray(e)) {
v = cvalue_array_aset(&Stack[SP-3]);
}
else {
type_error("aset", "sequence", e);
}

View File

@ -201,6 +201,7 @@ typedef struct {
} cprim_t;
#define CPRIM_NWORDS 2
#define MAX_INL_SIZE 96
#define CV_OWNED_BIT 0x1
#define CV_PARENT_BIT 0x2
@ -242,6 +243,7 @@ extern fltype_t *builtintype;
value_t cvalue(fltype_t *type, size_t sz);
void add_finalizer(cvalue_t *cv);
void cv_autorelease(cvalue_t *cv);
size_t ctype_sizeof(value_t type, int *palign);
value_t cvalue_copy(value_t v);
value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);

View File

@ -538,8 +538,8 @@ value_t read_sexpr(ios_t *f)
value_t v;
readstate_t state;
state.prev = readstate;
htable_new(&state.backrefs, 16);
htable_new(&state.gensyms, 16);
htable_new(&state.backrefs, 8);
htable_new(&state.gensyms, 8);
readstate = &state;
v = do_read_sexpr(f, UNBOUND);

View File

@ -14,6 +14,27 @@
#include "llt.h"
#include "flisp.h"
static value_t print_to_string(value_t v, int princ)
{
ios_t str;
ios_mem(&str, 0);
print(&str, v, princ);
value_t outp;
if (str.size < MAX_INL_SIZE) {
outp = cvalue_string(str.size);
memcpy(cv_data((cvalue_t*)ptr(outp)), str.buf, str.size);
}
else {
size_t sz;
char *buf = ios_takebuf(&str, &sz);
buf[sz] = '\0';
outp = cvalue_from_ref(stringtype, buf, sz-1, NIL);
cv_autorelease((cvalue_t*)ptr(outp));
}
ios_close(&str);
return outp;
}
value_t fl_intern(value_t *args, u_int32_t nargs)
{
argcount("intern", nargs, 1);
@ -123,7 +144,11 @@ value_t fl_string(value_t *args, u_int32_t nargs)
continue;
}
}
lerror(ArgError, "string: expected string, symbol or character");
args[i] = print_to_string(args[i], 0);
if (nargs == 1) // convert single value to string
return args[i];
sz += cv_len((cvalue_t*)ptr(args[i]));
//lerror(ArgError, "string: expected string, symbol or character");
}
cv = cvalue_string(sz);
char *ptr = cvalue_data(cv);

View File

@ -130,7 +130,7 @@ for internal use:
. disadvantage is looking through the lambda list on every lookup. maybe
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
* represent guest function as a tagged function pointer; allocate nothing
bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains
@ -927,7 +927,9 @@ consolidated todo list as of 8/30:
- use the unused tag for TAG_PRIM, add smaller prim representation
* finalizers in gc
* hashtable
* generic aref/aset
- expose io stream object
- new toplevel
- enable print-shared for cvalues' types
- remaining c types

View File

@ -154,9 +154,6 @@ static char *_buf_realloc(ios_t *s, size_t sz)
{
char *temp;
if (sz <= s->maxsize)
return s->buf;
if ((s->buf==NULL || s->buf==&s->local[0]) && (sz <= IOS_INLSIZE)) {
/* TODO: if we want to allow shrinking, see if the buffer shrank
down to this size, in which case we need to copy. */
@ -165,7 +162,10 @@ static char *_buf_realloc(ios_t *s, size_t sz)
s->ownbuf = 1;
return s->buf;
}
else if (s->ownbuf && s->buf != &s->local[0]) {
if (sz <= s->maxsize) return s->buf;
if (s->ownbuf && s->buf != &s->local[0]) {
// if we own the buffer we're free to resize it
// always allocate 1 bigger in case user wants to add a NUL
// terminator after taking over the buffer
@ -201,7 +201,7 @@ static size_t _write_grow(ios_t *s, char *data, size_t n)
if (s->bpos + n > s->maxsize) {
/* TODO: here you might want to add a mechanism for limiting
the growth of the stream. */
newsize = s->maxsize * 2;
newsize = s->maxsize ? s->maxsize * 2 : 8;
while (s->bpos + n > newsize)
newsize *= 2;
if (_buf_realloc(s, newsize) == NULL) {
@ -514,6 +514,8 @@ void ios_close(ios_t *s)
if (s->fd != -1 && s->ownfd)
close(s->fd);
s->fd = -1;
if (s->buf!=NULL && s->ownbuf && s->buf!=&s->local[0])
free(s->buf);
}
static void _buf_init(ios_t *s, bufmode_t bm)