ref: b99d8715ce8ea2f97f25d65b628421c49087e23c
parent: 7e04bb948c151b9984b3e4eaa5708a64a8ffe60b
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat Dec 27 01:02:53 EST 2008
generic aref/aset for all arrays (string v) now works on any value, by printing to a string some bug fixes in ios
--- a/femtolisp/Makefile
+++ b/femtolisp/Makefile
@@ -8,7 +8,7 @@
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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -1,4 +1,3 @@
-#define MAX_INL_SIZE 96
#ifdef BITS64
#define NWORDS(sz) (((sz)+7)>>3)
#else
@@ -113,6 +112,11 @@
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 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 @@
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 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 @@
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));
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -924,12 +924,15 @@
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,11 +941,14 @@
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);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -201,6 +201,7 @@
} 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 @@
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);
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -538,8 +538,8 @@
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);
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -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 @@
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);
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -130,7 +130,7 @@
. 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 @@
- 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
--- a/llt/ios.c
+++ b/llt/ios.c
@@ -154,9 +154,6 @@
{
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 @@
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 @@
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 @@
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)