lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Use backward compatible variable initializers

This commit is contained in:
Lassi Kortela 2019-08-19 01:14:09 +03:00
parent 486ec48a76
commit 023937e5ea
16 changed files with 898 additions and 457 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

130
c/builtins.c
View File

@ -47,12 +47,16 @@ size_t llength(value_t v)
static value_t fl_nconc(value_t *args, uint32_t nargs) static value_t fl_nconc(value_t *args, uint32_t nargs)
{ {
value_t lst, first;
value_t *pcdr;
struct cons *c;
uint32_t i;
if (nargs == 0) if (nargs == 0)
return FL_NIL; return FL_NIL;
value_t lst, first = FL_NIL; first = FL_NIL;
value_t *pcdr = &first; pcdr = &first;
struct cons *c; i = 0;
uint32_t i = 0;
while (1) { while (1) {
lst = args[i++]; lst = args[i++];
if (i >= nargs) if (i >= nargs)
@ -73,11 +77,13 @@ static value_t fl_nconc(value_t *args, uint32_t nargs)
static value_t fl_assq(value_t *args, uint32_t nargs) static value_t fl_assq(value_t *args, uint32_t nargs)
{ {
argcount("assq", nargs, 2); value_t item;
value_t item = args[0]; value_t v;
value_t v = args[1];
value_t bind; value_t bind;
argcount("assq", nargs, 2);
item = args[0];
v = args[1];
while (iscons(v)) { while (iscons(v)) {
bind = car_(v); bind = car_(v);
if (iscons(bind) && car_(bind) == item) if (iscons(bind) && car_(bind) == item)
@ -101,9 +107,11 @@ static value_t fl_memq(value_t *args, uint32_t nargs)
static value_t fl_length(value_t *args, uint32_t nargs) static value_t fl_length(value_t *args, uint32_t nargs)
{ {
argcount("length", nargs, 1); value_t a;
value_t a = args[0];
struct cvalue *cv; struct cvalue *cv;
argcount("length", nargs, 1);
a = args[0];
if (isvector(a)) { if (isvector(a)) {
return fixnum(vector_size(a)); return fixnum(vector_size(a));
} else if (iscprim(a)) { } else if (iscprim(a)) {
@ -123,12 +131,14 @@ static value_t fl_length(value_t *args, uint32_t nargs)
return fixnum(llength(a)); return fixnum(llength(a));
} }
type_error("length", "sequence", a); type_error("length", "sequence", a);
return FL_NIL; // TODO
} }
static value_t fl_f_raise(value_t *args, uint32_t nargs) static value_t fl_f_raise(value_t *args, uint32_t nargs)
{ {
argcount("raise", nargs, 1); argcount("raise", nargs, 1);
fl_raise(args[0]); fl_raise(args[0]);
return FL_NIL; // TODO
} }
static value_t fl_exit(value_t *args, uint32_t nargs) static value_t fl_exit(value_t *args, uint32_t nargs)
@ -157,8 +167,10 @@ static value_t fl_keywordp(value_t *args, uint32_t nargs)
static value_t fl_top_level_value(value_t *args, uint32_t nargs) static value_t fl_top_level_value(value_t *args, uint32_t nargs)
{ {
struct symbol *sym;
argcount("top-level-value", nargs, 1); argcount("top-level-value", nargs, 1);
struct symbol *sym = tosymbol(args[0], "top-level-value"); sym = tosymbol(args[0], "top-level-value");
if (sym->binding == UNBOUND) if (sym->binding == UNBOUND)
fl_raise(fl_list2(UnboundError, args[0])); fl_raise(fl_list2(UnboundError, args[0]));
return sym->binding; return sym->binding;
@ -166,8 +178,10 @@ static value_t fl_top_level_value(value_t *args, uint32_t nargs)
static value_t fl_set_top_level_value(value_t *args, uint32_t nargs) static value_t fl_set_top_level_value(value_t *args, uint32_t nargs)
{ {
struct symbol *sym;
argcount("set-top-level-value!", nargs, 2); argcount("set-top-level-value!", nargs, 2);
struct symbol *sym = tosymbol(args[0], "set-top-level-value!"); sym = tosymbol(args[0], "set-top-level-value!");
if (!isconstant(sym)) if (!isconstant(sym))
sym->binding = args[1]; sym->binding = args[1];
return args[1]; return args[1];
@ -188,9 +202,11 @@ extern struct symbol *symtab;
value_t fl_global_env(value_t *args, uint32_t nargs) value_t fl_global_env(value_t *args, uint32_t nargs)
{ {
value_t lst;
(void)args; (void)args;
argcount("environment", nargs, 0); argcount("environment", nargs, 0);
value_t lst = FL_NIL; lst = FL_NIL;
fl_gc_handle(&lst); fl_gc_handle(&lst);
global_env_list(symtab, &lst); global_env_list(symtab, &lst);
fl_free_gc_handles(1); fl_free_gc_handles(1);
@ -214,15 +230,19 @@ static value_t fl_constantp(value_t *args, uint32_t nargs)
static value_t fl_integer_valuedp(value_t *args, uint32_t nargs) static value_t fl_integer_valuedp(value_t *args, uint32_t nargs)
{ {
value_t v;
double d;
void *data;
argcount("integer-valued?", nargs, 1); argcount("integer-valued?", nargs, 1);
value_t v = args[0]; v = args[0];
if (isfixnum(v)) { if (isfixnum(v)) {
return FL_T; return FL_T;
} else if (iscprim(v)) { } else if (iscprim(v)) {
numerictype_t nt = cp_numtype((struct cprim *)ptr(v)); numerictype_t nt = cp_numtype((struct cprim *)ptr(v));
if (nt < T_FLOAT) if (nt < T_FLOAT)
return FL_T; return FL_T;
void *data = cp_data((struct cprim *)ptr(v)); data = cp_data((struct cprim *)ptr(v));
if (nt == T_FLOAT) { if (nt == T_FLOAT) {
float f = *(float *)data; float f = *(float *)data;
if (f < 0) if (f < 0)
@ -231,7 +251,7 @@ static value_t fl_integer_valuedp(value_t *args, uint32_t nargs)
return FL_T; return FL_T;
} else { } else {
assert(nt == T_DOUBLE); assert(nt == T_DOUBLE);
double d = *(double *)data; d = *(double *)data;
if (d < 0) if (d < 0)
d = -d; d = -d;
if (d <= DBL_MAXINT && (double)(int64_t)d == d) if (d <= DBL_MAXINT && (double)(int64_t)d == d)
@ -243,8 +263,10 @@ static value_t fl_integer_valuedp(value_t *args, uint32_t nargs)
static value_t fl_integerp(value_t *args, uint32_t nargs) static value_t fl_integerp(value_t *args, uint32_t nargs)
{ {
value_t v;
argcount("integer?", nargs, 1); argcount("integer?", nargs, 1);
value_t v = args[0]; v = args[0];
return (isfixnum(v) || return (isfixnum(v) ||
(iscprim(v) && cp_numtype((struct cprim *)ptr(v)) < T_FLOAT)) (iscprim(v) && cp_numtype((struct cprim *)ptr(v)) < T_FLOAT))
? FL_T ? FL_T
@ -261,6 +283,7 @@ static value_t fl_fixnum(value_t *args, uint32_t nargs)
return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp))); return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
} }
type_error("fixnum", "number", args[0]); type_error("fixnum", "number", args[0]);
return FL_NIL; // TODO
} }
static value_t fl_truncate(value_t *args, uint32_t nargs) static value_t fl_truncate(value_t *args, uint32_t nargs)
@ -289,12 +312,15 @@ static value_t fl_truncate(value_t *args, uint32_t nargs)
return return_from_int64((int64_t)d); return return_from_int64((int64_t)d);
} }
type_error("truncate", "number", args[0]); type_error("truncate", "number", args[0]);
return FL_NIL; // TODO
} }
static value_t fl_vector_alloc(value_t *args, uint32_t nargs) static value_t fl_vector_alloc(value_t *args, uint32_t nargs)
{ {
fixnum_t i; fixnum_t i;
value_t f, v; value_t f, v;
int k;
if (nargs == 0) if (nargs == 0)
lerror(ArgError, "vector.alloc: too few arguments"); lerror(ArgError, "vector.alloc: too few arguments");
i = (fixnum_t)toulong(args[0], "vector.alloc"); i = (fixnum_t)toulong(args[0], "vector.alloc");
@ -305,7 +331,6 @@ static value_t fl_vector_alloc(value_t *args, uint32_t nargs)
f = args[1]; f = args[1];
else else
f = FL_UNSPECIFIED; f = FL_UNSPECIFIED;
int k;
for (k = 0; k < i; k++) for (k = 0; k < i; k++)
vector_elt(v, k) = f; vector_elt(v, k) = f;
return v; return v;
@ -328,10 +353,13 @@ static double todouble(value_t a, char *fname)
return conv_to_double(cp_data(cp), nt); return conv_to_double(cp_data(cp), nt);
} }
type_error(fname, "number", a); type_error(fname, "number", a);
return FL_NIL; // TODO
} }
static value_t fl_path_cwd(value_t *args, uint32_t nargs) static value_t fl_path_cwd(value_t *args, uint32_t nargs)
{ {
char *ptr;
if (nargs > 1) if (nargs > 1)
argcount("path.cwd", nargs, 1); argcount("path.cwd", nargs, 1);
if (nargs == 0) { if (nargs == 0) {
@ -339,7 +367,7 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs)
get_cwd(buf, sizeof(buf)); get_cwd(buf, sizeof(buf));
return string_from_cstr(buf); return string_from_cstr(buf);
} }
char *ptr = tostring(args[0], "path.cwd"); ptr = tostring(args[0], "path.cwd");
if (set_cwd(ptr)) if (set_cwd(ptr))
lerrorf(IOError, "path.cwd: could not cd to %s", ptr); lerrorf(IOError, "path.cwd: could not cd to %s", ptr);
return FL_T; return FL_T;
@ -347,16 +375,21 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs)
static value_t fl_path_exists(value_t *args, uint32_t nargs) static value_t fl_path_exists(value_t *args, uint32_t nargs)
{ {
char *str;
argcount("path.exists?", nargs, 1); argcount("path.exists?", nargs, 1);
char *str = tostring(args[0], "path.exists?"); str = tostring(args[0], "path.exists?");
return os_path_exists(str) ? FL_T : FL_F; return os_path_exists(str) ? FL_T : FL_F;
} }
static value_t fl_os_getenv(value_t *args, uint32_t nargs) static value_t fl_os_getenv(value_t *args, uint32_t nargs)
{ {
char *name;
char *val;
argcount("os.getenv", nargs, 1); argcount("os.getenv", nargs, 1);
char *name = tostring(args[0], "os.getenv"); name = tostring(args[0], "os.getenv");
char *val = getenv(name); val = getenv(name);
if (val == NULL) if (val == NULL)
return FL_F; return FL_F;
if (*val == 0) if (*val == 0)
@ -366,25 +399,30 @@ static value_t fl_os_getenv(value_t *args, uint32_t nargs)
static value_t fl_os_setenv(value_t *args, uint32_t nargs) static value_t fl_os_setenv(value_t *args, uint32_t nargs)
{ {
argcount("os.setenv", nargs, 2); char *name;
char *name = tostring(args[0], "os.setenv"); char *val;
int result; int result;
argcount("os.setenv", nargs, 2);
name = tostring(args[0], "os.setenv");
if (args[1] == FL_F) { if (args[1] == FL_F) {
result = unsetenv(name); unsetenv(name);
} else { } else {
char *val = tostring(args[1], "os.setenv"); val = tostring(args[1], "os.setenv");
result = setenv(name, val, 1); result = setenv(name, val, 1);
if (result != 0) {
lerror(ArgError, "os.setenv: invalid environment variable");
}
} }
if (result != 0)
lerror(ArgError, "os.setenv: invalid environment variable");
return FL_T; return FL_T;
} }
static value_t fl_rand(value_t *args, uint32_t nargs) static value_t fl_rand(value_t *args, uint32_t nargs)
{ {
fixnum_t r;
(void)args; (void)args;
(void)nargs; (void)nargs;
fixnum_t r;
#ifdef BITS64 #ifdef BITS64
r = ((((uint64_t)random()) << 32) | random()) & 0x1fffffffffffffffLL; r = ((((uint64_t)random()) << 32) | random()) & 0x1fffffffffffffffLL;
#else #else
@ -392,30 +430,38 @@ static value_t fl_rand(value_t *args, uint32_t nargs)
#endif #endif
return fixnum(r); return fixnum(r);
} }
static value_t fl_rand32(value_t *args, uint32_t nargs) static value_t fl_rand32(value_t *args, uint32_t nargs)
{ {
uint32_t r;
(void)args; (void)args;
(void)nargs; (void)nargs;
uint32_t r = random(); r = random();
#ifdef BITS64 #ifdef BITS64
return fixnum(r); return fixnum(r);
#else #else
return mk_uint32(r); return mk_uint32(r);
#endif #endif
} }
static value_t fl_rand64(value_t *args, uint32_t nargs) static value_t fl_rand64(value_t *args, uint32_t nargs)
{ {
uint64_t r;
(void)args; (void)args;
(void)nargs; (void)nargs;
uint64_t r = (((uint64_t)random()) << 32) | random(); r = (((uint64_t)random()) << 32) | random();
return mk_uint64(r); return mk_uint64(r);
} }
static value_t fl_randd(value_t *args, uint32_t nargs) static value_t fl_randd(value_t *args, uint32_t nargs)
{ {
(void)args; (void)args;
(void)nargs; (void)nargs;
return mk_double(rand_double()); return mk_double(rand_double());
} }
static value_t fl_randf(value_t *args, uint32_t nargs) static value_t fl_randf(value_t *args, uint32_t nargs)
{ {
(void)args; (void)args;
@ -423,17 +469,19 @@ static value_t fl_randf(value_t *args, uint32_t nargs)
return mk_float(rand_float()); return mk_float(rand_float());
} }
#define MATH_FUNC_1ARG(name) \ #define MATH_FUNC_1ARG(name) \
static value_t fl_##name(value_t *args, uint32_t nargs) \ static value_t fl_##name(value_t *args, uint32_t nargs) \
{ \ { \
argcount(#name, nargs, 1); \ argcount(#name, nargs, 1); \
if (iscprim(args[0])) { \ if (iscprim(args[0])) { \
struct cprim *cp = (struct cprim *)ptr(args[0]); \ struct cprim *cp = (struct cprim *)ptr(args[0]); \
numerictype_t nt = cp_numtype(cp); \ numerictype_t nt = cp_numtype(cp); \
if (nt == T_FLOAT) \ if (nt == T_FLOAT) { \
return mk_float(name##f(*(float *)cp_data(cp))); \ float f = *(float *)cp_data(cp); \
} \ return mk_float(name((double)f)); \
return mk_double(name(todouble(args[0], #name))); \ } \
} \
return mk_double(name(todouble(args[0], #name))); \
} }
MATH_FUNC_1ARG(sqrt) MATH_FUNC_1ARG(sqrt)

156
c/cvalues.h
View File

@ -119,10 +119,11 @@ void cv_autorelease(struct cvalue *cv) { autorelease(cv); }
static value_t cprim(struct fltype *type, size_t sz) static value_t cprim(struct fltype *type, size_t sz)
{ {
struct cprim *pcp;
assert(!ismanaged((uintptr_t)type)); assert(!ismanaged((uintptr_t)type));
assert(sz == type->size); assert(sz == type->size);
struct cprim *pcp = pcp = (struct cprim *)alloc_words(CPRIM_NWORDS - 1 + NWORDS(sz));
(struct cprim *)alloc_words(CPRIM_NWORDS - 1 + NWORDS(sz));
pcp->type = type; pcp->type = type;
return tagptr(pcp, TAG_CPRIM); return tagptr(pcp, TAG_CPRIM);
} }
@ -130,8 +131,9 @@ static value_t cprim(struct fltype *type, size_t sz)
value_t cvalue(struct fltype *type, size_t sz) value_t cvalue(struct fltype *type, size_t sz)
{ {
struct cvalue *pcv; struct cvalue *pcv;
int str = 0; int str;
str = 0;
if (valid_numtype(type->numtype)) { if (valid_numtype(type->numtype)) {
return cprim(type, sz); return cprim(type, sz);
} }
@ -168,6 +170,7 @@ value_t cvalue(struct fltype *type, size_t sz)
value_t cvalue_from_data(struct fltype *type, void *data, size_t sz) value_t cvalue_from_data(struct fltype *type, void *data, size_t sz)
{ {
value_t cv; value_t cv;
cv = cvalue(type, sz); cv = cvalue(type, sz);
memcpy(cptr(cv), data, sz); memcpy(cptr(cv), data, sz);
return cv; return cv;
@ -208,7 +211,9 @@ value_t cvalue_static_cstring(const char *str)
value_t string_from_cstrn(const char *str, size_t n) value_t string_from_cstrn(const char *str, size_t n)
{ {
value_t v = cvalue_string(n); value_t v;
v = cvalue_string(n);
memcpy(cvalue_data(v), str, n); memcpy(cvalue_data(v), str, n);
return v; return v;
} }
@ -226,12 +231,15 @@ int fl_isstring(value_t v)
// convert to malloc representation (fixed address) // convert to malloc representation (fixed address)
void cv_pin(struct cvalue *cv) void cv_pin(struct cvalue *cv)
{ {
size_t sz;
void *data;
if (!isinlined(cv)) if (!isinlined(cv))
return; return;
size_t sz = cv_len(cv); sz = cv_len(cv);
if (cv_isstr(cv)) if (cv_isstr(cv))
sz++; sz++;
void *data = malloc(sz); data = malloc(sz);
memcpy(data, cv_data(cv), sz); memcpy(data, cv_data(cv), sz);
cv->data = data; cv->data = data;
autorelease(cv); autorelease(cv);
@ -264,11 +272,12 @@ num_init(float, double, T_FLOAT) num_init(double, double, T_DOUBLE)
#define num_ctor_init(typenam, ctype, tag) \ #define num_ctor_init(typenam, ctype, tag) \
value_t cvalue_##typenam(value_t *args, uint32_t nargs) \ value_t cvalue_##typenam(value_t *args, uint32_t nargs) \
{ \ { \
value_t cp; \
if (nargs == 0) { \ if (nargs == 0) { \
PUSH(fixnum(0)); \ PUSH(fixnum(0)); \
args = &Stack[SP - 1]; \ args = &Stack[SP - 1]; \
} \ } \
value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \ cp = cprim(typenam##type, sizeof(ctype##_t)); \
if (cvalue_##ctype##_init(typenam##type, args[0], \ if (cvalue_##ctype##_init(typenam##type, args[0], \
cp_data((struct cprim *)ptr(cp)))) \ cp_data((struct cprim *)ptr(cp)))) \
type_error(#typenam, "number", args[0]); \ type_error(#typenam, "number", args[0]); \
@ -352,10 +361,13 @@ static int cvalue_enum_init(struct fltype *ft, value_t arg, void *dest)
value_t cvalue_enum(value_t *args, uint32_t nargs) value_t cvalue_enum(value_t *args, uint32_t nargs)
{ {
value_t cv, type;
struct fltype *ft;
argcount("enum", nargs, 2); argcount("enum", nargs, 2);
value_t type = fl_list2(enumsym, args[0]); type = fl_list2(enumsym, args[0]);
struct fltype *ft = get_type(type); ft = get_type(type);
value_t cv = cvalue(ft, sizeof(int32_t)); cv = cvalue(ft, sizeof(int32_t));
cvalue_enum_init(ft, args[1], cp_data((struct cprim *)ptr(cv))); cvalue_enum_init(ft, args[1], cp_data((struct cprim *)ptr(cv)));
return cv; return cv;
} }
@ -443,18 +455,20 @@ static int cvalue_array_init(struct fltype *ft, value_t arg, void *dest)
value_t cvalue_array(value_t *args, uint32_t nargs) value_t cvalue_array(value_t *args, uint32_t nargs)
{ {
size_t elsize, cnt, sz, i; size_t elsize, cnt, sz, i;
value_t arg; value_t arg, cv;
struct fltype *type;
char *dest;
if (nargs < 1) if (nargs < 1)
argcount("array", nargs, 1); argcount("array", nargs, 1);
cnt = nargs - 1; cnt = nargs - 1;
struct fltype *type = get_array_type(args[0]); type = get_array_type(args[0]);
elsize = type->elsz; elsize = type->elsz;
sz = elsize * cnt; sz = elsize * cnt;
value_t cv = cvalue(type, sz); cv = cvalue(type, sz);
char *dest = cv_data((struct cvalue *)ptr(cv)); dest = cv_data((struct cvalue *)ptr(cv));
FOR_ARGS(i, 1, arg, args) FOR_ARGS(i, 1, arg, args)
{ {
cvalue_init(type->eltype, arg, dest); cvalue_init(type->eltype, arg, dest);
@ -476,8 +490,8 @@ static size_t cvalue_struct_offs(value_t type, value_t field,
value_t fld = car(cdr_(type)); value_t fld = car(cdr_(type));
size_t fsz, ssz = 0; size_t fsz, ssz = 0;
int al; int al;
*palign = 0;
*palign = 0;
while (iscons(fld)) { while (iscons(fld)) {
fsz = ctype_sizeof(car(cdr(car_(fld))), &al); fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
@ -501,8 +515,8 @@ static size_t cvalue_union_size(value_t type, int *palign)
value_t fld = car(cdr_(type)); value_t fld = car(cdr_(type));
size_t fsz, usz = 0; size_t fsz, usz = 0;
int al; int al;
*palign = 0;
*palign = 0;
while (iscons(fld)) { while (iscons(fld)) {
fsz = ctype_sizeof(car(cdr(car_(fld))), &al); fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
if (al > *palign) if (al > *palign)
@ -517,6 +531,9 @@ static size_t cvalue_union_size(value_t type, int *palign)
// *palign is an output argument giving the alignment required by type // *palign is an output argument giving the alignment required by type
size_t ctype_sizeof(value_t type, int *palign) size_t ctype_sizeof(value_t type, int *palign)
{ {
value_t hed, t, n;
size_t sz;
if (type == int8sym || type == uint8sym || type == bytesym) { if (type == int8sym || type == uint8sym || type == bytesym) {
*palign = 1; *palign = 1;
return 1; return 1;
@ -544,17 +561,17 @@ size_t ctype_sizeof(value_t type, int *palign)
#endif #endif
} }
if (iscons(type)) { if (iscons(type)) {
value_t hed = car_(type); hed = car_(type);
if (hed == pointersym || hed == cfunctionsym) { if (hed == pointersym || hed == cfunctionsym) {
*palign = ALIGNPTR; *palign = ALIGNPTR;
return sizeof(void *); return sizeof(void *);
} }
if (hed == arraysym) { if (hed == arraysym) {
value_t t = car(cdr_(type)); t = car(cdr_(type));
if (!iscons(cdr_(cdr_(type)))) if (!iscons(cdr_(cdr_(type))))
lerror(ArgError, "sizeof: incomplete type"); lerror(ArgError, "sizeof: incomplete type");
value_t n = car_(cdr_(cdr_(type))); n = car_(cdr_(cdr_(type)));
size_t sz = toulong(n, "sizeof"); sz = toulong(n, "sizeof");
return sz * ctype_sizeof(t, palign); return sz * ctype_sizeof(t, palign);
} else if (hed == structsym) { } else if (hed == structsym) {
return cvalue_struct_offs(type, NIL, 1, palign); return cvalue_struct_offs(type, NIL, 1, palign);
@ -597,13 +614,14 @@ void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz)
value_t cvalue_sizeof(value_t *args, uint32_t nargs) value_t cvalue_sizeof(value_t *args, uint32_t nargs)
{ {
char *data;
size_t n;
int a;
argcount("sizeof", nargs, 1); argcount("sizeof", nargs, 1);
if (issymbol(args[0]) || iscons(args[0])) { if (issymbol(args[0]) || iscons(args[0])) {
int a;
return size_wrap(ctype_sizeof(args[0], &a)); return size_wrap(ctype_sizeof(args[0], &a));
} }
size_t n;
char *data;
to_sized_ptr(args[0], "sizeof", &data, &n); to_sized_ptr(args[0], "sizeof", &data, &n);
return size_wrap(n); return size_wrap(n);
} }
@ -637,10 +655,11 @@ value_t cvalue_typeof(value_t *args, uint32_t nargs)
static value_t cvalue_relocate(value_t v) static value_t cvalue_relocate(value_t v)
{ {
size_t nw;
struct cvalue *cv = (struct cvalue *)ptr(v); struct cvalue *cv = (struct cvalue *)ptr(v);
struct cvalue *nv; struct cvalue *nv;
struct fltype *t;
value_t ncv; value_t ncv;
size_t nw;
nw = cv_nwords(cv); nw = cv_nwords(cv);
nv = (struct cvalue *)alloc_words(nw); nv = (struct cvalue *)alloc_words(nw);
@ -648,7 +667,7 @@ static value_t cvalue_relocate(value_t v)
if (isinlined(cv)) if (isinlined(cv))
nv->data = &nv->_space[0]; nv->data = &nv->_space[0];
ncv = tagptr(nv, TAG_CVALUE); ncv = tagptr(nv, TAG_CVALUE);
struct fltype *t = cv_class(cv); t = cv_class(cv);
if (t->vtable != NULL && t->vtable->relocate != NULL) if (t->vtable != NULL && t->vtable->relocate != NULL)
t->vtable->relocate(v, ncv); t->vtable->relocate(v, ncv);
forward(v, ncv); forward(v, ncv);
@ -657,16 +676,20 @@ static value_t cvalue_relocate(value_t v)
value_t cvalue_copy(value_t v) value_t cvalue_copy(value_t v)
{ {
struct cvalue *ncv;
struct cvalue *cv;
size_t nw, len;
assert(iscvalue(v)); assert(iscvalue(v));
PUSH(v); PUSH(v);
struct cvalue *cv = (struct cvalue *)ptr(v); cv = (struct cvalue *)ptr(v);
size_t nw = cv_nwords(cv); nw = cv_nwords(cv);
struct cvalue *ncv = (struct cvalue *)alloc_words(nw); ncv = (struct cvalue *)alloc_words(nw);
v = POP(); v = POP();
cv = (struct cvalue *)ptr(v); cv = (struct cvalue *)ptr(v);
memcpy(ncv, cv, nw * sizeof(value_t)); memcpy(ncv, cv, nw * sizeof(value_t));
if (!isinlined(cv)) { if (!isinlined(cv)) {
size_t len = cv_len(cv); len = cv_len(cv);
if (cv_isstr(cv)) if (cv_isstr(cv))
len++; len++;
ncv->data = malloc(len); ncv->data = malloc(len);
@ -762,16 +785,17 @@ static numerictype_t sym_to_numtype(value_t type)
// type, including user-defined. // type, including user-defined.
value_t cvalue_new(value_t *args, uint32_t nargs) value_t cvalue_new(value_t *args, uint32_t nargs)
{ {
struct fltype *ft;
value_t cv, type;
size_t elsz, cnt;
if (nargs < 1 || nargs > 2) if (nargs < 1 || nargs > 2)
argcount("c-value", nargs, 2); argcount("c-value", nargs, 2);
value_t type = args[0]; type = args[0];
struct fltype *ft = get_type(type); ft = get_type(type);
value_t cv;
if (ft->eltype != NULL) { if (ft->eltype != NULL) {
// special case to handle incomplete array types bla[] // special case to handle incomplete array types bla[]
size_t elsz = ft->elsz; elsz = ft->elsz;
size_t cnt;
if (iscons(cdr_(cdr_(type)))) if (iscons(cdr_(cdr_(type))))
cnt = toulong(car_(cdr_(cdr_(type))), "array"); cnt = toulong(car_(cdr_(cdr_(type))), "array");
else if (nargs == 2) else if (nargs == 2)
@ -800,6 +824,7 @@ value_t cvalue_compare(value_t a, value_t b)
size_t bsz = cv_len(cb); size_t bsz = cv_len(cb);
size_t minsz = asz < bsz ? asz : bsz; size_t minsz = asz < bsz ? asz : bsz;
int diff = memcmp(adata, bdata, minsz); int diff = memcmp(adata, bdata, minsz);
if (diff == 0) { if (diff == 0) {
if (asz > bsz) if (asz > bsz)
return fixnum(1); return fixnum(1);
@ -813,7 +838,9 @@ static void check_addr_args(char *fname, value_t arr, value_t ind,
char **data, unsigned long *index) char **data, unsigned long *index)
{ {
size_t numel; size_t numel;
struct cvalue *cv = (struct cvalue *)ptr(arr); struct cvalue *cv;
cv = (struct cvalue *)ptr(arr);
*data = cv_data(cv); *data = cv_data(cv);
numel = cv_len(cv) / (cv_class(cv)->elsz); numel = cv_len(cv) / (cv_class(cv)->elsz);
*index = toulong(ind, fname); *index = toulong(ind, fname);
@ -828,6 +855,9 @@ static value_t cvalue_array_aref(value_t *args)
struct fltype *eltype = cv_class((struct cvalue *)ptr(args[0]))->eltype; struct fltype *eltype = cv_class((struct cvalue *)ptr(args[0]))->eltype;
value_t el = 0; value_t el = 0;
numerictype_t nt = eltype->numtype; numerictype_t nt = eltype->numtype;
char *dest;
size_t sz;
if (nt >= T_INT32) if (nt >= T_INT32)
el = cvalue(eltype, eltype->size); el = cvalue(eltype, eltype->size);
check_addr_args("aref", args[0], args[1], &data, &index); check_addr_args("aref", args[0], args[1], &data, &index);
@ -840,8 +870,8 @@ static value_t cvalue_array_aref(value_t *args)
return fixnum(((int16_t *)data)[index]); return fixnum(((int16_t *)data)[index]);
return fixnum(((uint16_t *)data)[index]); return fixnum(((uint16_t *)data)[index]);
} }
char *dest = cptr(el); dest = cptr(el);
size_t sz = eltype->size; sz = eltype->size;
if (sz == 1) if (sz == 1)
*dest = data[index]; *dest = data[index];
else if (sz == 2) else if (sz == 2)
@ -858,19 +888,24 @@ static value_t cvalue_array_aref(value_t *args)
static value_t cvalue_array_aset(value_t *args) static value_t cvalue_array_aset(value_t *args)
{ {
char *data; char *data;
char *dest;
unsigned long index; unsigned long index;
struct fltype *eltype = cv_class((struct cvalue *)ptr(args[0]))->eltype; struct fltype *eltype;
eltype = cv_class((struct cvalue *)ptr(args[0]))->eltype;
check_addr_args("aset!", args[0], args[1], &data, &index); check_addr_args("aset!", args[0], args[1], &data, &index);
char *dest = data + index * eltype->size; dest = data + index * eltype->size;
cvalue_init(eltype, args[2], dest); cvalue_init(eltype, args[2], dest);
return args[2]; return args[2];
} }
value_t fl_builtin(value_t *args, uint32_t nargs) value_t fl_builtin(value_t *args, uint32_t nargs)
{ {
argcount("builtin", nargs, 1); struct symbol *name;
struct symbol *name = tosymbol(args[0], "builtin");
struct cvalue *cv; struct cvalue *cv;
argcount("builtin", nargs, 1);
name = tosymbol(args[0], "builtin");
if (ismanaged(args[0]) || (cv = name->dlcache) == NULL) { if (ismanaged(args[0]) || (cv = name->dlcache) == NULL) {
lerrorf(ArgError, "builtin: function %s not found", name->name); lerrorf(ArgError, "builtin: function %s not found", name->name);
} }
@ -879,17 +914,17 @@ value_t fl_builtin(value_t *args, uint32_t nargs)
value_t cbuiltin(char *name, builtin_t f) value_t cbuiltin(char *name, builtin_t f)
{ {
struct cvalue *cv = struct cvalue *cv;
(struct cvalue *)malloc(CVALUE_NWORDS * sizeof(value_t)); value_t sym;
cv = (struct cvalue *)malloc(CVALUE_NWORDS * sizeof(value_t));
cv->type = builtintype; cv->type = builtintype;
cv->data = &cv->_space[0]; cv->data = &cv->_space[0];
cv->len = sizeof(value_t); cv->len = sizeof(value_t);
*(void **)cv->data = f; *(void **)cv->data = f;
sym = symbol(name);
value_t sym = symbol(name);
((struct symbol *)ptr(sym))->dlcache = cv; ((struct symbol *)ptr(sym))->dlcache = cv;
ptrhash_put(&reverse_dlsym_lookup_table, cv, (void *)sym); ptrhash_put(&reverse_dlsym_lookup_table, cv, (void *)sym);
return tagptr(cv, TAG_CVALUE); return tagptr(cv, TAG_CVALUE);
} }
@ -1183,6 +1218,7 @@ static value_t fl_neg(value_t n)
} }
} }
type_error("-", "number", n); type_error("-", "number", n);
return FL_NIL; // TODO: remove
} }
static value_t fl_mul_any(value_t *args, uint32_t nargs, int64_t Saccum) static value_t fl_mul_any(value_t *args, uint32_t nargs, int64_t Saccum)
@ -1555,14 +1591,15 @@ static value_t fl_logxor(value_t *args, uint32_t nargs)
static value_t fl_lognot(value_t *args, uint32_t nargs) static value_t fl_lognot(value_t *args, uint32_t nargs)
{ {
struct cprim *cp;
void *aptr;
value_t a;
int ta;
argcount("lognot", nargs, 1); argcount("lognot", nargs, 1);
value_t a = args[0]; a = args[0];
if (isfixnum(a)) if (isfixnum(a))
return fixnum(~numval(a)); return fixnum(~numval(a));
struct cprim *cp;
int ta;
void *aptr;
if (iscprim(a)) { if (iscprim(a)) {
cp = (struct cprim *)ptr(a); cp = (struct cprim *)ptr(a);
ta = cp_numtype(cp); ta = cp_numtype(cp);
@ -1587,14 +1624,20 @@ static value_t fl_lognot(value_t *args, uint32_t nargs)
} }
} }
type_error("lognot", "integer", a); type_error("lognot", "integer", a);
return FL_NIL; // TODO: remove
} }
static value_t fl_ash(value_t *args, uint32_t nargs) static value_t fl_ash(value_t *args, uint32_t nargs)
{ {
int64_t accum, i64;
value_t a;
fixnum_t n; fixnum_t n;
int64_t accum; struct cprim *cp;
void *aptr;
int ta;
argcount("ash", nargs, 2); argcount("ash", nargs, 2);
value_t a = args[0]; a = args[0];
n = tofixnum(args[1], "ash"); n = tofixnum(args[1], "ash");
if (isfixnum(a)) { if (isfixnum(a)) {
if (n <= 0) if (n <= 0)
@ -1605,9 +1648,6 @@ static value_t fl_ash(value_t *args, uint32_t nargs)
else else
return return_from_int64(accum); return return_from_int64(accum);
} }
struct cprim *cp;
int ta;
void *aptr;
if (iscprim(a)) { if (iscprim(a)) {
if (n == 0) if (n == 0)
return a; return a;
@ -1638,7 +1678,7 @@ static value_t fl_ash(value_t *args, uint32_t nargs)
if (ta == T_UINT64) if (ta == T_UINT64)
return return_from_uint64((*(uint64_t *)aptr) << n); return return_from_uint64((*(uint64_t *)aptr) << n);
else if (ta < T_FLOAT) { else if (ta < T_FLOAT) {
int64_t i64 = conv_to_int64(aptr, ta); i64 = conv_to_int64(aptr, ta);
return return_from_int64(i64 << n); return return_from_int64(i64 << n);
} }
} }

23
c/equal.h
View File

@ -54,15 +54,15 @@ static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
static value_t bounded_compare(value_t a, value_t b, int bound, int eq) static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
{ {
value_t d; value_t d;
int taga, tagb, c;
compare_top: compare_top:
if (a == b) if (a == b)
return fixnum(0); return fixnum(0);
if (bound <= 0) if (bound <= 0)
return NIL; return NIL;
int taga = tag(a); taga = tag(a);
int tagb = cmptag(b); tagb = cmptag(b);
int c;
switch (taga) { switch (taga) {
case TAG_NUM: case TAG_NUM:
case TAG_NUM1: case TAG_NUM1:
@ -143,10 +143,11 @@ compare_top:
static value_t cyc_vector_compare(value_t a, value_t b, struct htable *table, static value_t cyc_vector_compare(value_t a, value_t b, struct htable *table,
int eq) int eq)
{ {
size_t la = vector_size(a);
size_t lb = vector_size(b);
size_t m, i;
value_t d, xa, xb, ca, cb; value_t d, xa, xb, ca, cb;
size_t m, i, la, lb;
la = vector_size(a);
lb = vector_size(b);
// first try to prove them different with no recursion // first try to prove them different with no recursion
if (eq && (la != lb)) if (eq && (la != lb))
@ -193,6 +194,7 @@ static value_t cyc_vector_compare(value_t a, value_t b, struct htable *table,
static value_t cyc_compare(value_t a, value_t b, struct htable *table, int eq) static value_t cyc_compare(value_t a, value_t b, struct htable *table, int eq)
{ {
value_t d, ca, cb; value_t d, ca, cb;
cyc_compare_top: cyc_compare_top:
if (a == b) if (a == b)
return fixnum(0); return fixnum(0);
@ -305,7 +307,6 @@ value_t fl_equal(value_t a, value_t b)
// *oob: output argument, means we hit the limit specified by 'bound' // *oob: output argument, means we hit the limit specified by 'bound'
static uintptr_t bounded_hash(value_t a, int bound, int *oob) static uintptr_t bounded_hash(value_t a, int bound, int *oob)
{ {
*oob = 0;
union { union {
double d; double d;
int64_t i64; int64_t i64;
@ -315,8 +316,12 @@ static uintptr_t bounded_hash(value_t a, int bound, int *oob)
struct cvalue *cv; struct cvalue *cv;
struct cprim *cp; struct cprim *cp;
void *data; void *data;
uintptr_t h = 0; uintptr_t h;
int oob2, tg = tag(a); int oob2, tg;
*oob = 0;
h = 0;
tg = tag(a);
switch (tg) { switch (tg) {
case TAG_NUM: case TAG_NUM:
case TAG_NUM1: case TAG_NUM1:

249
c/flisp.c
View File

@ -189,6 +189,8 @@ void fl_restorestate(struct fl_exception_context *_ctx)
void fl_raise(value_t e) void fl_raise(value_t e)
{ {
struct fl_exception_context *thisctx;
fl_lasterror = e; fl_lasterror = e;
// unwind read state // unwind read state
while (readstate != fl_ctx->rdst) { while (readstate != fl_ctx->rdst) {
@ -198,7 +200,7 @@ void fl_raise(value_t e)
if (fl_throwing_frame == 0) if (fl_throwing_frame == 0)
fl_throwing_frame = curr_frame; fl_throwing_frame = curr_frame;
N_GCHND = fl_ctx->ngchnd; N_GCHND = fl_ctx->ngchnd;
struct fl_exception_context *thisctx = fl_ctx; thisctx = fl_ctx;
if (fl_ctx->prev) // don't throw past toplevel if (fl_ctx->prev) // don't throw past toplevel
fl_ctx = fl_ctx->prev; fl_ctx = fl_ctx->prev;
longjmp(thisctx->buf, 1); longjmp(thisctx->buf, 1);
@ -207,6 +209,7 @@ void fl_raise(value_t e)
static value_t make_error_msg(char *format, va_list args) static value_t make_error_msg(char *format, va_list args)
{ {
char msgbuf[512]; char msgbuf[512];
vsnprintf(msgbuf, sizeof(msgbuf), format, args); vsnprintf(msgbuf, sizeof(msgbuf), format, args);
return string_from_cstr(msgbuf); return string_from_cstr(msgbuf);
} }
@ -214,19 +217,22 @@ static value_t make_error_msg(char *format, va_list args)
void lerrorf(value_t e, char *format, ...) void lerrorf(value_t e, char *format, ...)
{ {
va_list args; va_list args;
value_t msg;
PUSH(e); PUSH(e);
va_start(args, format); va_start(args, format);
value_t msg = make_error_msg(format, args); msg = make_error_msg(format, args);
va_end(args); va_end(args);
e = POP(); e = POP();
fl_raise(fl_list2(e, msg)); fl_raise(fl_list2(e, msg));
} }
void lerror(value_t e, const char *msg) void lerror(value_t e, const char *msg)
{ {
value_t m;
PUSH(e); PUSH(e);
value_t m = cvalue_static_cstring(msg); m = cvalue_static_cstring(msg);
e = POP(); e = POP();
fl_raise(fl_list2(e, m)); fl_raise(fl_list2(e, m));
} }
@ -245,12 +251,14 @@ void bounds_error(char *fname, value_t arr, value_t ind)
// -------------------------------------------------------- // --------------------------------------------------------
#define isstring fl_isstring #define isstring fl_isstring
// TODO: Remove the spurious return statement.
#define SAFECAST_OP(type, ctype, cnvt) \ #define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(value_t v, char *fname) \ ctype to##type(value_t v, char *fname) \
{ \ { \
if (is##type(v)) \ if (is##type(v)) \
return (ctype)cnvt(v); \ return (ctype)cnvt(v); \
type_error(fname, #type, v); \ type_error(fname, #type, v); \
return (ctype)FL_NIL; \
} }
SAFECAST_OP(cons, struct cons *, ptr) SAFECAST_OP(cons, struct cons *, ptr)
SAFECAST_OP(symbol, struct symbol *, ptr) SAFECAST_OP(symbol, struct symbol *, ptr)
@ -325,10 +333,11 @@ static char gsname[2][16];
static int gsnameno = 0; static int gsnameno = 0;
value_t fl_gensym(value_t *args, uint32_t nargs) value_t fl_gensym(value_t *args, uint32_t nargs)
{ {
argcount("gensym", nargs, 0); struct gensym *gs;
(void)args; (void)args;
struct gensym *gs = argcount("gensym", nargs, 0);
(struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *)); gs = (struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
gs->id = _gensym_ctr++; gs->id = _gensym_ctr++;
gs->binding = UNBOUND; gs->binding = UNBOUND;
gs->isconst = 0; gs->isconst = 0;
@ -346,11 +355,13 @@ static value_t fl_gensymp(value_t *args, uint32_t nargs)
char *symbol_name(value_t v) char *symbol_name(value_t v)
{ {
struct gensym *gs;
char *n;
if (ismanaged(v)) { if (ismanaged(v)) {
struct gensym *gs = (struct gensym *)ptr(v); gs = (struct gensym *)ptr(v);
gsnameno = 1 - gsnameno; gsnameno = 1 - gsnameno;
char *n = n = uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
*(--n) = 'g'; *(--n) = 'g';
return n; return n;
} }
@ -402,13 +413,16 @@ static value_t the_empty_vector;
value_t alloc_vector(size_t n, int init) value_t alloc_vector(size_t n, int init)
{ {
value_t *c;
value_t v;
unsigned int i;
if (n == 0) if (n == 0)
return the_empty_vector; return the_empty_vector;
value_t *c = alloc_words(n + 1); c = alloc_words(n + 1);
value_t v = tagptr(c, TAG_VECTOR); v = tagptr(c, TAG_VECTOR);
vector_setsize(v, n); vector_setsize(v, n);
if (init) { if (init) {
unsigned int i;
for (i = 0; i < n; i++) for (i = 0; i < n; i++)
vector_elt(v, i) = FL_UNSPECIFIED; vector_elt(v, i) = FL_UNSPECIFIED;
} }
@ -451,8 +465,9 @@ void fl_free_gc_handles(uint32_t n)
static value_t relocate(value_t v) static value_t relocate(value_t v)
{ {
value_t a, d, nc, first, *pcdr; value_t a, d, nc, first, *pcdr;
uintptr_t t = tag(v); uintptr_t t;
t = tag(v);
if (t == TAG_CONS) { if (t == TAG_CONS) {
// iterative implementation allows arbitrarily long cons chains // iterative implementation allows arbitrarily long cons chains
pcdr = &first; pcdr = &first;
@ -694,9 +709,10 @@ value_t fl_apply(value_t f, value_t l)
value_t fl_applyn(uint32_t n, value_t f, ...) value_t fl_applyn(uint32_t n, value_t f, ...)
{ {
va_list ap; va_list ap;
va_start(ap, f); value_t v;
size_t i; size_t i;
va_start(ap, f);
PUSH(f); PUSH(f);
while (SP + n > N_STACK) while (SP + n > N_STACK)
grow_stack(); grow_stack();
@ -704,7 +720,7 @@ value_t fl_applyn(uint32_t n, value_t f, ...)
value_t a = va_arg(ap, value_t); value_t a = va_arg(ap, value_t);
PUSH(a); PUSH(a);
} }
value_t v = _applyn(n); v = _applyn(n);
POPN(n + 1); POPN(n + 1);
va_end(ap); va_end(ap);
return v; return v;
@ -712,19 +728,22 @@ value_t fl_applyn(uint32_t n, value_t f, ...)
value_t fl_listn(size_t n, ...) value_t fl_listn(size_t n, ...)
{ {
struct cons *c;
struct cons *l;
va_list ap; va_list ap;
va_start(ap, n); uint32_t si;
uint32_t si = SP;
size_t i; size_t i;
si = SP;
va_start(ap, n);
while (SP + n > N_STACK) while (SP + n > N_STACK)
grow_stack(); grow_stack();
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
value_t a = va_arg(ap, value_t); value_t a = va_arg(ap, value_t);
PUSH(a); PUSH(a);
} }
struct cons *c = (struct cons *)alloc_words(n * 2); c = (struct cons *)alloc_words(n * 2);
struct cons *l = c; l = c;
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
c->car = Stack[si++]; c->car = Stack[si++];
c->cdr = tagptr(c + 1, TAG_CONS); c->cdr = tagptr(c + 1, TAG_CONS);
@ -739,9 +758,11 @@ value_t fl_listn(size_t n, ...)
value_t fl_list2(value_t a, value_t b) value_t fl_list2(value_t a, value_t b)
{ {
struct cons *c;
PUSH(a); PUSH(a);
PUSH(b); PUSH(b);
struct cons *c = (struct cons *)alloc_words(4); c = (struct cons *)alloc_words(4);
b = POP(); b = POP();
a = POP(); a = POP();
c[0].car = a; c[0].car = a;
@ -753,9 +774,11 @@ value_t fl_list2(value_t a, value_t b)
value_t fl_cons(value_t a, value_t b) value_t fl_cons(value_t a, value_t b)
{ {
value_t c;
PUSH(a); PUSH(a);
PUSH(b); PUSH(b);
value_t c = mk_cons(); c = mk_cons();
cdr_(c) = POP(); cdr_(c) = POP();
car_(c) = POP(); car_(c) = POP();
return c; return c;
@ -763,10 +786,12 @@ value_t fl_cons(value_t a, value_t b)
int fl_isnumber(value_t v) int fl_isnumber(value_t v)
{ {
struct cprim *c;
if (isfixnum(v)) if (isfixnum(v))
return 1; return 1;
if (iscprim(v)) { if (iscprim(v)) {
struct cprim *c = (struct cprim *)ptr(v); c = (struct cprim *)ptr(v);
return c->type != wchartype; return c->type != wchartype;
} }
return 0; return 0;
@ -792,6 +817,7 @@ static value_t _list(value_t *args, uint32_t nargs, int star)
struct cons *c; struct cons *c;
uint32_t i; uint32_t i;
value_t v; value_t v;
v = cons_reserve(nargs); v = cons_reserve(nargs);
c = (struct cons *)ptr(v); c = (struct cons *)ptr(v);
for (i = 0; i < nargs; i++) { for (i = 0; i < nargs; i++) {
@ -808,13 +834,16 @@ static value_t _list(value_t *args, uint32_t nargs, int star)
static value_t copy_list(value_t L) static value_t copy_list(value_t L)
{ {
value_t *plcons;
value_t *pL;
value_t c;
if (!iscons(L)) if (!iscons(L))
return NIL; return NIL;
PUSH(NIL); PUSH(NIL);
PUSH(L); PUSH(L);
value_t *plcons = &Stack[SP - 2]; plcons = &Stack[SP - 2];
value_t *pL = &Stack[SP - 1]; pL = &Stack[SP - 1];
value_t c;
c = mk_cons(); c = mk_cons();
PUSH(c); // save first cons PUSH(c); // save first cons
car_(c) = car_(*pL); car_(c) = car_(*pL);
@ -836,19 +865,22 @@ static value_t copy_list(value_t L)
static value_t do_trycatch(void) static value_t do_trycatch(void)
{ {
uint32_t saveSP = SP; value_t v, thunk;
value_t v; uint32_t saveSP;
value_t thunk = Stack[SP - 2];
saveSP = SP;
thunk = Stack[SP - 2];
Stack[SP - 2] = Stack[SP - 1]; Stack[SP - 2] = Stack[SP - 1];
Stack[SP - 1] = thunk; Stack[SP - 1] = thunk;
FL_TRY { v = apply_cl(0); }
FL_CATCH
{ {
v = Stack[saveSP - 2]; FL_TRY { v = apply_cl(0); }
PUSH(v); FL_CATCH
PUSH(fl_lasterror); {
v = apply_cl(1); v = Stack[saveSP - 2];
PUSH(v);
PUSH(fl_lasterror);
v = apply_cl(1);
}
} }
SP = saveSP; SP = saveSP;
return v; return v;
@ -862,14 +894,27 @@ static uint32_t process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw,
uint32_t nopt, uint32_t bp, uint32_t nargs, uint32_t nopt, uint32_t bp, uint32_t nargs,
int va) int va)
{ {
uint32_t extr = nopt + nkw; value_t hv;
uint32_t ntot = nreq + extr; uintptr_t x;
value_t args[extr], v; uintptr_t idx;
uint32_t i, a = 0, nrestargs; uintptr_t n;
value_t s1 = Stack[SP - 1]; uint32_t ntot;
value_t s2 = Stack[SP - 2]; value_t v;
value_t s4 = Stack[SP - 4]; uint32_t extr;
value_t s5 = Stack[SP - 5]; value_t *args;
uint32_t nrestargs, i, a;
value_t s1, s2, s4, s5;
extr = nopt + nkw;
ntot = nreq + extr;
if (!(args = calloc(extr, sizeof(*args)))) {
lerror(MemoryError, "out of memory");
}
a = 0;
s1 = Stack[SP - 1];
s2 = Stack[SP - 2];
s4 = Stack[SP - 4];
s5 = Stack[SP - 5];
if (nargs < nreq) if (nargs < nreq)
lerror(ArgError, "apply: too few arguments"); lerror(ArgError, "apply: too few arguments");
for (i = 0; i < extr; i++) for (i = 0; i < extr; i++)
@ -885,16 +930,16 @@ static uint32_t process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw,
if (i >= nargs) if (i >= nargs)
goto no_kw; goto no_kw;
// now process keywords // now process keywords
uintptr_t n = vector_size(kwtable) / 2; n = vector_size(kwtable) / 2;
do { do {
i++; i++;
if (i >= nargs) if (i >= nargs)
lerrorf(ArgError, "keyword %s requires an argument", lerrorf(ArgError, "keyword %s requires an argument",
symbol_name(v)); symbol_name(v));
value_t hv = fixnum(((struct symbol *)ptr(v))->hash); hv = fixnum(((struct symbol *)ptr(v))->hash);
uintptr_t x = 2 * (labs(numval(hv)) % n); x = 2 * (labs(numval(hv)) % n);
if (vector_elt(kwtable, x) == v) { if (vector_elt(kwtable, x) == v) {
uintptr_t idx = numval(vector_elt(kwtable, x + 1)); idx = numval(vector_elt(kwtable, x + 1));
assert(idx < nkw); assert(idx < nkw);
idx += nopt; idx += nopt;
if (args[idx] == UNBOUND) { if (args[idx] == UNBOUND) {
@ -2305,6 +2350,13 @@ void assign_global_builtins(struct builtinspec *b)
static value_t fl_function(value_t *args, uint32_t nargs) static value_t fl_function(value_t *args, uint32_t nargs)
{ {
struct cvalue *arr;
char *data;
int swap;
uint32_t ms;
struct function *fn;
value_t fv;
if (nargs == 1 && issymbol(args[0])) if (nargs == 1 && issymbol(args[0]))
return fl_builtin(args, nargs); return fl_builtin(args, nargs);
if (nargs < 2 || nargs > 4) if (nargs < 2 || nargs > 4)
@ -2313,10 +2365,10 @@ static value_t fl_function(value_t *args, uint32_t nargs)
type_error("function", "string", args[0]); type_error("function", "string", args[0]);
if (!isvector(args[1])) if (!isvector(args[1]))
type_error("function", "vector", args[1]); type_error("function", "vector", args[1]);
struct cvalue *arr = (struct cvalue *)ptr(args[0]); arr = (struct cvalue *)ptr(args[0]);
cv_pin(arr); cv_pin(arr);
char *data = cv_data(arr); data = cv_data(arr);
int swap = 0; swap = 0;
if ((uint8_t)data[4] >= N_OPCODES) { if ((uint8_t)data[4] >= N_OPCODES) {
// read syntax, shifted 48 for compact text representation // read syntax, shifted 48 for compact text representation
size_t i, sz = cv_len(arr); size_t i, sz = cv_len(arr);
@ -2327,10 +2379,10 @@ static value_t fl_function(value_t *args, uint32_t nargs)
swap = 1; swap = 1;
#endif #endif
} }
uint32_t ms = compute_maxstack((uint8_t *)data, cv_len(arr), swap); ms = compute_maxstack((uint8_t *)data, cv_len(arr), swap);
PUT_INT32(data, ms); PUT_INT32(data, ms);
struct function *fn = (struct function *)alloc_words(4); fn = (struct function *)alloc_words(4);
value_t fv = tagptr(fn, TAG_FUNCTION); fv = tagptr(fn, TAG_FUNCTION);
fn->bcode = args[0]; fn->bcode = args[0];
fn->vals = args[1]; fn->vals = args[1];
fn->env = NIL; fn->env = NIL;
@ -2356,32 +2408,40 @@ static value_t fl_function(value_t *args, uint32_t nargs)
static value_t fl_function_code(value_t *args, uint32_t nargs) static value_t fl_function_code(value_t *args, uint32_t nargs)
{ {
value_t v;
argcount("function:code", nargs, 1); argcount("function:code", nargs, 1);
value_t v = args[0]; v = args[0];
if (!isclosure(v)) if (!isclosure(v))
type_error("function:code", "function", v); type_error("function:code", "function", v);
return fn_bcode(v); return fn_bcode(v);
} }
static value_t fl_function_vals(value_t *args, uint32_t nargs) static value_t fl_function_vals(value_t *args, uint32_t nargs)
{ {
value_t v;
argcount("function:vals", nargs, 1); argcount("function:vals", nargs, 1);
value_t v = args[0]; v = args[0];
if (!isclosure(v)) if (!isclosure(v))
type_error("function:vals", "function", v); type_error("function:vals", "function", v);
return fn_vals(v); return fn_vals(v);
} }
static value_t fl_function_env(value_t *args, uint32_t nargs) static value_t fl_function_env(value_t *args, uint32_t nargs)
{ {
value_t v;
argcount("function:env", nargs, 1); argcount("function:env", nargs, 1);
value_t v = args[0]; v = args[0];
if (!isclosure(v)) if (!isclosure(v))
type_error("function:env", "function", v); type_error("function:env", "function", v);
return fn_env(v); return fn_env(v);
} }
static value_t fl_function_name(value_t *args, uint32_t nargs) static value_t fl_function_name(value_t *args, uint32_t nargs)
{ {
value_t v;
argcount("function:name", nargs, 1); argcount("function:name", nargs, 1);
value_t v = args[0]; v = args[0];
if (!isclosure(v)) if (!isclosure(v))
type_error("function:name", "function", v); type_error("function:name", "function", v);
return fn_name(v); return fn_name(v);
@ -2395,12 +2455,15 @@ value_t fl_copylist(value_t *args, uint32_t nargs)
value_t fl_append(value_t *args, uint32_t nargs) value_t fl_append(value_t *args, uint32_t nargs)
{ {
value_t first, lst, lastcons;
uint32_t i;
if (nargs == 0) if (nargs == 0)
return NIL; return NIL;
value_t first = NIL, lst, lastcons = NIL; first = lastcons = NIL;
fl_gc_handle(&first); fl_gc_handle(&first);
fl_gc_handle(&lastcons); fl_gc_handle(&lastcons);
uint32_t i = 0; i = 0;
while (1) { while (1) {
lst = args[i++]; lst = args[i++];
if (i >= nargs) if (i >= nargs)
@ -2442,12 +2505,14 @@ value_t fl_stacktrace(value_t *args, uint32_t nargs)
value_t fl_map1(value_t *args, uint32_t nargs) value_t fl_map1(value_t *args, uint32_t nargs)
{ {
value_t first, last, v;
int64_t argSP;
if (nargs < 2) if (nargs < 2)
lerror(ArgError, "map: too few arguments"); lerror(ArgError, "map: too few arguments");
if (!iscons(args[1])) if (!iscons(args[1]))
return NIL; return NIL;
value_t first, last, v; argSP = args - Stack;
int64_t argSP = args - Stack;
assert(argSP >= 0 && argSP < N_STACK); assert(argSP >= 0 && argSP < N_STACK);
if (nargs == 2) { if (nargs == 2) {
if (SP + 3 > N_STACK) if (SP + 3 > N_STACK)
@ -2479,6 +2544,7 @@ value_t fl_map1(value_t *args, uint32_t nargs)
fl_free_gc_handles(2); fl_free_gc_handles(2);
} else { } else {
size_t i; size_t i;
while (SP + nargs + 1 > N_STACK) while (SP + nargs + 1 > N_STACK)
grow_stack(); grow_stack();
PUSH(Stack[argSP]); PUSH(Stack[argSP]);
@ -2540,6 +2606,8 @@ extern void comparehash_init(void);
static void lisp_init(size_t initial_heapsize) static void lisp_init(size_t initial_heapsize)
{ {
char buf[1024];
char *exename;
int i; int i;
llt_init(); llt_init();
@ -2632,8 +2700,7 @@ static void lisp_init(size_t initial_heapsize)
cvalues_init(); cvalues_init();
char buf[1024]; exename = get_exename(buf, sizeof(buf));
char *exename = get_exename(buf, sizeof(buf));
if (exename != NULL) { if (exename != NULL) {
path_to_dirname(exename); path_to_dirname(exename);
setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename))); setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));
@ -2669,36 +2736,38 @@ int fl_load_boot_image(void)
ios_static_buffer(s, boot_image, sizeof(boot_image)); ios_static_buffer(s, boot_image, sizeof(boot_image));
PUSH(f); PUSH(f);
saveSP = SP; saveSP = SP;
FL_TRY
{ {
while (1) { FL_TRY
e = fl_read_sexpr(Stack[SP - 1]); {
if (ios_eof(value2c(struct ios *, Stack[SP - 1]))) while (1) {
break; e = fl_read_sexpr(Stack[SP - 1]);
if (isfunction(e)) { if (ios_eof(value2c(struct ios *, Stack[SP - 1])))
// stage 0 format: series of thunks break;
PUSH(e); if (isfunction(e)) {
(void)_applyn(0); // stage 0 format: series of thunks
SP = saveSP; PUSH(e);
} else { (void)_applyn(0);
// stage 1 format: list alternating symbol/value SP = saveSP;
while (iscons(e)) { } else {
sym = tosymbol(car_(e), "bootstrap"); // stage 1 format: list alternating symbol/value
e = cdr_(e); while (iscons(e)) {
(void)tocons(e, "bootstrap"); sym = tosymbol(car_(e), "bootstrap");
sym->binding = car_(e); e = cdr_(e);
e = cdr_(e); (void)tocons(e, "bootstrap");
sym->binding = car_(e);
e = cdr_(e);
}
break;
} }
break;
} }
} }
} FL_CATCH
FL_CATCH {
{ ios_puts("fatal error during bootstrap:\n", ios_stderr);
ios_puts("fatal error during bootstrap:\n", ios_stderr); fl_print(ios_stderr, fl_lasterror);
fl_print(ios_stderr, fl_lasterror); ios_putc('\n', ios_stderr);
ios_putc('\n', ios_stderr); return 1;
return 1; }
} }
ios_close(value2c(struct ios *, Stack[SP - 1])); ios_close(value2c(struct ios *, Stack[SP - 1]));
POPN(1); POPN(1);

7
c/htable.c
View File

@ -15,6 +15,8 @@
struct htable *htable_new(struct htable *h, size_t size) struct htable *htable_new(struct htable *h, size_t size)
{ {
size_t i;
if (size <= HT_N_INLINE / 2) { if (size <= HT_N_INLINE / 2) {
h->size = size = HT_N_INLINE; h->size = size = HT_N_INLINE;
h->table = &h->_space[0]; h->table = &h->_space[0];
@ -27,7 +29,6 @@ struct htable *htable_new(struct htable *h, size_t size)
} }
if (h->table == NULL) if (h->table == NULL)
return NULL; return NULL;
size_t i;
for (i = 0; i < size; i++) for (i = 0; i < size; i++)
h->table[i] = HT_NOTFOUND; h->table[i] = HT_NOTFOUND;
return h; return h;
@ -42,6 +43,8 @@ void htable_free(struct htable *h)
// empty and reduce size // empty and reduce size
void htable_reset(struct htable *h, size_t sz) void htable_reset(struct htable *h, size_t sz)
{ {
size_t i, hsz;
sz = nextipow2(sz); sz = nextipow2(sz);
if (h->size > sz * 4 && h->size > HT_N_INLINE) { if (h->size > sz * 4 && h->size > HT_N_INLINE) {
size_t newsz = sz * 4; size_t newsz = sz * 4;
@ -52,7 +55,7 @@ void htable_reset(struct htable *h, size_t sz)
h->size = newsz; h->size = newsz;
h->table = newtab; h->table = newtab;
} }
size_t i, hsz = h->size; hsz = h->size;
for (i = 0; i < hsz; i++) for (i = 0; i < hsz; i++)
h->table[i] = HT_NOTFOUND; h->table[i] = HT_NOTFOUND;
} }

2
c/htable_inc.h
View File

@ -100,10 +100,10 @@
size_t maxprobe = max_probe(sz); \ size_t maxprobe = max_probe(sz); \
void **tab = h->table; \ void **tab = h->table; \
size_t index = (uintptr_t)(HFUNC((uintptr_t)key) & (sz - 1)) * 2; \ size_t index = (uintptr_t)(HFUNC((uintptr_t)key) & (sz - 1)) * 2; \
sz *= 2; \
size_t orig = index; \ size_t orig = index; \
size_t iter = 0; \ size_t iter = 0; \
\ \
sz *= 2; \
do { \ do { \
if (tab[index] == HT_NOTFOUND) \ if (tab[index] == HT_NOTFOUND) \
return NULL; \ return NULL; \

123
c/ios.c
View File

@ -33,8 +33,11 @@
static void *our_memrchr(const void *s, int c, size_t n) static void *our_memrchr(const void *s, int c, size_t n)
{ {
const unsigned char *src = s + n; const unsigned char *src;
unsigned char uc = c; unsigned char uc;
src = (unsigned char *)s + n;
uc = c;
while (--src >= (unsigned char *)s) while (--src >= (unsigned char *)s)
if (*src == uc) if (*src == uc)
return (void *)src; return (void *)src;
@ -90,15 +93,17 @@ static int _os_read(long fd, void *buf, size_t n, size_t *nread)
static int _os_read_all(long fd, void *buf, size_t n, size_t *nread) static int _os_read_all(long fd, void *buf, size_t n, size_t *nread)
{ {
unsigned char *ubuf;
size_t got; size_t got;
int err;
ubuf = buf;
*nread = 0; *nread = 0;
while (n > 0) { while (n > 0) {
int err = _os_read(fd, buf, n, &got); err = _os_read(fd, ubuf, n, &got);
n -= got; n -= got;
*nread += got; *nread += got;
buf += got; ubuf += got;
if (err || got == 0) if (err || got == 0)
return err; return err;
} }
@ -126,15 +131,17 @@ static int _os_write(long fd, void *buf, size_t n, size_t *nwritten)
static int _os_write_all(long fd, void *buf, size_t n, size_t *nwritten) static int _os_write_all(long fd, void *buf, size_t n, size_t *nwritten)
{ {
unsigned char *ubuf;
size_t wrote; size_t wrote;
int err;
ubuf = buf;
*nwritten = 0; *nwritten = 0;
while (n > 0) { while (n > 0) {
int err = _os_write(fd, buf, n, &wrote); err = _os_write(fd, ubuf, n, &wrote);
n -= wrote; n -= wrote;
*nwritten += wrote; *nwritten += wrote;
buf += wrote; ubuf += wrote;
if (err) if (err)
return err; return err;
} }
@ -291,11 +298,14 @@ size_t ios_readall(struct ios *s, char *dest, size_t n)
size_t ios_readprep(struct ios *s, size_t n) size_t ios_readprep(struct ios *s, size_t n)
{ {
size_t got, space;
int result;
if (s->state == bst_wr && s->bm != bm_mem) { if (s->state == bst_wr && s->bm != bm_mem) {
ios_flush(s); ios_flush(s);
s->bpos = s->size = 0; s->bpos = s->size = 0;
} }
size_t space = s->size - s->bpos; space = s->size - s->bpos;
s->state = bst_rd; s->state = bst_rd;
if (space >= n || s->bm == bm_mem || s->fd == -1) if (space >= n || s->bm == bm_mem || s->fd == -1)
return space; return space;
@ -311,9 +321,7 @@ size_t ios_readprep(struct ios *s, size_t n)
return space; return space;
} }
} }
size_t got; result = _os_read(s->fd, s->buf + s->size, s->maxsize - s->size, &got);
int result =
_os_read(s->fd, s->buf + s->size, s->maxsize - s->size, &got);
if (result) if (result)
return space; return space;
s->size += got; s->size += got;
@ -330,13 +338,14 @@ static void _write_update_pos(struct ios *s)
size_t ios_write(struct ios *s, char *data, size_t n) size_t ios_write(struct ios *s, char *data, size_t n)
{ {
size_t space, wrote;
if (s->readonly) if (s->readonly)
return 0; return 0;
if (n == 0) if (n == 0)
return 0; return 0;
size_t space;
size_t wrote = 0;
wrote = 0;
if (s->state == bst_none) if (s->state == bst_none)
s->state = bst_wr; s->state = bst_wr;
if (s->state == bst_rd) { if (s->state == bst_rd) {
@ -386,6 +395,8 @@ size_t ios_write(struct ios *s, char *data, size_t n)
off_t ios_seek(struct ios *s, off_t pos) off_t ios_seek(struct ios *s, off_t pos)
{ {
off_t fdpos;
s->_eof = 0; s->_eof = 0;
if (s->bm == bm_mem) { if (s->bm == bm_mem) {
if ((size_t)pos > s->size) if ((size_t)pos > s->size)
@ -393,7 +404,7 @@ off_t ios_seek(struct ios *s, off_t pos)
s->bpos = pos; s->bpos = pos;
} else { } else {
ios_flush(s); ios_flush(s);
off_t fdpos = lseek(s->fd, pos, SEEK_SET); fdpos = lseek(s->fd, pos, SEEK_SET);
if (fdpos == (off_t)-1) if (fdpos == (off_t)-1)
return fdpos; return fdpos;
s->bpos = s->size = 0; s->bpos = s->size = 0;
@ -403,12 +414,14 @@ off_t ios_seek(struct ios *s, off_t pos)
off_t ios_seek_end(struct ios *s) off_t ios_seek_end(struct ios *s)
{ {
off_t fdpos;
s->_eof = 1; s->_eof = 1;
if (s->bm == bm_mem) { if (s->bm == bm_mem) {
s->bpos = s->size; s->bpos = s->size;
} else { } else {
ios_flush(s); ios_flush(s);
off_t fdpos = lseek(s->fd, 0, SEEK_END); fdpos = lseek(s->fd, 0, SEEK_END);
if (fdpos == (off_t)-1) if (fdpos == (off_t)-1)
return fdpos; return fdpos;
s->bpos = s->size = 0; s->bpos = s->size = 0;
@ -418,6 +431,8 @@ off_t ios_seek_end(struct ios *s)
off_t ios_skip(struct ios *s, off_t offs) off_t ios_skip(struct ios *s, off_t offs)
{ {
off_t fdpos;
if (offs != 0) { if (offs != 0) {
if (offs > 0) { if (offs > 0) {
if (offs <= (off_t)(s->size - s->bpos)) { if (offs <= (off_t)(s->size - s->bpos)) {
@ -441,7 +456,7 @@ off_t ios_skip(struct ios *s, off_t offs)
offs += s->bpos; offs += s->bpos;
else if (s->state == bst_rd) else if (s->state == bst_rd)
offs -= (s->size - s->bpos); offs -= (s->size - s->bpos);
off_t fdpos = lseek(s->fd, offs, SEEK_CUR); fdpos = lseek(s->fd, offs, SEEK_CUR);
if (fdpos == (off_t)-1) if (fdpos == (off_t)-1)
return fdpos; return fdpos;
s->bpos = s->size = 0; s->bpos = s->size = 0;
@ -452,10 +467,12 @@ off_t ios_skip(struct ios *s, off_t offs)
off_t ios_pos(struct ios *s) off_t ios_pos(struct ios *s)
{ {
off_t fdpos;
if (s->bm == bm_mem) if (s->bm == bm_mem)
return (off_t)s->bpos; return (off_t)s->bpos;
off_t fdpos = s->fpos; fdpos = s->fpos;
if (fdpos == (off_t)-1) { if (fdpos == (off_t)-1) {
fdpos = lseek(s->fd, 0, SEEK_CUR); fdpos = lseek(s->fd, 0, SEEK_CUR);
if (fdpos == (off_t)-1) if (fdpos == (off_t)-1)
@ -502,6 +519,9 @@ int ios_eof(struct ios *s)
int ios_flush(struct ios *s) int ios_flush(struct ios *s)
{ {
size_t nw, ntowrite;
int err;
if (s->ndirty == 0 || s->bm == bm_mem || s->buf == NULL) if (s->ndirty == 0 || s->bm == bm_mem || s->buf == NULL)
return 0; return 0;
if (s->fd == -1) if (s->fd == -1)
@ -512,9 +532,9 @@ int ios_flush(struct ios *s)
} }
} }
size_t nw, ntowrite = s->ndirty; ntowrite = s->ndirty;
s->fpos = -1; s->fpos = -1;
int err = _os_write_all(s->fd, s->buf, ntowrite, &nw); err = _os_write_all(s->fd, s->buf, ntowrite, &nw);
// todo: try recovering from some kinds of errors (e.g. retry) // todo: try recovering from some kinds of errors (e.g. retry)
if (s->state == bst_rd) { if (s->state == bst_rd) {
@ -596,8 +616,8 @@ char *ios_takebuf(struct ios *s, size_t *psize)
int ios_setbuf(struct ios *s, char *buf, size_t size, int own) int ios_setbuf(struct ios *s, char *buf, size_t size, int own)
{ {
ios_flush(s);
size_t nvalid = 0; size_t nvalid = 0;
ios_flush(s);
nvalid = (size < s->size) ? size : s->size; nvalid = (size < s->size) ? size : s->size;
if (nvalid > 0) if (nvalid > 0)
@ -637,7 +657,9 @@ void ios_set_readonly(struct ios *s)
static size_t ios_copy_(struct ios *to, struct ios *from, size_t nbytes, static size_t ios_copy_(struct ios *to, struct ios *from, size_t nbytes,
bool_t all) bool_t all)
{ {
size_t total = 0, avail; size_t total, avail, written, ntowrite;
total = 0;
if (!ios_eof(from)) { if (!ios_eof(from)) {
do { do {
avail = ios_readprep(from, IOS_BUFSIZE / 2); avail = ios_readprep(from, IOS_BUFSIZE / 2);
@ -645,7 +667,6 @@ static size_t ios_copy_(struct ios *to, struct ios *from, size_t nbytes,
from->_eof = 1; from->_eof = 1;
break; break;
} }
size_t written, ntowrite;
ntowrite = (avail <= nbytes || all) ? avail : nbytes; ntowrite = (avail <= nbytes || all) ? avail : nbytes;
written = ios_write(to, from->buf + from->bpos, ntowrite); written = ios_write(to, from->buf + from->bpos, ntowrite);
// TODO: should this be +=written instead? // TODO: should this be +=written instead?
@ -677,23 +698,27 @@ size_t ios_copyall(struct ios *to, struct ios *from)
size_t ios_copyuntil(struct ios *to, struct ios *from, char delim) size_t ios_copyuntil(struct ios *to, struct ios *from, char delim)
{ {
size_t total = 0, avail = from->size - from->bpos; size_t total, avail, ntowrite, written;
int first = 1; char *pd;
int first;
total = 0;
avail = from->size - from->bpos;
first = 1;
if (!ios_eof(from)) { if (!ios_eof(from)) {
do { do {
if (avail == 0) { if (avail == 0) {
first = 0; first = 0;
avail = ios_readprep(from, LINE_CHUNK_SIZE); avail = ios_readprep(from, LINE_CHUNK_SIZE);
} }
size_t written; pd = (char *)memchr(from->buf + from->bpos, delim, avail);
char *pd = (char *)memchr(from->buf + from->bpos, delim, avail);
if (pd == NULL) { if (pd == NULL) {
written = ios_write(to, from->buf + from->bpos, avail); written = ios_write(to, from->buf + from->bpos, avail);
from->bpos += avail; from->bpos += avail;
total += written; total += written;
avail = 0; avail = 0;
} else { } else {
size_t ntowrite = pd - (from->buf + from->bpos) + 1; ntowrite = pd - (from->buf + from->bpos) + 1;
written = ios_write(to, from->buf + from->bpos, ntowrite); written = ios_write(to, from->buf + from->bpos, ntowrite);
from->bpos += ntowrite; from->bpos += ntowrite;
total += written; total += written;
@ -731,11 +756,12 @@ static void _ios_init(struct ios *s)
struct ios *ios_file(struct ios *s, char *fname, int rd, int wr, int create, struct ios *ios_file(struct ios *s, char *fname, int rd, int wr, int create,
int trunc) int trunc)
{ {
int fd; int fd, flags;
if (!(rd || wr)) if (!(rd || wr))
// must specify read and/or write // must specify read and/or write
goto open_file_err; goto open_file_err;
int flags = wr ? (rd ? O_RDWR : O_WRONLY) : O_RDONLY; flags = wr ? (rd ? O_RDWR : O_WRONLY) : O_RDONLY;
if (create) if (create)
flags |= O_CREAT; flags |= O_CREAT;
if (trunc) if (trunc)
@ -762,7 +788,9 @@ struct ios *ios_mem(struct ios *s, size_t initsize)
struct ios *ios_str(struct ios *s, char *str) struct ios *ios_str(struct ios *s, char *str)
{ {
size_t n = strlen(str); size_t n;
n = strlen(str);
if (ios_mem(s, n + 1) == NULL) if (ios_mem(s, n + 1) == NULL)
return NULL; return NULL;
ios_write(s, str, n + 1); ios_write(s, str, n + 1);
@ -829,6 +857,7 @@ int ios_putc(int c, struct ios *s)
int ios_getc(struct ios *s) int ios_getc(struct ios *s)
{ {
char ch; char ch;
if (s->state == bst_rd && s->bpos < s->size) { if (s->state == bst_rd && s->bpos < s->size) {
ch = s->buf[s->bpos++]; ch = s->buf[s->bpos++];
} else { } else {
@ -844,11 +873,13 @@ int ios_getc(struct ios *s)
int ios_peekc(struct ios *s) int ios_peekc(struct ios *s)
{ {
size_t n;
if (s->bpos < s->size) if (s->bpos < s->size)
return (unsigned char)s->buf[s->bpos]; return (unsigned char)s->buf[s->bpos];
if (s->_eof) if (s->_eof)
return IOS_EOF; return IOS_EOF;
size_t n = ios_readprep(s, 1); n = ios_readprep(s, 1);
if (n == 0) if (n == 0)
return IOS_EOF; return IOS_EOF;
return (unsigned char)s->buf[s->bpos]; return (unsigned char)s->buf[s->bpos];
@ -878,7 +909,7 @@ int ios_ungetc(int c, struct ios *s)
int ios_getutf8(struct ios *s, uint32_t *pwc) int ios_getutf8(struct ios *s, uint32_t *pwc)
{ {
int c; int c;
size_t sz; size_t sz, i;
char c0; char c0;
char buf[8]; char buf[8];
@ -896,7 +927,7 @@ int ios_getutf8(struct ios *s, uint32_t *pwc)
if (ios_readprep(s, sz) < sz) if (ios_readprep(s, sz) < sz)
// NOTE: this can return EOF even if some bytes are available // NOTE: this can return EOF even if some bytes are available
return IOS_EOF; return IOS_EOF;
size_t i = s->bpos; i = s->bpos;
*pwc = u8_nextchar(s->buf, &i); *pwc = u8_nextchar(s->buf, &i);
ios_read(s, buf, sz + 1); ios_read(s, buf, sz + 1);
return 1; return 1;
@ -905,7 +936,7 @@ int ios_getutf8(struct ios *s, uint32_t *pwc)
int ios_peekutf8(struct ios *s, uint32_t *pwc) int ios_peekutf8(struct ios *s, uint32_t *pwc)
{ {
int c; int c;
size_t sz; size_t sz, i;
char c0; char c0;
c = ios_peekc(s); c = ios_peekc(s);
@ -919,7 +950,7 @@ int ios_peekutf8(struct ios *s, uint32_t *pwc)
sz = u8_seqlen(&c0) - 1; sz = u8_seqlen(&c0) - 1;
if (ios_readprep(s, sz) < sz) if (ios_readprep(s, sz) < sz)
return IOS_EOF; return IOS_EOF;
size_t i = s->bpos; i = s->bpos;
*pwc = u8_nextchar(s->buf, &i); *pwc = u8_nextchar(s->buf, &i);
return 1; return 1;
} }
@ -927,9 +958,11 @@ int ios_peekutf8(struct ios *s, uint32_t *pwc)
int ios_pututf8(struct ios *s, uint32_t wc) int ios_pututf8(struct ios *s, uint32_t wc)
{ {
char buf[8]; char buf[8];
size_t n;
if (wc < 0x80) if (wc < 0x80)
return ios_putc((int)wc, s); return ios_putc((int)wc, s);
size_t n = u8_toutf8(buf, 8, &wc, 1); n = u8_toutf8(buf, 8, &wc, 1);
return ios_write(s, buf, n); return ios_write(s, buf, n);
} }
@ -943,9 +976,10 @@ void ios_purge(struct ios *s)
char *ios_readline(struct ios *s) char *ios_readline(struct ios *s)
{ {
struct ios dest; struct ios dest;
size_t n;
ios_mem(&dest, 0); ios_mem(&dest, 0);
ios_copyuntil(&dest, s, '\n'); ios_copyuntil(&dest, s, '\n');
size_t n;
return ios_takebuf(&dest, &n); return ios_takebuf(&dest, &n);
} }
@ -953,14 +987,17 @@ int vasprintf(char **strp, const char *fmt, va_list ap);
int ios_vprintf(struct ios *s, const char *format, va_list args) int ios_vprintf(struct ios *s, const char *format, va_list args)
{ {
char *str = NULL; char *str;
int c; int c;
va_list al; va_list al;
va_copy(al, args); size_t avail;
char *start;
str = NULL;
va_copy(al, args);
if (s->state == bst_wr && s->bpos < s->maxsize && s->bm != bm_none) { if (s->state == bst_wr && s->bpos < s->maxsize && s->bm != bm_none) {
size_t avail = s->maxsize - s->bpos; avail = s->maxsize - s->bpos;
char *start = s->buf + s->bpos; start = s->buf + s->bpos;
c = vsnprintf(start, avail, format, args); c = vsnprintf(start, avail, format, args);
if (c < 0) { if (c < 0) {
va_end(al); va_end(al);
@ -977,10 +1014,8 @@ int ios_vprintf(struct ios *s, const char *format, va_list args)
} }
} }
c = vasprintf(&str, format, al); c = vasprintf(&str, format, al);
if (c >= 0) { if (c >= 0) {
ios_write(s, str, c); ios_write(s, str, c);
LLT_FREE(str); LLT_FREE(str);
} }
va_end(al); va_end(al);

187
c/iostream.c
View File

@ -93,9 +93,14 @@ struct ios *fl_toiostream(value_t v, char *fname)
value_t fl_file(value_t *args, uint32_t nargs) value_t fl_file(value_t *args, uint32_t nargs)
{ {
int i, r, w, c, t, a;
value_t f;
char *fname;
struct ios *s;
if (nargs < 1) if (nargs < 1)
argcount("file", nargs, 1); argcount("file", nargs, 1);
int i, r = 0, w = 0, c = 0, t = 0, a = 0; r = w = c = t = a = 0;
for (i = 1; i < (int)nargs; i++) { for (i = 1; i < (int)nargs; i++) {
if (args[i] == wrsym) if (args[i] == wrsym)
w = 1; w = 1;
@ -113,9 +118,9 @@ value_t fl_file(value_t *args, uint32_t nargs)
} }
if ((r | w | c | t | a) == 0) if ((r | w | c | t | a) == 0)
r = 1; // default to reading r = 1; // default to reading
value_t f = cvalue(iostreamtype, sizeof(struct ios)); f = cvalue(iostreamtype, sizeof(struct ios));
char *fname = tostring(args[0], "file"); fname = tostring(args[0], "file");
struct ios *s = value2c(struct ios *, f); s = value2c(struct ios *, f);
if (ios_file(s, fname, r, w, c, t) == NULL) if (ios_file(s, fname, r, w, c, t) == NULL)
lerrorf(IOError, "file: could not open \"%s\"", fname); lerrorf(IOError, "file: could not open \"%s\"", fname);
if (a) if (a)
@ -125,10 +130,13 @@ value_t fl_file(value_t *args, uint32_t nargs)
value_t fl_buffer(value_t *args, uint32_t nargs) value_t fl_buffer(value_t *args, uint32_t nargs)
{ {
value_t f;
struct ios *s;
argcount("buffer", nargs, 0); argcount("buffer", nargs, 0);
(void)args; (void)args;
value_t f = cvalue(iostreamtype, sizeof(struct ios)); f = cvalue(iostreamtype, sizeof(struct ios));
struct ios *s = value2c(struct ios *, f); s = value2c(struct ios *, f);
if (ios_mem(s, 0) == NULL) if (ios_mem(s, 0) == NULL)
lerror(MemoryError, "buffer: could not allocate stream"); lerror(MemoryError, "buffer: could not allocate stream");
return f; return f;
@ -136,7 +144,9 @@ value_t fl_buffer(value_t *args, uint32_t nargs)
value_t fl_read(value_t *args, uint32_t nargs) value_t fl_read(value_t *args, uint32_t nargs)
{ {
value_t arg = 0; value_t arg, v;
arg = 0;
if (nargs > 1) { if (nargs > 1) {
argcount("read", nargs, 1); argcount("read", nargs, 1);
} else if (nargs == 0) { } else if (nargs == 0) {
@ -146,7 +156,7 @@ value_t fl_read(value_t *args, uint32_t nargs)
} }
(void)toiostream(arg, "read"); (void)toiostream(arg, "read");
fl_gc_handle(&arg); fl_gc_handle(&arg);
value_t v = fl_read_sexpr(arg); v = fl_read_sexpr(arg);
fl_free_gc_handles(1); fl_free_gc_handles(1);
if (ios_eof(value2c(struct ios *, arg))) if (ios_eof(value2c(struct ios *, arg)))
return FL_EOF; return FL_EOF;
@ -155,9 +165,11 @@ value_t fl_read(value_t *args, uint32_t nargs)
value_t builtin_read_u8(value_t *args, uint32_t nargs) value_t builtin_read_u8(value_t *args, uint32_t nargs)
{ {
argcount("read-u8", nargs, 1); struct ios *s;
struct ios *s = toiostream(args[0], "read-u8");
int c; int c;
argcount("read-u8", nargs, 1);
s = toiostream(args[0], "read-u8");
if ((c = ios_getc(s)) == IOS_EOF) if ((c = ios_getc(s)) == IOS_EOF)
// lerror(IOError, "io.getc: end of file reached"); // lerror(IOError, "io.getc: end of file reached");
return FL_EOF; return FL_EOF;
@ -166,9 +178,11 @@ value_t builtin_read_u8(value_t *args, uint32_t nargs)
value_t fl_iogetc(value_t *args, uint32_t nargs) value_t fl_iogetc(value_t *args, uint32_t nargs)
{ {
argcount("io.getc", nargs, 1); struct ios *s;
struct ios *s = toiostream(args[0], "io.getc");
uint32_t wc; uint32_t wc;
argcount("io.getc", nargs, 1);
s = toiostream(args[0], "io.getc");
if (ios_getutf8(s, &wc) == IOS_EOF) if (ios_getutf8(s, &wc) == IOS_EOF)
// lerror(IOError, "io.getc: end of file reached"); // lerror(IOError, "io.getc: end of file reached");
return FL_EOF; return FL_EOF;
@ -177,9 +191,11 @@ value_t fl_iogetc(value_t *args, uint32_t nargs)
value_t fl_iopeekc(value_t *args, uint32_t nargs) value_t fl_iopeekc(value_t *args, uint32_t nargs)
{ {
argcount("io.peekc", nargs, 1); struct ios *s;
struct ios *s = toiostream(args[0], "io.peekc");
uint32_t wc; uint32_t wc;
argcount("io.peekc", nargs, 1);
s = toiostream(args[0], "io.peekc");
if (ios_peekutf8(s, &wc) == IOS_EOF) if (ios_peekutf8(s, &wc) == IOS_EOF)
return FL_EOF; return FL_EOF;
return mk_wchar(wc); return mk_wchar(wc);
@ -187,23 +203,29 @@ value_t fl_iopeekc(value_t *args, uint32_t nargs)
value_t fl_ioputc(value_t *args, uint32_t nargs) value_t fl_ioputc(value_t *args, uint32_t nargs)
{ {
struct ios *s;
uint32_t wc;
argcount("io.putc", nargs, 2); argcount("io.putc", nargs, 2);
struct ios *s = toiostream(args[0], "io.putc"); s = toiostream(args[0], "io.putc");
if (!iscprim(args[1]) || if (!iscprim(args[1]) ||
((struct cprim *)ptr(args[1]))->type != wchartype) ((struct cprim *)ptr(args[1]))->type != wchartype)
type_error("io.putc", "wchar", args[1]); type_error("io.putc", "wchar", args[1]);
uint32_t wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1])); wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
return fixnum(ios_pututf8(s, wc)); return fixnum(ios_pututf8(s, wc));
} }
value_t fl_ioungetc(value_t *args, uint32_t nargs) value_t fl_ioungetc(value_t *args, uint32_t nargs)
{ {
struct ios *s;
uint32_t wc;
argcount("io.ungetc", nargs, 2); argcount("io.ungetc", nargs, 2);
struct ios *s = toiostream(args[0], "io.ungetc"); s = toiostream(args[0], "io.ungetc");
if (!iscprim(args[1]) || if (!iscprim(args[1]) ||
((struct cprim *)ptr(args[1]))->type != wchartype) ((struct cprim *)ptr(args[1]))->type != wchartype)
type_error("io.ungetc", "wchar", args[1]); type_error("io.ungetc", "wchar", args[1]);
uint32_t wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1])); wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
if (wc >= 0x80) { if (wc >= 0x80) {
lerror(ArgError, "io_ungetc: unicode not yet supported"); lerror(ArgError, "io_ungetc: unicode not yet supported");
} }
@ -212,8 +234,10 @@ value_t fl_ioungetc(value_t *args, uint32_t nargs)
value_t fl_ioflush(value_t *args, uint32_t nargs) value_t fl_ioflush(value_t *args, uint32_t nargs)
{ {
struct ios *s;
argcount("io.flush", nargs, 1); argcount("io.flush", nargs, 1);
struct ios *s = toiostream(args[0], "io.flush"); s = toiostream(args[0], "io.flush");
if (ios_flush(s) != 0) if (ios_flush(s) != 0)
return FL_F; return FL_F;
return FL_T; return FL_T;
@ -221,33 +245,43 @@ value_t fl_ioflush(value_t *args, uint32_t nargs)
value_t fl_ioclose(value_t *args, uint32_t nargs) value_t fl_ioclose(value_t *args, uint32_t nargs)
{ {
struct ios *s;
argcount("io.close", nargs, 1); argcount("io.close", nargs, 1);
struct ios *s = toiostream(args[0], "io.close"); s = toiostream(args[0], "io.close");
ios_close(s); ios_close(s);
return FL_T; return FL_T;
} }
value_t fl_iopurge(value_t *args, uint32_t nargs) value_t fl_iopurge(value_t *args, uint32_t nargs)
{ {
struct ios *s;
argcount("io.discardbuffer", nargs, 1); argcount("io.discardbuffer", nargs, 1);
struct ios *s = toiostream(args[0], "io.discardbuffer"); s = toiostream(args[0], "io.discardbuffer");
ios_purge(s); ios_purge(s);
return FL_T; return FL_T;
} }
value_t fl_ioeof(value_t *args, uint32_t nargs) value_t fl_ioeof(value_t *args, uint32_t nargs)
{ {
struct ios *s;
argcount("io.eof?", nargs, 1); argcount("io.eof?", nargs, 1);
struct ios *s = toiostream(args[0], "io.eof?"); s = toiostream(args[0], "io.eof?");
return (ios_eof(s) ? FL_T : FL_F); return (ios_eof(s) ? FL_T : FL_F);
} }
value_t fl_ioseek(value_t *args, uint32_t nargs) value_t fl_ioseek(value_t *args, uint32_t nargs)
{ {
struct ios *s;
off_t res;
size_t pos;
argcount("io.seek", nargs, 2); argcount("io.seek", nargs, 2);
struct ios *s = toiostream(args[0], "io.seek"); s = toiostream(args[0], "io.seek");
size_t pos = toulong(args[1], "io.seek"); pos = toulong(args[1], "io.seek");
off_t res = ios_seek(s, (off_t)pos); res = ios_seek(s, (off_t)pos);
if (res == -1) if (res == -1)
return FL_F; return FL_F;
return FL_T; return FL_T;
@ -255,9 +289,12 @@ value_t fl_ioseek(value_t *args, uint32_t nargs)
value_t fl_iopos(value_t *args, uint32_t nargs) value_t fl_iopos(value_t *args, uint32_t nargs)
{ {
struct ios *s;
off_t res;
argcount("io.pos", nargs, 1); argcount("io.pos", nargs, 1);
struct ios *s = toiostream(args[0], "io.pos"); s = toiostream(args[0], "io.pos");
off_t res = ios_pos(s); res = ios_pos(s);
if (res == -1) if (res == -1)
return FL_F; return FL_F;
return size_wrap((size_t)res); return size_wrap((size_t)res);
@ -265,9 +302,10 @@ value_t fl_iopos(value_t *args, uint32_t nargs)
value_t fl_write(value_t *args, uint32_t nargs) value_t fl_write(value_t *args, uint32_t nargs)
{ {
struct ios *s;
if (nargs < 1 || nargs > 2) if (nargs < 1 || nargs > 2)
argcount("write", nargs, 1); argcount("write", nargs, 1);
struct ios *s;
if (nargs == 2) if (nargs == 2)
s = toiostream(args[1], "write"); s = toiostream(args[1], "write");
else else
@ -278,11 +316,14 @@ value_t fl_write(value_t *args, uint32_t nargs)
value_t fl_ioread(value_t *args, uint32_t nargs) value_t fl_ioread(value_t *args, uint32_t nargs)
{ {
struct fltype *ft;
char *data;
value_t cv;
size_t n, got;
if (nargs != 3) if (nargs != 3)
argcount("io.read", nargs, 2); argcount("io.read", nargs, 2);
(void)toiostream(args[0], "io.read"); (void)toiostream(args[0], "io.read");
size_t n;
struct fltype *ft;
if (nargs == 3) { if (nargs == 3) {
// form (io.read s type count) // form (io.read s type count)
ft = get_array_type(args[1]); ft = get_array_type(args[1]);
@ -293,13 +334,12 @@ value_t fl_ioread(value_t *args, uint32_t nargs)
lerror(ArgError, "io.read: incomplete type"); lerror(ArgError, "io.read: incomplete type");
n = ft->size; n = ft->size;
} }
value_t cv = cvalue(ft, n); cv = cvalue(ft, n);
char *data;
if (iscvalue(cv)) if (iscvalue(cv))
data = cv_data((struct cvalue *)ptr(cv)); data = cv_data((struct cvalue *)ptr(cv));
else else
data = cp_data((struct cprim *)ptr(cv)); data = cp_data((struct cprim *)ptr(cv));
size_t got = ios_read(value2c(struct ios *, args[0]), data, n); got = ios_read(value2c(struct ios *, args[0]), data, n);
if (got < n) if (got < n)
// lerror(IOError, "io.read: end of input reached"); // lerror(IOError, "io.read: end of input reached");
return FL_EOF; return FL_EOF;
@ -323,21 +363,25 @@ static void get_start_count_args(value_t *args, uint32_t nargs, size_t sz,
value_t fl_iowrite(value_t *args, uint32_t nargs) value_t fl_iowrite(value_t *args, uint32_t nargs)
{ {
char *data;
struct ios *s;
size_t nb, sz, offs;
uint32_t wc;
if (nargs < 2 || nargs > 4) if (nargs < 2 || nargs > 4)
argcount("io.write", nargs, 2); argcount("io.write", nargs, 2);
struct ios *s = toiostream(args[0], "io.write"); s = toiostream(args[0], "io.write");
if (iscprim(args[1]) && if (iscprim(args[1]) &&
((struct cprim *)ptr(args[1]))->type == wchartype) { ((struct cprim *)ptr(args[1]))->type == wchartype) {
if (nargs > 2) if (nargs > 2)
lerror(ArgError, lerror(ArgError,
"io.write: offset argument not supported for characters"); "io.write: offset argument not supported for characters");
uint32_t wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1])); wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
return fixnum(ios_pututf8(s, wc)); return fixnum(ios_pututf8(s, wc));
} }
char *data; offs = 0;
size_t sz, offs = 0;
to_sized_ptr(args[1], "io.write", &data, &sz); to_sized_ptr(args[1], "io.write", &data, &sz);
size_t nb = sz; nb = sz;
if (nargs > 2) { if (nargs > 2) {
get_start_count_args(&args[1], nargs - 1, sz, &offs, &nb, "io.write"); get_start_count_args(&args[1], nargs - 1, sz, &offs, &nb, "io.write");
data += offs; data += offs;
@ -347,13 +391,16 @@ value_t fl_iowrite(value_t *args, uint32_t nargs)
value_t fl_dump(value_t *args, uint32_t nargs) value_t fl_dump(value_t *args, uint32_t nargs)
{ {
char *data;
struct ios *s;
size_t nb, sz, offs;
if (nargs < 1 || nargs > 3) if (nargs < 1 || nargs > 3)
argcount("dump", nargs, 1); argcount("dump", nargs, 1);
struct ios *s = toiostream(symbol_value(outstrsym), "dump"); s = toiostream(symbol_value(outstrsym), "dump");
char *data; offs = 0;
size_t sz, offs = 0;
to_sized_ptr(args[0], "dump", &data, &sz); to_sized_ptr(args[0], "dump", &data, &sz);
size_t nb = sz; nb = sz;
if (nargs > 1) { if (nargs > 1) {
get_start_count_args(args, nargs, sz, &offs, &nb, "dump"); get_start_count_args(args, nargs, sz, &offs, &nb, "dump");
data += offs; data += offs;
@ -364,7 +411,9 @@ value_t fl_dump(value_t *args, uint32_t nargs)
static char get_delim_arg(value_t arg, char *fname) static char get_delim_arg(value_t arg, char *fname)
{ {
size_t uldelim = toulong(arg, fname); size_t uldelim;
uldelim = toulong(arg, fname);
if (uldelim > 0x7f) { if (uldelim > 0x7f) {
// wchars > 0x7f, or anything else > 0xff, are out of range // wchars > 0x7f, or anything else > 0xff, are out of range
if ((iscprim(arg) && if ((iscprim(arg) &&
@ -377,16 +426,23 @@ static char get_delim_arg(value_t arg, char *fname)
value_t fl_ioreaduntil(value_t *args, uint32_t nargs) value_t fl_ioreaduntil(value_t *args, uint32_t nargs)
{ {
argcount("io.readuntil", nargs, 2);
value_t str = cvalue_string(80);
struct cvalue *cv = (struct cvalue *)ptr(str);
char *data = cv_data(cv);
struct ios dest; struct ios dest;
struct cvalue *cv;
struct ios *src;
char *data;
value_t str;
size_t n;
char delim;
argcount("io.readuntil", nargs, 2);
str = cvalue_string(80);
cv = (struct cvalue *)ptr(str);
data = cv_data(cv);
ios_mem(&dest, 0); ios_mem(&dest, 0);
ios_setbuf(&dest, data, 80, 0); ios_setbuf(&dest, data, 80, 0);
char delim = get_delim_arg(args[1], "io.readuntil"); delim = get_delim_arg(args[1], "io.readuntil");
struct ios *src = toiostream(args[0], "io.readuntil"); src = toiostream(args[0], "io.readuntil");
size_t n = ios_copyuntil(&dest, src, delim); n = ios_copyuntil(&dest, src, delim);
cv->len = n; cv->len = n;
if (dest.buf != data) { if (dest.buf != data) {
// outgrew initial space // outgrew initial space
@ -401,21 +457,29 @@ value_t fl_ioreaduntil(value_t *args, uint32_t nargs)
value_t fl_iocopyuntil(value_t *args, uint32_t nargs) value_t fl_iocopyuntil(value_t *args, uint32_t nargs)
{ {
struct ios *dest;
struct ios *src;
char delim;
argcount("io.copyuntil", nargs, 3); argcount("io.copyuntil", nargs, 3);
struct ios *dest = toiostream(args[0], "io.copyuntil"); dest = toiostream(args[0], "io.copyuntil");
struct ios *src = toiostream(args[1], "io.copyuntil"); src = toiostream(args[1], "io.copyuntil");
char delim = get_delim_arg(args[2], "io.copyuntil"); delim = get_delim_arg(args[2], "io.copyuntil");
return size_wrap(ios_copyuntil(dest, src, delim)); return size_wrap(ios_copyuntil(dest, src, delim));
} }
value_t fl_iocopy(value_t *args, uint32_t nargs) value_t fl_iocopy(value_t *args, uint32_t nargs)
{ {
struct ios *dest;
struct ios *src;
size_t n;
if (nargs < 2 || nargs > 3) if (nargs < 2 || nargs > 3)
argcount("io.copy", nargs, 2); argcount("io.copy", nargs, 2);
struct ios *dest = toiostream(args[0], "io.copy"); dest = toiostream(args[0], "io.copy");
struct ios *src = toiostream(args[1], "io.copy"); src = toiostream(args[1], "io.copy");
if (nargs == 3) { if (nargs == 3) {
size_t n = toulong(args[2], "io.copy"); n = toulong(args[2], "io.copy");
return size_wrap(ios_copy(dest, src, n)); return size_wrap(ios_copy(dest, src, n));
} }
return size_wrap(ios_copyall(dest, src)); return size_wrap(ios_copyall(dest, src));
@ -423,16 +487,19 @@ value_t fl_iocopy(value_t *args, uint32_t nargs)
value_t stream_to_string(value_t *ps) value_t stream_to_string(value_t *ps)
{ {
struct ios *st;
char *b;
value_t str; value_t str;
size_t n; size_t n;
struct ios *st = value2c(struct ios *, *ps);
st = value2c(struct ios *, *ps);
if (st->buf == &st->local[0]) { if (st->buf == &st->local[0]) {
n = st->size; n = st->size;
str = cvalue_string(n); str = cvalue_string(n);
memcpy(cvalue_data(str), value2c(struct ios *, *ps)->buf, n); memcpy(cvalue_data(str), value2c(struct ios *, *ps)->buf, n);
ios_trunc(value2c(struct ios *, *ps), 0); ios_trunc(value2c(struct ios *, *ps), 0);
} else { } else {
char *b = ios_takebuf(st, &n); b = ios_takebuf(st, &n);
n--; n--;
b[n] = '\0'; b[n] = '\0';
str = cvalue_from_ref(stringtype, b, n, FL_NIL); str = cvalue_from_ref(stringtype, b, n, FL_NIL);
@ -443,8 +510,10 @@ value_t stream_to_string(value_t *ps)
value_t fl_iotostring(value_t *args, uint32_t nargs) value_t fl_iotostring(value_t *args, uint32_t nargs)
{ {
struct ios *src;
argcount("io.tostring!", nargs, 1); argcount("io.tostring!", nargs, 1);
struct ios *src = toiostream(args[0], "io.tostring!"); src = toiostream(args[0], "io.tostring!");
if (src->bm != bm_mem) if (src->bm != bm_mem)
lerror(ArgError, "io.tostring!: requires memory stream"); lerror(ArgError, "io.tostring!: requires memory stream");
return stream_to_string(&args[0]); return stream_to_string(&args[0]);

5
c/lookup3.h
View File

@ -479,6 +479,9 @@ size_t length, /* length of the key */
uint32_t *pc, /* IN: primary initval, OUT: primary hash */ uint32_t *pc, /* IN: primary initval, OUT: primary hash */
uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
{ {
#ifdef VALGRIND
const uint8_t *k8;
#endif
uint32_t a, b, c; /* internal state */ uint32_t a, b, c; /* internal state */
union { union {
const void *ptr; const void *ptr;
@ -492,7 +495,6 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
u.ptr = key; u.ptr = key;
if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) {
const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */
const uint8_t *k8;
/*------ all but last block: aligned reads and affect 32 bits of /*------ all but last block: aligned reads and affect 32 bits of
* (a,b,c) */ * (a,b,c) */
@ -517,7 +519,6 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
* noticably faster for short strings (like English words). * noticably faster for short strings (like English words).
*/ */
#ifndef VALGRIND #ifndef VALGRIND
(void)k8;
switch (length) { switch (length) {
case 12: case 12:
c += k[2]; c += k[2];

12
c/operators.h
View File

@ -272,11 +272,13 @@ int cmp_same_eq(void *a, void *b, numerictype_t tag)
int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag) int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag)
{ {
double da, db;
if (atag == btag) if (atag == btag)
return cmp_same_lt(a, b, atag); return cmp_same_lt(a, b, atag);
double da = conv_to_double(a, atag); da = conv_to_double(a, atag);
double db = conv_to_double(b, btag); db = conv_to_double(b, btag);
// casting to double will only get the wrong answer for big int64s // casting to double will only get the wrong answer for big int64s
// that differ in low bits // that differ in low bits
@ -327,15 +329,17 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag)
int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag, int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag,
int equalnans) int equalnans)
{ {
double da, db;
union { union {
double d; double d;
int64_t i64; int64_t i64;
} u, v; } u, v;
if (atag == btag && (!equalnans || atag < T_FLOAT)) if (atag == btag && (!equalnans || atag < T_FLOAT))
return cmp_same_eq(a, b, atag); return cmp_same_eq(a, b, atag);
double da = conv_to_double(a, atag); da = conv_to_double(a, atag);
double db = conv_to_double(b, btag); db = conv_to_double(b, btag);
if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) { if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) {
if (equalnans) { if (equalnans) {

97
c/print.h
View File

@ -10,6 +10,7 @@ static fixnum_t P_LEVEL;
static int SCR_WIDTH = 80; static int SCR_WIDTH = 80;
static int HPOS = 0, VPOS; static int HPOS = 0, VPOS;
static void outc(char c, struct ios *f) static void outc(char c, struct ios *f)
{ {
ios_putc(c, f); ios_putc(c, f);
@ -18,22 +19,27 @@ static void outc(char c, struct ios *f)
else else
HPOS++; HPOS++;
} }
static void outs(char *s, struct ios *f) static void outs(char *s, struct ios *f)
{ {
ios_puts(s, f); ios_puts(s, f);
HPOS += u8_strwidth(s); HPOS += u8_strwidth(s);
} }
static void outsn(char *s, struct ios *f, size_t n) static void outsn(char *s, struct ios *f, size_t n)
{ {
ios_write(f, s, n); ios_write(f, s, n);
HPOS += u8_strwidth(s); HPOS += u8_strwidth(s);
} }
static int outindent(int n, struct ios *f) static int outindent(int n, struct ios *f)
{ {
int n0;
// move back to left margin if we get too indented // move back to left margin if we get too indented
if (n > SCR_WIDTH - 12) if (n > SCR_WIDTH - 12)
n = 2; n = 2;
int n0 = n; n0 = n;
ios_putc('\n', f); ios_putc('\n', f);
VPOS++; VPOS++;
HPOS = n; HPOS = n;
@ -51,6 +57,7 @@ void fl_print_str(char *s, struct ios *f) { outs(s, f); }
void print_traverse(value_t v) void print_traverse(value_t v)
{ {
value_t *bp; value_t *bp;
while (iscons(v)) { while (iscons(v)) {
if (ismarked(v)) { if (ismarked(v)) {
bp = (value_t *)ptrhash_bp(&printconses, (void *)v); bp = (value_t *)ptrhash_bp(&printconses, (void *)v);
@ -71,26 +78,32 @@ void print_traverse(value_t v)
return; return;
} }
if (isvector(v)) { if (isvector(v)) {
unsigned int i;
if (vector_size(v) > 0) if (vector_size(v) > 0)
mark_cons(v); mark_cons(v);
unsigned int i;
for (i = 0; i < vector_size(v); i++) for (i = 0; i < vector_size(v); i++)
print_traverse(vector_elt(v, i)); print_traverse(vector_elt(v, i));
} else if (iscprim(v)) { } else if (iscprim(v)) {
// don't consider shared references to e.g. chars // don't consider shared references to e.g. chars
} else if (isclosure(v)) { } else if (isclosure(v)) {
struct function *f;
mark_cons(v); mark_cons(v);
struct function *f = (struct function *)ptr(v); f = (struct function *)ptr(v);
print_traverse(f->bcode); print_traverse(f->bcode);
print_traverse(f->vals); print_traverse(f->vals);
print_traverse(f->env); print_traverse(f->env);
} else { } else {
struct cvalue *cv;
struct fltype *t;
assert(iscvalue(v)); assert(iscvalue(v));
struct cvalue *cv = (struct cvalue *)ptr(v); cv = (struct cvalue *)ptr(v);
// don't consider shared references to "" // don't consider shared references to ""
if (!cv_isstr(cv) || cv_len(cv) != 0) if (!cv_isstr(cv) || cv_len(cv) != 0)
mark_cons(v); mark_cons(v);
struct fltype *t = cv_class(cv); t = cv_class(cv);
if (t->vtable != NULL && t->vtable->print_traverse != NULL) if (t->vtable != NULL && t->vtable->print_traverse != NULL)
t->vtable->print_traverse(v); t->vtable->print_traverse(v);
} }
@ -98,8 +111,9 @@ void print_traverse(value_t v)
static void print_symbol_name(struct ios *f, char *name) static void print_symbol_name(struct ios *f, char *name)
{ {
int i, escape = 0, charescape = 0; int i, escape, charescape;
escape = charescape = 0;
if ((name[0] == '\0') || (name[0] == '.' && name[1] == '\0') || if ((name[0] == '\0') || (name[0] == '.' && name[1] == '\0') ||
(name[0] == '#') || isnumtok(name, NULL)) (name[0] == '#') || isnumtok(name, NULL))
escape = 1; escape = 1;
@ -197,7 +211,9 @@ static int lengthestimate(value_t v)
static int allsmallp(value_t v) static int allsmallp(value_t v)
{ {
int n = 1; int n;
n = 1;
while (iscons(v)) { while (iscons(v)) {
if (!smallp(car_(v))) if (!smallp(car_(v)))
return 0; return 0;
@ -224,9 +240,11 @@ static int indentafter2(value_t head, value_t v)
static int indentevery(value_t v) static int indentevery(value_t v)
{ {
value_t c;
// indent before every subform of a special form, unless every // indent before every subform of a special form, unless every
// subform is "small" // subform is "small"
value_t c = car_(v); c = car_(v);
if (c == LAMBDA || c == setqsym) if (c == LAMBDA || c == setqsym)
return 0; return 0;
if (c == IF) // TODO: others if (c == IF) // TODO: others
@ -245,8 +263,12 @@ static int blockindent(value_t v)
static void print_pair(struct ios *f, value_t v) static void print_pair(struct ios *f, value_t v)
{ {
value_t cd; value_t cd, head;
char *op = NULL; char *op;
int startpos, newindent, blk, n_unindented;
int lastv, n, si, ind, est, always, nextsmall, thistiny, after2, after3;
op = NULL;
if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL && if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL &&
!ptrhash_has(&printconses, (void *)cdr_(v)) && !ptrhash_has(&printconses, (void *)cdr_(v)) &&
(((car_(v) == QUOTE) && (op = "'")) || (((car_(v) == QUOTE) && (op = "'")) ||
@ -261,16 +283,17 @@ static void print_pair(struct ios *f, value_t v)
fl_print_child(f, car_(cdr_(v))); fl_print_child(f, car_(cdr_(v)));
return; return;
} }
int startpos = HPOS; startpos = HPOS;
outc('(', f); outc('(', f);
int newindent = HPOS, blk = blockindent(v); newindent = HPOS;
int lastv, n = 0, si, ind = 0, est, always = 0, nextsmall, thistiny; blk = blockindent(v);
n = ind = always = 0;
if (!blk) if (!blk)
always = indentevery(v); always = indentevery(v);
value_t head = car_(v); head = car_(v);
int after3 = indentafter3(head, v); after3 = indentafter3(head, v);
int after2 = indentafter2(head, v); after2 = indentafter2(head, v);
int n_unindented = 1; n_unindented = 1;
while (1) { while (1) {
cd = cdr_(v); cd = cdr_(v);
if (print_length >= 0 && n >= print_length && cd != NIL) { if (print_length >= 0 && n >= print_length && cd != NIL) {
@ -339,6 +362,7 @@ static void cvalue_print(struct ios *f, value_t v);
static int print_circle_prefix(struct ios *f, value_t v) static int print_circle_prefix(struct ios *f, value_t v)
{ {
value_t label; value_t label;
if ((label = (value_t)ptrhash_get(&printconses, (void *)v)) != if ((label = (value_t)ptrhash_get(&printconses, (void *)v)) !=
(value_t)HT_NOTFOUND) { (value_t)HT_NOTFOUND) {
if (!ismarked(v)) { if (!ismarked(v)) {
@ -355,13 +379,13 @@ static int print_circle_prefix(struct ios *f, value_t v)
void fl_print_child(struct ios *f, value_t v) void fl_print_child(struct ios *f, value_t v)
{ {
char *name; char *name;
if (print_level >= 0 && P_LEVEL >= print_level && if (print_level >= 0 && P_LEVEL >= print_level &&
(iscons(v) || isvector(v) || isclosure(v))) { (iscons(v) || isvector(v) || isclosure(v))) {
outc('#', f); outc('#', f);
return; return;
} }
P_LEVEL++; P_LEVEL++;
switch (tag(v)) { switch (tag(v)) {
case TAG_NUM: case TAG_NUM:
case TAG_NUM1: case TAG_NUM1:
@ -393,12 +417,16 @@ void fl_print_child(struct ios *f, value_t v)
} else { } else {
assert(isclosure(v)); assert(isclosure(v));
if (!print_princ) { if (!print_princ) {
struct function *fn;
char *data;
size_t i, sz;
if (print_circle_prefix(f, v)) if (print_circle_prefix(f, v))
break; break;
struct function *fn = (struct function *)ptr(v); fn = (struct function *)ptr(v);
outs("#fn(", f); outs("#fn(", f);
char *data = cvalue_data(fn->bcode); data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(fn->bcode); sz = cvalue_len(fn->bcode);
for (i = 0; i < sz; i++) for (i = 0; i < sz; i++)
data[i] += 48; data[i] += 48;
fl_print_child(f, fn->bcode); fl_print_child(f, fn->bcode);
@ -432,9 +460,11 @@ void fl_print_child(struct ios *f, value_t v)
if (!print_princ && print_circle_prefix(f, v)) if (!print_princ && print_circle_prefix(f, v))
break; break;
if (isvector(v)) { if (isvector(v)) {
int newindent, est, sz, i;
outc('[', f); outc('[', f);
int newindent = HPOS, est; newindent = HPOS;
int i, sz = vector_size(v); sz = vector_size(v);
for (i = 0; i < sz; i++) { for (i = 0; i < sz; i++) {
if (print_length >= 0 && i >= print_length && i < sz - 1) { if (print_length >= 0 && i >= print_length && i < sz - 1) {
outsn("...", f, 3); outsn("...", f, 3);
@ -605,9 +635,10 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
else else
HPOS += ios_printf(f, "#byte(#x%hhx)", ch); HPOS += ios_printf(f, "#byte(#x%hhx)", ch);
} else if (type == wcharsym) { } else if (type == wcharsym) {
uint32_t wc = *(uint32_t *)data;
char seq[8]; char seq[8];
uint32_t wc = *(uint32_t *)data;
size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1); size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
seq[nb] = '\0'; seq[nb] = '\0';
if (print_princ) { if (print_princ) {
// TODO: better multibyte handling // TODO: better multibyte handling
@ -648,6 +679,7 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
char buf[64]; char buf[64];
double d; double d;
int ndec; int ndec;
if (type == floatsym) { if (type == floatsym) {
d = (double)*(float *)data; d = (double)*(float *)data;
ndec = 8; ndec = 8;
@ -657,6 +689,7 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
} }
if (!DFINITE(d)) { if (!DFINITE(d)) {
char *rep; char *rep;
if (isnan(d)) if (isnan(d))
rep = sign_bit(d) ? "-nan.0" : "+nan.0"; rep = sign_bit(d) ? "-nan.0" : "+nan.0";
else else
@ -673,8 +706,10 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
if (type == floatsym && !print_princ && !weak) if (type == floatsym && !print_princ && !weak)
outc('f', f); outc('f', f);
} else { } else {
int hasdec;
snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10); snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
int hasdec = (strpbrk(buf, ".eE") != NULL); hasdec = (strpbrk(buf, ".eE") != NULL);
outs(buf, f); outs(buf, f);
if (!hasdec) if (!hasdec)
outsn(".0", f, 2); outsn(".0", f, 2);
@ -707,7 +742,8 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
} else if (iscons(type)) { } else if (iscons(type)) {
if (car_(type) == arraysym) { if (car_(type) == arraysym) {
value_t eltype = car(cdr_(type)); value_t eltype = car(cdr_(type));
size_t cnt, elsize; size_t cnt, elsize, i;
if (iscons(cdr_(cdr_(type)))) { if (iscons(cdr_(cdr_(type)))) {
cnt = toulong(car_(cdr_(cdr_(type))), "length"); cnt = toulong(car_(cdr_(cdr_(type))), "length");
elsize = cnt ? len / cnt : 0; elsize = cnt ? len / cnt : 0;
@ -735,7 +771,6 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
// TODO wchar // TODO wchar
} else { } else {
} }
size_t i;
if (!weak) { if (!weak) {
if (eltype == uint8sym) { if (eltype == uint8sym) {
outsn("#vu8(", f, 5); outsn("#vu8(", f, 5);
@ -811,7 +846,9 @@ static void cvalue_print(struct ios *f, value_t v)
static void set_print_width(void) static void set_print_width(void)
{ {
value_t pw = symbol_value(printwidthsym); value_t pw;
pw = symbol_value(printwidthsym);
if (!isfixnum(pw)) if (!isfixnum(pw))
return; return;
SCR_WIDTH = numval(pw); SCR_WIDTH = numval(pw);
@ -819,12 +856,14 @@ static void set_print_width(void)
void fl_print(struct ios *f, value_t v) void fl_print(struct ios *f, value_t v)
{ {
value_t pl;
print_pretty = (symbol_value(printprettysym) != FL_F); print_pretty = (symbol_value(printprettysym) != FL_F);
if (print_pretty) if (print_pretty)
set_print_width(); set_print_width();
print_princ = (symbol_value(printreadablysym) == FL_F); print_princ = (symbol_value(printreadablysym) == FL_F);
value_t pl = symbol_value(printlengthsym); pl = symbol_value(printlengthsym);
if (isfixnum(pl)) if (isfixnum(pl))
print_length = numval(pl); print_length = numval(pl);
else else

50
c/read.h
View File

@ -394,16 +394,24 @@ static uint32_t peek(void)
tokval = fixnum(x); tokval = fixnum(x);
} else if (symchar(c)) { } else if (symchar(c)) {
read_token(ch, 0); read_token(ch, 0);
if (c == 'b') {
if (((c == 'b' && (base = 2)) || (c == 'o' && (base = 8)) || base = 2;
(c == 'd' && (base = 10)) || (c == 'x' && (base = 16))) && } else if (c == 'o') {
(isdigit_base(buf[1], base) || buf[1] == '-')) { base = 8;
} else if (c == 'd') {
base = 10;
} else if (c == 'x') {
base = 16;
} else {
base = 0;
}
if (base && (isdigit_base(buf[1], base) || buf[1] == '-')) {
if (!read_numtok(&buf[1], &tokval, base)) if (!read_numtok(&buf[1], &tokval, base))
lerrorf(ParseError, "read: invalid base %d constant", lerrorf(ParseError, "read: invalid base %d constant",
base); base);
return (toktype = TOK_NUM); toktype = TOK_NUM;
return toktype;
} }
toktype = TOK_SHARPSYM; toktype = TOK_SHARPSYM;
tokval = symbol(buf); tokval = symbol(buf);
} else { } else {
@ -439,11 +447,15 @@ static uint32_t peek(void)
// reader, and requires at least 1 and up to 3 garbage collections! // reader, and requires at least 1 and up to 3 garbage collections!
static value_t vector_grow(value_t v) static value_t vector_grow(value_t v)
{ {
size_t i, s = vector_size(v); value_t newv;
size_t d = vector_grow_amt(s); size_t i, s;
size_t d;
s = vector_size(v);
d = vector_grow_amt(s);
PUSH(v); PUSH(v);
assert(s + d > s); assert(s + d > s);
value_t newv = alloc_vector(s + d, 1); newv = alloc_vector(s + d, 1);
v = Stack[SP - 1]; v = Stack[SP - 1];
for (i = 0; i < s; i++) for (i = 0; i < s; i++)
vector_elt(newv, i) = vector_elt(v, i); vector_elt(newv, i) = vector_elt(v, i);
@ -459,8 +471,11 @@ static value_t vector_grow(value_t v)
static value_t read_vector(value_t label, uint32_t closer) static value_t read_vector(value_t label, uint32_t closer)
{ {
value_t v = the_empty_vector, elt; value_t v, elt;
uint32_t i = 0; uint32_t i;
v = the_empty_vector;
i = 0;
PUSH(v); PUSH(v);
if (label != UNBOUND) if (label != UNBOUND)
ptrhash_put(&readstate->backrefs, (void *)label, (void *)v); ptrhash_put(&readstate->backrefs, (void *)label, (void *)v);
@ -529,8 +544,17 @@ static value_t read_string(void)
wc = strtol(eseq, NULL, 8); wc = strtol(eseq, NULL, 8);
// \DDD and \xXX read bytes, not characters // \DDD and \xXX read bytes, not characters
buf[i++] = ((char)wc); buf[i++] = ((char)wc);
} else if ((c == 'x' && (ndig = 2)) || (c == 'u' && (ndig = 4)) || }
(c == 'U' && (ndig = 8))) { if (c == 'x') {
ndig = 2;
} else if (c == 'u') {
ndig = 4;
} else if (c == 'U') {
ndig = 8;
} else {
ndig = 0;
}
if (ndig) {
c = ios_getc(F); c = ios_getc(F);
while (hex_digit(c) && j < ndig && (c != IOS_EOF)) { while (hex_digit(c) && j < ndig && (c != IOS_EOF)) {
eseq[j++] = c; eseq[j++] = c;

200
c/string.c
View File

@ -42,13 +42,16 @@ value_t fl_stringp(value_t *args, uint32_t nargs)
value_t fl_string_count(value_t *args, uint32_t nargs) value_t fl_string_count(value_t *args, uint32_t nargs)
{ {
size_t start = 0; char *str;
size_t start, len, stop;
start = 0;
if (nargs < 1 || nargs > 3) if (nargs < 1 || nargs > 3)
argcount("string.count", nargs, 1); argcount("string.count", nargs, 1);
if (!fl_isstring(args[0])) if (!fl_isstring(args[0]))
type_error("string.count", "string", args[0]); type_error("string.count", "string", args[0]);
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
size_t stop = len; stop = len;
if (nargs > 1) { if (nargs > 1) {
start = toulong(args[1], "string.count"); start = toulong(args[1], "string.count");
if (start > len) if (start > len)
@ -61,12 +64,14 @@ value_t fl_string_count(value_t *args, uint32_t nargs)
return fixnum(0); return fixnum(0);
} }
} }
char *str = cvalue_data(args[0]); str = cvalue_data(args[0]);
return size_wrap(u8_charnum(str + start, stop - start)); return size_wrap(u8_charnum(str + start, stop - start));
} }
value_t fl_string_width(value_t *args, uint32_t nargs) value_t fl_string_width(value_t *args, uint32_t nargs)
{ {
char *s;
argcount("string.width", nargs, 1); argcount("string.width", nargs, 1);
if (iscprim(args[0])) { if (iscprim(args[0])) {
struct cprim *cp = (struct cprim *)ptr(args[0]); struct cprim *cp = (struct cprim *)ptr(args[0]);
@ -77,17 +82,20 @@ value_t fl_string_width(value_t *args, uint32_t nargs)
return fixnum(w); return fixnum(w);
} }
} }
char *s = tostring(args[0], "string.width"); s = tostring(args[0], "string.width");
return size_wrap(u8_strwidth(s)); return size_wrap(u8_strwidth(s));
} }
value_t fl_string_reverse(value_t *args, uint32_t nargs) value_t fl_string_reverse(value_t *args, uint32_t nargs)
{ {
size_t len;
value_t ns;
argcount("string.reverse", nargs, 1); argcount("string.reverse", nargs, 1);
if (!fl_isstring(args[0])) if (!fl_isstring(args[0]))
type_error("string.reverse", "string", args[0]); type_error("string.reverse", "string", args[0]);
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
value_t ns = cvalue_string(len); ns = cvalue_string(len);
u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len); u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
return ns; return ns;
} }
@ -110,11 +118,19 @@ value_t fl_string_encode(value_t *args, uint32_t nargs)
} }
} }
type_error("string.encode", "wchar array", args[0]); type_error("string.encode", "wchar array", args[0]);
return FL_NIL; // TODO: remove
} }
value_t fl_string_decode(value_t *args, uint32_t nargs) value_t fl_string_decode(value_t *args, uint32_t nargs)
{ {
int term = 0; int term;
struct cvalue *cv;
char *ptr;
size_t nb, nc, newsz;
value_t wcstr;
uint32_t *pwc;
term = 0;
if (nargs == 2) { if (nargs == 2) {
term = (args[1] != FL_F); term = (args[1] != FL_F);
} else { } else {
@ -122,16 +138,16 @@ value_t fl_string_decode(value_t *args, uint32_t nargs)
} }
if (!fl_isstring(args[0])) if (!fl_isstring(args[0]))
type_error("string.decode", "string", args[0]); type_error("string.decode", "string", args[0]);
struct cvalue *cv = (struct cvalue *)ptr(args[0]); cv = (struct cvalue *)ptr(args[0]);
char *ptr = (char *)cv_data(cv); ptr = (char *)cv_data(cv);
size_t nb = cv_len(cv); nb = cv_len(cv);
size_t nc = u8_charnum(ptr, nb); nc = u8_charnum(ptr, nb);
size_t newsz = nc * sizeof(uint32_t); newsz = nc * sizeof(uint32_t);
if (term) if (term)
newsz += sizeof(uint32_t); newsz += sizeof(uint32_t);
value_t wcstr = cvalue(wcstringtype, newsz); wcstr = cvalue(wcstringtype, newsz);
ptr = cv_data((struct cvalue *)ptr(args[0])); // relocatable pointer ptr = cv_data((struct cvalue *)ptr(args[0])); // relocatable pointer
uint32_t *pwc = cvalue_data(wcstr); pwc = cvalue_data(wcstr);
u8_toucs(pwc, nc, ptr, nb); u8_toucs(pwc, nc, ptr, nb);
if (term) if (term)
pwc[nc] = 0; pwc[nc] = 0;
@ -143,37 +159,44 @@ extern value_t stream_to_string(value_t *ps);
value_t fl_string(value_t *args, uint32_t nargs) value_t fl_string(value_t *args, uint32_t nargs)
{ {
value_t arg, buf;
struct ios *s;
uint32_t i;
value_t oldpr, oldpp, outp;
if (nargs == 1 && fl_isstring(args[0])) if (nargs == 1 && fl_isstring(args[0]))
return args[0]; return args[0];
value_t arg, buf = fl_buffer(NULL, 0); buf = fl_buffer(NULL, 0);
fl_gc_handle(&buf); fl_gc_handle(&buf);
struct ios *s = value2c(struct ios *, buf); s = value2c(struct ios *, buf);
uint32_t i; oldpr = symbol_value(printreadablysym);
value_t oldpr = symbol_value(printreadablysym); oldpp = symbol_value(printprettysym);
value_t oldpp = symbol_value(printprettysym);
set(printreadablysym, FL_F); set(printreadablysym, FL_F);
set(printprettysym, FL_F); set(printprettysym, FL_F);
FOR_ARGS(i, 0, arg, args) { fl_print(s, args[i]); } FOR_ARGS(i, 0, arg, args) { fl_print(s, args[i]); }
set(printreadablysym, oldpr); set(printreadablysym, oldpr);
set(printprettysym, oldpp); set(printprettysym, oldpp);
value_t outp = stream_to_string(&buf); outp = stream_to_string(&buf);
fl_free_gc_handles(1); fl_free_gc_handles(1);
return outp; return outp;
} }
value_t fl_string_split(value_t *args, uint32_t nargs) value_t fl_string_split(value_t *args, uint32_t nargs)
{ {
char *s;
char *delim;
size_t len, dlen, ssz, tokend, tokstart, i, junk;
value_t first, c, last;
argcount("string.split", nargs, 2); argcount("string.split", nargs, 2);
char *s = tostring(args[0], "string.split"); s = tostring(args[0], "string.split");
char *delim = tostring(args[1], "string.split"); delim = tostring(args[1], "string.split");
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
size_t dlen = cv_len((struct cvalue *)ptr(args[1])); dlen = cv_len((struct cvalue *)ptr(args[1]));
size_t ssz, tokend = 0, tokstart = 0, i = 0; tokend = tokstart = i = 0;
value_t first = FL_NIL, c = FL_NIL, last; first = c = FL_NIL;
size_t junk;
fl_gc_handle(&first); fl_gc_handle(&first);
fl_gc_handle(&last); fl_gc_handle(&last);
do { do {
// find and allocate next token // find and allocate next token
tokstart = tokend = i; tokstart = tokend = i;
@ -207,11 +230,14 @@ value_t fl_string_split(value_t *args, uint32_t nargs)
value_t fl_string_sub(value_t *args, uint32_t nargs) value_t fl_string_sub(value_t *args, uint32_t nargs)
{ {
char *s;
size_t len, i1, i2;
value_t ns;
if (nargs != 2) if (nargs != 2)
argcount("string.sub", nargs, 3); argcount("string.sub", nargs, 3);
char *s = tostring(args[0], "string.sub"); s = tostring(args[0], "string.sub");
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
size_t i1, i2;
i1 = toulong(args[1], "string.sub"); i1 = toulong(args[1], "string.sub");
if (i1 > len) if (i1 > len)
bounds_error("string.sub", args[0], args[1]); bounds_error("string.sub", args[0], args[1]);
@ -224,20 +250,23 @@ value_t fl_string_sub(value_t *args, uint32_t nargs)
} }
if (i2 <= i1) if (i2 <= i1)
return cvalue_string(0); return cvalue_string(0);
value_t ns = cvalue_string(i2 - i1); ns = cvalue_string(i2 - i1);
memcpy(cv_data((struct cvalue *)ptr(ns)), &s[i1], i2 - i1); memcpy(cv_data((struct cvalue *)ptr(ns)), &s[i1], i2 - i1);
return ns; return ns;
} }
value_t fl_string_char(value_t *args, uint32_t nargs) value_t fl_string_char(value_t *args, uint32_t nargs)
{ {
char *s;
size_t len, i, sl;
argcount("string.char", nargs, 2); argcount("string.char", nargs, 2);
char *s = tostring(args[0], "string.char"); s = tostring(args[0], "string.char");
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
size_t i = toulong(args[1], "string.char"); i = toulong(args[1], "string.char");
if (i >= len) if (i >= len)
bounds_error("string.char", args[0], args[1]); bounds_error("string.char", args[0], args[1]);
size_t sl = u8_seqlen(&s[i]); sl = u8_seqlen(&s[i]);
if (sl > len || i > len - sl) if (sl > len || i > len - sl)
bounds_error("string.char", args[0], args[1]); bounds_error("string.char", args[0], args[1]);
return mk_wchar(u8_nextchar(s, &i)); return mk_wchar(u8_nextchar(s, &i));
@ -245,16 +274,20 @@ value_t fl_string_char(value_t *args, uint32_t nargs)
value_t fl_char_upcase(value_t *args, uint32_t nargs) value_t fl_char_upcase(value_t *args, uint32_t nargs)
{ {
struct cprim *cp;
argcount("char.upcase", nargs, 1); argcount("char.upcase", nargs, 1);
struct cprim *cp = (struct cprim *)ptr(args[0]); cp = (struct cprim *)ptr(args[0]);
if (!iscprim(args[0]) || cp_class(cp) != wchartype) if (!iscprim(args[0]) || cp_class(cp) != wchartype)
type_error("char.upcase", "wchar", args[0]); type_error("char.upcase", "wchar", args[0]);
return mk_wchar(towupper(*(int32_t *)cp_data(cp))); return mk_wchar(towupper(*(int32_t *)cp_data(cp)));
} }
value_t fl_char_downcase(value_t *args, uint32_t nargs) value_t fl_char_downcase(value_t *args, uint32_t nargs)
{ {
struct cprim *cp;
argcount("char.downcase", nargs, 1); argcount("char.downcase", nargs, 1);
struct cprim *cp = (struct cprim *)ptr(args[0]); cp = (struct cprim *)ptr(args[0]);
if (!iscprim(args[0]) || cp_class(cp) != wchartype) if (!iscprim(args[0]) || cp_class(cp) != wchartype)
type_error("char.downcase", "wchar", args[0]); type_error("char.downcase", "wchar", args[0]);
return mk_wchar(towlower(*(int32_t *)cp_data(cp))); return mk_wchar(towlower(*(int32_t *)cp_data(cp)));
@ -262,8 +295,10 @@ value_t fl_char_downcase(value_t *args, uint32_t nargs)
value_t fl_char_alpha(value_t *args, uint32_t nargs) value_t fl_char_alpha(value_t *args, uint32_t nargs)
{ {
struct cprim *cp;
argcount("char-alphabetic?", nargs, 1); argcount("char-alphabetic?", nargs, 1);
struct cprim *cp = (struct cprim *)ptr(args[0]); cp = (struct cprim *)ptr(args[0]);
if (!iscprim(args[0]) || cp_class(cp) != wchartype) if (!iscprim(args[0]) || cp_class(cp) != wchartype)
type_error("char-alphabetic?", "wchar", args[0]); type_error("char-alphabetic?", "wchar", args[0]);
return iswalpha(*(int32_t *)cp_data(cp)) ? FL_T : FL_F; return iswalpha(*(int32_t *)cp_data(cp)) ? FL_T : FL_F;
@ -271,7 +306,9 @@ value_t fl_char_alpha(value_t *args, uint32_t nargs)
static value_t mem_find_byte(char *s, char c, size_t start, size_t len) static value_t mem_find_byte(char *s, char c, size_t start, size_t len)
{ {
char *p = memchr(s + start, c, len - start); char *p;
p = memchr(s + start, c, len - start);
if (p == NULL) if (p == NULL)
return FL_F; return FL_F;
return size_wrap((size_t)(p - s)); return size_wrap((size_t)(p - s));
@ -280,20 +317,25 @@ static value_t mem_find_byte(char *s, char c, size_t start, size_t len)
value_t fl_string_find(value_t *args, uint32_t nargs) value_t fl_string_find(value_t *args, uint32_t nargs)
{ {
char cbuf[8]; char cbuf[8];
size_t start = 0; char *s;
char *needle;
struct cprim *cp;
value_t v;
size_t start, len, needlesz, i;
if (nargs == 3) if (nargs == 3)
start = toulong(args[2], "string.find"); start = toulong(args[2], "string.find");
else else {
argcount("string.find", nargs, 2); argcount("string.find", nargs, 2);
char *s = tostring(args[0], "string.find"); start = 0;
size_t len = cv_len((struct cvalue *)ptr(args[0])); }
s = tostring(args[0], "string.find");
len = cv_len((struct cvalue *)ptr(args[0]));
if (start > len) if (start > len)
bounds_error("string.find", args[0], args[2]); bounds_error("string.find", args[0], args[2]);
char *needle;
size_t needlesz;
value_t v = args[1]; v = args[1];
struct cprim *cp = (struct cprim *)ptr(v); cp = (struct cprim *)ptr(v);
if (iscprim(v) && cp_class(cp) == wchartype) { if (iscprim(v) && cp_class(cp) == wchartype) {
uint32_t c = *(uint32_t *)cp_data(cp); uint32_t c = *(uint32_t *)cp_data(cp);
if (c <= 0x7f) if (c <= 0x7f)
@ -315,7 +357,6 @@ value_t fl_string_find(value_t *args, uint32_t nargs)
return mem_find_byte(s, needle[0], start, len); return mem_find_byte(s, needle[0], start, len);
else if (needlesz == 0) else if (needlesz == 0)
return size_wrap(start); return size_wrap(start);
size_t i;
for (i = start; i < len - needlesz + 1; i++) { for (i = start; i < len - needlesz + 1; i++) {
if (s[i] == needle[0]) { if (s[i] == needle[0]) {
if (!memcmp(&s[i + 1], needle + 1, needlesz - 1)) if (!memcmp(&s[i + 1], needle + 1, needlesz - 1))
@ -327,12 +368,15 @@ value_t fl_string_find(value_t *args, uint32_t nargs)
value_t fl_string_inc(value_t *args, uint32_t nargs) value_t fl_string_inc(value_t *args, uint32_t nargs)
{ {
char *s;
size_t len, cnt, i;
if (nargs < 2 || nargs > 3) if (nargs < 2 || nargs > 3)
argcount("string.inc", nargs, 2); argcount("string.inc", nargs, 2);
char *s = tostring(args[0], "string.inc"); s = tostring(args[0], "string.inc");
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
size_t i = toulong(args[1], "string.inc"); i = toulong(args[1], "string.inc");
size_t cnt = 1; cnt = 1;
if (nargs == 3) if (nargs == 3)
cnt = toulong(args[2], "string.inc"); cnt = toulong(args[2], "string.inc");
while (cnt--) { while (cnt--) {
@ -345,12 +389,15 @@ value_t fl_string_inc(value_t *args, uint32_t nargs)
value_t fl_string_dec(value_t *args, uint32_t nargs) value_t fl_string_dec(value_t *args, uint32_t nargs)
{ {
char *s;
size_t len, cnt, i;
if (nargs < 2 || nargs > 3) if (nargs < 2 || nargs > 3)
argcount("string.dec", nargs, 2); argcount("string.dec", nargs, 2);
char *s = tostring(args[0], "string.dec"); s = tostring(args[0], "string.dec");
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
size_t i = toulong(args[1], "string.dec"); i = toulong(args[1], "string.dec");
size_t cnt = 1; cnt = 1;
if (nargs == 3) if (nargs == 3)
cnt = toulong(args[2], "string.dec"); cnt = toulong(args[2], "string.dec");
// note: i is allowed to start at index len // note: i is allowed to start at index len
@ -366,7 +413,9 @@ value_t fl_string_dec(value_t *args, uint32_t nargs)
static unsigned long get_radix_arg(value_t arg, char *fname) static unsigned long get_radix_arg(value_t arg, char *fname)
{ {
unsigned long radix = toulong(arg, fname); unsigned long radix;
radix = toulong(arg, fname);
if (radix < 2 || radix > 36) if (radix < 2 || radix > 36)
lerrorf(ArgError, "%s: invalid radix", fname); lerrorf(ArgError, "%s: invalid radix", fname);
return radix; return radix;
@ -374,11 +423,17 @@ static unsigned long get_radix_arg(value_t arg, char *fname)
value_t fl_numbertostring(value_t *args, uint32_t nargs) value_t fl_numbertostring(value_t *args, uint32_t nargs)
{ {
char buf[128];
uint64_t num;
unsigned long radix;
value_t n;
char *str;
int neg;
if (nargs < 1 || nargs > 2) if (nargs < 1 || nargs > 2)
argcount("number->string", nargs, 2); argcount("number->string", nargs, 2);
value_t n = args[0]; n = args[0];
int neg = 0; neg = 0;
uint64_t num;
if (isfixnum(n)) if (isfixnum(n))
num = numval(n); num = numval(n);
else if (!iscprim(n)) else if (!iscprim(n))
@ -390,11 +445,10 @@ value_t fl_numbertostring(value_t *args, uint32_t nargs)
num = -num; num = -num;
neg = 1; neg = 1;
} }
unsigned long radix = 10; radix = 10;
if (nargs == 2) if (nargs == 2)
radix = get_radix_arg(args[1], "number->string"); radix = get_radix_arg(args[1], "number->string");
char buf[128]; str = uint2str(buf, sizeof(buf), num, radix);
char *str = uint2str(buf, sizeof(buf), num, radix);
if (neg && str > &buf[0]) if (neg && str > &buf[0])
*(--str) = '-'; *(--str) = '-';
return string_from_cstr(str); return string_from_cstr(str);
@ -402,11 +456,14 @@ value_t fl_numbertostring(value_t *args, uint32_t nargs)
value_t fl_stringtonumber(value_t *args, uint32_t nargs) value_t fl_stringtonumber(value_t *args, uint32_t nargs)
{ {
char *str;
value_t n;
unsigned long radix;
if (nargs < 1 || nargs > 2) if (nargs < 1 || nargs > 2)
argcount("string->number", nargs, 2); argcount("string->number", nargs, 2);
char *str = tostring(args[0], "string->number"); str = tostring(args[0], "string->number");
value_t n; radix = 0;
unsigned long radix = 0;
if (nargs == 2) if (nargs == 2)
radix = get_radix_arg(args[1], "string->number"); radix = get_radix_arg(args[1], "string->number");
if (!isnumtok_base(str, &n, (int)radix)) if (!isnumtok_base(str, &n, (int)radix))
@ -416,9 +473,12 @@ value_t fl_stringtonumber(value_t *args, uint32_t nargs)
value_t fl_string_isutf8(value_t *args, uint32_t nargs) value_t fl_string_isutf8(value_t *args, uint32_t nargs)
{ {
char *s;
size_t len;
argcount("string.isutf8", nargs, 1); argcount("string.isutf8", nargs, 1);
char *s = tostring(args[0], "string.isutf8"); s = tostring(args[0], "string.isutf8");
size_t len = cv_len((struct cvalue *)ptr(args[0])); len = cv_len((struct cvalue *)ptr(args[0]));
return u8_isvalid(s, len) ? FL_T : FL_F; return u8_isvalid(s, len) ? FL_T : FL_F;
} }

61
c/table.c
View File

@ -70,12 +70,14 @@ void free_htable(value_t self)
void relocate_htable(value_t oldv, value_t newv) void relocate_htable(value_t oldv, value_t newv)
{ {
struct htable *oldh = size_t i;
(struct htable *)cv_data((struct cvalue *)ptr(oldv)); struct htable *oldh;
struct htable *h = (struct htable *)cv_data((struct cvalue *)ptr(newv)); struct htable *h;
oldh = (struct htable *)cv_data((struct cvalue *)ptr(oldv));
h = (struct htable *)cv_data((struct cvalue *)ptr(newv));
if (oldh->table == &oldh->_space[0]) if (oldh->table == &oldh->_space[0])
h->table = &h->_space[0]; h->table = &h->_space[0];
size_t i;
for (i = 0; i < h->size; i++) { for (i = 0; i < h->size; i++) {
if (h->table[i] != HT_NOTFOUND) if (h->table[i] != HT_NOTFOUND)
h->table[i] = (void *)relocate_lispvalue((value_t)h->table[i]); h->table[i] = (void *)relocate_lispvalue((value_t)h->table[i]);
@ -105,10 +107,14 @@ static struct htable *totable(value_t v, char *fname)
value_t fl_table(value_t *args, uint32_t nargs) value_t fl_table(value_t *args, uint32_t nargs)
{ {
size_t cnt = (size_t)nargs; struct htable *h;
value_t nt, k, arg;
size_t cnt;
uint32_t i;
cnt = (size_t)nargs;
if (cnt & 1) if (cnt & 1)
lerror(ArgError, "table: arguments must come in pairs"); lerror(ArgError, "table: arguments must come in pairs");
value_t nt;
// prevent small tables from being added to finalizer list // prevent small tables from being added to finalizer list
if (cnt <= HT_N_INLINE) { if (cnt <= HT_N_INLINE) {
tabletype->vtable->finalize = NULL; tabletype->vtable->finalize = NULL;
@ -117,10 +123,10 @@ value_t fl_table(value_t *args, uint32_t nargs)
} else { } else {
nt = cvalue(tabletype, 2 * sizeof(void *)); nt = cvalue(tabletype, 2 * sizeof(void *));
} }
struct htable *h = (struct htable *)cv_data((struct cvalue *)ptr(nt)); h = (struct htable *)cv_data((struct cvalue *)ptr(nt));
htable_new(h, cnt / 2); htable_new(h, cnt / 2);
uint32_t i; k = FL_NIL;
value_t k = FL_NIL, arg = FL_NIL; arg = FL_NIL;
FOR_ARGS(i, 0, arg, args) FOR_ARGS(i, 0, arg, args)
{ {
if (i & 1) if (i & 1)
@ -134,9 +140,12 @@ value_t fl_table(value_t *args, uint32_t nargs)
// (put! table key value) // (put! table key value)
value_t fl_table_put(value_t *args, uint32_t nargs) value_t fl_table_put(value_t *args, uint32_t nargs)
{ {
struct htable *h;
void **table0;
argcount("put!", nargs, 3); argcount("put!", nargs, 3);
struct htable *h = totable(args[0], "put!"); h = totable(args[0], "put!");
void **table0 = h->table; table0 = h->table;
equalhash_put(h, (void *)args[1], (void *)args[2]); equalhash_put(h, (void *)args[1], (void *)args[2]);
// register finalizer if we outgrew inline space // register finalizer if we outgrew inline space
if (table0 == &h->_space[0] && h->table != &h->_space[0]) { if (table0 == &h->_space[0] && h->table != &h->_space[0]) {
@ -155,10 +164,13 @@ static void key_error(char *fname, value_t key)
// (get table key [default]) // (get table key [default])
value_t fl_table_get(value_t *args, uint32_t nargs) value_t fl_table_get(value_t *args, uint32_t nargs)
{ {
struct htable *h;
value_t v;
if (nargs != 3) if (nargs != 3)
argcount("get", nargs, 2); argcount("get", nargs, 2);
struct htable *h = totable(args[0], "get"); h = totable(args[0], "get");
value_t v = (value_t)equalhash_get(h, (void *)args[1]); v = (value_t)equalhash_get(h, (void *)args[1]);
if (v == (value_t)HT_NOTFOUND) { if (v == (value_t)HT_NOTFOUND) {
if (nargs == 3) if (nargs == 3)
return args[2]; return args[2];
@ -170,16 +182,20 @@ value_t fl_table_get(value_t *args, uint32_t nargs)
// (has? table key) // (has? table key)
value_t fl_table_has(value_t *args, uint32_t nargs) value_t fl_table_has(value_t *args, uint32_t nargs)
{ {
struct htable *h;
argcount("has", nargs, 2); argcount("has", nargs, 2);
struct htable *h = totable(args[0], "has"); h = totable(args[0], "has");
return equalhash_has(h, (void *)args[1]) ? FL_T : FL_F; return equalhash_has(h, (void *)args[1]) ? FL_T : FL_F;
} }
// (del! table key) // (del! table key)
value_t fl_table_del(value_t *args, uint32_t nargs) value_t fl_table_del(value_t *args, uint32_t nargs)
{ {
struct htable *h;
argcount("del!", nargs, 2); argcount("del!", nargs, 2);
struct htable *h = totable(args[0], "del!"); h = totable(args[0], "del!");
if (!equalhash_remove(h, (void *)args[1])) if (!equalhash_remove(h, (void *)args[1]))
key_error("del!", args[1]); key_error("del!", args[1]);
return args[0]; return args[0];
@ -187,11 +203,18 @@ value_t fl_table_del(value_t *args, uint32_t nargs)
value_t fl_table_foldl(value_t *args, uint32_t nargs) value_t fl_table_foldl(value_t *args, uint32_t nargs)
{ {
struct htable *h;
void **table;
size_t i, n;
value_t f, zero, t;
argcount("table.foldl", nargs, 3); argcount("table.foldl", nargs, 3);
value_t f = args[0], zero = args[1], t = args[2]; f = args[0];
struct htable *h = totable(t, "table.foldl"); zero = args[1];
size_t i, n = h->size; t = args[2];
void **table = h->table; h = totable(t, "table.foldl");
n = h->size;
table = h->table;
fl_gc_handle(&f); fl_gc_handle(&f);
fl_gc_handle(&zero); fl_gc_handle(&zero);
fl_gc_handle(&t); fl_gc_handle(&t);

22
c/types.h
View File

@ -1,25 +1,25 @@
struct fltype *get_type(value_t t) struct fltype *get_type(value_t t)
{ {
struct fltype *ft; struct fltype *ft;
void **bp;
size_t sz;
int align, isarray;
if (issymbol(t)) { if (issymbol(t)) {
ft = ((struct symbol *)ptr(t))->type; ft = ((struct symbol *)ptr(t))->type;
if (ft != NULL) if (ft != NULL)
return ft; return ft;
} }
void **bp = equalhash_bp(&TypeTable, (void *)t); bp = equalhash_bp(&TypeTable, (void *)t);
if (*bp != HT_NOTFOUND) if (*bp != HT_NOTFOUND)
return *bp; return *bp;
int align,
isarray = (iscons(t) && car_(t) == arraysym && iscons(cdr_(t))); isarray = (iscons(t) && car_(t) == arraysym && iscons(cdr_(t)));
size_t sz;
if (isarray && !iscons(cdr_(cdr_(t)))) { if (isarray && !iscons(cdr_(cdr_(t)))) {
// special case: incomplete array type // special case: incomplete array type
sz = 0; sz = 0;
} else { } else {
sz = ctype_sizeof(t, &align); sz = ctype_sizeof(t, &align);
} }
ft = (struct fltype *)malloc(sizeof(struct fltype)); ft = (struct fltype *)malloc(sizeof(struct fltype));
ft->type = t; ft->type = t;
if (issymbol(t)) { if (issymbol(t)) {
@ -58,7 +58,9 @@ struct fltype *get_type(value_t t)
struct fltype *get_array_type(value_t eltype) struct fltype *get_array_type(value_t eltype)
{ {
struct fltype *et = get_type(eltype); struct fltype *et;
et = get_type(eltype);
if (et->artype == NULL) if (et->artype == NULL)
et->artype = get_type(fl_list2(arraysym, eltype)); et->artype = get_type(fl_list2(arraysym, eltype));
return et->artype; return et->artype;
@ -67,7 +69,9 @@ struct fltype *get_array_type(value_t eltype)
struct fltype *define_opaque_type(value_t sym, size_t sz, struct fltype *define_opaque_type(value_t sym, size_t sz,
struct cvtable *vtab, cvinitfunc_t init) struct cvtable *vtab, cvinitfunc_t init)
{ {
struct fltype *ft = (struct fltype *)malloc(sizeof(struct fltype)); struct fltype *ft;
ft = (struct fltype *)malloc(sizeof(struct fltype));
ft->type = sym; ft->type = sym;
ft->size = sz; ft->size = sz;
ft->numtype = N_NUMTYPES; ft->numtype = N_NUMTYPES;
@ -82,9 +86,11 @@ struct fltype *define_opaque_type(value_t sym, size_t sz,
void relocate_typetable(void) void relocate_typetable(void)
{ {
struct htable *h = &TypeTable; struct htable *h;
size_t i; size_t i;
void *nv; void *nv;
h = &TypeTable;
for (i = 0; i < h->size; i += 2) { for (i = 0; i < h->size; i += 2) {
if (h->table[i] != HT_NOTFOUND) { if (h->table[i] != HT_NOTFOUND) {
nv = (void *)relocate((value_t)h->table[i]); nv = (void *)relocate((value_t)h->table[i]);

31
c/utf8.c
View File

@ -391,13 +391,16 @@ char read_escape_control_char(char c)
returns number of input characters processed, 0 if error */ returns number of input characters processed, 0 if error */
size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest) size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest)
{ {
assert(ssz > 0);
uint32_t ch; uint32_t ch;
char digs[10]; char digs[10];
int dno = 0, ndig; int dno, ndig;
size_t i = 1; size_t i;
char c0 = str[0]; char c0;
assert(ssz > 0);
dno = 0;
i = 1;
c0 = str[0];
if (octal_digit(c0)) { if (octal_digit(c0)) {
i = 0; i = 0;
do { do {
@ -405,8 +408,19 @@ size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest)
} while (i < ssz && octal_digit(str[i]) && dno < 3); } while (i < ssz && octal_digit(str[i]) && dno < 3);
digs[dno] = '\0'; digs[dno] = '\0';
ch = strtol(digs, NULL, 8); ch = strtol(digs, NULL, 8);
} else if ((c0 == 'x' && (ndig = 2)) || (c0 == 'u' && (ndig = 4)) || *dest = ch;
(c0 == 'U' && (ndig = 8))) { return i;
}
if (c0 == 'x') {
ndig = 2;
} else if (c0 == 'u') {
ndig = 4;
} else if (c0 == 'U') {
ndig = 8;
} else {
ndig = 0;
}
if (ndig) {
while (i < ssz && hex_digit(str[i]) && dno < ndig) { while (i < ssz && hex_digit(str[i]) && dno < ndig) {
digs[dno++] = str[i++]; digs[dno++] = str[i++];
} }
@ -418,7 +432,6 @@ size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest)
ch = (uint32_t)read_escape_control_char(c0); ch = (uint32_t)read_escape_control_char(c0);
} }
*dest = ch; *dest = ch;
return i; return i;
} }
@ -599,11 +612,13 @@ char *u8_memrchr(const char *s, uint32_t ch, size_t sz)
int u8_is_locale_utf8(const char *locale) int u8_is_locale_utf8(const char *locale)
{ {
const char *cp;
if (locale == NULL) if (locale == NULL)
return 0; return 0;
/* this code based on libutf8 */ /* this code based on libutf8 */
const char *cp = locale; cp = locale;
for (; *cp != '\0' && *cp != '@' && *cp != '+' && *cp != ','; cp++) { for (; *cp != '\0' && *cp != '@' && *cp != '+' && *cp != ','; cp++) {
if (*cp == '.') { if (*cp == '.') {