ref: d6470ac62ffc08c0e14798f6ac96c678045b958e
parent: 9acdf313b977ce11cf05254f9f05f6f8725ffbaa
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Thu Aug 28 23:27:59 EDT 2008
fixed array constructor so it doesn't require allocating a generic container first updates and improvements to ios
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -332,7 +332,6 @@
#ifdef BITS64
return fixnum(r);
#else
- if (fits_fixnum(r)) return fixnum(r);
return mk_uint32(r);
#endif
}
@@ -340,9 +339,6 @@
{(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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -16,7 +16,7 @@
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 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 @@
}
#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 @@
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 @@
}
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 @@
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);+ else if (iscons(arg) || arg==NIL) {+ i = 0;
+ while (iscons(arg)) {+ if (SP >= N_STACK)
+ break;
+ PUSH(car_(arg));
+ i++;
+ arg = cdr_(arg);
+ }
+ if (i != cnt)
+ lerror(ArgError, "array: size mismatch");
+ array_init_fromargs((char*)dest, &Stack[SP-i], i, eltype, elsize);
+ POPN(i);
+ return;
}
- 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;
+ 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;
}
- return;
- }
- 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);
+ else {+ // TODO: initialize array from different type elements
+ lerror(ArgError, "array: element type mismatch");
}
- 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);
- return;
- }
- }
- else {- type_error("array", "cons", *init);- }
- lerror(ArgError, "array: invalid size");
}
+ if (cnt == 1)
+ cvalue_init(eltype, arg, dest);
+ else
+ type_error("array", "sequence", arg);}
-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;
-}
-
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 @@
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 @@
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 @@
// 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 @@
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;
}
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -1433,7 +1433,7 @@
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 @@
set(symbol("that"), v); ios_puts("\n\n", ios_stdout);}
- ios_puts("\n", ios_stdout);+ ios_putc('\n', ios_stdout);return 0;
}
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -530,18 +530,22 @@
if (!weak) { outs("#array(", f);do_print(f, eltype, princ);
- outc(' ', f);+ if (cnt > 0)
+ outc(' ', f);}
- outc('[', f);+ else {+ outc('[', f);+ }
for(i=0; i < cnt; i++) {- cvalue_printdata(f, data, elsize, eltype, princ, 1);
- if (i < cnt-1)
+ 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);
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -149,15 +149,14 @@
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 @@
([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 @@
(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 @@
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 @@
- 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 @@
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 @@
*rand
+*randn
*rand.uint32
*rand.uint64
*rand.double
+*rand.float
-----------------------------------------------------------------------------
@@ -880,3 +908,5 @@
* *print-pretty* to control it
- if indent gets too large, dedent back to left edge
+
+-----------------------------------------------------------------------------
--- a/llt/ios.c
+++ b/llt/ios.c
@@ -189,7 +189,7 @@
// 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,16 +249,15 @@
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
if (all)
@@ -321,6 +320,12 @@
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 @@
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 @@
}
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 @@
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 @@
{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_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 @@
ios_write(s, str, c);
- if (str != &buf[0]) free(str);
+ free(str);
return c;
}