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

fixed array constructor so it doesn't require allocating a generic 

container first

updates and improvements to ios
This commit is contained in:
JeffBezanson 2008-08-29 03:27:59 +00:00
parent 9acdf313b9
commit d6470ac62f
6 changed files with 254 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
femtolisp/builtins.c
View File

@ -332,7 +332,6 @@ value_t fl_rand32(value_t *args, u_int32_t nargs)
#ifdef BITS64
return fixnum(r);
#else
if (fits_fixnum(r)) return fixnum(r);
return mk_uint32(r);
#endif
}
@ -340,9 +339,6 @@ value_t fl_rand64(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
ulong r = (((uint64_t)random())<<32) | random();
#ifdef BITS64
if (fits_fixnum(r)) return fixnum(r);
#endif
return mk_uint64(r);
}
value_t fl_randd(value_t *args, u_int32_t nargs)

300
femtolisp/cvalues.c
View File

@ -16,7 +16,7 @@ static int struct_aligns[8] = {
sizeof(struct { char a; int64_t i; }) };
static int ALIGN2, ALIGN4, ALIGN8, ALIGNPTR;
typedef void (*cvinitfunc_t)(value_t*, u_int32_t, void*, void*);
typedef void (*cvinitfunc_t)(value_t, value_t, void*, void*);
value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
value_t int64sym, uint64sym;
@ -30,7 +30,7 @@ value_t unionsym;
value_t autoreleasesym, typeofsym, sizeofsym;
static void cvalue_init(value_t type, value_t *vs, u_int32_t nv, void *dest);
static void cvalue_init(value_t type, value_t v, void *dest);
void cvalue_print(ios_t *f, value_t v, int princ);
// exported guest functions
@ -239,39 +239,45 @@ static double strtodouble(char *str, char *fname)
}
#define num_ctor(typenam, cnvt, tag, fromstr) \
static void cvalue_##typenam##_init(value_t *args, u_int32_t nargs, \
static void cvalue_##typenam##_init(value_t type, value_t arg, \
void *dest, void *data) \
{ \
typenam##_t n=0; \
(void)data; \
if (nargs) { \
if (iscvalue(args[0])) { \
cvalue_t *cv = (cvalue_t*)ptr(args[0]); \
void *p = cv_data(cv); \
if (valid_numtype(cv_numtype(cv))) { \
n = (typenam##_t)conv_to_##cnvt(p, cv_numtype(cv)); \
} \
else if (cv->flags.cstring) { \
n = fromstr(p, #typenam); \
} \
else if (cv_len(cv) == sizeof(typenam##_t)) { \
n = *(typenam##_t*)p; \
} \
else { \
type_error(#typenam, "number", args[0]); \
} \
(void)data; (void)type; \
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 = (typenam##_t)conv_to_##cnvt(p, cv_numtype(cv)); \
} \
else if (cv->flags.cstring) { \
n = fromstr(p, #typenam); \
} \
else if (cv_len(cv) == sizeof(typenam##_t)) { \
n = *(typenam##_t*)p; \
} \
else { \
n = tofixnum(args[0], #typenam); \
goto cnvt_error; \
} \
} \
else { \
goto cnvt_error; \
} \
*((typenam##_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##sym, sizeof(typenam##_t)); \
((cprim_t*)ptr(cv))->flags.numtype = tag; \
cvalue_##typenam##_init(args, nargs, &((cprim_t*)ptr(cv))->data, 0); \
cvalue_##typenam##_init(typenam##sym, \
args[0], &((cprim_t*)ptr(cv))->data, 0); \
return cv; \
} \
value_t mk_##typenam(typenam##_t n) \
@ -332,20 +338,18 @@ value_t char_from_code(uint32_t code)
return cvalue_char(&ccode, 1);
}
static void cvalue_enum_init(value_t *args, u_int32_t nargs, void *dest,
void *data)
static void cvalue_enum_init(value_t type, value_t arg, void *dest, void *data)
{
int n=0;
value_t syms;
(void)data;
argcount("enum", nargs, 2);
syms = args[0];
syms = car(cdr(type));
if (!iscons(syms))
type_error("enum", "cons", syms);
if (issymbol(args[1])) {
if (issymbol(arg)) {
while (iscons(syms)) {
if (car_(syms) == args[1]) {
if (car_(syms) == arg) {
*(int*)dest = n;
return;
}
@ -354,13 +358,13 @@ static void cvalue_enum_init(value_t *args, u_int32_t nargs, void *dest,
}
lerror(ArgError, "enum: invalid enum value");
}
if (isfixnum(args[1])) {
n = (int)numval(args[1]);
if (isfixnum(arg)) {
n = (int)numval(arg);
}
else if (iscvalue(args[1])) {
cvalue_t *cv = (cvalue_t*)ptr(args[1]);
else if (iscvalue(arg)) {
cvalue_t *cv = (cvalue_t*)ptr(arg);
if (!valid_numtype(cv_numtype(cv)))
type_error("enum", "number", args[1]);
type_error("enum", "number", arg);
n = conv_to_int32(cv_data(cv), cv_numtype(cv));
}
if ((unsigned)n >= llength(syms))
@ -373,105 +377,112 @@ value_t cvalue_enum(value_t *args, u_int32_t nargs)
argcount("enum", nargs, 2);
value_t cv = cvalue(list2(enumsym, args[0]), 4);
((cvalue_t*)ptr(cv))->flags.numtype = T_INT32;
cvalue_enum_init(args, nargs, cv_data((cvalue_t*)ptr(cv)), NULL);
cvalue_enum_init(cv_type((cvalue_t*)ptr(cv)),
args[1], cv_data((cvalue_t*)ptr(cv)), NULL);
return cv;
}
static void cvalue_array_init(value_t *args, u_int32_t nargs, void *dest,
void *data)
static void array_init_fromargs(char *dest, value_t *vals, size_t cnt,
value_t eltype, size_t elsize)
{
size_t cnt=0, elsize, i;
value_t *init = NULL;
size_t i;
for(i=0; i < cnt; i++) {
cvalue_init(eltype, vals[i], dest);
dest += elsize;
}
}
static int isarray(value_t v)
{
if (!iscvalue(v)) return 0;
value_t type = cv_type((cvalue_t*)ptr(v));
return (iscons(type) && car_(type)==arraysym);
}
static size_t predict_arraylen(value_t arg)
{
if (isvector(arg))
return vector_size(arg);
else if (iscons(arg))
return llength(arg);
else if (arg == NIL)
return 0;
if (isarray(arg))
return cvalue_arraylen(arg);
return 1;
}
static void cvalue_array_init(value_t type, value_t arg, void *dest, void *data)
{
size_t elsize, i, cnt, sz;
int junk;
value_t eltype = car(cdr(type));
if (data != 0)
elsize = (size_t)data; // already computed by constructor
else
elsize = ctype_sizeof(args[0], &junk);
char *out = (char*)dest;
elsize = ctype_sizeof(eltype, &junk);
if (nargs == 2) {
if (isvector(args[1]) || iscons(args[1]) || args[1]==NIL)
init = &args[1];
else
cnt = toulong(args[1], "array");
cnt = predict_arraylen(arg);
if (iscons(cdr_(cdr_(type)))) {
size_t tc = toulong(car_(cdr_(cdr_(type))), "array");
if (tc != cnt)
lerror(ArgError, "array: size mismatch");
}
else if (nargs == 3) {
cnt = toulong(args[1], "array");
init = &args[2];
sz = elsize * cnt;
if (isvector(arg)) {
array_init_fromargs((char*)dest, &vector_elt(arg,0), cnt,
eltype, elsize);
return;
}
else {
argcount("array", nargs, 2);
}
if (init) {
if (isvector(*init)) {
if (cnt && vector_size(*init) != cnt)
lerror(ArgError, "array: size mismatch");
cnt = vector_size(*init);
for(i=0; i < cnt; i++) {
cvalue_init(args[0], &vector_elt(*init, i), 1, out);
out += elsize;
}
return;
else if (iscons(arg) || arg==NIL) {
i = 0;
while (iscons(arg)) {
if (SP >= N_STACK)
break;
PUSH(car_(arg));
i++;
arg = cdr_(arg);
}
else if (iscons(*init) || *init==NIL) {
for(i=0; i < cnt || cnt==0; i++) {
if (!iscons(*init)) {
if (cnt != 0)
lerror(ArgError, "array: size mismatch");
else
break;
}
cvalue_init(args[0], &car_(*init), 1, out);
out += elsize;
*init = cdr_(*init);
}
return;
}
else if (iscvalue(*init)) {
cvalue_t *cv = (cvalue_t*)ptr(*init);
size_t tot = cnt*elsize;
if (tot == cv_len(cv)) {
if (tot) memcpy(out, cv_data(cv), tot);
if (i != cnt)
lerror(ArgError, "array: size mismatch");
array_init_fromargs((char*)dest, &Stack[SP-i], i, eltype, elsize);
POPN(i);
return;
}
else if (iscvalue(arg)) {
cvalue_t *cv = (cvalue_t*)ptr(arg);
if (isarray(arg)) {
value_t aet = car(cdr(cv_type(cv)));
if (aet == eltype) {
if (cv_len(cv) == sz)
memcpy(dest, cv_data(cv), sz);
else
lerror(ArgError, "array: size mismatch");
return;
}
else {
// TODO: initialize array from different type elements
lerror(ArgError, "array: element type mismatch");
}
}
else {
type_error("array", "cons", *init);
}
lerror(ArgError, "array: invalid size");
}
}
static size_t predict_arraylen(value_t *args, u_int32_t nargs, size_t *elsz)
{
int junk;
size_t cnt;
if (nargs < 2)
argcount("array", nargs, 2);
*elsz = ctype_sizeof(args[0], &junk);
if (isvector(args[1])) {
cnt = vector_size(args[1]);
}
else if (iscons(args[1])) {
cnt = llength(args[1]);
}
else if (args[1] == NIL) {
cnt = 0;
}
else {
cnt = toulong(args[1], "array");
}
return cnt;
if (cnt == 1)
cvalue_init(eltype, arg, dest);
else
type_error("array", "sequence", arg);
}
static value_t alloc_array(value_t type, size_t sz)
{
value_t cv;
if (car_(cdr_(type)) == charsym) {
PUSH(type);
cv = cvalue_string(sz);
((cvalue_t*)ptr(cv))->type = type;
((cvalue_t*)ptr(cv))->type = POP();
}
else {
cv = cvalue(type, sz);
@ -482,12 +493,18 @@ static value_t alloc_array(value_t type, size_t sz)
value_t cvalue_array(value_t *args, u_int32_t nargs)
{
size_t elsize, cnt, sz;
int junk;
cnt = predict_arraylen(args, nargs, &elsize);
if (nargs < 1)
argcount("array", nargs, 1);
cnt = nargs - 1;
elsize = ctype_sizeof(args[0], &junk);
sz = elsize * cnt;
value_t cv = alloc_array(listn(3, arraysym, args[0], size_wrap(cnt)), sz);
cvalue_array_init(args, nargs, cv_data((cvalue_t*)ptr(cv)), (void*)elsize);
array_init_fromargs(cv_data((cvalue_t*)ptr(cv)), &args[1], cnt,
args[0], elsize);
return cv;
}
@ -683,33 +700,24 @@ value_t cvalue_copy(value_t v)
return tagptr(pnv, TAG_CVALUE);
}
static void cvalue_init(value_t type, value_t *vs, u_int32_t nv, void *dest)
static void cvalue_init(value_t type, value_t v, void *dest)
{
cvinitfunc_t f;
unsigned int i, na=0;
if (issymbol(type)) {
f = ((symbol_t*)ptr(type))->dlcache;
}
else if (!iscons(type)) {
f = NULL;
lerror(ArgError, "c-value: invalid c type");
}
else {
else if (iscons(type)) {
value_t head = car_(type);
f = ((symbol_t*)ptr(head))->dlcache;
type = cdr_(type);
while (iscons(type)) {
PUSH(car_(type));
na++;
type = cdr_(type);
}
}
for(i=0; i < nv; i++)
PUSH(vs[i]);
na += nv;
f(&Stack[SP-na], na, dest, NULL);
POPN(na);
else {
f = NULL;
}
if (f == NULL)
lerror(ArgError, "c-value: invalid c type");
f(type, v, dest, NULL);
}
static numerictype_t sym_to_numtype(value_t type)
@ -756,29 +764,26 @@ static numerictype_t sym_to_numtype(value_t type)
// type, including user-defined.
value_t cvalue_new(value_t *args, u_int32_t nargs)
{
if (nargs < 1)
argcount("c-value", nargs, 1);
if (nargs < 1 || nargs > 2)
argcount("c-value", nargs, 2);
value_t type = args[0];
value_t cv;
if (iscons(type) && car_(type) == arraysym) {
// special case to handle incomplete array types bla[]
size_t elsz;
value_t c = cdr_(type);
int na=0;
while (iscons(c)) {
PUSH(car_(c));
c = cdr_(c);
na++;
}
if (nargs > 1) {
PUSH(args[1]);
na++;
}
size_t cnt = predict_arraylen(&Stack[SP-na], na, &elsz);
value_t eltype = car(cdr_(type));
int junk;
size_t elsz = ctype_sizeof(eltype, &junk);
size_t cnt;
if (iscons(cdr_(cdr_(type))))
cnt = toulong(car_(cdr_(cdr_(type))), "array");
else if (nargs == 2)
cnt = predict_arraylen(args[1]);
else
cnt = 0;
cv = alloc_array(type, elsz * cnt);
cvalue_array_init(&Stack[SP-na], na, cv_data((cvalue_t*)ptr(cv)),
(void*)elsz);
POPN(na);
if (nargs == 2)
cvalue_array_init(type, args[1], cv_data((cvalue_t*)ptr(cv)),
(void*)elsz);
}
else {
int junk;
@ -786,7 +791,8 @@ value_t cvalue_new(value_t *args, u_int32_t nargs)
if (issymbol(type)) {
((cvalue_t*)ptr(cv))->flags.numtype = sym_to_numtype(type);
}
cvalue_init(type, &args[1], nargs-1, cv_data((cvalue_t*)ptr(cv)));
if (nargs == 2)
cvalue_init(type, args[1], cv_data((cvalue_t*)ptr(cv)));
}
return cv;
}

4
femtolisp/flisp.c
View File

@ -1433,7 +1433,7 @@ value_t load_file(char *fname)
FL_TRY {
while (1) {
e = read_sexpr(f);
//print(ios_stdout,e,0); ios_puts("\n", ios_stdout);
//print(ios_stdout,e,0); ios_putc('\n', ios_stdout);
if (ios_eof(f)) break;
v = toplevel_eval(e);
}
@ -1497,6 +1497,6 @@ int main(int argc, char *argv[])
set(symbol("that"), v);
ios_puts("\n\n", ios_stdout);
}
ios_puts("\n", ios_stdout);
ios_putc('\n', ios_stdout);
return 0;
}

18
femtolisp/print.c
View File

@ -530,18 +530,22 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
if (!weak) {
outs("#array(", f);
do_print(f, eltype, princ);
outc(' ', f);
}
outc('[', f);
for(i=0; i < cnt; i++) {
cvalue_printdata(f, data, elsize, eltype, princ, 1);
if (i < cnt-1)
if (cnt > 0)
outc(' ', f);
}
else {
outc('[', f);
}
for(i=0; i < cnt; i++) {
if (i > 0)
outc(' ', f);
cvalue_printdata(f, data, elsize, eltype, princ, 1);
data += elsize;
}
outc(']', f);
if (!weak)
outc(')', f);
else
outc(']', f);
}
else if (car_(type) == enumsym) {
value_t sym = list_nth(car(cdr_(type)), *(size_t*)data);

54
femtolisp/todo
View File

@ -149,15 +149,14 @@ typedef struct _cvtable_t {
void (*print)(struct _cvalue_t *, FILE *);
} cvtable_t;
; remember: variable-length data preferred over variable-length arglists
c type representations:
symbols void, [u]int[8,16,32,64], float, double, [u]char, [u]short,
[u]int, [u]long, lispvalue
(c-function ret-type (argtype ...))
(array type N)
(array type[ N])
(struct ((name type) (name type) ...))
(union ((name type) (name type) ...))
(mlayout ((name type offset) (name type offset) ...))
(enum (name1 name2 ...))
(pointer type)
@ -167,8 +166,8 @@ constructors:
([u]int64 b3 b2 b1 b0)
(float hi lo) or (float "3.14")
(double b3 b2 b1 b0) or (double "3.14")
(array ctype (val ...))
(struct ((name type) ...) (val ...))
(array ctype val ...)
(struct ((name type) ...) val ...)
(pointer ctype) ; null pointer
(pointer cvalue) ; constructs pointer to the given value
; same as (pointer (typeof x) x)
@ -243,11 +242,27 @@ should be related formally:
(if (symbolp type) (apply (eval type) ())
(apply (eval (car type)) (cdr type))))
NOTE: this relationship is no longer true. we don't want to have to
construct 1 cvalue from 1 lisp value every time, since that could
require allocating a totally redundant list or vector. it should be
possible to make a cvalue from a series of lisp arguments. for
example there are now 2 different ways to make an array:
1) from series of arguments: (array type val0 val1 ...)
2) from 1 (optional) value: (c-value '(array int8[ size])[ V])
constructors will internally use the second form to initialize elements
of aggregates. e.g. 'array' in the first case will conceptually call
(c-value type val0)
(c-value type val1)
...
for aggregate types, you can keep a variable referring to the relevant
piece:
(setq point '((x int) (y int)))
(struct point [2 3]) ; looks like c declaration 'struct point x;'
(struct point 2 3) ; looks like c declaration 'struct point x;'
a type is a function, so something similar to typedef is achieved by:
@ -373,10 +388,10 @@ then we can write the vector clause in backquote as e.g.
setup plan:
- create source directory and svn repository, move llt sources into it
* create source directory and svn repository, move llt sources into it
* write femtolisp.h, definitions for extensions to #include
- add fl_ prefix to all exported functions
- port read and print to jclib's iostreams
* port read and print to llt iostreams
* get rid of flutils; use ptrhash instead
* builtinp needs to be a builtin ;) to distinguish lisp builtins from cvalues
* allocation and gc for cvalues
@ -585,6 +600,10 @@ cvalues todo:
- anonymous unions
* fix princ for cvalues
- make header size for primitives 8 bytes, even on 64-bit arch
- more efficient read for #array(), so it doesn't need to build a pairlist
- make sure shared pieces of types, like lists of enum values, can be
printed as shared structure to avoid duplication.
- share more types, allocate less
- string constructor/concatenator:
(string 'sym #char(65) #wchar(945) "blah" 23)
@ -797,23 +816,30 @@ String API
IOStream API
read
read - (read[ stream]) ; get next sexpr from stream
print, sprint
princ, sprinc
stream - (stream cvalue-as-bytestream)
iostream - (stream[ cvalue-as-bytestream])
file
fifo
socket
stream.eof
stream.write - (stream.write cvalue)
stream.read - (stream.read ctype)
stream.write - (stream.write s cvalue)
stream.read - (stream.read s ctype)
stream.copy - (stream.copy to from [nbytes])
stream.copyuntil - (stream.copy to from byte)
stream.flush
stream.pos - (stream.pos s [set-pos])
stream.seek - (stream.seek s offset)
stream.seekend - move to end of stream
stream.trunc
stream.getc - get utf8 character(s)
stream.tostring! - destructively convert stringstream to string
stream.readline
stream.readlines
stream.readall
print-to-string
princ-to-string
path.combine
@ -840,9 +866,11 @@ IOStream API
*rand
*randn
*rand.uint32
*rand.uint64
*rand.double
*rand.float
-----------------------------------------------------------------------------
@ -880,3 +908,5 @@ switch to miser mode, otherwise default is ok, for example:
* *print-pretty* to control it
- if indent gets too large, dedent back to left edge
-----------------------------------------------------------------------------

69
llt/ios.c
View File

@ -189,7 +189,7 @@ static char *_buf_realloc(ios_t *s, size_t sz)
// write a block of data into the buffer at the current position, resizing
// if necessary. returns # written.
static size_t _writebuf_force(ios_t *s, char *data, size_t n)
static size_t _write_grow(ios_t *s, char *data, size_t n)
{
size_t amt;
size_t newsize;
@ -249,15 +249,14 @@ static size_t _ios_read(ios_t *s, char *dest, size_t n, int all)
s->bpos += avail;
return avail;
}
else {
dest += avail;
n -= avail;
tot += avail;
ios_flush(s);
s->bpos = s->size = 0;
s->state = bst_rd;
}
dest += avail;
n -= avail;
tot += avail;
ios_flush(s);
s->bpos = s->size = 0;
s->state = bst_rd;
if (n > MOST_OF(s->maxsize)) {
// doesn't fit comfortably in buffer; go direct
@ -321,6 +320,12 @@ size_t ios_readprep(ios_t *s, size_t n)
return s->size - s->bpos;
}
static void _write_update_pos(ios_t *s)
{
if (s->bpos > s->ndirty) s->ndirty = s->bpos;
if (s->bpos > s->size) s->size = s->bpos;
}
size_t ios_write(ios_t *s, char *data, size_t n)
{
if (n == 0) return 0;
@ -334,7 +339,7 @@ size_t ios_write(ios_t *s, char *data, size_t n)
space = s->size - s->bpos;
if (s->bm == bm_mem) {
wrote = _writebuf_force(s, data, n);
wrote = _write_grow(s, data, n);
}
else if (s->bm == bm_none) {
int result = _os_write_all(s->fd, data, n, &wrote);
@ -366,10 +371,7 @@ size_t ios_write(ios_t *s, char *data, size_t n)
}
return ios_write(s, data, n);
}
if (s->bpos > s->ndirty)
s->ndirty = s->bpos;
if (s->bpos > s->size)
s->size = s->bpos;
_write_update_pos(s);
return wrote;
}
@ -617,7 +619,7 @@ static void _ios_init(ios_t *s)
s->tally = 0;
s->fd = -1;
s->byteswap = 0;
s->ownbuf = 0;
s->ownbuf = 1;
s->ownfd = 0;
s->_eof = 0;
s->rereadable = 0;
@ -692,6 +694,13 @@ int ios_putc(int c, ios_t *s)
{
char ch = (char)c;
if (s->state == bst_wr && s->bpos < s->maxsize && s->bm != bm_none) {
s->buf[s->bpos++] = ch;
_write_update_pos(s);
if (s->bm == bm_line && ch == '\n')
ios_flush(s);
return 1;
}
return (int)ios_write(s, &ch, 1);
}
@ -754,17 +763,31 @@ int ios_getutf8(ios_t *s, uint32_t *pwc)
int ios_printf(ios_t *s, char *format, ...)
{
char buf[512];
char *str=&buf[0];
char *str=NULL;
va_list args;
int c;
va_start(args, format);
// TODO: avoid copy
c = vsnprintf(buf, sizeof(buf), format, args);
if ((size_t)c >= sizeof(buf))
c = vasprintf(&str, format, args);
if (s->state == bst_wr && s->bpos < s->maxsize && s->bm != bm_none) {
size_t avail = s->maxsize - s->bpos;
char *start = s->buf + s->bpos;
c = vsnprintf(start, avail, format, args);
if (c < 0) {
va_end(args);
return c;
}
if (c < avail) {
va_end(args);
s->bpos += (size_t)c;
_write_update_pos(s);
// TODO: only works right if newline is at end
if (s->bm == bm_line && memrchr(start, '\n', (size_t)c))
ios_flush(s);
return c;
}
}
c = vasprintf(&str, format, args);
va_end(args);
@ -772,6 +795,6 @@ int ios_printf(ios_t *s, char *format, ...)
ios_write(s, str, c);
if (str != &buf[0]) free(str);
free(str);
return c;
}