Use backward compatible variable initializers
This commit is contained in:
parent
486ec48a76
commit
023937e5ea
112
c/builtins.c
112
c/builtins.c
|
@ -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) {
|
||||||
if (result != 0)
|
|
||||||
lerror(ArgError, "os.setenv: invalid environment variable");
|
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;
|
||||||
|
@ -430,8 +476,10 @@ static value_t fl_randf(value_t *args, uint32_t nargs)
|
||||||
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))); \
|
||||||
}
|
}
|
||||||
|
|
156
c/cvalues.h
156
c/cvalues.h
|
@ -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
23
c/equal.h
|
@ -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:
|
||||||
|
|
185
c/flisp.c
185
c/flisp.c
|
@ -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,12 +865,14 @@ 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_TRY { v = apply_cl(0); }
|
||||||
FL_CATCH
|
FL_CATCH
|
||||||
{
|
{
|
||||||
|
@ -850,6 +881,7 @@ static value_t do_trycatch(void)
|
||||||
PUSH(fl_lasterror);
|
PUSH(fl_lasterror);
|
||||||
v = apply_cl(1);
|
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,6 +2736,7 @@ 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
|
FL_TRY
|
||||||
{
|
{
|
||||||
while (1) {
|
while (1) {
|
||||||
|
@ -2700,6 +2768,7 @@ int fl_load_boot_image(void)
|
||||||
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);
|
||||||
return 0;
|
return 0;
|
||||||
|
|
|
@ -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;
|
||||||
}
|
}
|
||||||
|
|
|
@ -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
123
c/ios.c
|
@ -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
187
c/iostream.c
|
@ -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]);
|
||||||
|
|
|
@ -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];
|
||||||
|
|
|
@ -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
97
c/print.h
|
@ -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
50
c/read.h
|
@ -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
200
c/string.c
|
@ -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
61
c/table.c
|
@ -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
22
c/types.h
|
@ -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
31
c/utf8.c
|
@ -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 == '.') {
|
||||||
|
|
Loading…
Reference in New Issue