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)
{
value_t lst, first;
value_t *pcdr;
struct cons *c;
uint32_t i;
if (nargs == 0)
return FL_NIL;
value_t lst, first = FL_NIL;
value_t *pcdr = &first;
struct cons *c;
uint32_t i = 0;
first = FL_NIL;
pcdr = &first;
i = 0;
while (1) {
lst = args[i++];
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)
{
argcount("assq", nargs, 2);
value_t item = args[0];
value_t v = args[1];
value_t item;
value_t v;
value_t bind;
argcount("assq", nargs, 2);
item = args[0];
v = args[1];
while (iscons(v)) {
bind = car_(v);
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)
{
argcount("length", nargs, 1);
value_t a = args[0];
value_t a;
struct cvalue *cv;
argcount("length", nargs, 1);
a = args[0];
if (isvector(a)) {
return fixnum(vector_size(a));
} else if (iscprim(a)) {
@ -123,12 +131,14 @@ static value_t fl_length(value_t *args, uint32_t nargs)
return fixnum(llength(a));
}
type_error("length", "sequence", a);
return FL_NIL; // TODO
}
static value_t fl_f_raise(value_t *args, uint32_t nargs)
{
argcount("raise", nargs, 1);
fl_raise(args[0]);
return FL_NIL; // TODO
}
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)
{
struct symbol *sym;
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)
fl_raise(fl_list2(UnboundError, args[0]));
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)
{
struct symbol *sym;
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))
sym->binding = 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 lst;
(void)args;
argcount("environment", nargs, 0);
value_t lst = FL_NIL;
lst = FL_NIL;
fl_gc_handle(&lst);
global_env_list(symtab, &lst);
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)
{
value_t v;
double d;
void *data;
argcount("integer-valued?", nargs, 1);
value_t v = args[0];
v = args[0];
if (isfixnum(v)) {
return FL_T;
} else if (iscprim(v)) {
numerictype_t nt = cp_numtype((struct cprim *)ptr(v));
if (nt < T_FLOAT)
return FL_T;
void *data = cp_data((struct cprim *)ptr(v));
data = cp_data((struct cprim *)ptr(v));
if (nt == T_FLOAT) {
float f = *(float *)data;
if (f < 0)
@ -231,7 +251,7 @@ static value_t fl_integer_valuedp(value_t *args, uint32_t nargs)
return FL_T;
} else {
assert(nt == T_DOUBLE);
double d = *(double *)data;
d = *(double *)data;
if (d < 0)
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)
{
value_t v;
argcount("integer?", nargs, 1);
value_t v = args[0];
v = args[0];
return (isfixnum(v) ||
(iscprim(v) && cp_numtype((struct cprim *)ptr(v)) < T_FLOAT))
? 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)));
}
type_error("fixnum", "number", args[0]);
return FL_NIL; // TODO
}
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);
}
type_error("truncate", "number", args[0]);
return FL_NIL; // TODO
}
static value_t fl_vector_alloc(value_t *args, uint32_t nargs)
{
fixnum_t i;
value_t f, v;
int k;
if (nargs == 0)
lerror(ArgError, "vector.alloc: too few arguments");
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];
else
f = FL_UNSPECIFIED;
int k;
for (k = 0; k < i; k++)
vector_elt(v, k) = f;
return v;
@ -328,10 +353,13 @@ static double todouble(value_t a, char *fname)
return conv_to_double(cp_data(cp), nt);
}
type_error(fname, "number", a);
return FL_NIL; // TODO
}
static value_t fl_path_cwd(value_t *args, uint32_t nargs)
{
char *ptr;
if (nargs > 1)
argcount("path.cwd", nargs, 1);
if (nargs == 0) {
@ -339,7 +367,7 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs)
get_cwd(buf, sizeof(buf));
return string_from_cstr(buf);
}
char *ptr = tostring(args[0], "path.cwd");
ptr = tostring(args[0], "path.cwd");
if (set_cwd(ptr))
lerrorf(IOError, "path.cwd: could not cd to %s", ptr);
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)
{
char *str;
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;
}
static value_t fl_os_getenv(value_t *args, uint32_t nargs)
{
char *name;
char *val;
argcount("os.getenv", nargs, 1);
char *name = tostring(args[0], "os.getenv");
char *val = getenv(name);
name = tostring(args[0], "os.getenv");
val = getenv(name);
if (val == NULL)
return FL_F;
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)
{
argcount("os.setenv", nargs, 2);
char *name = tostring(args[0], "os.setenv");
char *name;
char *val;
int result;
argcount("os.setenv", nargs, 2);
name = tostring(args[0], "os.setenv");
if (args[1] == FL_F) {
result = unsetenv(name);
unsetenv(name);
} else {
char *val = tostring(args[1], "os.setenv");
val = tostring(args[1], "os.setenv");
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;
}
static value_t fl_rand(value_t *args, uint32_t nargs)
{
fixnum_t r;
(void)args;
(void)nargs;
fixnum_t r;
#ifdef BITS64
r = ((((uint64_t)random()) << 32) | random()) & 0x1fffffffffffffffLL;
#else
@ -392,30 +430,38 @@ static value_t fl_rand(value_t *args, uint32_t nargs)
#endif
return fixnum(r);
}
static value_t fl_rand32(value_t *args, uint32_t nargs)
{
uint32_t r;
(void)args;
(void)nargs;
uint32_t r = random();
r = random();
#ifdef BITS64
return fixnum(r);
#else
return mk_uint32(r);
#endif
}
static value_t fl_rand64(value_t *args, uint32_t nargs)
{
uint64_t r;
(void)args;
(void)nargs;
uint64_t r = (((uint64_t)random()) << 32) | random();
r = (((uint64_t)random()) << 32) | random();
return mk_uint64(r);
}
static value_t fl_randd(value_t *args, uint32_t nargs)
{
(void)args;
(void)nargs;
return mk_double(rand_double());
}
static value_t fl_randf(value_t *args, uint32_t nargs)
{
(void)args;
@ -423,17 +469,19 @@ static value_t fl_randf(value_t *args, uint32_t nargs)
return mk_float(rand_float());
}
#define MATH_FUNC_1ARG(name) \
static value_t fl_##name(value_t *args, uint32_t nargs) \
{ \
argcount(#name, nargs, 1); \
if (iscprim(args[0])) { \
struct cprim *cp = (struct cprim *)ptr(args[0]); \
numerictype_t nt = cp_numtype(cp); \
if (nt == T_FLOAT) \
return mk_float(name##f(*(float *)cp_data(cp))); \
} \
return mk_double(name(todouble(args[0], #name))); \
#define MATH_FUNC_1ARG(name) \
static value_t fl_##name(value_t *args, uint32_t nargs) \
{ \
argcount(#name, nargs, 1); \
if (iscprim(args[0])) { \
struct cprim *cp = (struct cprim *)ptr(args[0]); \
numerictype_t nt = cp_numtype(cp); \
if (nt == T_FLOAT) { \
float f = *(float *)cp_data(cp); \
return mk_float(name((double)f)); \
} \
} \
return mk_double(name(todouble(args[0], #name))); \
}
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)
{
struct cprim *pcp;
assert(!ismanaged((uintptr_t)type));
assert(sz == type->size);
struct cprim *pcp =
(struct cprim *)alloc_words(CPRIM_NWORDS - 1 + NWORDS(sz));
pcp = (struct cprim *)alloc_words(CPRIM_NWORDS - 1 + NWORDS(sz));
pcp->type = type;
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)
{
struct cvalue *pcv;
int str = 0;
int str;
str = 0;
if (valid_numtype(type->numtype)) {
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 cv;
cv = cvalue(type, sz);
memcpy(cptr(cv), data, sz);
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 v = cvalue_string(n);
value_t v;
v = cvalue_string(n);
memcpy(cvalue_data(v), str, n);
return v;
}
@ -226,12 +231,15 @@ int fl_isstring(value_t v)
// convert to malloc representation (fixed address)
void cv_pin(struct cvalue *cv)
{
size_t sz;
void *data;
if (!isinlined(cv))
return;
size_t sz = cv_len(cv);
sz = cv_len(cv);
if (cv_isstr(cv))
sz++;
void *data = malloc(sz);
data = malloc(sz);
memcpy(data, cv_data(cv), sz);
cv->data = data;
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) \
value_t cvalue_##typenam(value_t *args, uint32_t nargs) \
{ \
value_t cp; \
if (nargs == 0) { \
PUSH(fixnum(0)); \
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], \
cp_data((struct cprim *)ptr(cp)))) \
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 cv, type;
struct fltype *ft;
argcount("enum", nargs, 2);
value_t type = fl_list2(enumsym, args[0]);
struct fltype *ft = get_type(type);
value_t cv = cvalue(ft, sizeof(int32_t));
type = fl_list2(enumsym, args[0]);
ft = get_type(type);
cv = cvalue(ft, sizeof(int32_t));
cvalue_enum_init(ft, args[1], cp_data((struct cprim *)ptr(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)
{
size_t elsize, cnt, sz, i;
value_t arg;
value_t arg, cv;
struct fltype *type;
char *dest;
if (nargs < 1)
argcount("array", nargs, 1);
cnt = nargs - 1;
struct fltype *type = get_array_type(args[0]);
type = get_array_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;
value_t cv = cvalue(type, sz);
char *dest = cv_data((struct cvalue *)ptr(cv));
cv = cvalue(type, sz);
dest = cv_data((struct cvalue *)ptr(cv));
FOR_ARGS(i, 1, arg, args)
{
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));
size_t fsz, ssz = 0;
int al;
*palign = 0;
*palign = 0;
while (iscons(fld)) {
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));
size_t fsz, usz = 0;
int al;
*palign = 0;
*palign = 0;
while (iscons(fld)) {
fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
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
size_t ctype_sizeof(value_t type, int *palign)
{
value_t hed, t, n;
size_t sz;
if (type == int8sym || type == uint8sym || type == bytesym) {
*palign = 1;
return 1;
@ -544,17 +561,17 @@ size_t ctype_sizeof(value_t type, int *palign)
#endif
}
if (iscons(type)) {
value_t hed = car_(type);
hed = car_(type);
if (hed == pointersym || hed == cfunctionsym) {
*palign = ALIGNPTR;
return sizeof(void *);
}
if (hed == arraysym) {
value_t t = car(cdr_(type));
t = car(cdr_(type));
if (!iscons(cdr_(cdr_(type))))
lerror(ArgError, "sizeof: incomplete type");
value_t n = car_(cdr_(cdr_(type)));
size_t sz = toulong(n, "sizeof");
n = car_(cdr_(cdr_(type)));
sz = toulong(n, "sizeof");
return sz * ctype_sizeof(t, palign);
} else if (hed == structsym) {
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)
{
char *data;
size_t n;
int a;
argcount("sizeof", nargs, 1);
if (issymbol(args[0]) || iscons(args[0])) {
int a;
return size_wrap(ctype_sizeof(args[0], &a));
}
size_t n;
char *data;
to_sized_ptr(args[0], "sizeof", &data, &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)
{
size_t nw;
struct cvalue *cv = (struct cvalue *)ptr(v);
struct cvalue *nv;
struct fltype *t;
value_t ncv;
size_t nw;
nw = cv_nwords(cv);
nv = (struct cvalue *)alloc_words(nw);
@ -648,7 +667,7 @@ static value_t cvalue_relocate(value_t v)
if (isinlined(cv))
nv->data = &nv->_space[0];
ncv = tagptr(nv, TAG_CVALUE);
struct fltype *t = cv_class(cv);
t = cv_class(cv);
if (t->vtable != NULL && t->vtable->relocate != NULL)
t->vtable->relocate(v, ncv);
forward(v, ncv);
@ -657,16 +676,20 @@ static value_t cvalue_relocate(value_t v)
value_t cvalue_copy(value_t v)
{
struct cvalue *ncv;
struct cvalue *cv;
size_t nw, len;
assert(iscvalue(v));
PUSH(v);
struct cvalue *cv = (struct cvalue *)ptr(v);
size_t nw = cv_nwords(cv);
struct cvalue *ncv = (struct cvalue *)alloc_words(nw);
cv = (struct cvalue *)ptr(v);
nw = cv_nwords(cv);
ncv = (struct cvalue *)alloc_words(nw);
v = POP();
cv = (struct cvalue *)ptr(v);
memcpy(ncv, cv, nw * sizeof(value_t));
if (!isinlined(cv)) {
size_t len = cv_len(cv);
len = cv_len(cv);
if (cv_isstr(cv))
len++;
ncv->data = malloc(len);
@ -762,16 +785,17 @@ static numerictype_t sym_to_numtype(value_t type)
// type, including user-defined.
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)
argcount("c-value", nargs, 2);
value_t type = args[0];
struct fltype *ft = get_type(type);
value_t cv;
type = args[0];
ft = get_type(type);
if (ft->eltype != NULL) {
// special case to handle incomplete array types bla[]
size_t elsz = ft->elsz;
size_t cnt;
elsz = ft->elsz;
if (iscons(cdr_(cdr_(type))))
cnt = toulong(car_(cdr_(cdr_(type))), "array");
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 minsz = asz < bsz ? asz : bsz;
int diff = memcmp(adata, bdata, minsz);
if (diff == 0) {
if (asz > bsz)
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)
{
size_t numel;
struct cvalue *cv = (struct cvalue *)ptr(arr);
struct cvalue *cv;
cv = (struct cvalue *)ptr(arr);
*data = cv_data(cv);
numel = cv_len(cv) / (cv_class(cv)->elsz);
*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;
value_t el = 0;
numerictype_t nt = eltype->numtype;
char *dest;
size_t sz;
if (nt >= T_INT32)
el = cvalue(eltype, eltype->size);
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(((uint16_t *)data)[index]);
}
char *dest = cptr(el);
size_t sz = eltype->size;
dest = cptr(el);
sz = eltype->size;
if (sz == 1)
*dest = data[index];
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)
{
char *data;
char *dest;
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);
char *dest = data + index * eltype->size;
dest = data + index * eltype->size;
cvalue_init(eltype, args[2], dest);
return args[2];
}
value_t fl_builtin(value_t *args, uint32_t nargs)
{
argcount("builtin", nargs, 1);
struct symbol *name = tosymbol(args[0], "builtin");
struct symbol *name;
struct cvalue *cv;
argcount("builtin", nargs, 1);
name = tosymbol(args[0], "builtin");
if (ismanaged(args[0]) || (cv = name->dlcache) == NULL) {
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)
{
struct cvalue *cv =
(struct cvalue *)malloc(CVALUE_NWORDS * sizeof(value_t));
struct cvalue *cv;
value_t sym;
cv = (struct cvalue *)malloc(CVALUE_NWORDS * sizeof(value_t));
cv->type = builtintype;
cv->data = &cv->_space[0];
cv->len = sizeof(value_t);
*(void **)cv->data = f;
value_t sym = symbol(name);
sym = symbol(name);
((struct symbol *)ptr(sym))->dlcache = cv;
ptrhash_put(&reverse_dlsym_lookup_table, cv, (void *)sym);
return tagptr(cv, TAG_CVALUE);
}
@ -1183,6 +1218,7 @@ static value_t fl_neg(value_t 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)
@ -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)
{
struct cprim *cp;
void *aptr;
value_t a;
int ta;
argcount("lognot", nargs, 1);
value_t a = args[0];
a = args[0];
if (isfixnum(a))
return fixnum(~numval(a));
struct cprim *cp;
int ta;
void *aptr;
if (iscprim(a)) {
cp = (struct cprim *)ptr(a);
ta = cp_numtype(cp);
@ -1587,14 +1624,20 @@ static value_t fl_lognot(value_t *args, uint32_t nargs)
}
}
type_error("lognot", "integer", a);
return FL_NIL; // TODO: remove
}
static value_t fl_ash(value_t *args, uint32_t nargs)
{
int64_t accum, i64;
value_t a;
fixnum_t n;
int64_t accum;
struct cprim *cp;
void *aptr;
int ta;
argcount("ash", nargs, 2);
value_t a = args[0];
a = args[0];
n = tofixnum(args[1], "ash");
if (isfixnum(a)) {
if (n <= 0)
@ -1605,9 +1648,6 @@ static value_t fl_ash(value_t *args, uint32_t nargs)
else
return return_from_int64(accum);
}
struct cprim *cp;
int ta;
void *aptr;
if (iscprim(a)) {
if (n == 0)
return a;
@ -1638,7 +1678,7 @@ static value_t fl_ash(value_t *args, uint32_t nargs)
if (ta == T_UINT64)
return return_from_uint64((*(uint64_t *)aptr) << n);
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);
}
}

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)
{
value_t d;
int taga, tagb, c;
compare_top:
if (a == b)
return fixnum(0);
if (bound <= 0)
return NIL;
int taga = tag(a);
int tagb = cmptag(b);
int c;
taga = tag(a);
tagb = cmptag(b);
switch (taga) {
case TAG_NUM:
case TAG_NUM1:
@ -143,10 +143,11 @@ compare_top:
static value_t cyc_vector_compare(value_t a, value_t b, struct htable *table,
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;
size_t m, i, la, lb;
la = vector_size(a);
lb = vector_size(b);
// first try to prove them different with no recursion
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)
{
value_t d, ca, cb;
cyc_compare_top:
if (a == b)
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'
static uintptr_t bounded_hash(value_t a, int bound, int *oob)
{
*oob = 0;
union {
double d;
int64_t i64;
@ -315,8 +316,12 @@ static uintptr_t bounded_hash(value_t a, int bound, int *oob)
struct cvalue *cv;
struct cprim *cp;
void *data;
uintptr_t h = 0;
int oob2, tg = tag(a);
uintptr_t h;
int oob2, tg;
*oob = 0;
h = 0;
tg = tag(a);
switch (tg) {
case TAG_NUM:
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)
{
struct fl_exception_context *thisctx;
fl_lasterror = e;
// unwind read state
while (readstate != fl_ctx->rdst) {
@ -198,7 +200,7 @@ void fl_raise(value_t e)
if (fl_throwing_frame == 0)
fl_throwing_frame = curr_frame;
N_GCHND = fl_ctx->ngchnd;
struct fl_exception_context *thisctx = fl_ctx;
thisctx = fl_ctx;
if (fl_ctx->prev) // don't throw past toplevel
fl_ctx = fl_ctx->prev;
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)
{
char msgbuf[512];
vsnprintf(msgbuf, sizeof(msgbuf), format, args);
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, ...)
{
va_list args;
value_t msg;
PUSH(e);
va_start(args, format);
value_t msg = make_error_msg(format, args);
msg = make_error_msg(format, args);
va_end(args);
e = POP();
fl_raise(fl_list2(e, msg));
}
void lerror(value_t e, const char *msg)
{
value_t m;
PUSH(e);
value_t m = cvalue_static_cstring(msg);
m = cvalue_static_cstring(msg);
e = POP();
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
// TODO: Remove the spurious return statement.
#define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(value_t v, char *fname) \
{ \
if (is##type(v)) \
return (ctype)cnvt(v); \
type_error(fname, #type, v); \
return (ctype)FL_NIL; \
}
SAFECAST_OP(cons, struct cons *, ptr)
SAFECAST_OP(symbol, struct symbol *, ptr)
@ -325,10 +333,11 @@ static char gsname[2][16];
static int gsnameno = 0;
value_t fl_gensym(value_t *args, uint32_t nargs)
{
argcount("gensym", nargs, 0);
struct gensym *gs;
(void)args;
struct gensym *gs =
(struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
argcount("gensym", nargs, 0);
gs = (struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
gs->id = _gensym_ctr++;
gs->binding = UNBOUND;
gs->isconst = 0;
@ -346,11 +355,13 @@ static value_t fl_gensymp(value_t *args, uint32_t nargs)
char *symbol_name(value_t v)
{
struct gensym *gs;
char *n;
if (ismanaged(v)) {
struct gensym *gs = (struct gensym *)ptr(v);
gs = (struct gensym *)ptr(v);
gsnameno = 1 - gsnameno;
char *n =
uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
n = uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
*(--n) = 'g';
return n;
}
@ -402,13 +413,16 @@ static value_t the_empty_vector;
value_t alloc_vector(size_t n, int init)
{
value_t *c;
value_t v;
unsigned int i;
if (n == 0)
return the_empty_vector;
value_t *c = alloc_words(n + 1);
value_t v = tagptr(c, TAG_VECTOR);
c = alloc_words(n + 1);
v = tagptr(c, TAG_VECTOR);
vector_setsize(v, n);
if (init) {
unsigned int i;
for (i = 0; i < n; i++)
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)
{
value_t a, d, nc, first, *pcdr;
uintptr_t t = tag(v);
uintptr_t t;
t = tag(v);
if (t == TAG_CONS) {
// iterative implementation allows arbitrarily long cons chains
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, ...)
{
va_list ap;
va_start(ap, f);
value_t v;
size_t i;
va_start(ap, f);
PUSH(f);
while (SP + n > N_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);
PUSH(a);
}
value_t v = _applyn(n);
v = _applyn(n);
POPN(n + 1);
va_end(ap);
return v;
@ -712,19 +728,22 @@ value_t fl_applyn(uint32_t n, value_t f, ...)
value_t fl_listn(size_t n, ...)
{
struct cons *c;
struct cons *l;
va_list ap;
va_start(ap, n);
uint32_t si = SP;
uint32_t si;
size_t i;
si = SP;
va_start(ap, n);
while (SP + n > N_STACK)
grow_stack();
for (i = 0; i < n; i++) {
value_t a = va_arg(ap, value_t);
PUSH(a);
}
struct cons *c = (struct cons *)alloc_words(n * 2);
struct cons *l = c;
c = (struct cons *)alloc_words(n * 2);
l = c;
for (i = 0; i < n; i++) {
c->car = Stack[si++];
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)
{
struct cons *c;
PUSH(a);
PUSH(b);
struct cons *c = (struct cons *)alloc_words(4);
c = (struct cons *)alloc_words(4);
b = POP();
a = POP();
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 c;
PUSH(a);
PUSH(b);
value_t c = mk_cons();
c = mk_cons();
cdr_(c) = POP();
car_(c) = POP();
return c;
@ -763,10 +786,12 @@ value_t fl_cons(value_t a, value_t b)
int fl_isnumber(value_t v)
{
struct cprim *c;
if (isfixnum(v))
return 1;
if (iscprim(v)) {
struct cprim *c = (struct cprim *)ptr(v);
c = (struct cprim *)ptr(v);
return c->type != wchartype;
}
return 0;
@ -792,6 +817,7 @@ static value_t _list(value_t *args, uint32_t nargs, int star)
struct cons *c;
uint32_t i;
value_t v;
v = cons_reserve(nargs);
c = (struct cons *)ptr(v);
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)
{
value_t *plcons;
value_t *pL;
value_t c;
if (!iscons(L))
return NIL;
PUSH(NIL);
PUSH(L);
value_t *plcons = &Stack[SP - 2];
value_t *pL = &Stack[SP - 1];
value_t c;
plcons = &Stack[SP - 2];
pL = &Stack[SP - 1];
c = mk_cons();
PUSH(c); // save first cons
car_(c) = car_(*pL);
@ -836,19 +865,22 @@ static value_t copy_list(value_t L)
static value_t do_trycatch(void)
{
uint32_t saveSP = SP;
value_t v;
value_t thunk = Stack[SP - 2];
value_t v, thunk;
uint32_t saveSP;
saveSP = SP;
thunk = Stack[SP - 2];
Stack[SP - 2] = Stack[SP - 1];
Stack[SP - 1] = thunk;
FL_TRY { v = apply_cl(0); }
FL_CATCH
{
v = Stack[saveSP - 2];
PUSH(v);
PUSH(fl_lasterror);
v = apply_cl(1);
FL_TRY { v = apply_cl(0); }
FL_CATCH
{
v = Stack[saveSP - 2];
PUSH(v);
PUSH(fl_lasterror);
v = apply_cl(1);
}
}
SP = saveSP;
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,
int va)
{
uint32_t extr = nopt + nkw;
uint32_t ntot = nreq + extr;
value_t args[extr], v;
uint32_t i, a = 0, nrestargs;
value_t s1 = Stack[SP - 1];
value_t s2 = Stack[SP - 2];
value_t s4 = Stack[SP - 4];
value_t s5 = Stack[SP - 5];
value_t hv;
uintptr_t x;
uintptr_t idx;
uintptr_t n;
uint32_t ntot;
value_t v;
uint32_t extr;
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)
lerror(ArgError, "apply: too few arguments");
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)
goto no_kw;
// now process keywords
uintptr_t n = vector_size(kwtable) / 2;
n = vector_size(kwtable) / 2;
do {
i++;
if (i >= nargs)
lerrorf(ArgError, "keyword %s requires an argument",
symbol_name(v));
value_t hv = fixnum(((struct symbol *)ptr(v))->hash);
uintptr_t x = 2 * (labs(numval(hv)) % n);
hv = fixnum(((struct symbol *)ptr(v))->hash);
x = 2 * (labs(numval(hv)) % n);
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);
idx += nopt;
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)
{
struct cvalue *arr;
char *data;
int swap;
uint32_t ms;
struct function *fn;
value_t fv;
if (nargs == 1 && issymbol(args[0]))
return fl_builtin(args, nargs);
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]);
if (!isvector(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);
char *data = cv_data(arr);
int swap = 0;
data = cv_data(arr);
swap = 0;
if ((uint8_t)data[4] >= N_OPCODES) {
// read syntax, shifted 48 for compact text representation
size_t i, sz = cv_len(arr);
@ -2327,10 +2379,10 @@ static value_t fl_function(value_t *args, uint32_t nargs)
swap = 1;
#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);
struct function *fn = (struct function *)alloc_words(4);
value_t fv = tagptr(fn, TAG_FUNCTION);
fn = (struct function *)alloc_words(4);
fv = tagptr(fn, TAG_FUNCTION);
fn->bcode = args[0];
fn->vals = args[1];
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)
{
value_t v;
argcount("function:code", nargs, 1);
value_t v = args[0];
v = args[0];
if (!isclosure(v))
type_error("function:code", "function", v);
return fn_bcode(v);
}
static value_t fl_function_vals(value_t *args, uint32_t nargs)
{
value_t v;
argcount("function:vals", nargs, 1);
value_t v = args[0];
v = args[0];
if (!isclosure(v))
type_error("function:vals", "function", v);
return fn_vals(v);
}
static value_t fl_function_env(value_t *args, uint32_t nargs)
{
value_t v;
argcount("function:env", nargs, 1);
value_t v = args[0];
v = args[0];
if (!isclosure(v))
type_error("function:env", "function", v);
return fn_env(v);
}
static value_t fl_function_name(value_t *args, uint32_t nargs)
{
value_t v;
argcount("function:name", nargs, 1);
value_t v = args[0];
v = args[0];
if (!isclosure(v))
type_error("function:name", "function", 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 first, lst, lastcons;
uint32_t i;
if (nargs == 0)
return NIL;
value_t first = NIL, lst, lastcons = NIL;
first = lastcons = NIL;
fl_gc_handle(&first);
fl_gc_handle(&lastcons);
uint32_t i = 0;
i = 0;
while (1) {
lst = args[i++];
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 first, last, v;
int64_t argSP;
if (nargs < 2)
lerror(ArgError, "map: too few arguments");
if (!iscons(args[1]))
return NIL;
value_t first, last, v;
int64_t argSP = args - Stack;
argSP = args - Stack;
assert(argSP >= 0 && argSP < N_STACK);
if (nargs == 2) {
if (SP + 3 > N_STACK)
@ -2479,6 +2544,7 @@ value_t fl_map1(value_t *args, uint32_t nargs)
fl_free_gc_handles(2);
} else {
size_t i;
while (SP + nargs + 1 > N_STACK)
grow_stack();
PUSH(Stack[argSP]);
@ -2540,6 +2606,8 @@ extern void comparehash_init(void);
static void lisp_init(size_t initial_heapsize)
{
char buf[1024];
char *exename;
int i;
llt_init();
@ -2632,8 +2700,7 @@ static void lisp_init(size_t initial_heapsize)
cvalues_init();
char buf[1024];
char *exename = get_exename(buf, sizeof(buf));
exename = get_exename(buf, sizeof(buf));
if (exename != NULL) {
path_to_dirname(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));
PUSH(f);
saveSP = SP;
FL_TRY
{
while (1) {
e = fl_read_sexpr(Stack[SP - 1]);
if (ios_eof(value2c(struct ios *, Stack[SP - 1])))
break;
if (isfunction(e)) {
// stage 0 format: series of thunks
PUSH(e);
(void)_applyn(0);
SP = saveSP;
} else {
// stage 1 format: list alternating symbol/value
while (iscons(e)) {
sym = tosymbol(car_(e), "bootstrap");
e = cdr_(e);
(void)tocons(e, "bootstrap");
sym->binding = car_(e);
e = cdr_(e);
FL_TRY
{
while (1) {
e = fl_read_sexpr(Stack[SP - 1]);
if (ios_eof(value2c(struct ios *, Stack[SP - 1])))
break;
if (isfunction(e)) {
// stage 0 format: series of thunks
PUSH(e);
(void)_applyn(0);
SP = saveSP;
} else {
// stage 1 format: list alternating symbol/value
while (iscons(e)) {
sym = tosymbol(car_(e), "bootstrap");
e = cdr_(e);
(void)tocons(e, "bootstrap");
sym->binding = car_(e);
e = cdr_(e);
}
break;
}
break;
}
}
}
FL_CATCH
{
ios_puts("fatal error during bootstrap:\n", ios_stderr);
fl_print(ios_stderr, fl_lasterror);
ios_putc('\n', ios_stderr);
return 1;
FL_CATCH
{
ios_puts("fatal error during bootstrap:\n", ios_stderr);
fl_print(ios_stderr, fl_lasterror);
ios_putc('\n', ios_stderr);
return 1;
}
}
ios_close(value2c(struct ios *, Stack[SP - 1]));
POPN(1);

7
c/htable.c
View File

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

2
c/htable_inc.h
View File

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

123
c/ios.c
View File

@ -33,8 +33,11 @@
static void *our_memrchr(const void *s, int c, size_t n)
{
const unsigned char *src = s + n;
unsigned char uc = c;
const unsigned char *src;
unsigned char uc;
src = (unsigned char *)s + n;
uc = c;
while (--src >= (unsigned char *)s)
if (*src == uc)
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)
{
unsigned char *ubuf;
size_t got;
int err;
ubuf = buf;
*nread = 0;
while (n > 0) {
int err = _os_read(fd, buf, n, &got);
err = _os_read(fd, ubuf, n, &got);
n -= got;
*nread += got;
buf += got;
ubuf += got;
if (err || got == 0)
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)
{
unsigned char *ubuf;
size_t wrote;
int err;
ubuf = buf;
*nwritten = 0;
while (n > 0) {
int err = _os_write(fd, buf, n, &wrote);
err = _os_write(fd, ubuf, n, &wrote);
n -= wrote;
*nwritten += wrote;
buf += wrote;
ubuf += wrote;
if (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 got, space;
int result;
if (s->state == bst_wr && s->bm != bm_mem) {
ios_flush(s);
s->bpos = s->size = 0;
}
size_t space = s->size - s->bpos;
space = s->size - s->bpos;
s->state = bst_rd;
if (space >= n || s->bm == bm_mem || s->fd == -1)
return space;
@ -311,9 +321,7 @@ size_t ios_readprep(struct ios *s, size_t n)
return space;
}
}
size_t got;
int result =
_os_read(s->fd, s->buf + s->size, s->maxsize - s->size, &got);
result = _os_read(s->fd, s->buf + s->size, s->maxsize - s->size, &got);
if (result)
return space;
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 space, wrote;
if (s->readonly)
return 0;
if (n == 0)
return 0;
size_t space;
size_t wrote = 0;
wrote = 0;
if (s->state == bst_none)
s->state = bst_wr;
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 fdpos;
s->_eof = 0;
if (s->bm == bm_mem) {
if ((size_t)pos > s->size)
@ -393,7 +404,7 @@ off_t ios_seek(struct ios *s, off_t pos)
s->bpos = pos;
} else {
ios_flush(s);
off_t fdpos = lseek(s->fd, pos, SEEK_SET);
fdpos = lseek(s->fd, pos, SEEK_SET);
if (fdpos == (off_t)-1)
return fdpos;
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 fdpos;
s->_eof = 1;
if (s->bm == bm_mem) {
s->bpos = s->size;
} else {
ios_flush(s);
off_t fdpos = lseek(s->fd, 0, SEEK_END);
fdpos = lseek(s->fd, 0, SEEK_END);
if (fdpos == (off_t)-1)
return fdpos;
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 fdpos;
if (offs != 0) {
if (offs > 0) {
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;
else if (s->state == bst_rd)
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)
return fdpos;
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 fdpos;
if (s->bm == bm_mem)
return (off_t)s->bpos;
off_t fdpos = s->fpos;
fdpos = s->fpos;
if (fdpos == (off_t)-1) {
fdpos = lseek(s->fd, 0, SEEK_CUR);
if (fdpos == (off_t)-1)
@ -502,6 +519,9 @@ int ios_eof(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)
return 0;
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;
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)
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)
{
ios_flush(s);
size_t nvalid = 0;
ios_flush(s);
nvalid = (size < s->size) ? size : s->size;
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,
bool_t all)
{
size_t total = 0, avail;
size_t total, avail, written, ntowrite;
total = 0;
if (!ios_eof(from)) {
do {
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;
break;
}
size_t written, ntowrite;
ntowrite = (avail <= nbytes || all) ? avail : nbytes;
written = ios_write(to, from->buf + from->bpos, ntowrite);
// 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 total = 0, avail = from->size - from->bpos;
int first = 1;
size_t total, avail, ntowrite, written;
char *pd;
int first;
total = 0;
avail = from->size - from->bpos;
first = 1;
if (!ios_eof(from)) {
do {
if (avail == 0) {
first = 0;
avail = ios_readprep(from, LINE_CHUNK_SIZE);
}
size_t written;
char *pd = (char *)memchr(from->buf + from->bpos, delim, avail);
pd = (char *)memchr(from->buf + from->bpos, delim, avail);
if (pd == NULL) {
written = ios_write(to, from->buf + from->bpos, avail);
from->bpos += avail;
total += written;
avail = 0;
} 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);
from->bpos += ntowrite;
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,
int trunc)
{
int fd;
int fd, flags;
if (!(rd || wr))
// must specify read and/or write
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)
flags |= O_CREAT;
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)
{
size_t n = strlen(str);
size_t n;
n = strlen(str);
if (ios_mem(s, n + 1) == NULL)
return NULL;
ios_write(s, str, n + 1);
@ -829,6 +857,7 @@ int ios_putc(int c, struct ios *s)
int ios_getc(struct ios *s)
{
char ch;
if (s->state == bst_rd && s->bpos < s->size) {
ch = s->buf[s->bpos++];
} else {
@ -844,11 +873,13 @@ int ios_getc(struct ios *s)
int ios_peekc(struct ios *s)
{
size_t n;
if (s->bpos < s->size)
return (unsigned char)s->buf[s->bpos];
if (s->_eof)
return IOS_EOF;
size_t n = ios_readprep(s, 1);
n = ios_readprep(s, 1);
if (n == 0)
return IOS_EOF;
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 c;
size_t sz;
size_t sz, i;
char c0;
char buf[8];
@ -896,7 +927,7 @@ int ios_getutf8(struct ios *s, uint32_t *pwc)
if (ios_readprep(s, sz) < sz)
// NOTE: this can return EOF even if some bytes are available
return IOS_EOF;
size_t i = s->bpos;
i = s->bpos;
*pwc = u8_nextchar(s->buf, &i);
ios_read(s, buf, sz + 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 c;
size_t sz;
size_t sz, i;
char c0;
c = ios_peekc(s);
@ -919,7 +950,7 @@ int ios_peekutf8(struct ios *s, uint32_t *pwc)
sz = u8_seqlen(&c0) - 1;
if (ios_readprep(s, sz) < sz)
return IOS_EOF;
size_t i = s->bpos;
i = s->bpos;
*pwc = u8_nextchar(s->buf, &i);
return 1;
}
@ -927,9 +958,11 @@ int ios_peekutf8(struct ios *s, uint32_t *pwc)
int ios_pututf8(struct ios *s, uint32_t wc)
{
char buf[8];
size_t n;
if (wc < 0x80)
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);
}
@ -943,9 +976,10 @@ void ios_purge(struct ios *s)
char *ios_readline(struct ios *s)
{
struct ios dest;
size_t n;
ios_mem(&dest, 0);
ios_copyuntil(&dest, s, '\n');
size_t 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)
{
char *str = NULL;
char *str;
int c;
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) {
size_t avail = s->maxsize - s->bpos;
char *start = s->buf + s->bpos;
avail = s->maxsize - s->bpos;
start = s->buf + s->bpos;
c = vsnprintf(start, avail, format, args);
if (c < 0) {
va_end(al);
@ -977,10 +1014,8 @@ int ios_vprintf(struct ios *s, const char *format, va_list args)
}
}
c = vasprintf(&str, format, al);
if (c >= 0) {
ios_write(s, str, c);
LLT_FREE(str);
}
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)
{
int i, r, w, c, t, a;
value_t f;
char *fname;
struct ios *s;
if (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++) {
if (args[i] == wrsym)
w = 1;
@ -113,9 +118,9 @@ value_t fl_file(value_t *args, uint32_t nargs)
}
if ((r | w | c | t | a) == 0)
r = 1; // default to reading
value_t f = cvalue(iostreamtype, sizeof(struct ios));
char *fname = tostring(args[0], "file");
struct ios *s = value2c(struct ios *, f);
f = cvalue(iostreamtype, sizeof(struct ios));
fname = tostring(args[0], "file");
s = value2c(struct ios *, f);
if (ios_file(s, fname, r, w, c, t) == NULL)
lerrorf(IOError, "file: could not open \"%s\"", fname);
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 f;
struct ios *s;
argcount("buffer", nargs, 0);
(void)args;
value_t f = cvalue(iostreamtype, sizeof(struct ios));
struct ios *s = value2c(struct ios *, f);
f = cvalue(iostreamtype, sizeof(struct ios));
s = value2c(struct ios *, f);
if (ios_mem(s, 0) == NULL)
lerror(MemoryError, "buffer: could not allocate stream");
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 arg = 0;
value_t arg, v;
arg = 0;
if (nargs > 1) {
argcount("read", nargs, 1);
} else if (nargs == 0) {
@ -146,7 +156,7 @@ value_t fl_read(value_t *args, uint32_t nargs)
}
(void)toiostream(arg, "read");
fl_gc_handle(&arg);
value_t v = fl_read_sexpr(arg);
v = fl_read_sexpr(arg);
fl_free_gc_handles(1);
if (ios_eof(value2c(struct ios *, arg)))
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)
{
argcount("read-u8", nargs, 1);
struct ios *s = toiostream(args[0], "read-u8");
struct ios *s;
int c;
argcount("read-u8", nargs, 1);
s = toiostream(args[0], "read-u8");
if ((c = ios_getc(s)) == IOS_EOF)
// lerror(IOError, "io.getc: end of file reached");
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)
{
argcount("io.getc", nargs, 1);
struct ios *s = toiostream(args[0], "io.getc");
struct ios *s;
uint32_t wc;
argcount("io.getc", nargs, 1);
s = toiostream(args[0], "io.getc");
if (ios_getutf8(s, &wc) == IOS_EOF)
// lerror(IOError, "io.getc: end of file reached");
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)
{
argcount("io.peekc", nargs, 1);
struct ios *s = toiostream(args[0], "io.peekc");
struct ios *s;
uint32_t wc;
argcount("io.peekc", nargs, 1);
s = toiostream(args[0], "io.peekc");
if (ios_peekutf8(s, &wc) == IOS_EOF)
return FL_EOF;
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)
{
struct ios *s;
uint32_t wc;
argcount("io.putc", nargs, 2);
struct ios *s = toiostream(args[0], "io.putc");
s = toiostream(args[0], "io.putc");
if (!iscprim(args[1]) ||
((struct cprim *)ptr(args[1]))->type != wchartype)
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));
}
value_t fl_ioungetc(value_t *args, uint32_t nargs)
{
struct ios *s;
uint32_t wc;
argcount("io.ungetc", nargs, 2);
struct ios *s = toiostream(args[0], "io.ungetc");
s = toiostream(args[0], "io.ungetc");
if (!iscprim(args[1]) ||
((struct cprim *)ptr(args[1]))->type != wchartype)
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) {
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)
{
struct ios *s;
argcount("io.flush", nargs, 1);
struct ios *s = toiostream(args[0], "io.flush");
s = toiostream(args[0], "io.flush");
if (ios_flush(s) != 0)
return FL_F;
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)
{
struct ios *s;
argcount("io.close", nargs, 1);
struct ios *s = toiostream(args[0], "io.close");
s = toiostream(args[0], "io.close");
ios_close(s);
return FL_T;
}
value_t fl_iopurge(value_t *args, uint32_t nargs)
{
struct ios *s;
argcount("io.discardbuffer", nargs, 1);
struct ios *s = toiostream(args[0], "io.discardbuffer");
s = toiostream(args[0], "io.discardbuffer");
ios_purge(s);
return FL_T;
}
value_t fl_ioeof(value_t *args, uint32_t nargs)
{
struct ios *s;
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);
}
value_t fl_ioseek(value_t *args, uint32_t nargs)
{
struct ios *s;
off_t res;
size_t pos;
argcount("io.seek", nargs, 2);
struct ios *s = toiostream(args[0], "io.seek");
size_t pos = toulong(args[1], "io.seek");
off_t res = ios_seek(s, (off_t)pos);
s = toiostream(args[0], "io.seek");
pos = toulong(args[1], "io.seek");
res = ios_seek(s, (off_t)pos);
if (res == -1)
return FL_F;
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)
{
struct ios *s;
off_t res;
argcount("io.pos", nargs, 1);
struct ios *s = toiostream(args[0], "io.pos");
off_t res = ios_pos(s);
s = toiostream(args[0], "io.pos");
res = ios_pos(s);
if (res == -1)
return FL_F;
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)
{
struct ios *s;
if (nargs < 1 || nargs > 2)
argcount("write", nargs, 1);
struct ios *s;
if (nargs == 2)
s = toiostream(args[1], "write");
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)
{
struct fltype *ft;
char *data;
value_t cv;
size_t n, got;
if (nargs != 3)
argcount("io.read", nargs, 2);
(void)toiostream(args[0], "io.read");
size_t n;
struct fltype *ft;
if (nargs == 3) {
// form (io.read s type count)
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");
n = ft->size;
}
value_t cv = cvalue(ft, n);
char *data;
cv = cvalue(ft, n);
if (iscvalue(cv))
data = cv_data((struct cvalue *)ptr(cv));
else
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)
// lerror(IOError, "io.read: end of input reached");
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)
{
char *data;
struct ios *s;
size_t nb, sz, offs;
uint32_t wc;
if (nargs < 2 || nargs > 4)
argcount("io.write", nargs, 2);
struct ios *s = toiostream(args[0], "io.write");
s = toiostream(args[0], "io.write");
if (iscprim(args[1]) &&
((struct cprim *)ptr(args[1]))->type == wchartype) {
if (nargs > 2)
lerror(ArgError,
"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));
}
char *data;
size_t sz, offs = 0;
offs = 0;
to_sized_ptr(args[1], "io.write", &data, &sz);
size_t nb = sz;
nb = sz;
if (nargs > 2) {
get_start_count_args(&args[1], nargs - 1, sz, &offs, &nb, "io.write");
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)
{
char *data;
struct ios *s;
size_t nb, sz, offs;
if (nargs < 1 || nargs > 3)
argcount("dump", nargs, 1);
struct ios *s = toiostream(symbol_value(outstrsym), "dump");
char *data;
size_t sz, offs = 0;
s = toiostream(symbol_value(outstrsym), "dump");
offs = 0;
to_sized_ptr(args[0], "dump", &data, &sz);
size_t nb = sz;
nb = sz;
if (nargs > 1) {
get_start_count_args(args, nargs, sz, &offs, &nb, "dump");
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)
{
size_t uldelim = toulong(arg, fname);
size_t uldelim;
uldelim = toulong(arg, fname);
if (uldelim > 0x7f) {
// wchars > 0x7f, or anything else > 0xff, are out of range
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)
{
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 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_setbuf(&dest, data, 80, 0);
char delim = get_delim_arg(args[1], "io.readuntil");
struct ios *src = toiostream(args[0], "io.readuntil");
size_t n = ios_copyuntil(&dest, src, delim);
delim = get_delim_arg(args[1], "io.readuntil");
src = toiostream(args[0], "io.readuntil");
n = ios_copyuntil(&dest, src, delim);
cv->len = n;
if (dest.buf != data) {
// 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)
{
struct ios *dest;
struct ios *src;
char delim;
argcount("io.copyuntil", nargs, 3);
struct ios *dest = toiostream(args[0], "io.copyuntil");
struct ios *src = toiostream(args[1], "io.copyuntil");
char delim = get_delim_arg(args[2], "io.copyuntil");
dest = toiostream(args[0], "io.copyuntil");
src = toiostream(args[1], "io.copyuntil");
delim = get_delim_arg(args[2], "io.copyuntil");
return size_wrap(ios_copyuntil(dest, src, delim));
}
value_t fl_iocopy(value_t *args, uint32_t nargs)
{
struct ios *dest;
struct ios *src;
size_t n;
if (nargs < 2 || nargs > 3)
argcount("io.copy", nargs, 2);
struct ios *dest = toiostream(args[0], "io.copy");
struct ios *src = toiostream(args[1], "io.copy");
dest = toiostream(args[0], "io.copy");
src = toiostream(args[1], "io.copy");
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_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)
{
struct ios *st;
char *b;
value_t str;
size_t n;
struct ios *st = value2c(struct ios *, *ps);
st = value2c(struct ios *, *ps);
if (st->buf == &st->local[0]) {
n = st->size;
str = cvalue_string(n);
memcpy(cvalue_data(str), value2c(struct ios *, *ps)->buf, n);
ios_trunc(value2c(struct ios *, *ps), 0);
} else {
char *b = ios_takebuf(st, &n);
b = ios_takebuf(st, &n);
n--;
b[n] = '\0';
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)
{
struct ios *src;
argcount("io.tostring!", nargs, 1);
struct ios *src = toiostream(args[0], "io.tostring!");
src = toiostream(args[0], "io.tostring!");
if (src->bm != bm_mem)
lerror(ArgError, "io.tostring!: requires memory stream");
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 *pb) /* IN: secondary initval, OUT: secondary hash */
{
#ifdef VALGRIND
const uint8_t *k8;
#endif
uint32_t a, b, c; /* internal state */
union {
const void *ptr;
@ -492,7 +495,6 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
u.ptr = key;
if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) {
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
* (a,b,c) */
@ -517,7 +519,6 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
* noticably faster for short strings (like English words).
*/
#ifndef VALGRIND
(void)k8;
switch (length) {
case 12:
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)
{
double da, db;
if (atag == btag)
return cmp_same_lt(a, b, atag);
double da = conv_to_double(a, atag);
double db = conv_to_double(b, btag);
da = conv_to_double(a, atag);
db = conv_to_double(b, btag);
// casting to double will only get the wrong answer for big int64s
// 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 equalnans)
{
double da, db;
union {
double d;
int64_t i64;
} u, v;
if (atag == btag && (!equalnans || atag < T_FLOAT))
return cmp_same_eq(a, b, atag);
double da = conv_to_double(a, atag);
double db = conv_to_double(b, btag);
da = conv_to_double(a, atag);
db = conv_to_double(b, btag);
if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) {
if (equalnans) {

97
c/print.h
View File

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

50
c/read.h
View File

@ -394,16 +394,24 @@ static uint32_t peek(void)
tokval = fixnum(x);
} else if (symchar(c)) {
read_token(ch, 0);
if (((c == 'b' && (base = 2)) || (c == 'o' && (base = 8)) ||
(c == 'd' && (base = 10)) || (c == 'x' && (base = 16))) &&
(isdigit_base(buf[1], base) || buf[1] == '-')) {
if (c == 'b') {
base = 2;
} else if (c == 'o') {
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))
lerrorf(ParseError, "read: invalid base %d constant",
base);
return (toktype = TOK_NUM);
toktype = TOK_NUM;
return toktype;
}
toktype = TOK_SHARPSYM;
tokval = symbol(buf);
} else {
@ -439,11 +447,15 @@ static uint32_t peek(void)
// reader, and requires at least 1 and up to 3 garbage collections!
static value_t vector_grow(value_t v)
{
size_t i, s = vector_size(v);
size_t d = vector_grow_amt(s);
value_t newv;
size_t i, s;
size_t d;
s = vector_size(v);
d = vector_grow_amt(s);
PUSH(v);
assert(s + d > s);
value_t newv = alloc_vector(s + d, 1);
newv = alloc_vector(s + d, 1);
v = Stack[SP - 1];
for (i = 0; i < s; 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)
{
value_t v = the_empty_vector, elt;
uint32_t i = 0;
value_t v, elt;
uint32_t i;
v = the_empty_vector;
i = 0;
PUSH(v);
if (label != UNBOUND)
ptrhash_put(&readstate->backrefs, (void *)label, (void *)v);
@ -529,8 +544,17 @@ static value_t read_string(void)
wc = strtol(eseq, NULL, 8);
// \DDD and \xXX read bytes, not characters
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);
while (hex_digit(c) && j < ndig && (c != IOS_EOF)) {
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)
{
size_t start = 0;
char *str;
size_t start, len, stop;
start = 0;
if (nargs < 1 || nargs > 3)
argcount("string.count", nargs, 1);
if (!fl_isstring(args[0]))
type_error("string.count", "string", args[0]);
size_t len = cv_len((struct cvalue *)ptr(args[0]));
size_t stop = len;
len = cv_len((struct cvalue *)ptr(args[0]));
stop = len;
if (nargs > 1) {
start = toulong(args[1], "string.count");
if (start > len)
@ -61,12 +64,14 @@ value_t fl_string_count(value_t *args, uint32_t nargs)
return fixnum(0);
}
}
char *str = cvalue_data(args[0]);
str = cvalue_data(args[0]);
return size_wrap(u8_charnum(str + start, stop - start));
}
value_t fl_string_width(value_t *args, uint32_t nargs)
{
char *s;
argcount("string.width", nargs, 1);
if (iscprim(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);
}
}
char *s = tostring(args[0], "string.width");
s = tostring(args[0], "string.width");
return size_wrap(u8_strwidth(s));
}
value_t fl_string_reverse(value_t *args, uint32_t nargs)
{
size_t len;
value_t ns;
argcount("string.reverse", nargs, 1);
if (!fl_isstring(args[0]))
type_error("string.reverse", "string", args[0]);
size_t len = cv_len((struct cvalue *)ptr(args[0]));
value_t ns = cvalue_string(len);
len = cv_len((struct cvalue *)ptr(args[0]));
ns = cvalue_string(len);
u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
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]);
return FL_NIL; // TODO: remove
}
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) {
term = (args[1] != FL_F);
} else {
@ -122,16 +138,16 @@ value_t fl_string_decode(value_t *args, uint32_t nargs)
}
if (!fl_isstring(args[0]))
type_error("string.decode", "string", args[0]);
struct cvalue *cv = (struct cvalue *)ptr(args[0]);
char *ptr = (char *)cv_data(cv);
size_t nb = cv_len(cv);
size_t nc = u8_charnum(ptr, nb);
size_t newsz = nc * sizeof(uint32_t);
cv = (struct cvalue *)ptr(args[0]);
ptr = (char *)cv_data(cv);
nb = cv_len(cv);
nc = u8_charnum(ptr, nb);
newsz = nc * sizeof(uint32_t);
if (term)
newsz += sizeof(uint32_t);
value_t wcstr = cvalue(wcstringtype, newsz);
wcstr = cvalue(wcstringtype, newsz);
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);
if (term)
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 arg, buf;
struct ios *s;
uint32_t i;
value_t oldpr, oldpp, outp;
if (nargs == 1 && fl_isstring(args[0]))
return args[0];
value_t arg, buf = fl_buffer(NULL, 0);
buf = fl_buffer(NULL, 0);
fl_gc_handle(&buf);
struct ios *s = value2c(struct ios *, buf);
uint32_t i;
value_t oldpr = symbol_value(printreadablysym);
value_t oldpp = symbol_value(printprettysym);
s = value2c(struct ios *, buf);
oldpr = symbol_value(printreadablysym);
oldpp = symbol_value(printprettysym);
set(printreadablysym, FL_F);
set(printprettysym, FL_F);
FOR_ARGS(i, 0, arg, args) { fl_print(s, args[i]); }
set(printreadablysym, oldpr);
set(printprettysym, oldpp);
value_t outp = stream_to_string(&buf);
outp = stream_to_string(&buf);
fl_free_gc_handles(1);
return outp;
}
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);
char *s = tostring(args[0], "string.split");
char *delim = tostring(args[1], "string.split");
size_t len = cv_len((struct cvalue *)ptr(args[0]));
size_t dlen = cv_len((struct cvalue *)ptr(args[1]));
size_t ssz, tokend = 0, tokstart = 0, i = 0;
value_t first = FL_NIL, c = FL_NIL, last;
size_t junk;
s = tostring(args[0], "string.split");
delim = tostring(args[1], "string.split");
len = cv_len((struct cvalue *)ptr(args[0]));
dlen = cv_len((struct cvalue *)ptr(args[1]));
tokend = tokstart = i = 0;
first = c = FL_NIL;
fl_gc_handle(&first);
fl_gc_handle(&last);
do {
// find and allocate next token
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)
{
char *s;
size_t len, i1, i2;
value_t ns;
if (nargs != 2)
argcount("string.sub", nargs, 3);
char *s = tostring(args[0], "string.sub");
size_t len = cv_len((struct cvalue *)ptr(args[0]));
size_t i1, i2;
s = tostring(args[0], "string.sub");
len = cv_len((struct cvalue *)ptr(args[0]));
i1 = toulong(args[1], "string.sub");
if (i1 > len)
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)
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);
return ns;
}
value_t fl_string_char(value_t *args, uint32_t nargs)
{
char *s;
size_t len, i, sl;
argcount("string.char", nargs, 2);
char *s = tostring(args[0], "string.char");
size_t len = cv_len((struct cvalue *)ptr(args[0]));
size_t i = toulong(args[1], "string.char");
s = tostring(args[0], "string.char");
len = cv_len((struct cvalue *)ptr(args[0]));
i = toulong(args[1], "string.char");
if (i >= len)
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)
bounds_error("string.char", args[0], args[1]);
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)
{
struct cprim *cp;
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)
type_error("char.upcase", "wchar", args[0]);
return mk_wchar(towupper(*(int32_t *)cp_data(cp)));
}
value_t fl_char_downcase(value_t *args, uint32_t nargs)
{
struct cprim *cp;
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)
type_error("char.downcase", "wchar", args[0]);
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)
{
struct cprim *cp;
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)
type_error("char-alphabetic?", "wchar", args[0]);
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)
{
char *p = memchr(s + start, c, len - start);
char *p;
p = memchr(s + start, c, len - start);
if (p == NULL)
return FL_F;
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)
{
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)
start = toulong(args[2], "string.find");
else
else {
argcount("string.find", nargs, 2);
char *s = tostring(args[0], "string.find");
size_t len = cv_len((struct cvalue *)ptr(args[0]));
start = 0;
}
s = tostring(args[0], "string.find");
len = cv_len((struct cvalue *)ptr(args[0]));
if (start > len)
bounds_error("string.find", args[0], args[2]);
char *needle;
size_t needlesz;
value_t v = args[1];
struct cprim *cp = (struct cprim *)ptr(v);
v = args[1];
cp = (struct cprim *)ptr(v);
if (iscprim(v) && cp_class(cp) == wchartype) {
uint32_t c = *(uint32_t *)cp_data(cp);
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);
else if (needlesz == 0)
return size_wrap(start);
size_t i;
for (i = start; i < len - needlesz + 1; i++) {
if (s[i] == needle[0]) {
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)
{
char *s;
size_t len, cnt, i;
if (nargs < 2 || nargs > 3)
argcount("string.inc", nargs, 2);
char *s = tostring(args[0], "string.inc");
size_t len = cv_len((struct cvalue *)ptr(args[0]));
size_t i = toulong(args[1], "string.inc");
size_t cnt = 1;
s = tostring(args[0], "string.inc");
len = cv_len((struct cvalue *)ptr(args[0]));
i = toulong(args[1], "string.inc");
cnt = 1;
if (nargs == 3)
cnt = toulong(args[2], "string.inc");
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)
{
char *s;
size_t len, cnt, i;
if (nargs < 2 || nargs > 3)
argcount("string.dec", nargs, 2);
char *s = tostring(args[0], "string.dec");
size_t len = cv_len((struct cvalue *)ptr(args[0]));
size_t i = toulong(args[1], "string.dec");
size_t cnt = 1;
s = tostring(args[0], "string.dec");
len = cv_len((struct cvalue *)ptr(args[0]));
i = toulong(args[1], "string.dec");
cnt = 1;
if (nargs == 3)
cnt = toulong(args[2], "string.dec");
// 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)
{
unsigned long radix = toulong(arg, fname);
unsigned long radix;
radix = toulong(arg, fname);
if (radix < 2 || radix > 36)
lerrorf(ArgError, "%s: invalid radix", fname);
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)
{
char buf[128];
uint64_t num;
unsigned long radix;
value_t n;
char *str;
int neg;
if (nargs < 1 || nargs > 2)
argcount("number->string", nargs, 2);
value_t n = args[0];
int neg = 0;
uint64_t num;
n = args[0];
neg = 0;
if (isfixnum(n))
num = numval(n);
else if (!iscprim(n))
@ -390,11 +445,10 @@ value_t fl_numbertostring(value_t *args, uint32_t nargs)
num = -num;
neg = 1;
}
unsigned long radix = 10;
radix = 10;
if (nargs == 2)
radix = get_radix_arg(args[1], "number->string");
char buf[128];
char *str = uint2str(buf, sizeof(buf), num, radix);
str = uint2str(buf, sizeof(buf), num, radix);
if (neg && str > &buf[0])
*(--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)
{
char *str;
value_t n;
unsigned long radix;
if (nargs < 1 || nargs > 2)
argcount("string->number", nargs, 2);
char *str = tostring(args[0], "string->number");
value_t n;
unsigned long radix = 0;
str = tostring(args[0], "string->number");
radix = 0;
if (nargs == 2)
radix = get_radix_arg(args[1], "string->number");
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)
{
char *s;
size_t len;
argcount("string.isutf8", nargs, 1);
char *s = tostring(args[0], "string.isutf8");
size_t len = cv_len((struct cvalue *)ptr(args[0]));
s = tostring(args[0], "string.isutf8");
len = cv_len((struct cvalue *)ptr(args[0]));
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)
{
struct htable *oldh =
(struct htable *)cv_data((struct cvalue *)ptr(oldv));
struct htable *h = (struct htable *)cv_data((struct cvalue *)ptr(newv));
size_t i;
struct htable *oldh;
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])
h->table = &h->_space[0];
size_t i;
for (i = 0; i < h->size; i++) {
if (h->table[i] != HT_NOTFOUND)
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)
{
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)
lerror(ArgError, "table: arguments must come in pairs");
value_t nt;
// prevent small tables from being added to finalizer list
if (cnt <= HT_N_INLINE) {
tabletype->vtable->finalize = NULL;
@ -117,10 +123,10 @@ value_t fl_table(value_t *args, uint32_t nargs)
} else {
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);
uint32_t i;
value_t k = FL_NIL, arg = FL_NIL;
k = FL_NIL;
arg = FL_NIL;
FOR_ARGS(i, 0, arg, args)
{
if (i & 1)
@ -134,9 +140,12 @@ value_t fl_table(value_t *args, uint32_t nargs)
// (put! table key value)
value_t fl_table_put(value_t *args, uint32_t nargs)
{
struct htable *h;
void **table0;
argcount("put!", nargs, 3);
struct htable *h = totable(args[0], "put!");
void **table0 = h->table;
h = totable(args[0], "put!");
table0 = h->table;
equalhash_put(h, (void *)args[1], (void *)args[2]);
// register finalizer if we outgrew inline space
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])
value_t fl_table_get(value_t *args, uint32_t nargs)
{
struct htable *h;
value_t v;
if (nargs != 3)
argcount("get", nargs, 2);
struct htable *h = totable(args[0], "get");
value_t v = (value_t)equalhash_get(h, (void *)args[1]);
h = totable(args[0], "get");
v = (value_t)equalhash_get(h, (void *)args[1]);
if (v == (value_t)HT_NOTFOUND) {
if (nargs == 3)
return args[2];
@ -170,16 +182,20 @@ value_t fl_table_get(value_t *args, uint32_t nargs)
// (has? table key)
value_t fl_table_has(value_t *args, uint32_t nargs)
{
struct htable *h;
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;
}
// (del! table key)
value_t fl_table_del(value_t *args, uint32_t nargs)
{
struct htable *h;
argcount("del!", nargs, 2);
struct htable *h = totable(args[0], "del!");
h = totable(args[0], "del!");
if (!equalhash_remove(h, (void *)args[1]))
key_error("del!", args[1]);
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)
{
struct htable *h;
void **table;
size_t i, n;
value_t f, zero, t;
argcount("table.foldl", nargs, 3);
value_t f = args[0], zero = args[1], t = args[2];
struct htable *h = totable(t, "table.foldl");
size_t i, n = h->size;
void **table = h->table;
f = args[0];
zero = args[1];
t = args[2];
h = totable(t, "table.foldl");
n = h->size;
table = h->table;
fl_gc_handle(&f);
fl_gc_handle(&zero);
fl_gc_handle(&t);

22
c/types.h
View File

@ -1,25 +1,25 @@
struct fltype *get_type(value_t t)
{
struct fltype *ft;
void **bp;
size_t sz;
int align, isarray;
if (issymbol(t)) {
ft = ((struct symbol *)ptr(t))->type;
if (ft != NULL)
return ft;
}
void **bp = equalhash_bp(&TypeTable, (void *)t);
bp = equalhash_bp(&TypeTable, (void *)t);
if (*bp != HT_NOTFOUND)
return *bp;
int align,
isarray = (iscons(t) && car_(t) == arraysym && iscons(cdr_(t)));
size_t sz;
if (isarray && !iscons(cdr_(cdr_(t)))) {
// special case: incomplete array type
sz = 0;
} else {
sz = ctype_sizeof(t, &align);
}
ft = (struct fltype *)malloc(sizeof(struct fltype));
ft->type = 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 *et = get_type(eltype);
struct fltype *et;
et = get_type(eltype);
if (et->artype == NULL)
et->artype = get_type(fl_list2(arraysym, eltype));
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 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->size = sz;
ft->numtype = N_NUMTYPES;
@ -82,9 +86,11 @@ struct fltype *define_opaque_type(value_t sym, size_t sz,
void relocate_typetable(void)
{
struct htable *h = &TypeTable;
struct htable *h;
size_t i;
void *nv;
h = &TypeTable;
for (i = 0; i < h->size; i += 2) {
if (h->table[i] != HT_NOTFOUND) {
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 */
size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest)
{
assert(ssz > 0);
uint32_t ch;
char digs[10];
int dno = 0, ndig;
size_t i = 1;
char c0 = str[0];
int dno, ndig;
size_t i;
char c0;
assert(ssz > 0);
dno = 0;
i = 1;
c0 = str[0];
if (octal_digit(c0)) {
i = 0;
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);
digs[dno] = '\0';
ch = strtol(digs, NULL, 8);
} else if ((c0 == 'x' && (ndig = 2)) || (c0 == 'u' && (ndig = 4)) ||
(c0 == 'U' && (ndig = 8))) {
*dest = ch;
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) {
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);
}
*dest = ch;
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)
{
const char *cp;
if (locale == NULL)
return 0;
/* this code based on libutf8 */
const char *cp = locale;
cp = locale;
for (; *cp != '\0' && *cp != '@' && *cp != '+' && *cp != ','; cp++) {
if (*cp == '.') {