Use backward compatible variable initializers
This commit is contained in:
parent
486ec48a76
commit
023937e5ea
130
c/builtins.c
130
c/builtins.c
|
|
@ -47,12 +47,16 @@ size_t llength(value_t v)
|
|||
|
||||
static value_t fl_nconc(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t lst, first;
|
||||
value_t *pcdr;
|
||||
struct cons *c;
|
||||
uint32_t i;
|
||||
|
||||
if (nargs == 0)
|
||||
return FL_NIL;
|
||||
value_t lst, first = FL_NIL;
|
||||
value_t *pcdr = &first;
|
||||
struct cons *c;
|
||||
uint32_t i = 0;
|
||||
first = FL_NIL;
|
||||
pcdr = &first;
|
||||
i = 0;
|
||||
while (1) {
|
||||
lst = args[i++];
|
||||
if (i >= nargs)
|
||||
|
|
@ -73,11 +77,13 @@ static value_t fl_nconc(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_assq(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("assq", nargs, 2);
|
||||
value_t item = args[0];
|
||||
value_t v = args[1];
|
||||
value_t item;
|
||||
value_t v;
|
||||
value_t bind;
|
||||
|
||||
argcount("assq", nargs, 2);
|
||||
item = args[0];
|
||||
v = args[1];
|
||||
while (iscons(v)) {
|
||||
bind = car_(v);
|
||||
if (iscons(bind) && car_(bind) == item)
|
||||
|
|
@ -101,9 +107,11 @@ static value_t fl_memq(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_length(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("length", nargs, 1);
|
||||
value_t a = args[0];
|
||||
value_t a;
|
||||
struct cvalue *cv;
|
||||
|
||||
argcount("length", nargs, 1);
|
||||
a = args[0];
|
||||
if (isvector(a)) {
|
||||
return fixnum(vector_size(a));
|
||||
} else if (iscprim(a)) {
|
||||
|
|
@ -123,12 +131,14 @@ static value_t fl_length(value_t *args, uint32_t nargs)
|
|||
return fixnum(llength(a));
|
||||
}
|
||||
type_error("length", "sequence", a);
|
||||
return FL_NIL; // TODO
|
||||
}
|
||||
|
||||
static value_t fl_f_raise(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("raise", nargs, 1);
|
||||
fl_raise(args[0]);
|
||||
return FL_NIL; // TODO
|
||||
}
|
||||
|
||||
static value_t fl_exit(value_t *args, uint32_t nargs)
|
||||
|
|
@ -157,8 +167,10 @@ static value_t fl_keywordp(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_top_level_value(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct symbol *sym;
|
||||
|
||||
argcount("top-level-value", nargs, 1);
|
||||
struct symbol *sym = tosymbol(args[0], "top-level-value");
|
||||
sym = tosymbol(args[0], "top-level-value");
|
||||
if (sym->binding == UNBOUND)
|
||||
fl_raise(fl_list2(UnboundError, args[0]));
|
||||
return sym->binding;
|
||||
|
|
@ -166,8 +178,10 @@ static value_t fl_top_level_value(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_set_top_level_value(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct symbol *sym;
|
||||
|
||||
argcount("set-top-level-value!", nargs, 2);
|
||||
struct symbol *sym = tosymbol(args[0], "set-top-level-value!");
|
||||
sym = tosymbol(args[0], "set-top-level-value!");
|
||||
if (!isconstant(sym))
|
||||
sym->binding = args[1];
|
||||
return args[1];
|
||||
|
|
@ -188,9 +202,11 @@ extern struct symbol *symtab;
|
|||
|
||||
value_t fl_global_env(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t lst;
|
||||
|
||||
(void)args;
|
||||
argcount("environment", nargs, 0);
|
||||
value_t lst = FL_NIL;
|
||||
lst = FL_NIL;
|
||||
fl_gc_handle(&lst);
|
||||
global_env_list(symtab, &lst);
|
||||
fl_free_gc_handles(1);
|
||||
|
|
@ -214,15 +230,19 @@ static value_t fl_constantp(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_integer_valuedp(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t v;
|
||||
double d;
|
||||
void *data;
|
||||
|
||||
argcount("integer-valued?", nargs, 1);
|
||||
value_t v = args[0];
|
||||
v = args[0];
|
||||
if (isfixnum(v)) {
|
||||
return FL_T;
|
||||
} else if (iscprim(v)) {
|
||||
numerictype_t nt = cp_numtype((struct cprim *)ptr(v));
|
||||
if (nt < T_FLOAT)
|
||||
return FL_T;
|
||||
void *data = cp_data((struct cprim *)ptr(v));
|
||||
data = cp_data((struct cprim *)ptr(v));
|
||||
if (nt == T_FLOAT) {
|
||||
float f = *(float *)data;
|
||||
if (f < 0)
|
||||
|
|
@ -231,7 +251,7 @@ static value_t fl_integer_valuedp(value_t *args, uint32_t nargs)
|
|||
return FL_T;
|
||||
} else {
|
||||
assert(nt == T_DOUBLE);
|
||||
double d = *(double *)data;
|
||||
d = *(double *)data;
|
||||
if (d < 0)
|
||||
d = -d;
|
||||
if (d <= DBL_MAXINT && (double)(int64_t)d == d)
|
||||
|
|
@ -243,8 +263,10 @@ static value_t fl_integer_valuedp(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_integerp(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t v;
|
||||
|
||||
argcount("integer?", nargs, 1);
|
||||
value_t v = args[0];
|
||||
v = args[0];
|
||||
return (isfixnum(v) ||
|
||||
(iscprim(v) && cp_numtype((struct cprim *)ptr(v)) < T_FLOAT))
|
||||
? FL_T
|
||||
|
|
@ -261,6 +283,7 @@ static value_t fl_fixnum(value_t *args, uint32_t nargs)
|
|||
return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
|
||||
}
|
||||
type_error("fixnum", "number", args[0]);
|
||||
return FL_NIL; // TODO
|
||||
}
|
||||
|
||||
static value_t fl_truncate(value_t *args, uint32_t nargs)
|
||||
|
|
@ -289,12 +312,15 @@ static value_t fl_truncate(value_t *args, uint32_t nargs)
|
|||
return return_from_int64((int64_t)d);
|
||||
}
|
||||
type_error("truncate", "number", args[0]);
|
||||
return FL_NIL; // TODO
|
||||
}
|
||||
|
||||
static value_t fl_vector_alloc(value_t *args, uint32_t nargs)
|
||||
{
|
||||
fixnum_t i;
|
||||
value_t f, v;
|
||||
int k;
|
||||
|
||||
if (nargs == 0)
|
||||
lerror(ArgError, "vector.alloc: too few arguments");
|
||||
i = (fixnum_t)toulong(args[0], "vector.alloc");
|
||||
|
|
@ -305,7 +331,6 @@ static value_t fl_vector_alloc(value_t *args, uint32_t nargs)
|
|||
f = args[1];
|
||||
else
|
||||
f = FL_UNSPECIFIED;
|
||||
int k;
|
||||
for (k = 0; k < i; k++)
|
||||
vector_elt(v, k) = f;
|
||||
return v;
|
||||
|
|
@ -328,10 +353,13 @@ static double todouble(value_t a, char *fname)
|
|||
return conv_to_double(cp_data(cp), nt);
|
||||
}
|
||||
type_error(fname, "number", a);
|
||||
return FL_NIL; // TODO
|
||||
}
|
||||
|
||||
static value_t fl_path_cwd(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *ptr;
|
||||
|
||||
if (nargs > 1)
|
||||
argcount("path.cwd", nargs, 1);
|
||||
if (nargs == 0) {
|
||||
|
|
@ -339,7 +367,7 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs)
|
|||
get_cwd(buf, sizeof(buf));
|
||||
return string_from_cstr(buf);
|
||||
}
|
||||
char *ptr = tostring(args[0], "path.cwd");
|
||||
ptr = tostring(args[0], "path.cwd");
|
||||
if (set_cwd(ptr))
|
||||
lerrorf(IOError, "path.cwd: could not cd to %s", ptr);
|
||||
return FL_T;
|
||||
|
|
@ -347,16 +375,21 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_path_exists(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *str;
|
||||
|
||||
argcount("path.exists?", nargs, 1);
|
||||
char *str = tostring(args[0], "path.exists?");
|
||||
str = tostring(args[0], "path.exists?");
|
||||
return os_path_exists(str) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
static value_t fl_os_getenv(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *name;
|
||||
char *val;
|
||||
|
||||
argcount("os.getenv", nargs, 1);
|
||||
char *name = tostring(args[0], "os.getenv");
|
||||
char *val = getenv(name);
|
||||
name = tostring(args[0], "os.getenv");
|
||||
val = getenv(name);
|
||||
if (val == NULL)
|
||||
return FL_F;
|
||||
if (*val == 0)
|
||||
|
|
@ -366,25 +399,30 @@ static value_t fl_os_getenv(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_os_setenv(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("os.setenv", nargs, 2);
|
||||
char *name = tostring(args[0], "os.setenv");
|
||||
char *name;
|
||||
char *val;
|
||||
int result;
|
||||
|
||||
argcount("os.setenv", nargs, 2);
|
||||
name = tostring(args[0], "os.setenv");
|
||||
if (args[1] == FL_F) {
|
||||
result = unsetenv(name);
|
||||
unsetenv(name);
|
||||
} else {
|
||||
char *val = tostring(args[1], "os.setenv");
|
||||
val = tostring(args[1], "os.setenv");
|
||||
result = setenv(name, val, 1);
|
||||
if (result != 0) {
|
||||
lerror(ArgError, "os.setenv: invalid environment variable");
|
||||
}
|
||||
}
|
||||
if (result != 0)
|
||||
lerror(ArgError, "os.setenv: invalid environment variable");
|
||||
return FL_T;
|
||||
}
|
||||
|
||||
static value_t fl_rand(value_t *args, uint32_t nargs)
|
||||
{
|
||||
fixnum_t r;
|
||||
|
||||
(void)args;
|
||||
(void)nargs;
|
||||
fixnum_t r;
|
||||
#ifdef BITS64
|
||||
r = ((((uint64_t)random()) << 32) | random()) & 0x1fffffffffffffffLL;
|
||||
#else
|
||||
|
|
@ -392,30 +430,38 @@ static value_t fl_rand(value_t *args, uint32_t nargs)
|
|||
#endif
|
||||
return fixnum(r);
|
||||
}
|
||||
|
||||
static value_t fl_rand32(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t r;
|
||||
|
||||
(void)args;
|
||||
(void)nargs;
|
||||
uint32_t r = random();
|
||||
r = random();
|
||||
#ifdef BITS64
|
||||
return fixnum(r);
|
||||
#else
|
||||
return mk_uint32(r);
|
||||
#endif
|
||||
}
|
||||
|
||||
static value_t fl_rand64(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint64_t r;
|
||||
|
||||
(void)args;
|
||||
(void)nargs;
|
||||
uint64_t r = (((uint64_t)random()) << 32) | random();
|
||||
r = (((uint64_t)random()) << 32) | random();
|
||||
return mk_uint64(r);
|
||||
}
|
||||
|
||||
static value_t fl_randd(value_t *args, uint32_t nargs)
|
||||
{
|
||||
(void)args;
|
||||
(void)nargs;
|
||||
return mk_double(rand_double());
|
||||
}
|
||||
|
||||
static value_t fl_randf(value_t *args, uint32_t nargs)
|
||||
{
|
||||
(void)args;
|
||||
|
|
@ -423,17 +469,19 @@ static value_t fl_randf(value_t *args, uint32_t nargs)
|
|||
return mk_float(rand_float());
|
||||
}
|
||||
|
||||
#define MATH_FUNC_1ARG(name) \
|
||||
static value_t fl_##name(value_t *args, uint32_t nargs) \
|
||||
{ \
|
||||
argcount(#name, nargs, 1); \
|
||||
if (iscprim(args[0])) { \
|
||||
struct cprim *cp = (struct cprim *)ptr(args[0]); \
|
||||
numerictype_t nt = cp_numtype(cp); \
|
||||
if (nt == T_FLOAT) \
|
||||
return mk_float(name##f(*(float *)cp_data(cp))); \
|
||||
} \
|
||||
return mk_double(name(todouble(args[0], #name))); \
|
||||
#define MATH_FUNC_1ARG(name) \
|
||||
static value_t fl_##name(value_t *args, uint32_t nargs) \
|
||||
{ \
|
||||
argcount(#name, nargs, 1); \
|
||||
if (iscprim(args[0])) { \
|
||||
struct cprim *cp = (struct cprim *)ptr(args[0]); \
|
||||
numerictype_t nt = cp_numtype(cp); \
|
||||
if (nt == T_FLOAT) { \
|
||||
float f = *(float *)cp_data(cp); \
|
||||
return mk_float(name((double)f)); \
|
||||
} \
|
||||
} \
|
||||
return mk_double(name(todouble(args[0], #name))); \
|
||||
}
|
||||
|
||||
MATH_FUNC_1ARG(sqrt)
|
||||
|
|
|
|||
156
c/cvalues.h
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)
|
||||
{
|
||||
struct cprim *pcp;
|
||||
|
||||
assert(!ismanaged((uintptr_t)type));
|
||||
assert(sz == type->size);
|
||||
struct cprim *pcp =
|
||||
(struct cprim *)alloc_words(CPRIM_NWORDS - 1 + NWORDS(sz));
|
||||
pcp = (struct cprim *)alloc_words(CPRIM_NWORDS - 1 + NWORDS(sz));
|
||||
pcp->type = type;
|
||||
return tagptr(pcp, TAG_CPRIM);
|
||||
}
|
||||
|
|
@ -130,8 +131,9 @@ static value_t cprim(struct fltype *type, size_t sz)
|
|||
value_t cvalue(struct fltype *type, size_t sz)
|
||||
{
|
||||
struct cvalue *pcv;
|
||||
int str = 0;
|
||||
int str;
|
||||
|
||||
str = 0;
|
||||
if (valid_numtype(type->numtype)) {
|
||||
return cprim(type, sz);
|
||||
}
|
||||
|
|
@ -168,6 +170,7 @@ value_t cvalue(struct fltype *type, size_t sz)
|
|||
value_t cvalue_from_data(struct fltype *type, void *data, size_t sz)
|
||||
{
|
||||
value_t cv;
|
||||
|
||||
cv = cvalue(type, sz);
|
||||
memcpy(cptr(cv), data, sz);
|
||||
return cv;
|
||||
|
|
@ -208,7 +211,9 @@ value_t cvalue_static_cstring(const char *str)
|
|||
|
||||
value_t string_from_cstrn(const char *str, size_t n)
|
||||
{
|
||||
value_t v = cvalue_string(n);
|
||||
value_t v;
|
||||
|
||||
v = cvalue_string(n);
|
||||
memcpy(cvalue_data(v), str, n);
|
||||
return v;
|
||||
}
|
||||
|
|
@ -226,12 +231,15 @@ int fl_isstring(value_t v)
|
|||
// convert to malloc representation (fixed address)
|
||||
void cv_pin(struct cvalue *cv)
|
||||
{
|
||||
size_t sz;
|
||||
void *data;
|
||||
|
||||
if (!isinlined(cv))
|
||||
return;
|
||||
size_t sz = cv_len(cv);
|
||||
sz = cv_len(cv);
|
||||
if (cv_isstr(cv))
|
||||
sz++;
|
||||
void *data = malloc(sz);
|
||||
data = malloc(sz);
|
||||
memcpy(data, cv_data(cv), sz);
|
||||
cv->data = data;
|
||||
autorelease(cv);
|
||||
|
|
@ -264,11 +272,12 @@ num_init(float, double, T_FLOAT) num_init(double, double, T_DOUBLE)
|
|||
#define num_ctor_init(typenam, ctype, tag) \
|
||||
value_t cvalue_##typenam(value_t *args, uint32_t nargs) \
|
||||
{ \
|
||||
value_t cp; \
|
||||
if (nargs == 0) { \
|
||||
PUSH(fixnum(0)); \
|
||||
args = &Stack[SP - 1]; \
|
||||
} \
|
||||
value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \
|
||||
cp = cprim(typenam##type, sizeof(ctype##_t)); \
|
||||
if (cvalue_##ctype##_init(typenam##type, args[0], \
|
||||
cp_data((struct cprim *)ptr(cp)))) \
|
||||
type_error(#typenam, "number", args[0]); \
|
||||
|
|
@ -352,10 +361,13 @@ static int cvalue_enum_init(struct fltype *ft, value_t arg, void *dest)
|
|||
|
||||
value_t cvalue_enum(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t cv, type;
|
||||
struct fltype *ft;
|
||||
|
||||
argcount("enum", nargs, 2);
|
||||
value_t type = fl_list2(enumsym, args[0]);
|
||||
struct fltype *ft = get_type(type);
|
||||
value_t cv = cvalue(ft, sizeof(int32_t));
|
||||
type = fl_list2(enumsym, args[0]);
|
||||
ft = get_type(type);
|
||||
cv = cvalue(ft, sizeof(int32_t));
|
||||
cvalue_enum_init(ft, args[1], cp_data((struct cprim *)ptr(cv)));
|
||||
return cv;
|
||||
}
|
||||
|
|
@ -443,18 +455,20 @@ static int cvalue_array_init(struct fltype *ft, value_t arg, void *dest)
|
|||
value_t cvalue_array(value_t *args, uint32_t nargs)
|
||||
{
|
||||
size_t elsize, cnt, sz, i;
|
||||
value_t arg;
|
||||
value_t arg, cv;
|
||||
struct fltype *type;
|
||||
char *dest;
|
||||
|
||||
if (nargs < 1)
|
||||
argcount("array", nargs, 1);
|
||||
|
||||
cnt = nargs - 1;
|
||||
struct fltype *type = get_array_type(args[0]);
|
||||
type = get_array_type(args[0]);
|
||||
elsize = type->elsz;
|
||||
sz = elsize * cnt;
|
||||
|
||||
value_t cv = cvalue(type, sz);
|
||||
char *dest = cv_data((struct cvalue *)ptr(cv));
|
||||
cv = cvalue(type, sz);
|
||||
dest = cv_data((struct cvalue *)ptr(cv));
|
||||
FOR_ARGS(i, 1, arg, args)
|
||||
{
|
||||
cvalue_init(type->eltype, arg, dest);
|
||||
|
|
@ -476,8 +490,8 @@ static size_t cvalue_struct_offs(value_t type, value_t field,
|
|||
value_t fld = car(cdr_(type));
|
||||
size_t fsz, ssz = 0;
|
||||
int al;
|
||||
*palign = 0;
|
||||
|
||||
*palign = 0;
|
||||
while (iscons(fld)) {
|
||||
fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
|
||||
|
||||
|
|
@ -501,8 +515,8 @@ static size_t cvalue_union_size(value_t type, int *palign)
|
|||
value_t fld = car(cdr_(type));
|
||||
size_t fsz, usz = 0;
|
||||
int al;
|
||||
*palign = 0;
|
||||
|
||||
*palign = 0;
|
||||
while (iscons(fld)) {
|
||||
fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
|
||||
if (al > *palign)
|
||||
|
|
@ -517,6 +531,9 @@ static size_t cvalue_union_size(value_t type, int *palign)
|
|||
// *palign is an output argument giving the alignment required by type
|
||||
size_t ctype_sizeof(value_t type, int *palign)
|
||||
{
|
||||
value_t hed, t, n;
|
||||
size_t sz;
|
||||
|
||||
if (type == int8sym || type == uint8sym || type == bytesym) {
|
||||
*palign = 1;
|
||||
return 1;
|
||||
|
|
@ -544,17 +561,17 @@ size_t ctype_sizeof(value_t type, int *palign)
|
|||
#endif
|
||||
}
|
||||
if (iscons(type)) {
|
||||
value_t hed = car_(type);
|
||||
hed = car_(type);
|
||||
if (hed == pointersym || hed == cfunctionsym) {
|
||||
*palign = ALIGNPTR;
|
||||
return sizeof(void *);
|
||||
}
|
||||
if (hed == arraysym) {
|
||||
value_t t = car(cdr_(type));
|
||||
t = car(cdr_(type));
|
||||
if (!iscons(cdr_(cdr_(type))))
|
||||
lerror(ArgError, "sizeof: incomplete type");
|
||||
value_t n = car_(cdr_(cdr_(type)));
|
||||
size_t sz = toulong(n, "sizeof");
|
||||
n = car_(cdr_(cdr_(type)));
|
||||
sz = toulong(n, "sizeof");
|
||||
return sz * ctype_sizeof(t, palign);
|
||||
} else if (hed == structsym) {
|
||||
return cvalue_struct_offs(type, NIL, 1, palign);
|
||||
|
|
@ -597,13 +614,14 @@ void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz)
|
|||
|
||||
value_t cvalue_sizeof(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *data;
|
||||
size_t n;
|
||||
int a;
|
||||
|
||||
argcount("sizeof", nargs, 1);
|
||||
if (issymbol(args[0]) || iscons(args[0])) {
|
||||
int a;
|
||||
return size_wrap(ctype_sizeof(args[0], &a));
|
||||
}
|
||||
size_t n;
|
||||
char *data;
|
||||
to_sized_ptr(args[0], "sizeof", &data, &n);
|
||||
return size_wrap(n);
|
||||
}
|
||||
|
|
@ -637,10 +655,11 @@ value_t cvalue_typeof(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t cvalue_relocate(value_t v)
|
||||
{
|
||||
size_t nw;
|
||||
struct cvalue *cv = (struct cvalue *)ptr(v);
|
||||
struct cvalue *nv;
|
||||
struct fltype *t;
|
||||
value_t ncv;
|
||||
size_t nw;
|
||||
|
||||
nw = cv_nwords(cv);
|
||||
nv = (struct cvalue *)alloc_words(nw);
|
||||
|
|
@ -648,7 +667,7 @@ static value_t cvalue_relocate(value_t v)
|
|||
if (isinlined(cv))
|
||||
nv->data = &nv->_space[0];
|
||||
ncv = tagptr(nv, TAG_CVALUE);
|
||||
struct fltype *t = cv_class(cv);
|
||||
t = cv_class(cv);
|
||||
if (t->vtable != NULL && t->vtable->relocate != NULL)
|
||||
t->vtable->relocate(v, ncv);
|
||||
forward(v, ncv);
|
||||
|
|
@ -657,16 +676,20 @@ static value_t cvalue_relocate(value_t v)
|
|||
|
||||
value_t cvalue_copy(value_t v)
|
||||
{
|
||||
struct cvalue *ncv;
|
||||
struct cvalue *cv;
|
||||
size_t nw, len;
|
||||
|
||||
assert(iscvalue(v));
|
||||
PUSH(v);
|
||||
struct cvalue *cv = (struct cvalue *)ptr(v);
|
||||
size_t nw = cv_nwords(cv);
|
||||
struct cvalue *ncv = (struct cvalue *)alloc_words(nw);
|
||||
cv = (struct cvalue *)ptr(v);
|
||||
nw = cv_nwords(cv);
|
||||
ncv = (struct cvalue *)alloc_words(nw);
|
||||
v = POP();
|
||||
cv = (struct cvalue *)ptr(v);
|
||||
memcpy(ncv, cv, nw * sizeof(value_t));
|
||||
if (!isinlined(cv)) {
|
||||
size_t len = cv_len(cv);
|
||||
len = cv_len(cv);
|
||||
if (cv_isstr(cv))
|
||||
len++;
|
||||
ncv->data = malloc(len);
|
||||
|
|
@ -762,16 +785,17 @@ static numerictype_t sym_to_numtype(value_t type)
|
|||
// type, including user-defined.
|
||||
value_t cvalue_new(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct fltype *ft;
|
||||
value_t cv, type;
|
||||
size_t elsz, cnt;
|
||||
|
||||
if (nargs < 1 || nargs > 2)
|
||||
argcount("c-value", nargs, 2);
|
||||
value_t type = args[0];
|
||||
struct fltype *ft = get_type(type);
|
||||
value_t cv;
|
||||
type = args[0];
|
||||
ft = get_type(type);
|
||||
if (ft->eltype != NULL) {
|
||||
// special case to handle incomplete array types bla[]
|
||||
size_t elsz = ft->elsz;
|
||||
size_t cnt;
|
||||
|
||||
elsz = ft->elsz;
|
||||
if (iscons(cdr_(cdr_(type))))
|
||||
cnt = toulong(car_(cdr_(cdr_(type))), "array");
|
||||
else if (nargs == 2)
|
||||
|
|
@ -800,6 +824,7 @@ value_t cvalue_compare(value_t a, value_t b)
|
|||
size_t bsz = cv_len(cb);
|
||||
size_t minsz = asz < bsz ? asz : bsz;
|
||||
int diff = memcmp(adata, bdata, minsz);
|
||||
|
||||
if (diff == 0) {
|
||||
if (asz > bsz)
|
||||
return fixnum(1);
|
||||
|
|
@ -813,7 +838,9 @@ static void check_addr_args(char *fname, value_t arr, value_t ind,
|
|||
char **data, unsigned long *index)
|
||||
{
|
||||
size_t numel;
|
||||
struct cvalue *cv = (struct cvalue *)ptr(arr);
|
||||
struct cvalue *cv;
|
||||
|
||||
cv = (struct cvalue *)ptr(arr);
|
||||
*data = cv_data(cv);
|
||||
numel = cv_len(cv) / (cv_class(cv)->elsz);
|
||||
*index = toulong(ind, fname);
|
||||
|
|
@ -828,6 +855,9 @@ static value_t cvalue_array_aref(value_t *args)
|
|||
struct fltype *eltype = cv_class((struct cvalue *)ptr(args[0]))->eltype;
|
||||
value_t el = 0;
|
||||
numerictype_t nt = eltype->numtype;
|
||||
char *dest;
|
||||
size_t sz;
|
||||
|
||||
if (nt >= T_INT32)
|
||||
el = cvalue(eltype, eltype->size);
|
||||
check_addr_args("aref", args[0], args[1], &data, &index);
|
||||
|
|
@ -840,8 +870,8 @@ static value_t cvalue_array_aref(value_t *args)
|
|||
return fixnum(((int16_t *)data)[index]);
|
||||
return fixnum(((uint16_t *)data)[index]);
|
||||
}
|
||||
char *dest = cptr(el);
|
||||
size_t sz = eltype->size;
|
||||
dest = cptr(el);
|
||||
sz = eltype->size;
|
||||
if (sz == 1)
|
||||
*dest = data[index];
|
||||
else if (sz == 2)
|
||||
|
|
@ -858,19 +888,24 @@ static value_t cvalue_array_aref(value_t *args)
|
|||
static value_t cvalue_array_aset(value_t *args)
|
||||
{
|
||||
char *data;
|
||||
char *dest;
|
||||
unsigned long index;
|
||||
struct fltype *eltype = cv_class((struct cvalue *)ptr(args[0]))->eltype;
|
||||
struct fltype *eltype;
|
||||
|
||||
eltype = cv_class((struct cvalue *)ptr(args[0]))->eltype;
|
||||
check_addr_args("aset!", args[0], args[1], &data, &index);
|
||||
char *dest = data + index * eltype->size;
|
||||
dest = data + index * eltype->size;
|
||||
cvalue_init(eltype, args[2], dest);
|
||||
return args[2];
|
||||
}
|
||||
|
||||
value_t fl_builtin(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("builtin", nargs, 1);
|
||||
struct symbol *name = tosymbol(args[0], "builtin");
|
||||
struct symbol *name;
|
||||
struct cvalue *cv;
|
||||
|
||||
argcount("builtin", nargs, 1);
|
||||
name = tosymbol(args[0], "builtin");
|
||||
if (ismanaged(args[0]) || (cv = name->dlcache) == NULL) {
|
||||
lerrorf(ArgError, "builtin: function %s not found", name->name);
|
||||
}
|
||||
|
|
@ -879,17 +914,17 @@ value_t fl_builtin(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t cbuiltin(char *name, builtin_t f)
|
||||
{
|
||||
struct cvalue *cv =
|
||||
(struct cvalue *)malloc(CVALUE_NWORDS * sizeof(value_t));
|
||||
struct cvalue *cv;
|
||||
value_t sym;
|
||||
|
||||
cv = (struct cvalue *)malloc(CVALUE_NWORDS * sizeof(value_t));
|
||||
cv->type = builtintype;
|
||||
cv->data = &cv->_space[0];
|
||||
cv->len = sizeof(value_t);
|
||||
*(void **)cv->data = f;
|
||||
|
||||
value_t sym = symbol(name);
|
||||
sym = symbol(name);
|
||||
((struct symbol *)ptr(sym))->dlcache = cv;
|
||||
ptrhash_put(&reverse_dlsym_lookup_table, cv, (void *)sym);
|
||||
|
||||
return tagptr(cv, TAG_CVALUE);
|
||||
}
|
||||
|
||||
|
|
@ -1183,6 +1218,7 @@ static value_t fl_neg(value_t n)
|
|||
}
|
||||
}
|
||||
type_error("-", "number", n);
|
||||
return FL_NIL; // TODO: remove
|
||||
}
|
||||
|
||||
static value_t fl_mul_any(value_t *args, uint32_t nargs, int64_t Saccum)
|
||||
|
|
@ -1555,14 +1591,15 @@ static value_t fl_logxor(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_lognot(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct cprim *cp;
|
||||
void *aptr;
|
||||
value_t a;
|
||||
int ta;
|
||||
|
||||
argcount("lognot", nargs, 1);
|
||||
value_t a = args[0];
|
||||
a = args[0];
|
||||
if (isfixnum(a))
|
||||
return fixnum(~numval(a));
|
||||
struct cprim *cp;
|
||||
int ta;
|
||||
void *aptr;
|
||||
|
||||
if (iscprim(a)) {
|
||||
cp = (struct cprim *)ptr(a);
|
||||
ta = cp_numtype(cp);
|
||||
|
|
@ -1587,14 +1624,20 @@ static value_t fl_lognot(value_t *args, uint32_t nargs)
|
|||
}
|
||||
}
|
||||
type_error("lognot", "integer", a);
|
||||
return FL_NIL; // TODO: remove
|
||||
}
|
||||
|
||||
static value_t fl_ash(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int64_t accum, i64;
|
||||
value_t a;
|
||||
fixnum_t n;
|
||||
int64_t accum;
|
||||
struct cprim *cp;
|
||||
void *aptr;
|
||||
int ta;
|
||||
|
||||
argcount("ash", nargs, 2);
|
||||
value_t a = args[0];
|
||||
a = args[0];
|
||||
n = tofixnum(args[1], "ash");
|
||||
if (isfixnum(a)) {
|
||||
if (n <= 0)
|
||||
|
|
@ -1605,9 +1648,6 @@ static value_t fl_ash(value_t *args, uint32_t nargs)
|
|||
else
|
||||
return return_from_int64(accum);
|
||||
}
|
||||
struct cprim *cp;
|
||||
int ta;
|
||||
void *aptr;
|
||||
if (iscprim(a)) {
|
||||
if (n == 0)
|
||||
return a;
|
||||
|
|
@ -1638,7 +1678,7 @@ static value_t fl_ash(value_t *args, uint32_t nargs)
|
|||
if (ta == T_UINT64)
|
||||
return return_from_uint64((*(uint64_t *)aptr) << n);
|
||||
else if (ta < T_FLOAT) {
|
||||
int64_t i64 = conv_to_int64(aptr, ta);
|
||||
i64 = conv_to_int64(aptr, ta);
|
||||
return return_from_int64(i64 << n);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
23
c/equal.h
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)
|
||||
{
|
||||
value_t d;
|
||||
int taga, tagb, c;
|
||||
|
||||
compare_top:
|
||||
if (a == b)
|
||||
return fixnum(0);
|
||||
if (bound <= 0)
|
||||
return NIL;
|
||||
int taga = tag(a);
|
||||
int tagb = cmptag(b);
|
||||
int c;
|
||||
taga = tag(a);
|
||||
tagb = cmptag(b);
|
||||
switch (taga) {
|
||||
case TAG_NUM:
|
||||
case TAG_NUM1:
|
||||
|
|
@ -143,10 +143,11 @@ compare_top:
|
|||
static value_t cyc_vector_compare(value_t a, value_t b, struct htable *table,
|
||||
int eq)
|
||||
{
|
||||
size_t la = vector_size(a);
|
||||
size_t lb = vector_size(b);
|
||||
size_t m, i;
|
||||
value_t d, xa, xb, ca, cb;
|
||||
size_t m, i, la, lb;
|
||||
|
||||
la = vector_size(a);
|
||||
lb = vector_size(b);
|
||||
|
||||
// first try to prove them different with no recursion
|
||||
if (eq && (la != lb))
|
||||
|
|
@ -193,6 +194,7 @@ static value_t cyc_vector_compare(value_t a, value_t b, struct htable *table,
|
|||
static value_t cyc_compare(value_t a, value_t b, struct htable *table, int eq)
|
||||
{
|
||||
value_t d, ca, cb;
|
||||
|
||||
cyc_compare_top:
|
||||
if (a == b)
|
||||
return fixnum(0);
|
||||
|
|
@ -305,7 +307,6 @@ value_t fl_equal(value_t a, value_t b)
|
|||
// *oob: output argument, means we hit the limit specified by 'bound'
|
||||
static uintptr_t bounded_hash(value_t a, int bound, int *oob)
|
||||
{
|
||||
*oob = 0;
|
||||
union {
|
||||
double d;
|
||||
int64_t i64;
|
||||
|
|
@ -315,8 +316,12 @@ static uintptr_t bounded_hash(value_t a, int bound, int *oob)
|
|||
struct cvalue *cv;
|
||||
struct cprim *cp;
|
||||
void *data;
|
||||
uintptr_t h = 0;
|
||||
int oob2, tg = tag(a);
|
||||
uintptr_t h;
|
||||
int oob2, tg;
|
||||
|
||||
*oob = 0;
|
||||
h = 0;
|
||||
tg = tag(a);
|
||||
switch (tg) {
|
||||
case TAG_NUM:
|
||||
case TAG_NUM1:
|
||||
|
|
|
|||
249
c/flisp.c
249
c/flisp.c
|
|
@ -189,6 +189,8 @@ void fl_restorestate(struct fl_exception_context *_ctx)
|
|||
|
||||
void fl_raise(value_t e)
|
||||
{
|
||||
struct fl_exception_context *thisctx;
|
||||
|
||||
fl_lasterror = e;
|
||||
// unwind read state
|
||||
while (readstate != fl_ctx->rdst) {
|
||||
|
|
@ -198,7 +200,7 @@ void fl_raise(value_t e)
|
|||
if (fl_throwing_frame == 0)
|
||||
fl_throwing_frame = curr_frame;
|
||||
N_GCHND = fl_ctx->ngchnd;
|
||||
struct fl_exception_context *thisctx = fl_ctx;
|
||||
thisctx = fl_ctx;
|
||||
if (fl_ctx->prev) // don't throw past toplevel
|
||||
fl_ctx = fl_ctx->prev;
|
||||
longjmp(thisctx->buf, 1);
|
||||
|
|
@ -207,6 +209,7 @@ void fl_raise(value_t e)
|
|||
static value_t make_error_msg(char *format, va_list args)
|
||||
{
|
||||
char msgbuf[512];
|
||||
|
||||
vsnprintf(msgbuf, sizeof(msgbuf), format, args);
|
||||
return string_from_cstr(msgbuf);
|
||||
}
|
||||
|
|
@ -214,19 +217,22 @@ static value_t make_error_msg(char *format, va_list args)
|
|||
void lerrorf(value_t e, char *format, ...)
|
||||
{
|
||||
va_list args;
|
||||
value_t msg;
|
||||
|
||||
PUSH(e);
|
||||
va_start(args, format);
|
||||
value_t msg = make_error_msg(format, args);
|
||||
msg = make_error_msg(format, args);
|
||||
va_end(args);
|
||||
|
||||
e = POP();
|
||||
fl_raise(fl_list2(e, msg));
|
||||
}
|
||||
|
||||
void lerror(value_t e, const char *msg)
|
||||
{
|
||||
value_t m;
|
||||
|
||||
PUSH(e);
|
||||
value_t m = cvalue_static_cstring(msg);
|
||||
m = cvalue_static_cstring(msg);
|
||||
e = POP();
|
||||
fl_raise(fl_list2(e, m));
|
||||
}
|
||||
|
|
@ -245,12 +251,14 @@ void bounds_error(char *fname, value_t arr, value_t ind)
|
|||
// --------------------------------------------------------
|
||||
|
||||
#define isstring fl_isstring
|
||||
// TODO: Remove the spurious return statement.
|
||||
#define SAFECAST_OP(type, ctype, cnvt) \
|
||||
ctype to##type(value_t v, char *fname) \
|
||||
{ \
|
||||
if (is##type(v)) \
|
||||
return (ctype)cnvt(v); \
|
||||
type_error(fname, #type, v); \
|
||||
return (ctype)FL_NIL; \
|
||||
}
|
||||
SAFECAST_OP(cons, struct cons *, ptr)
|
||||
SAFECAST_OP(symbol, struct symbol *, ptr)
|
||||
|
|
@ -325,10 +333,11 @@ static char gsname[2][16];
|
|||
static int gsnameno = 0;
|
||||
value_t fl_gensym(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("gensym", nargs, 0);
|
||||
struct gensym *gs;
|
||||
|
||||
(void)args;
|
||||
struct gensym *gs =
|
||||
(struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
|
||||
argcount("gensym", nargs, 0);
|
||||
gs = (struct gensym *)alloc_words(sizeof(struct gensym) / sizeof(void *));
|
||||
gs->id = _gensym_ctr++;
|
||||
gs->binding = UNBOUND;
|
||||
gs->isconst = 0;
|
||||
|
|
@ -346,11 +355,13 @@ static value_t fl_gensymp(value_t *args, uint32_t nargs)
|
|||
|
||||
char *symbol_name(value_t v)
|
||||
{
|
||||
struct gensym *gs;
|
||||
char *n;
|
||||
|
||||
if (ismanaged(v)) {
|
||||
struct gensym *gs = (struct gensym *)ptr(v);
|
||||
gs = (struct gensym *)ptr(v);
|
||||
gsnameno = 1 - gsnameno;
|
||||
char *n =
|
||||
uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
|
||||
n = uint2str(gsname[gsnameno] + 1, sizeof(gsname[0]) - 1, gs->id, 10);
|
||||
*(--n) = 'g';
|
||||
return n;
|
||||
}
|
||||
|
|
@ -402,13 +413,16 @@ static value_t the_empty_vector;
|
|||
|
||||
value_t alloc_vector(size_t n, int init)
|
||||
{
|
||||
value_t *c;
|
||||
value_t v;
|
||||
unsigned int i;
|
||||
|
||||
if (n == 0)
|
||||
return the_empty_vector;
|
||||
value_t *c = alloc_words(n + 1);
|
||||
value_t v = tagptr(c, TAG_VECTOR);
|
||||
c = alloc_words(n + 1);
|
||||
v = tagptr(c, TAG_VECTOR);
|
||||
vector_setsize(v, n);
|
||||
if (init) {
|
||||
unsigned int i;
|
||||
for (i = 0; i < n; i++)
|
||||
vector_elt(v, i) = FL_UNSPECIFIED;
|
||||
}
|
||||
|
|
@ -451,8 +465,9 @@ void fl_free_gc_handles(uint32_t n)
|
|||
static value_t relocate(value_t v)
|
||||
{
|
||||
value_t a, d, nc, first, *pcdr;
|
||||
uintptr_t t = tag(v);
|
||||
uintptr_t t;
|
||||
|
||||
t = tag(v);
|
||||
if (t == TAG_CONS) {
|
||||
// iterative implementation allows arbitrarily long cons chains
|
||||
pcdr = &first;
|
||||
|
|
@ -694,9 +709,10 @@ value_t fl_apply(value_t f, value_t l)
|
|||
value_t fl_applyn(uint32_t n, value_t f, ...)
|
||||
{
|
||||
va_list ap;
|
||||
va_start(ap, f);
|
||||
value_t v;
|
||||
size_t i;
|
||||
|
||||
va_start(ap, f);
|
||||
PUSH(f);
|
||||
while (SP + n > N_STACK)
|
||||
grow_stack();
|
||||
|
|
@ -704,7 +720,7 @@ value_t fl_applyn(uint32_t n, value_t f, ...)
|
|||
value_t a = va_arg(ap, value_t);
|
||||
PUSH(a);
|
||||
}
|
||||
value_t v = _applyn(n);
|
||||
v = _applyn(n);
|
||||
POPN(n + 1);
|
||||
va_end(ap);
|
||||
return v;
|
||||
|
|
@ -712,19 +728,22 @@ value_t fl_applyn(uint32_t n, value_t f, ...)
|
|||
|
||||
value_t fl_listn(size_t n, ...)
|
||||
{
|
||||
struct cons *c;
|
||||
struct cons *l;
|
||||
va_list ap;
|
||||
va_start(ap, n);
|
||||
uint32_t si = SP;
|
||||
uint32_t si;
|
||||
size_t i;
|
||||
|
||||
si = SP;
|
||||
va_start(ap, n);
|
||||
while (SP + n > N_STACK)
|
||||
grow_stack();
|
||||
for (i = 0; i < n; i++) {
|
||||
value_t a = va_arg(ap, value_t);
|
||||
PUSH(a);
|
||||
}
|
||||
struct cons *c = (struct cons *)alloc_words(n * 2);
|
||||
struct cons *l = c;
|
||||
c = (struct cons *)alloc_words(n * 2);
|
||||
l = c;
|
||||
for (i = 0; i < n; i++) {
|
||||
c->car = Stack[si++];
|
||||
c->cdr = tagptr(c + 1, TAG_CONS);
|
||||
|
|
@ -739,9 +758,11 @@ value_t fl_listn(size_t n, ...)
|
|||
|
||||
value_t fl_list2(value_t a, value_t b)
|
||||
{
|
||||
struct cons *c;
|
||||
|
||||
PUSH(a);
|
||||
PUSH(b);
|
||||
struct cons *c = (struct cons *)alloc_words(4);
|
||||
c = (struct cons *)alloc_words(4);
|
||||
b = POP();
|
||||
a = POP();
|
||||
c[0].car = a;
|
||||
|
|
@ -753,9 +774,11 @@ value_t fl_list2(value_t a, value_t b)
|
|||
|
||||
value_t fl_cons(value_t a, value_t b)
|
||||
{
|
||||
value_t c;
|
||||
|
||||
PUSH(a);
|
||||
PUSH(b);
|
||||
value_t c = mk_cons();
|
||||
c = mk_cons();
|
||||
cdr_(c) = POP();
|
||||
car_(c) = POP();
|
||||
return c;
|
||||
|
|
@ -763,10 +786,12 @@ value_t fl_cons(value_t a, value_t b)
|
|||
|
||||
int fl_isnumber(value_t v)
|
||||
{
|
||||
struct cprim *c;
|
||||
|
||||
if (isfixnum(v))
|
||||
return 1;
|
||||
if (iscprim(v)) {
|
||||
struct cprim *c = (struct cprim *)ptr(v);
|
||||
c = (struct cprim *)ptr(v);
|
||||
return c->type != wchartype;
|
||||
}
|
||||
return 0;
|
||||
|
|
@ -792,6 +817,7 @@ static value_t _list(value_t *args, uint32_t nargs, int star)
|
|||
struct cons *c;
|
||||
uint32_t i;
|
||||
value_t v;
|
||||
|
||||
v = cons_reserve(nargs);
|
||||
c = (struct cons *)ptr(v);
|
||||
for (i = 0; i < nargs; i++) {
|
||||
|
|
@ -808,13 +834,16 @@ static value_t _list(value_t *args, uint32_t nargs, int star)
|
|||
|
||||
static value_t copy_list(value_t L)
|
||||
{
|
||||
value_t *plcons;
|
||||
value_t *pL;
|
||||
value_t c;
|
||||
|
||||
if (!iscons(L))
|
||||
return NIL;
|
||||
PUSH(NIL);
|
||||
PUSH(L);
|
||||
value_t *plcons = &Stack[SP - 2];
|
||||
value_t *pL = &Stack[SP - 1];
|
||||
value_t c;
|
||||
plcons = &Stack[SP - 2];
|
||||
pL = &Stack[SP - 1];
|
||||
c = mk_cons();
|
||||
PUSH(c); // save first cons
|
||||
car_(c) = car_(*pL);
|
||||
|
|
@ -836,19 +865,22 @@ static value_t copy_list(value_t L)
|
|||
|
||||
static value_t do_trycatch(void)
|
||||
{
|
||||
uint32_t saveSP = SP;
|
||||
value_t v;
|
||||
value_t thunk = Stack[SP - 2];
|
||||
value_t v, thunk;
|
||||
uint32_t saveSP;
|
||||
|
||||
saveSP = SP;
|
||||
thunk = Stack[SP - 2];
|
||||
Stack[SP - 2] = Stack[SP - 1];
|
||||
Stack[SP - 1] = thunk;
|
||||
|
||||
FL_TRY { v = apply_cl(0); }
|
||||
FL_CATCH
|
||||
{
|
||||
v = Stack[saveSP - 2];
|
||||
PUSH(v);
|
||||
PUSH(fl_lasterror);
|
||||
v = apply_cl(1);
|
||||
FL_TRY { v = apply_cl(0); }
|
||||
FL_CATCH
|
||||
{
|
||||
v = Stack[saveSP - 2];
|
||||
PUSH(v);
|
||||
PUSH(fl_lasterror);
|
||||
v = apply_cl(1);
|
||||
}
|
||||
}
|
||||
SP = saveSP;
|
||||
return v;
|
||||
|
|
@ -862,14 +894,27 @@ static uint32_t process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw,
|
|||
uint32_t nopt, uint32_t bp, uint32_t nargs,
|
||||
int va)
|
||||
{
|
||||
uint32_t extr = nopt + nkw;
|
||||
uint32_t ntot = nreq + extr;
|
||||
value_t args[extr], v;
|
||||
uint32_t i, a = 0, nrestargs;
|
||||
value_t s1 = Stack[SP - 1];
|
||||
value_t s2 = Stack[SP - 2];
|
||||
value_t s4 = Stack[SP - 4];
|
||||
value_t s5 = Stack[SP - 5];
|
||||
value_t hv;
|
||||
uintptr_t x;
|
||||
uintptr_t idx;
|
||||
uintptr_t n;
|
||||
uint32_t ntot;
|
||||
value_t v;
|
||||
uint32_t extr;
|
||||
value_t *args;
|
||||
uint32_t nrestargs, i, a;
|
||||
value_t s1, s2, s4, s5;
|
||||
|
||||
extr = nopt + nkw;
|
||||
ntot = nreq + extr;
|
||||
if (!(args = calloc(extr, sizeof(*args)))) {
|
||||
lerror(MemoryError, "out of memory");
|
||||
}
|
||||
a = 0;
|
||||
s1 = Stack[SP - 1];
|
||||
s2 = Stack[SP - 2];
|
||||
s4 = Stack[SP - 4];
|
||||
s5 = Stack[SP - 5];
|
||||
if (nargs < nreq)
|
||||
lerror(ArgError, "apply: too few arguments");
|
||||
for (i = 0; i < extr; i++)
|
||||
|
|
@ -885,16 +930,16 @@ static uint32_t process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw,
|
|||
if (i >= nargs)
|
||||
goto no_kw;
|
||||
// now process keywords
|
||||
uintptr_t n = vector_size(kwtable) / 2;
|
||||
n = vector_size(kwtable) / 2;
|
||||
do {
|
||||
i++;
|
||||
if (i >= nargs)
|
||||
lerrorf(ArgError, "keyword %s requires an argument",
|
||||
symbol_name(v));
|
||||
value_t hv = fixnum(((struct symbol *)ptr(v))->hash);
|
||||
uintptr_t x = 2 * (labs(numval(hv)) % n);
|
||||
hv = fixnum(((struct symbol *)ptr(v))->hash);
|
||||
x = 2 * (labs(numval(hv)) % n);
|
||||
if (vector_elt(kwtable, x) == v) {
|
||||
uintptr_t idx = numval(vector_elt(kwtable, x + 1));
|
||||
idx = numval(vector_elt(kwtable, x + 1));
|
||||
assert(idx < nkw);
|
||||
idx += nopt;
|
||||
if (args[idx] == UNBOUND) {
|
||||
|
|
@ -2305,6 +2350,13 @@ void assign_global_builtins(struct builtinspec *b)
|
|||
|
||||
static value_t fl_function(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct cvalue *arr;
|
||||
char *data;
|
||||
int swap;
|
||||
uint32_t ms;
|
||||
struct function *fn;
|
||||
value_t fv;
|
||||
|
||||
if (nargs == 1 && issymbol(args[0]))
|
||||
return fl_builtin(args, nargs);
|
||||
if (nargs < 2 || nargs > 4)
|
||||
|
|
@ -2313,10 +2365,10 @@ static value_t fl_function(value_t *args, uint32_t nargs)
|
|||
type_error("function", "string", args[0]);
|
||||
if (!isvector(args[1]))
|
||||
type_error("function", "vector", args[1]);
|
||||
struct cvalue *arr = (struct cvalue *)ptr(args[0]);
|
||||
arr = (struct cvalue *)ptr(args[0]);
|
||||
cv_pin(arr);
|
||||
char *data = cv_data(arr);
|
||||
int swap = 0;
|
||||
data = cv_data(arr);
|
||||
swap = 0;
|
||||
if ((uint8_t)data[4] >= N_OPCODES) {
|
||||
// read syntax, shifted 48 for compact text representation
|
||||
size_t i, sz = cv_len(arr);
|
||||
|
|
@ -2327,10 +2379,10 @@ static value_t fl_function(value_t *args, uint32_t nargs)
|
|||
swap = 1;
|
||||
#endif
|
||||
}
|
||||
uint32_t ms = compute_maxstack((uint8_t *)data, cv_len(arr), swap);
|
||||
ms = compute_maxstack((uint8_t *)data, cv_len(arr), swap);
|
||||
PUT_INT32(data, ms);
|
||||
struct function *fn = (struct function *)alloc_words(4);
|
||||
value_t fv = tagptr(fn, TAG_FUNCTION);
|
||||
fn = (struct function *)alloc_words(4);
|
||||
fv = tagptr(fn, TAG_FUNCTION);
|
||||
fn->bcode = args[0];
|
||||
fn->vals = args[1];
|
||||
fn->env = NIL;
|
||||
|
|
@ -2356,32 +2408,40 @@ static value_t fl_function(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t fl_function_code(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t v;
|
||||
|
||||
argcount("function:code", nargs, 1);
|
||||
value_t v = args[0];
|
||||
v = args[0];
|
||||
if (!isclosure(v))
|
||||
type_error("function:code", "function", v);
|
||||
return fn_bcode(v);
|
||||
}
|
||||
static value_t fl_function_vals(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t v;
|
||||
|
||||
argcount("function:vals", nargs, 1);
|
||||
value_t v = args[0];
|
||||
v = args[0];
|
||||
if (!isclosure(v))
|
||||
type_error("function:vals", "function", v);
|
||||
return fn_vals(v);
|
||||
}
|
||||
static value_t fl_function_env(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t v;
|
||||
|
||||
argcount("function:env", nargs, 1);
|
||||
value_t v = args[0];
|
||||
v = args[0];
|
||||
if (!isclosure(v))
|
||||
type_error("function:env", "function", v);
|
||||
return fn_env(v);
|
||||
}
|
||||
static value_t fl_function_name(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t v;
|
||||
|
||||
argcount("function:name", nargs, 1);
|
||||
value_t v = args[0];
|
||||
v = args[0];
|
||||
if (!isclosure(v))
|
||||
type_error("function:name", "function", v);
|
||||
return fn_name(v);
|
||||
|
|
@ -2395,12 +2455,15 @@ value_t fl_copylist(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_append(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t first, lst, lastcons;
|
||||
uint32_t i;
|
||||
|
||||
if (nargs == 0)
|
||||
return NIL;
|
||||
value_t first = NIL, lst, lastcons = NIL;
|
||||
first = lastcons = NIL;
|
||||
fl_gc_handle(&first);
|
||||
fl_gc_handle(&lastcons);
|
||||
uint32_t i = 0;
|
||||
i = 0;
|
||||
while (1) {
|
||||
lst = args[i++];
|
||||
if (i >= nargs)
|
||||
|
|
@ -2442,12 +2505,14 @@ value_t fl_stacktrace(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_map1(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t first, last, v;
|
||||
int64_t argSP;
|
||||
|
||||
if (nargs < 2)
|
||||
lerror(ArgError, "map: too few arguments");
|
||||
if (!iscons(args[1]))
|
||||
return NIL;
|
||||
value_t first, last, v;
|
||||
int64_t argSP = args - Stack;
|
||||
argSP = args - Stack;
|
||||
assert(argSP >= 0 && argSP < N_STACK);
|
||||
if (nargs == 2) {
|
||||
if (SP + 3 > N_STACK)
|
||||
|
|
@ -2479,6 +2544,7 @@ value_t fl_map1(value_t *args, uint32_t nargs)
|
|||
fl_free_gc_handles(2);
|
||||
} else {
|
||||
size_t i;
|
||||
|
||||
while (SP + nargs + 1 > N_STACK)
|
||||
grow_stack();
|
||||
PUSH(Stack[argSP]);
|
||||
|
|
@ -2540,6 +2606,8 @@ extern void comparehash_init(void);
|
|||
|
||||
static void lisp_init(size_t initial_heapsize)
|
||||
{
|
||||
char buf[1024];
|
||||
char *exename;
|
||||
int i;
|
||||
|
||||
llt_init();
|
||||
|
|
@ -2632,8 +2700,7 @@ static void lisp_init(size_t initial_heapsize)
|
|||
|
||||
cvalues_init();
|
||||
|
||||
char buf[1024];
|
||||
char *exename = get_exename(buf, sizeof(buf));
|
||||
exename = get_exename(buf, sizeof(buf));
|
||||
if (exename != NULL) {
|
||||
path_to_dirname(exename);
|
||||
setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));
|
||||
|
|
@ -2669,36 +2736,38 @@ int fl_load_boot_image(void)
|
|||
ios_static_buffer(s, boot_image, sizeof(boot_image));
|
||||
PUSH(f);
|
||||
saveSP = SP;
|
||||
FL_TRY
|
||||
{
|
||||
while (1) {
|
||||
e = fl_read_sexpr(Stack[SP - 1]);
|
||||
if (ios_eof(value2c(struct ios *, Stack[SP - 1])))
|
||||
break;
|
||||
if (isfunction(e)) {
|
||||
// stage 0 format: series of thunks
|
||||
PUSH(e);
|
||||
(void)_applyn(0);
|
||||
SP = saveSP;
|
||||
} else {
|
||||
// stage 1 format: list alternating symbol/value
|
||||
while (iscons(e)) {
|
||||
sym = tosymbol(car_(e), "bootstrap");
|
||||
e = cdr_(e);
|
||||
(void)tocons(e, "bootstrap");
|
||||
sym->binding = car_(e);
|
||||
e = cdr_(e);
|
||||
FL_TRY
|
||||
{
|
||||
while (1) {
|
||||
e = fl_read_sexpr(Stack[SP - 1]);
|
||||
if (ios_eof(value2c(struct ios *, Stack[SP - 1])))
|
||||
break;
|
||||
if (isfunction(e)) {
|
||||
// stage 0 format: series of thunks
|
||||
PUSH(e);
|
||||
(void)_applyn(0);
|
||||
SP = saveSP;
|
||||
} else {
|
||||
// stage 1 format: list alternating symbol/value
|
||||
while (iscons(e)) {
|
||||
sym = tosymbol(car_(e), "bootstrap");
|
||||
e = cdr_(e);
|
||||
(void)tocons(e, "bootstrap");
|
||||
sym->binding = car_(e);
|
||||
e = cdr_(e);
|
||||
}
|
||||
break;
|
||||
}
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
FL_CATCH
|
||||
{
|
||||
ios_puts("fatal error during bootstrap:\n", ios_stderr);
|
||||
fl_print(ios_stderr, fl_lasterror);
|
||||
ios_putc('\n', ios_stderr);
|
||||
return 1;
|
||||
FL_CATCH
|
||||
{
|
||||
ios_puts("fatal error during bootstrap:\n", ios_stderr);
|
||||
fl_print(ios_stderr, fl_lasterror);
|
||||
ios_putc('\n', ios_stderr);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
ios_close(value2c(struct ios *, Stack[SP - 1]));
|
||||
POPN(1);
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@
|
|||
|
||||
struct htable *htable_new(struct htable *h, size_t size)
|
||||
{
|
||||
size_t i;
|
||||
|
||||
if (size <= HT_N_INLINE / 2) {
|
||||
h->size = size = HT_N_INLINE;
|
||||
h->table = &h->_space[0];
|
||||
|
|
@ -27,7 +29,6 @@ struct htable *htable_new(struct htable *h, size_t size)
|
|||
}
|
||||
if (h->table == NULL)
|
||||
return NULL;
|
||||
size_t i;
|
||||
for (i = 0; i < size; i++)
|
||||
h->table[i] = HT_NOTFOUND;
|
||||
return h;
|
||||
|
|
@ -42,6 +43,8 @@ void htable_free(struct htable *h)
|
|||
// empty and reduce size
|
||||
void htable_reset(struct htable *h, size_t sz)
|
||||
{
|
||||
size_t i, hsz;
|
||||
|
||||
sz = nextipow2(sz);
|
||||
if (h->size > sz * 4 && h->size > HT_N_INLINE) {
|
||||
size_t newsz = sz * 4;
|
||||
|
|
@ -52,7 +55,7 @@ void htable_reset(struct htable *h, size_t sz)
|
|||
h->size = newsz;
|
||||
h->table = newtab;
|
||||
}
|
||||
size_t i, hsz = h->size;
|
||||
hsz = h->size;
|
||||
for (i = 0; i < hsz; i++)
|
||||
h->table[i] = HT_NOTFOUND;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -100,10 +100,10 @@
|
|||
size_t maxprobe = max_probe(sz); \
|
||||
void **tab = h->table; \
|
||||
size_t index = (uintptr_t)(HFUNC((uintptr_t)key) & (sz - 1)) * 2; \
|
||||
sz *= 2; \
|
||||
size_t orig = index; \
|
||||
size_t iter = 0; \
|
||||
\
|
||||
sz *= 2; \
|
||||
do { \
|
||||
if (tab[index] == HT_NOTFOUND) \
|
||||
return NULL; \
|
||||
|
|
|
|||
123
c/ios.c
123
c/ios.c
|
|
@ -33,8 +33,11 @@
|
|||
|
||||
static void *our_memrchr(const void *s, int c, size_t n)
|
||||
{
|
||||
const unsigned char *src = s + n;
|
||||
unsigned char uc = c;
|
||||
const unsigned char *src;
|
||||
unsigned char uc;
|
||||
|
||||
src = (unsigned char *)s + n;
|
||||
uc = c;
|
||||
while (--src >= (unsigned char *)s)
|
||||
if (*src == uc)
|
||||
return (void *)src;
|
||||
|
|
@ -90,15 +93,17 @@ static int _os_read(long fd, void *buf, size_t n, size_t *nread)
|
|||
|
||||
static int _os_read_all(long fd, void *buf, size_t n, size_t *nread)
|
||||
{
|
||||
unsigned char *ubuf;
|
||||
size_t got;
|
||||
int err;
|
||||
|
||||
ubuf = buf;
|
||||
*nread = 0;
|
||||
|
||||
while (n > 0) {
|
||||
int err = _os_read(fd, buf, n, &got);
|
||||
err = _os_read(fd, ubuf, n, &got);
|
||||
n -= got;
|
||||
*nread += got;
|
||||
buf += got;
|
||||
ubuf += got;
|
||||
if (err || got == 0)
|
||||
return err;
|
||||
}
|
||||
|
|
@ -126,15 +131,17 @@ static int _os_write(long fd, void *buf, size_t n, size_t *nwritten)
|
|||
|
||||
static int _os_write_all(long fd, void *buf, size_t n, size_t *nwritten)
|
||||
{
|
||||
unsigned char *ubuf;
|
||||
size_t wrote;
|
||||
int err;
|
||||
|
||||
ubuf = buf;
|
||||
*nwritten = 0;
|
||||
|
||||
while (n > 0) {
|
||||
int err = _os_write(fd, buf, n, &wrote);
|
||||
err = _os_write(fd, ubuf, n, &wrote);
|
||||
n -= wrote;
|
||||
*nwritten += wrote;
|
||||
buf += wrote;
|
||||
ubuf += wrote;
|
||||
if (err)
|
||||
return err;
|
||||
}
|
||||
|
|
@ -291,11 +298,14 @@ size_t ios_readall(struct ios *s, char *dest, size_t n)
|
|||
|
||||
size_t ios_readprep(struct ios *s, size_t n)
|
||||
{
|
||||
size_t got, space;
|
||||
int result;
|
||||
|
||||
if (s->state == bst_wr && s->bm != bm_mem) {
|
||||
ios_flush(s);
|
||||
s->bpos = s->size = 0;
|
||||
}
|
||||
size_t space = s->size - s->bpos;
|
||||
space = s->size - s->bpos;
|
||||
s->state = bst_rd;
|
||||
if (space >= n || s->bm == bm_mem || s->fd == -1)
|
||||
return space;
|
||||
|
|
@ -311,9 +321,7 @@ size_t ios_readprep(struct ios *s, size_t n)
|
|||
return space;
|
||||
}
|
||||
}
|
||||
size_t got;
|
||||
int result =
|
||||
_os_read(s->fd, s->buf + s->size, s->maxsize - s->size, &got);
|
||||
result = _os_read(s->fd, s->buf + s->size, s->maxsize - s->size, &got);
|
||||
if (result)
|
||||
return space;
|
||||
s->size += got;
|
||||
|
|
@ -330,13 +338,14 @@ static void _write_update_pos(struct ios *s)
|
|||
|
||||
size_t ios_write(struct ios *s, char *data, size_t n)
|
||||
{
|
||||
size_t space, wrote;
|
||||
|
||||
if (s->readonly)
|
||||
return 0;
|
||||
if (n == 0)
|
||||
return 0;
|
||||
size_t space;
|
||||
size_t wrote = 0;
|
||||
|
||||
wrote = 0;
|
||||
if (s->state == bst_none)
|
||||
s->state = bst_wr;
|
||||
if (s->state == bst_rd) {
|
||||
|
|
@ -386,6 +395,8 @@ size_t ios_write(struct ios *s, char *data, size_t n)
|
|||
|
||||
off_t ios_seek(struct ios *s, off_t pos)
|
||||
{
|
||||
off_t fdpos;
|
||||
|
||||
s->_eof = 0;
|
||||
if (s->bm == bm_mem) {
|
||||
if ((size_t)pos > s->size)
|
||||
|
|
@ -393,7 +404,7 @@ off_t ios_seek(struct ios *s, off_t pos)
|
|||
s->bpos = pos;
|
||||
} else {
|
||||
ios_flush(s);
|
||||
off_t fdpos = lseek(s->fd, pos, SEEK_SET);
|
||||
fdpos = lseek(s->fd, pos, SEEK_SET);
|
||||
if (fdpos == (off_t)-1)
|
||||
return fdpos;
|
||||
s->bpos = s->size = 0;
|
||||
|
|
@ -403,12 +414,14 @@ off_t ios_seek(struct ios *s, off_t pos)
|
|||
|
||||
off_t ios_seek_end(struct ios *s)
|
||||
{
|
||||
off_t fdpos;
|
||||
|
||||
s->_eof = 1;
|
||||
if (s->bm == bm_mem) {
|
||||
s->bpos = s->size;
|
||||
} else {
|
||||
ios_flush(s);
|
||||
off_t fdpos = lseek(s->fd, 0, SEEK_END);
|
||||
fdpos = lseek(s->fd, 0, SEEK_END);
|
||||
if (fdpos == (off_t)-1)
|
||||
return fdpos;
|
||||
s->bpos = s->size = 0;
|
||||
|
|
@ -418,6 +431,8 @@ off_t ios_seek_end(struct ios *s)
|
|||
|
||||
off_t ios_skip(struct ios *s, off_t offs)
|
||||
{
|
||||
off_t fdpos;
|
||||
|
||||
if (offs != 0) {
|
||||
if (offs > 0) {
|
||||
if (offs <= (off_t)(s->size - s->bpos)) {
|
||||
|
|
@ -441,7 +456,7 @@ off_t ios_skip(struct ios *s, off_t offs)
|
|||
offs += s->bpos;
|
||||
else if (s->state == bst_rd)
|
||||
offs -= (s->size - s->bpos);
|
||||
off_t fdpos = lseek(s->fd, offs, SEEK_CUR);
|
||||
fdpos = lseek(s->fd, offs, SEEK_CUR);
|
||||
if (fdpos == (off_t)-1)
|
||||
return fdpos;
|
||||
s->bpos = s->size = 0;
|
||||
|
|
@ -452,10 +467,12 @@ off_t ios_skip(struct ios *s, off_t offs)
|
|||
|
||||
off_t ios_pos(struct ios *s)
|
||||
{
|
||||
off_t fdpos;
|
||||
|
||||
if (s->bm == bm_mem)
|
||||
return (off_t)s->bpos;
|
||||
|
||||
off_t fdpos = s->fpos;
|
||||
fdpos = s->fpos;
|
||||
if (fdpos == (off_t)-1) {
|
||||
fdpos = lseek(s->fd, 0, SEEK_CUR);
|
||||
if (fdpos == (off_t)-1)
|
||||
|
|
@ -502,6 +519,9 @@ int ios_eof(struct ios *s)
|
|||
|
||||
int ios_flush(struct ios *s)
|
||||
{
|
||||
size_t nw, ntowrite;
|
||||
int err;
|
||||
|
||||
if (s->ndirty == 0 || s->bm == bm_mem || s->buf == NULL)
|
||||
return 0;
|
||||
if (s->fd == -1)
|
||||
|
|
@ -512,9 +532,9 @@ int ios_flush(struct ios *s)
|
|||
}
|
||||
}
|
||||
|
||||
size_t nw, ntowrite = s->ndirty;
|
||||
ntowrite = s->ndirty;
|
||||
s->fpos = -1;
|
||||
int err = _os_write_all(s->fd, s->buf, ntowrite, &nw);
|
||||
err = _os_write_all(s->fd, s->buf, ntowrite, &nw);
|
||||
// todo: try recovering from some kinds of errors (e.g. retry)
|
||||
|
||||
if (s->state == bst_rd) {
|
||||
|
|
@ -596,8 +616,8 @@ char *ios_takebuf(struct ios *s, size_t *psize)
|
|||
|
||||
int ios_setbuf(struct ios *s, char *buf, size_t size, int own)
|
||||
{
|
||||
ios_flush(s);
|
||||
size_t nvalid = 0;
|
||||
ios_flush(s);
|
||||
|
||||
nvalid = (size < s->size) ? size : s->size;
|
||||
if (nvalid > 0)
|
||||
|
|
@ -637,7 +657,9 @@ void ios_set_readonly(struct ios *s)
|
|||
static size_t ios_copy_(struct ios *to, struct ios *from, size_t nbytes,
|
||||
bool_t all)
|
||||
{
|
||||
size_t total = 0, avail;
|
||||
size_t total, avail, written, ntowrite;
|
||||
|
||||
total = 0;
|
||||
if (!ios_eof(from)) {
|
||||
do {
|
||||
avail = ios_readprep(from, IOS_BUFSIZE / 2);
|
||||
|
|
@ -645,7 +667,6 @@ static size_t ios_copy_(struct ios *to, struct ios *from, size_t nbytes,
|
|||
from->_eof = 1;
|
||||
break;
|
||||
}
|
||||
size_t written, ntowrite;
|
||||
ntowrite = (avail <= nbytes || all) ? avail : nbytes;
|
||||
written = ios_write(to, from->buf + from->bpos, ntowrite);
|
||||
// TODO: should this be +=written instead?
|
||||
|
|
@ -677,23 +698,27 @@ size_t ios_copyall(struct ios *to, struct ios *from)
|
|||
|
||||
size_t ios_copyuntil(struct ios *to, struct ios *from, char delim)
|
||||
{
|
||||
size_t total = 0, avail = from->size - from->bpos;
|
||||
int first = 1;
|
||||
size_t total, avail, ntowrite, written;
|
||||
char *pd;
|
||||
int first;
|
||||
|
||||
total = 0;
|
||||
avail = from->size - from->bpos;
|
||||
first = 1;
|
||||
if (!ios_eof(from)) {
|
||||
do {
|
||||
if (avail == 0) {
|
||||
first = 0;
|
||||
avail = ios_readprep(from, LINE_CHUNK_SIZE);
|
||||
}
|
||||
size_t written;
|
||||
char *pd = (char *)memchr(from->buf + from->bpos, delim, avail);
|
||||
pd = (char *)memchr(from->buf + from->bpos, delim, avail);
|
||||
if (pd == NULL) {
|
||||
written = ios_write(to, from->buf + from->bpos, avail);
|
||||
from->bpos += avail;
|
||||
total += written;
|
||||
avail = 0;
|
||||
} else {
|
||||
size_t ntowrite = pd - (from->buf + from->bpos) + 1;
|
||||
ntowrite = pd - (from->buf + from->bpos) + 1;
|
||||
written = ios_write(to, from->buf + from->bpos, ntowrite);
|
||||
from->bpos += ntowrite;
|
||||
total += written;
|
||||
|
|
@ -731,11 +756,12 @@ static void _ios_init(struct ios *s)
|
|||
struct ios *ios_file(struct ios *s, char *fname, int rd, int wr, int create,
|
||||
int trunc)
|
||||
{
|
||||
int fd;
|
||||
int fd, flags;
|
||||
|
||||
if (!(rd || wr))
|
||||
// must specify read and/or write
|
||||
goto open_file_err;
|
||||
int flags = wr ? (rd ? O_RDWR : O_WRONLY) : O_RDONLY;
|
||||
flags = wr ? (rd ? O_RDWR : O_WRONLY) : O_RDONLY;
|
||||
if (create)
|
||||
flags |= O_CREAT;
|
||||
if (trunc)
|
||||
|
|
@ -762,7 +788,9 @@ struct ios *ios_mem(struct ios *s, size_t initsize)
|
|||
|
||||
struct ios *ios_str(struct ios *s, char *str)
|
||||
{
|
||||
size_t n = strlen(str);
|
||||
size_t n;
|
||||
|
||||
n = strlen(str);
|
||||
if (ios_mem(s, n + 1) == NULL)
|
||||
return NULL;
|
||||
ios_write(s, str, n + 1);
|
||||
|
|
@ -829,6 +857,7 @@ int ios_putc(int c, struct ios *s)
|
|||
int ios_getc(struct ios *s)
|
||||
{
|
||||
char ch;
|
||||
|
||||
if (s->state == bst_rd && s->bpos < s->size) {
|
||||
ch = s->buf[s->bpos++];
|
||||
} else {
|
||||
|
|
@ -844,11 +873,13 @@ int ios_getc(struct ios *s)
|
|||
|
||||
int ios_peekc(struct ios *s)
|
||||
{
|
||||
size_t n;
|
||||
|
||||
if (s->bpos < s->size)
|
||||
return (unsigned char)s->buf[s->bpos];
|
||||
if (s->_eof)
|
||||
return IOS_EOF;
|
||||
size_t n = ios_readprep(s, 1);
|
||||
n = ios_readprep(s, 1);
|
||||
if (n == 0)
|
||||
return IOS_EOF;
|
||||
return (unsigned char)s->buf[s->bpos];
|
||||
|
|
@ -878,7 +909,7 @@ int ios_ungetc(int c, struct ios *s)
|
|||
int ios_getutf8(struct ios *s, uint32_t *pwc)
|
||||
{
|
||||
int c;
|
||||
size_t sz;
|
||||
size_t sz, i;
|
||||
char c0;
|
||||
char buf[8];
|
||||
|
||||
|
|
@ -896,7 +927,7 @@ int ios_getutf8(struct ios *s, uint32_t *pwc)
|
|||
if (ios_readprep(s, sz) < sz)
|
||||
// NOTE: this can return EOF even if some bytes are available
|
||||
return IOS_EOF;
|
||||
size_t i = s->bpos;
|
||||
i = s->bpos;
|
||||
*pwc = u8_nextchar(s->buf, &i);
|
||||
ios_read(s, buf, sz + 1);
|
||||
return 1;
|
||||
|
|
@ -905,7 +936,7 @@ int ios_getutf8(struct ios *s, uint32_t *pwc)
|
|||
int ios_peekutf8(struct ios *s, uint32_t *pwc)
|
||||
{
|
||||
int c;
|
||||
size_t sz;
|
||||
size_t sz, i;
|
||||
char c0;
|
||||
|
||||
c = ios_peekc(s);
|
||||
|
|
@ -919,7 +950,7 @@ int ios_peekutf8(struct ios *s, uint32_t *pwc)
|
|||
sz = u8_seqlen(&c0) - 1;
|
||||
if (ios_readprep(s, sz) < sz)
|
||||
return IOS_EOF;
|
||||
size_t i = s->bpos;
|
||||
i = s->bpos;
|
||||
*pwc = u8_nextchar(s->buf, &i);
|
||||
return 1;
|
||||
}
|
||||
|
|
@ -927,9 +958,11 @@ int ios_peekutf8(struct ios *s, uint32_t *pwc)
|
|||
int ios_pututf8(struct ios *s, uint32_t wc)
|
||||
{
|
||||
char buf[8];
|
||||
size_t n;
|
||||
|
||||
if (wc < 0x80)
|
||||
return ios_putc((int)wc, s);
|
||||
size_t n = u8_toutf8(buf, 8, &wc, 1);
|
||||
n = u8_toutf8(buf, 8, &wc, 1);
|
||||
return ios_write(s, buf, n);
|
||||
}
|
||||
|
||||
|
|
@ -943,9 +976,10 @@ void ios_purge(struct ios *s)
|
|||
char *ios_readline(struct ios *s)
|
||||
{
|
||||
struct ios dest;
|
||||
size_t n;
|
||||
|
||||
ios_mem(&dest, 0);
|
||||
ios_copyuntil(&dest, s, '\n');
|
||||
size_t n;
|
||||
return ios_takebuf(&dest, &n);
|
||||
}
|
||||
|
||||
|
|
@ -953,14 +987,17 @@ int vasprintf(char **strp, const char *fmt, va_list ap);
|
|||
|
||||
int ios_vprintf(struct ios *s, const char *format, va_list args)
|
||||
{
|
||||
char *str = NULL;
|
||||
char *str;
|
||||
int c;
|
||||
va_list al;
|
||||
va_copy(al, args);
|
||||
size_t avail;
|
||||
char *start;
|
||||
|
||||
str = NULL;
|
||||
va_copy(al, args);
|
||||
if (s->state == bst_wr && s->bpos < s->maxsize && s->bm != bm_none) {
|
||||
size_t avail = s->maxsize - s->bpos;
|
||||
char *start = s->buf + s->bpos;
|
||||
avail = s->maxsize - s->bpos;
|
||||
start = s->buf + s->bpos;
|
||||
c = vsnprintf(start, avail, format, args);
|
||||
if (c < 0) {
|
||||
va_end(al);
|
||||
|
|
@ -977,10 +1014,8 @@ int ios_vprintf(struct ios *s, const char *format, va_list args)
|
|||
}
|
||||
}
|
||||
c = vasprintf(&str, format, al);
|
||||
|
||||
if (c >= 0) {
|
||||
ios_write(s, str, c);
|
||||
|
||||
LLT_FREE(str);
|
||||
}
|
||||
va_end(al);
|
||||
|
|
|
|||
187
c/iostream.c
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)
|
||||
{
|
||||
int i, r, w, c, t, a;
|
||||
value_t f;
|
||||
char *fname;
|
||||
struct ios *s;
|
||||
|
||||
if (nargs < 1)
|
||||
argcount("file", nargs, 1);
|
||||
int i, r = 0, w = 0, c = 0, t = 0, a = 0;
|
||||
r = w = c = t = a = 0;
|
||||
for (i = 1; i < (int)nargs; i++) {
|
||||
if (args[i] == wrsym)
|
||||
w = 1;
|
||||
|
|
@ -113,9 +118,9 @@ value_t fl_file(value_t *args, uint32_t nargs)
|
|||
}
|
||||
if ((r | w | c | t | a) == 0)
|
||||
r = 1; // default to reading
|
||||
value_t f = cvalue(iostreamtype, sizeof(struct ios));
|
||||
char *fname = tostring(args[0], "file");
|
||||
struct ios *s = value2c(struct ios *, f);
|
||||
f = cvalue(iostreamtype, sizeof(struct ios));
|
||||
fname = tostring(args[0], "file");
|
||||
s = value2c(struct ios *, f);
|
||||
if (ios_file(s, fname, r, w, c, t) == NULL)
|
||||
lerrorf(IOError, "file: could not open \"%s\"", fname);
|
||||
if (a)
|
||||
|
|
@ -125,10 +130,13 @@ value_t fl_file(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_buffer(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t f;
|
||||
struct ios *s;
|
||||
|
||||
argcount("buffer", nargs, 0);
|
||||
(void)args;
|
||||
value_t f = cvalue(iostreamtype, sizeof(struct ios));
|
||||
struct ios *s = value2c(struct ios *, f);
|
||||
f = cvalue(iostreamtype, sizeof(struct ios));
|
||||
s = value2c(struct ios *, f);
|
||||
if (ios_mem(s, 0) == NULL)
|
||||
lerror(MemoryError, "buffer: could not allocate stream");
|
||||
return f;
|
||||
|
|
@ -136,7 +144,9 @@ value_t fl_buffer(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_read(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t arg = 0;
|
||||
value_t arg, v;
|
||||
|
||||
arg = 0;
|
||||
if (nargs > 1) {
|
||||
argcount("read", nargs, 1);
|
||||
} else if (nargs == 0) {
|
||||
|
|
@ -146,7 +156,7 @@ value_t fl_read(value_t *args, uint32_t nargs)
|
|||
}
|
||||
(void)toiostream(arg, "read");
|
||||
fl_gc_handle(&arg);
|
||||
value_t v = fl_read_sexpr(arg);
|
||||
v = fl_read_sexpr(arg);
|
||||
fl_free_gc_handles(1);
|
||||
if (ios_eof(value2c(struct ios *, arg)))
|
||||
return FL_EOF;
|
||||
|
|
@ -155,9 +165,11 @@ value_t fl_read(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t builtin_read_u8(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("read-u8", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "read-u8");
|
||||
struct ios *s;
|
||||
int c;
|
||||
|
||||
argcount("read-u8", nargs, 1);
|
||||
s = toiostream(args[0], "read-u8");
|
||||
if ((c = ios_getc(s)) == IOS_EOF)
|
||||
// lerror(IOError, "io.getc: end of file reached");
|
||||
return FL_EOF;
|
||||
|
|
@ -166,9 +178,11 @@ value_t builtin_read_u8(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_iogetc(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("io.getc", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "io.getc");
|
||||
struct ios *s;
|
||||
uint32_t wc;
|
||||
|
||||
argcount("io.getc", nargs, 1);
|
||||
s = toiostream(args[0], "io.getc");
|
||||
if (ios_getutf8(s, &wc) == IOS_EOF)
|
||||
// lerror(IOError, "io.getc: end of file reached");
|
||||
return FL_EOF;
|
||||
|
|
@ -177,9 +191,11 @@ value_t fl_iogetc(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_iopeekc(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("io.peekc", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "io.peekc");
|
||||
struct ios *s;
|
||||
uint32_t wc;
|
||||
|
||||
argcount("io.peekc", nargs, 1);
|
||||
s = toiostream(args[0], "io.peekc");
|
||||
if (ios_peekutf8(s, &wc) == IOS_EOF)
|
||||
return FL_EOF;
|
||||
return mk_wchar(wc);
|
||||
|
|
@ -187,23 +203,29 @@ value_t fl_iopeekc(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_ioputc(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
uint32_t wc;
|
||||
|
||||
argcount("io.putc", nargs, 2);
|
||||
struct ios *s = toiostream(args[0], "io.putc");
|
||||
s = toiostream(args[0], "io.putc");
|
||||
if (!iscprim(args[1]) ||
|
||||
((struct cprim *)ptr(args[1]))->type != wchartype)
|
||||
type_error("io.putc", "wchar", args[1]);
|
||||
uint32_t wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
|
||||
wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
|
||||
return fixnum(ios_pututf8(s, wc));
|
||||
}
|
||||
|
||||
value_t fl_ioungetc(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
uint32_t wc;
|
||||
|
||||
argcount("io.ungetc", nargs, 2);
|
||||
struct ios *s = toiostream(args[0], "io.ungetc");
|
||||
s = toiostream(args[0], "io.ungetc");
|
||||
if (!iscprim(args[1]) ||
|
||||
((struct cprim *)ptr(args[1]))->type != wchartype)
|
||||
type_error("io.ungetc", "wchar", args[1]);
|
||||
uint32_t wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
|
||||
wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
|
||||
if (wc >= 0x80) {
|
||||
lerror(ArgError, "io_ungetc: unicode not yet supported");
|
||||
}
|
||||
|
|
@ -212,8 +234,10 @@ value_t fl_ioungetc(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_ioflush(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
|
||||
argcount("io.flush", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "io.flush");
|
||||
s = toiostream(args[0], "io.flush");
|
||||
if (ios_flush(s) != 0)
|
||||
return FL_F;
|
||||
return FL_T;
|
||||
|
|
@ -221,33 +245,43 @@ value_t fl_ioflush(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_ioclose(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
|
||||
argcount("io.close", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "io.close");
|
||||
s = toiostream(args[0], "io.close");
|
||||
ios_close(s);
|
||||
return FL_T;
|
||||
}
|
||||
|
||||
value_t fl_iopurge(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
|
||||
argcount("io.discardbuffer", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "io.discardbuffer");
|
||||
s = toiostream(args[0], "io.discardbuffer");
|
||||
ios_purge(s);
|
||||
return FL_T;
|
||||
}
|
||||
|
||||
value_t fl_ioeof(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
|
||||
argcount("io.eof?", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "io.eof?");
|
||||
s = toiostream(args[0], "io.eof?");
|
||||
return (ios_eof(s) ? FL_T : FL_F);
|
||||
}
|
||||
|
||||
value_t fl_ioseek(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
off_t res;
|
||||
size_t pos;
|
||||
|
||||
argcount("io.seek", nargs, 2);
|
||||
struct ios *s = toiostream(args[0], "io.seek");
|
||||
size_t pos = toulong(args[1], "io.seek");
|
||||
off_t res = ios_seek(s, (off_t)pos);
|
||||
s = toiostream(args[0], "io.seek");
|
||||
pos = toulong(args[1], "io.seek");
|
||||
res = ios_seek(s, (off_t)pos);
|
||||
if (res == -1)
|
||||
return FL_F;
|
||||
return FL_T;
|
||||
|
|
@ -255,9 +289,12 @@ value_t fl_ioseek(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_iopos(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
off_t res;
|
||||
|
||||
argcount("io.pos", nargs, 1);
|
||||
struct ios *s = toiostream(args[0], "io.pos");
|
||||
off_t res = ios_pos(s);
|
||||
s = toiostream(args[0], "io.pos");
|
||||
res = ios_pos(s);
|
||||
if (res == -1)
|
||||
return FL_F;
|
||||
return size_wrap((size_t)res);
|
||||
|
|
@ -265,9 +302,10 @@ value_t fl_iopos(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_write(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *s;
|
||||
|
||||
if (nargs < 1 || nargs > 2)
|
||||
argcount("write", nargs, 1);
|
||||
struct ios *s;
|
||||
if (nargs == 2)
|
||||
s = toiostream(args[1], "write");
|
||||
else
|
||||
|
|
@ -278,11 +316,14 @@ value_t fl_write(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_ioread(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct fltype *ft;
|
||||
char *data;
|
||||
value_t cv;
|
||||
size_t n, got;
|
||||
|
||||
if (nargs != 3)
|
||||
argcount("io.read", nargs, 2);
|
||||
(void)toiostream(args[0], "io.read");
|
||||
size_t n;
|
||||
struct fltype *ft;
|
||||
if (nargs == 3) {
|
||||
// form (io.read s type count)
|
||||
ft = get_array_type(args[1]);
|
||||
|
|
@ -293,13 +334,12 @@ value_t fl_ioread(value_t *args, uint32_t nargs)
|
|||
lerror(ArgError, "io.read: incomplete type");
|
||||
n = ft->size;
|
||||
}
|
||||
value_t cv = cvalue(ft, n);
|
||||
char *data;
|
||||
cv = cvalue(ft, n);
|
||||
if (iscvalue(cv))
|
||||
data = cv_data((struct cvalue *)ptr(cv));
|
||||
else
|
||||
data = cp_data((struct cprim *)ptr(cv));
|
||||
size_t got = ios_read(value2c(struct ios *, args[0]), data, n);
|
||||
got = ios_read(value2c(struct ios *, args[0]), data, n);
|
||||
if (got < n)
|
||||
// lerror(IOError, "io.read: end of input reached");
|
||||
return FL_EOF;
|
||||
|
|
@ -323,21 +363,25 @@ static void get_start_count_args(value_t *args, uint32_t nargs, size_t sz,
|
|||
|
||||
value_t fl_iowrite(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *data;
|
||||
struct ios *s;
|
||||
size_t nb, sz, offs;
|
||||
uint32_t wc;
|
||||
|
||||
if (nargs < 2 || nargs > 4)
|
||||
argcount("io.write", nargs, 2);
|
||||
struct ios *s = toiostream(args[0], "io.write");
|
||||
s = toiostream(args[0], "io.write");
|
||||
if (iscprim(args[1]) &&
|
||||
((struct cprim *)ptr(args[1]))->type == wchartype) {
|
||||
if (nargs > 2)
|
||||
lerror(ArgError,
|
||||
"io.write: offset argument not supported for characters");
|
||||
uint32_t wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
|
||||
wc = *(uint32_t *)cp_data((struct cprim *)ptr(args[1]));
|
||||
return fixnum(ios_pututf8(s, wc));
|
||||
}
|
||||
char *data;
|
||||
size_t sz, offs = 0;
|
||||
offs = 0;
|
||||
to_sized_ptr(args[1], "io.write", &data, &sz);
|
||||
size_t nb = sz;
|
||||
nb = sz;
|
||||
if (nargs > 2) {
|
||||
get_start_count_args(&args[1], nargs - 1, sz, &offs, &nb, "io.write");
|
||||
data += offs;
|
||||
|
|
@ -347,13 +391,16 @@ value_t fl_iowrite(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_dump(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *data;
|
||||
struct ios *s;
|
||||
size_t nb, sz, offs;
|
||||
|
||||
if (nargs < 1 || nargs > 3)
|
||||
argcount("dump", nargs, 1);
|
||||
struct ios *s = toiostream(symbol_value(outstrsym), "dump");
|
||||
char *data;
|
||||
size_t sz, offs = 0;
|
||||
s = toiostream(symbol_value(outstrsym), "dump");
|
||||
offs = 0;
|
||||
to_sized_ptr(args[0], "dump", &data, &sz);
|
||||
size_t nb = sz;
|
||||
nb = sz;
|
||||
if (nargs > 1) {
|
||||
get_start_count_args(args, nargs, sz, &offs, &nb, "dump");
|
||||
data += offs;
|
||||
|
|
@ -364,7 +411,9 @@ value_t fl_dump(value_t *args, uint32_t nargs)
|
|||
|
||||
static char get_delim_arg(value_t arg, char *fname)
|
||||
{
|
||||
size_t uldelim = toulong(arg, fname);
|
||||
size_t uldelim;
|
||||
|
||||
uldelim = toulong(arg, fname);
|
||||
if (uldelim > 0x7f) {
|
||||
// wchars > 0x7f, or anything else > 0xff, are out of range
|
||||
if ((iscprim(arg) &&
|
||||
|
|
@ -377,16 +426,23 @@ static char get_delim_arg(value_t arg, char *fname)
|
|||
|
||||
value_t fl_ioreaduntil(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("io.readuntil", nargs, 2);
|
||||
value_t str = cvalue_string(80);
|
||||
struct cvalue *cv = (struct cvalue *)ptr(str);
|
||||
char *data = cv_data(cv);
|
||||
struct ios dest;
|
||||
struct cvalue *cv;
|
||||
struct ios *src;
|
||||
char *data;
|
||||
value_t str;
|
||||
size_t n;
|
||||
char delim;
|
||||
|
||||
argcount("io.readuntil", nargs, 2);
|
||||
str = cvalue_string(80);
|
||||
cv = (struct cvalue *)ptr(str);
|
||||
data = cv_data(cv);
|
||||
ios_mem(&dest, 0);
|
||||
ios_setbuf(&dest, data, 80, 0);
|
||||
char delim = get_delim_arg(args[1], "io.readuntil");
|
||||
struct ios *src = toiostream(args[0], "io.readuntil");
|
||||
size_t n = ios_copyuntil(&dest, src, delim);
|
||||
delim = get_delim_arg(args[1], "io.readuntil");
|
||||
src = toiostream(args[0], "io.readuntil");
|
||||
n = ios_copyuntil(&dest, src, delim);
|
||||
cv->len = n;
|
||||
if (dest.buf != data) {
|
||||
// outgrew initial space
|
||||
|
|
@ -401,21 +457,29 @@ value_t fl_ioreaduntil(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_iocopyuntil(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *dest;
|
||||
struct ios *src;
|
||||
char delim;
|
||||
|
||||
argcount("io.copyuntil", nargs, 3);
|
||||
struct ios *dest = toiostream(args[0], "io.copyuntil");
|
||||
struct ios *src = toiostream(args[1], "io.copyuntil");
|
||||
char delim = get_delim_arg(args[2], "io.copyuntil");
|
||||
dest = toiostream(args[0], "io.copyuntil");
|
||||
src = toiostream(args[1], "io.copyuntil");
|
||||
delim = get_delim_arg(args[2], "io.copyuntil");
|
||||
return size_wrap(ios_copyuntil(dest, src, delim));
|
||||
}
|
||||
|
||||
value_t fl_iocopy(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *dest;
|
||||
struct ios *src;
|
||||
size_t n;
|
||||
|
||||
if (nargs < 2 || nargs > 3)
|
||||
argcount("io.copy", nargs, 2);
|
||||
struct ios *dest = toiostream(args[0], "io.copy");
|
||||
struct ios *src = toiostream(args[1], "io.copy");
|
||||
dest = toiostream(args[0], "io.copy");
|
||||
src = toiostream(args[1], "io.copy");
|
||||
if (nargs == 3) {
|
||||
size_t n = toulong(args[2], "io.copy");
|
||||
n = toulong(args[2], "io.copy");
|
||||
return size_wrap(ios_copy(dest, src, n));
|
||||
}
|
||||
return size_wrap(ios_copyall(dest, src));
|
||||
|
|
@ -423,16 +487,19 @@ value_t fl_iocopy(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t stream_to_string(value_t *ps)
|
||||
{
|
||||
struct ios *st;
|
||||
char *b;
|
||||
value_t str;
|
||||
size_t n;
|
||||
struct ios *st = value2c(struct ios *, *ps);
|
||||
|
||||
st = value2c(struct ios *, *ps);
|
||||
if (st->buf == &st->local[0]) {
|
||||
n = st->size;
|
||||
str = cvalue_string(n);
|
||||
memcpy(cvalue_data(str), value2c(struct ios *, *ps)->buf, n);
|
||||
ios_trunc(value2c(struct ios *, *ps), 0);
|
||||
} else {
|
||||
char *b = ios_takebuf(st, &n);
|
||||
b = ios_takebuf(st, &n);
|
||||
n--;
|
||||
b[n] = '\0';
|
||||
str = cvalue_from_ref(stringtype, b, n, FL_NIL);
|
||||
|
|
@ -443,8 +510,10 @@ value_t stream_to_string(value_t *ps)
|
|||
|
||||
value_t fl_iotostring(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct ios *src;
|
||||
|
||||
argcount("io.tostring!", nargs, 1);
|
||||
struct ios *src = toiostream(args[0], "io.tostring!");
|
||||
src = toiostream(args[0], "io.tostring!");
|
||||
if (src->bm != bm_mem)
|
||||
lerror(ArgError, "io.tostring!: requires memory stream");
|
||||
return stream_to_string(&args[0]);
|
||||
|
|
|
|||
|
|
@ -479,6 +479,9 @@ size_t length, /* length of the key */
|
|||
uint32_t *pc, /* IN: primary initval, OUT: primary hash */
|
||||
uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
|
||||
{
|
||||
#ifdef VALGRIND
|
||||
const uint8_t *k8;
|
||||
#endif
|
||||
uint32_t a, b, c; /* internal state */
|
||||
union {
|
||||
const void *ptr;
|
||||
|
|
@ -492,7 +495,6 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
|
|||
u.ptr = key;
|
||||
if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) {
|
||||
const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */
|
||||
const uint8_t *k8;
|
||||
|
||||
/*------ all but last block: aligned reads and affect 32 bits of
|
||||
* (a,b,c) */
|
||||
|
|
@ -517,7 +519,6 @@ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
|
|||
* noticably faster for short strings (like English words).
|
||||
*/
|
||||
#ifndef VALGRIND
|
||||
(void)k8;
|
||||
switch (length) {
|
||||
case 12:
|
||||
c += k[2];
|
||||
|
|
|
|||
|
|
@ -272,11 +272,13 @@ int cmp_same_eq(void *a, void *b, numerictype_t tag)
|
|||
|
||||
int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag)
|
||||
{
|
||||
double da, db;
|
||||
|
||||
if (atag == btag)
|
||||
return cmp_same_lt(a, b, atag);
|
||||
|
||||
double da = conv_to_double(a, atag);
|
||||
double db = conv_to_double(b, btag);
|
||||
da = conv_to_double(a, atag);
|
||||
db = conv_to_double(b, btag);
|
||||
|
||||
// casting to double will only get the wrong answer for big int64s
|
||||
// that differ in low bits
|
||||
|
|
@ -327,15 +329,17 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag)
|
|||
int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag,
|
||||
int equalnans)
|
||||
{
|
||||
double da, db;
|
||||
union {
|
||||
double d;
|
||||
int64_t i64;
|
||||
} u, v;
|
||||
|
||||
if (atag == btag && (!equalnans || atag < T_FLOAT))
|
||||
return cmp_same_eq(a, b, atag);
|
||||
|
||||
double da = conv_to_double(a, atag);
|
||||
double db = conv_to_double(b, btag);
|
||||
da = conv_to_double(a, atag);
|
||||
db = conv_to_double(b, btag);
|
||||
|
||||
if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) {
|
||||
if (equalnans) {
|
||||
|
|
|
|||
97
c/print.h
97
c/print.h
|
|
@ -10,6 +10,7 @@ static fixnum_t P_LEVEL;
|
|||
static int SCR_WIDTH = 80;
|
||||
|
||||
static int HPOS = 0, VPOS;
|
||||
|
||||
static void outc(char c, struct ios *f)
|
||||
{
|
||||
ios_putc(c, f);
|
||||
|
|
@ -18,22 +19,27 @@ static void outc(char c, struct ios *f)
|
|||
else
|
||||
HPOS++;
|
||||
}
|
||||
|
||||
static void outs(char *s, struct ios *f)
|
||||
{
|
||||
ios_puts(s, f);
|
||||
HPOS += u8_strwidth(s);
|
||||
}
|
||||
|
||||
static void outsn(char *s, struct ios *f, size_t n)
|
||||
{
|
||||
ios_write(f, s, n);
|
||||
HPOS += u8_strwidth(s);
|
||||
}
|
||||
|
||||
static int outindent(int n, struct ios *f)
|
||||
{
|
||||
int n0;
|
||||
|
||||
// move back to left margin if we get too indented
|
||||
if (n > SCR_WIDTH - 12)
|
||||
n = 2;
|
||||
int n0 = n;
|
||||
n0 = n;
|
||||
ios_putc('\n', f);
|
||||
VPOS++;
|
||||
HPOS = n;
|
||||
|
|
@ -51,6 +57,7 @@ void fl_print_str(char *s, struct ios *f) { outs(s, f); }
|
|||
void print_traverse(value_t v)
|
||||
{
|
||||
value_t *bp;
|
||||
|
||||
while (iscons(v)) {
|
||||
if (ismarked(v)) {
|
||||
bp = (value_t *)ptrhash_bp(&printconses, (void *)v);
|
||||
|
|
@ -71,26 +78,32 @@ void print_traverse(value_t v)
|
|||
return;
|
||||
}
|
||||
if (isvector(v)) {
|
||||
unsigned int i;
|
||||
|
||||
if (vector_size(v) > 0)
|
||||
mark_cons(v);
|
||||
unsigned int i;
|
||||
for (i = 0; i < vector_size(v); i++)
|
||||
print_traverse(vector_elt(v, i));
|
||||
} else if (iscprim(v)) {
|
||||
// don't consider shared references to e.g. chars
|
||||
} else if (isclosure(v)) {
|
||||
struct function *f;
|
||||
|
||||
mark_cons(v);
|
||||
struct function *f = (struct function *)ptr(v);
|
||||
f = (struct function *)ptr(v);
|
||||
print_traverse(f->bcode);
|
||||
print_traverse(f->vals);
|
||||
print_traverse(f->env);
|
||||
} else {
|
||||
struct cvalue *cv;
|
||||
struct fltype *t;
|
||||
|
||||
assert(iscvalue(v));
|
||||
struct cvalue *cv = (struct cvalue *)ptr(v);
|
||||
cv = (struct cvalue *)ptr(v);
|
||||
// don't consider shared references to ""
|
||||
if (!cv_isstr(cv) || cv_len(cv) != 0)
|
||||
mark_cons(v);
|
||||
struct fltype *t = cv_class(cv);
|
||||
t = cv_class(cv);
|
||||
if (t->vtable != NULL && t->vtable->print_traverse != NULL)
|
||||
t->vtable->print_traverse(v);
|
||||
}
|
||||
|
|
@ -98,8 +111,9 @@ void print_traverse(value_t v)
|
|||
|
||||
static void print_symbol_name(struct ios *f, char *name)
|
||||
{
|
||||
int i, escape = 0, charescape = 0;
|
||||
int i, escape, charescape;
|
||||
|
||||
escape = charescape = 0;
|
||||
if ((name[0] == '\0') || (name[0] == '.' && name[1] == '\0') ||
|
||||
(name[0] == '#') || isnumtok(name, NULL))
|
||||
escape = 1;
|
||||
|
|
@ -197,7 +211,9 @@ static int lengthestimate(value_t v)
|
|||
|
||||
static int allsmallp(value_t v)
|
||||
{
|
||||
int n = 1;
|
||||
int n;
|
||||
|
||||
n = 1;
|
||||
while (iscons(v)) {
|
||||
if (!smallp(car_(v)))
|
||||
return 0;
|
||||
|
|
@ -224,9 +240,11 @@ static int indentafter2(value_t head, value_t v)
|
|||
|
||||
static int indentevery(value_t v)
|
||||
{
|
||||
value_t c;
|
||||
|
||||
// indent before every subform of a special form, unless every
|
||||
// subform is "small"
|
||||
value_t c = car_(v);
|
||||
c = car_(v);
|
||||
if (c == LAMBDA || c == setqsym)
|
||||
return 0;
|
||||
if (c == IF) // TODO: others
|
||||
|
|
@ -245,8 +263,12 @@ static int blockindent(value_t v)
|
|||
|
||||
static void print_pair(struct ios *f, value_t v)
|
||||
{
|
||||
value_t cd;
|
||||
char *op = NULL;
|
||||
value_t cd, head;
|
||||
char *op;
|
||||
int startpos, newindent, blk, n_unindented;
|
||||
int lastv, n, si, ind, est, always, nextsmall, thistiny, after2, after3;
|
||||
|
||||
op = NULL;
|
||||
if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL &&
|
||||
!ptrhash_has(&printconses, (void *)cdr_(v)) &&
|
||||
(((car_(v) == QUOTE) && (op = "'")) ||
|
||||
|
|
@ -261,16 +283,17 @@ static void print_pair(struct ios *f, value_t v)
|
|||
fl_print_child(f, car_(cdr_(v)));
|
||||
return;
|
||||
}
|
||||
int startpos = HPOS;
|
||||
startpos = HPOS;
|
||||
outc('(', f);
|
||||
int newindent = HPOS, blk = blockindent(v);
|
||||
int lastv, n = 0, si, ind = 0, est, always = 0, nextsmall, thistiny;
|
||||
newindent = HPOS;
|
||||
blk = blockindent(v);
|
||||
n = ind = always = 0;
|
||||
if (!blk)
|
||||
always = indentevery(v);
|
||||
value_t head = car_(v);
|
||||
int after3 = indentafter3(head, v);
|
||||
int after2 = indentafter2(head, v);
|
||||
int n_unindented = 1;
|
||||
head = car_(v);
|
||||
after3 = indentafter3(head, v);
|
||||
after2 = indentafter2(head, v);
|
||||
n_unindented = 1;
|
||||
while (1) {
|
||||
cd = cdr_(v);
|
||||
if (print_length >= 0 && n >= print_length && cd != NIL) {
|
||||
|
|
@ -339,6 +362,7 @@ static void cvalue_print(struct ios *f, value_t v);
|
|||
static int print_circle_prefix(struct ios *f, value_t v)
|
||||
{
|
||||
value_t label;
|
||||
|
||||
if ((label = (value_t)ptrhash_get(&printconses, (void *)v)) !=
|
||||
(value_t)HT_NOTFOUND) {
|
||||
if (!ismarked(v)) {
|
||||
|
|
@ -355,13 +379,13 @@ static int print_circle_prefix(struct ios *f, value_t v)
|
|||
void fl_print_child(struct ios *f, value_t v)
|
||||
{
|
||||
char *name;
|
||||
|
||||
if (print_level >= 0 && P_LEVEL >= print_level &&
|
||||
(iscons(v) || isvector(v) || isclosure(v))) {
|
||||
outc('#', f);
|
||||
return;
|
||||
}
|
||||
P_LEVEL++;
|
||||
|
||||
switch (tag(v)) {
|
||||
case TAG_NUM:
|
||||
case TAG_NUM1:
|
||||
|
|
@ -393,12 +417,16 @@ void fl_print_child(struct ios *f, value_t v)
|
|||
} else {
|
||||
assert(isclosure(v));
|
||||
if (!print_princ) {
|
||||
struct function *fn;
|
||||
char *data;
|
||||
size_t i, sz;
|
||||
|
||||
if (print_circle_prefix(f, v))
|
||||
break;
|
||||
struct function *fn = (struct function *)ptr(v);
|
||||
fn = (struct function *)ptr(v);
|
||||
outs("#fn(", f);
|
||||
char *data = cvalue_data(fn->bcode);
|
||||
size_t i, sz = cvalue_len(fn->bcode);
|
||||
data = cvalue_data(fn->bcode);
|
||||
sz = cvalue_len(fn->bcode);
|
||||
for (i = 0; i < sz; i++)
|
||||
data[i] += 48;
|
||||
fl_print_child(f, fn->bcode);
|
||||
|
|
@ -432,9 +460,11 @@ void fl_print_child(struct ios *f, value_t v)
|
|||
if (!print_princ && print_circle_prefix(f, v))
|
||||
break;
|
||||
if (isvector(v)) {
|
||||
int newindent, est, sz, i;
|
||||
|
||||
outc('[', f);
|
||||
int newindent = HPOS, est;
|
||||
int i, sz = vector_size(v);
|
||||
newindent = HPOS;
|
||||
sz = vector_size(v);
|
||||
for (i = 0; i < sz; i++) {
|
||||
if (print_length >= 0 && i >= print_length && i < sz - 1) {
|
||||
outsn("...", f, 3);
|
||||
|
|
@ -605,9 +635,10 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
|
|||
else
|
||||
HPOS += ios_printf(f, "#byte(#x%hhx)", ch);
|
||||
} else if (type == wcharsym) {
|
||||
uint32_t wc = *(uint32_t *)data;
|
||||
char seq[8];
|
||||
uint32_t wc = *(uint32_t *)data;
|
||||
size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
|
||||
|
||||
seq[nb] = '\0';
|
||||
if (print_princ) {
|
||||
// TODO: better multibyte handling
|
||||
|
|
@ -648,6 +679,7 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
|
|||
char buf[64];
|
||||
double d;
|
||||
int ndec;
|
||||
|
||||
if (type == floatsym) {
|
||||
d = (double)*(float *)data;
|
||||
ndec = 8;
|
||||
|
|
@ -657,6 +689,7 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
|
|||
}
|
||||
if (!DFINITE(d)) {
|
||||
char *rep;
|
||||
|
||||
if (isnan(d))
|
||||
rep = sign_bit(d) ? "-nan.0" : "+nan.0";
|
||||
else
|
||||
|
|
@ -673,8 +706,10 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
|
|||
if (type == floatsym && !print_princ && !weak)
|
||||
outc('f', f);
|
||||
} else {
|
||||
int hasdec;
|
||||
|
||||
snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
|
||||
int hasdec = (strpbrk(buf, ".eE") != NULL);
|
||||
hasdec = (strpbrk(buf, ".eE") != NULL);
|
||||
outs(buf, f);
|
||||
if (!hasdec)
|
||||
outsn(".0", f, 2);
|
||||
|
|
@ -707,7 +742,8 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
|
|||
} else if (iscons(type)) {
|
||||
if (car_(type) == arraysym) {
|
||||
value_t eltype = car(cdr_(type));
|
||||
size_t cnt, elsize;
|
||||
size_t cnt, elsize, i;
|
||||
|
||||
if (iscons(cdr_(cdr_(type)))) {
|
||||
cnt = toulong(car_(cdr_(cdr_(type))), "length");
|
||||
elsize = cnt ? len / cnt : 0;
|
||||
|
|
@ -735,7 +771,6 @@ static void cvalue_printdata(struct ios *f, void *data, size_t len,
|
|||
// TODO wchar
|
||||
} else {
|
||||
}
|
||||
size_t i;
|
||||
if (!weak) {
|
||||
if (eltype == uint8sym) {
|
||||
outsn("#vu8(", f, 5);
|
||||
|
|
@ -811,7 +846,9 @@ static void cvalue_print(struct ios *f, value_t v)
|
|||
|
||||
static void set_print_width(void)
|
||||
{
|
||||
value_t pw = symbol_value(printwidthsym);
|
||||
value_t pw;
|
||||
|
||||
pw = symbol_value(printwidthsym);
|
||||
if (!isfixnum(pw))
|
||||
return;
|
||||
SCR_WIDTH = numval(pw);
|
||||
|
|
@ -819,12 +856,14 @@ static void set_print_width(void)
|
|||
|
||||
void fl_print(struct ios *f, value_t v)
|
||||
{
|
||||
value_t pl;
|
||||
|
||||
print_pretty = (symbol_value(printprettysym) != FL_F);
|
||||
if (print_pretty)
|
||||
set_print_width();
|
||||
print_princ = (symbol_value(printreadablysym) == FL_F);
|
||||
|
||||
value_t pl = symbol_value(printlengthsym);
|
||||
pl = symbol_value(printlengthsym);
|
||||
if (isfixnum(pl))
|
||||
print_length = numval(pl);
|
||||
else
|
||||
|
|
|
|||
50
c/read.h
50
c/read.h
|
|
@ -394,16 +394,24 @@ static uint32_t peek(void)
|
|||
tokval = fixnum(x);
|
||||
} else if (symchar(c)) {
|
||||
read_token(ch, 0);
|
||||
|
||||
if (((c == 'b' && (base = 2)) || (c == 'o' && (base = 8)) ||
|
||||
(c == 'd' && (base = 10)) || (c == 'x' && (base = 16))) &&
|
||||
(isdigit_base(buf[1], base) || buf[1] == '-')) {
|
||||
if (c == 'b') {
|
||||
base = 2;
|
||||
} else if (c == 'o') {
|
||||
base = 8;
|
||||
} else if (c == 'd') {
|
||||
base = 10;
|
||||
} else if (c == 'x') {
|
||||
base = 16;
|
||||
} else {
|
||||
base = 0;
|
||||
}
|
||||
if (base && (isdigit_base(buf[1], base) || buf[1] == '-')) {
|
||||
if (!read_numtok(&buf[1], &tokval, base))
|
||||
lerrorf(ParseError, "read: invalid base %d constant",
|
||||
base);
|
||||
return (toktype = TOK_NUM);
|
||||
toktype = TOK_NUM;
|
||||
return toktype;
|
||||
}
|
||||
|
||||
toktype = TOK_SHARPSYM;
|
||||
tokval = symbol(buf);
|
||||
} else {
|
||||
|
|
@ -439,11 +447,15 @@ static uint32_t peek(void)
|
|||
// reader, and requires at least 1 and up to 3 garbage collections!
|
||||
static value_t vector_grow(value_t v)
|
||||
{
|
||||
size_t i, s = vector_size(v);
|
||||
size_t d = vector_grow_amt(s);
|
||||
value_t newv;
|
||||
size_t i, s;
|
||||
size_t d;
|
||||
|
||||
s = vector_size(v);
|
||||
d = vector_grow_amt(s);
|
||||
PUSH(v);
|
||||
assert(s + d > s);
|
||||
value_t newv = alloc_vector(s + d, 1);
|
||||
newv = alloc_vector(s + d, 1);
|
||||
v = Stack[SP - 1];
|
||||
for (i = 0; i < s; i++)
|
||||
vector_elt(newv, i) = vector_elt(v, i);
|
||||
|
|
@ -459,8 +471,11 @@ static value_t vector_grow(value_t v)
|
|||
|
||||
static value_t read_vector(value_t label, uint32_t closer)
|
||||
{
|
||||
value_t v = the_empty_vector, elt;
|
||||
uint32_t i = 0;
|
||||
value_t v, elt;
|
||||
uint32_t i;
|
||||
|
||||
v = the_empty_vector;
|
||||
i = 0;
|
||||
PUSH(v);
|
||||
if (label != UNBOUND)
|
||||
ptrhash_put(&readstate->backrefs, (void *)label, (void *)v);
|
||||
|
|
@ -529,8 +544,17 @@ static value_t read_string(void)
|
|||
wc = strtol(eseq, NULL, 8);
|
||||
// \DDD and \xXX read bytes, not characters
|
||||
buf[i++] = ((char)wc);
|
||||
} else if ((c == 'x' && (ndig = 2)) || (c == 'u' && (ndig = 4)) ||
|
||||
(c == 'U' && (ndig = 8))) {
|
||||
}
|
||||
if (c == 'x') {
|
||||
ndig = 2;
|
||||
} else if (c == 'u') {
|
||||
ndig = 4;
|
||||
} else if (c == 'U') {
|
||||
ndig = 8;
|
||||
} else {
|
||||
ndig = 0;
|
||||
}
|
||||
if (ndig) {
|
||||
c = ios_getc(F);
|
||||
while (hex_digit(c) && j < ndig && (c != IOS_EOF)) {
|
||||
eseq[j++] = c;
|
||||
|
|
|
|||
200
c/string.c
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)
|
||||
{
|
||||
size_t start = 0;
|
||||
char *str;
|
||||
size_t start, len, stop;
|
||||
|
||||
start = 0;
|
||||
if (nargs < 1 || nargs > 3)
|
||||
argcount("string.count", nargs, 1);
|
||||
if (!fl_isstring(args[0]))
|
||||
type_error("string.count", "string", args[0]);
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
size_t stop = len;
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
stop = len;
|
||||
if (nargs > 1) {
|
||||
start = toulong(args[1], "string.count");
|
||||
if (start > len)
|
||||
|
|
@ -61,12 +64,14 @@ value_t fl_string_count(value_t *args, uint32_t nargs)
|
|||
return fixnum(0);
|
||||
}
|
||||
}
|
||||
char *str = cvalue_data(args[0]);
|
||||
str = cvalue_data(args[0]);
|
||||
return size_wrap(u8_charnum(str + start, stop - start));
|
||||
}
|
||||
|
||||
value_t fl_string_width(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *s;
|
||||
|
||||
argcount("string.width", nargs, 1);
|
||||
if (iscprim(args[0])) {
|
||||
struct cprim *cp = (struct cprim *)ptr(args[0]);
|
||||
|
|
@ -77,17 +82,20 @@ value_t fl_string_width(value_t *args, uint32_t nargs)
|
|||
return fixnum(w);
|
||||
}
|
||||
}
|
||||
char *s = tostring(args[0], "string.width");
|
||||
s = tostring(args[0], "string.width");
|
||||
return size_wrap(u8_strwidth(s));
|
||||
}
|
||||
|
||||
value_t fl_string_reverse(value_t *args, uint32_t nargs)
|
||||
{
|
||||
size_t len;
|
||||
value_t ns;
|
||||
|
||||
argcount("string.reverse", nargs, 1);
|
||||
if (!fl_isstring(args[0]))
|
||||
type_error("string.reverse", "string", args[0]);
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
value_t ns = cvalue_string(len);
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
ns = cvalue_string(len);
|
||||
u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
|
||||
return ns;
|
||||
}
|
||||
|
|
@ -110,11 +118,19 @@ value_t fl_string_encode(value_t *args, uint32_t nargs)
|
|||
}
|
||||
}
|
||||
type_error("string.encode", "wchar array", args[0]);
|
||||
return FL_NIL; // TODO: remove
|
||||
}
|
||||
|
||||
value_t fl_string_decode(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int term = 0;
|
||||
int term;
|
||||
struct cvalue *cv;
|
||||
char *ptr;
|
||||
size_t nb, nc, newsz;
|
||||
value_t wcstr;
|
||||
uint32_t *pwc;
|
||||
|
||||
term = 0;
|
||||
if (nargs == 2) {
|
||||
term = (args[1] != FL_F);
|
||||
} else {
|
||||
|
|
@ -122,16 +138,16 @@ value_t fl_string_decode(value_t *args, uint32_t nargs)
|
|||
}
|
||||
if (!fl_isstring(args[0]))
|
||||
type_error("string.decode", "string", args[0]);
|
||||
struct cvalue *cv = (struct cvalue *)ptr(args[0]);
|
||||
char *ptr = (char *)cv_data(cv);
|
||||
size_t nb = cv_len(cv);
|
||||
size_t nc = u8_charnum(ptr, nb);
|
||||
size_t newsz = nc * sizeof(uint32_t);
|
||||
cv = (struct cvalue *)ptr(args[0]);
|
||||
ptr = (char *)cv_data(cv);
|
||||
nb = cv_len(cv);
|
||||
nc = u8_charnum(ptr, nb);
|
||||
newsz = nc * sizeof(uint32_t);
|
||||
if (term)
|
||||
newsz += sizeof(uint32_t);
|
||||
value_t wcstr = cvalue(wcstringtype, newsz);
|
||||
wcstr = cvalue(wcstringtype, newsz);
|
||||
ptr = cv_data((struct cvalue *)ptr(args[0])); // relocatable pointer
|
||||
uint32_t *pwc = cvalue_data(wcstr);
|
||||
pwc = cvalue_data(wcstr);
|
||||
u8_toucs(pwc, nc, ptr, nb);
|
||||
if (term)
|
||||
pwc[nc] = 0;
|
||||
|
|
@ -143,37 +159,44 @@ extern value_t stream_to_string(value_t *ps);
|
|||
|
||||
value_t fl_string(value_t *args, uint32_t nargs)
|
||||
{
|
||||
value_t arg, buf;
|
||||
struct ios *s;
|
||||
uint32_t i;
|
||||
value_t oldpr, oldpp, outp;
|
||||
|
||||
if (nargs == 1 && fl_isstring(args[0]))
|
||||
return args[0];
|
||||
value_t arg, buf = fl_buffer(NULL, 0);
|
||||
buf = fl_buffer(NULL, 0);
|
||||
fl_gc_handle(&buf);
|
||||
struct ios *s = value2c(struct ios *, buf);
|
||||
uint32_t i;
|
||||
value_t oldpr = symbol_value(printreadablysym);
|
||||
value_t oldpp = symbol_value(printprettysym);
|
||||
s = value2c(struct ios *, buf);
|
||||
oldpr = symbol_value(printreadablysym);
|
||||
oldpp = symbol_value(printprettysym);
|
||||
set(printreadablysym, FL_F);
|
||||
set(printprettysym, FL_F);
|
||||
FOR_ARGS(i, 0, arg, args) { fl_print(s, args[i]); }
|
||||
set(printreadablysym, oldpr);
|
||||
set(printprettysym, oldpp);
|
||||
value_t outp = stream_to_string(&buf);
|
||||
outp = stream_to_string(&buf);
|
||||
fl_free_gc_handles(1);
|
||||
return outp;
|
||||
}
|
||||
|
||||
value_t fl_string_split(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *s;
|
||||
char *delim;
|
||||
size_t len, dlen, ssz, tokend, tokstart, i, junk;
|
||||
value_t first, c, last;
|
||||
|
||||
argcount("string.split", nargs, 2);
|
||||
char *s = tostring(args[0], "string.split");
|
||||
char *delim = tostring(args[1], "string.split");
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
size_t dlen = cv_len((struct cvalue *)ptr(args[1]));
|
||||
size_t ssz, tokend = 0, tokstart = 0, i = 0;
|
||||
value_t first = FL_NIL, c = FL_NIL, last;
|
||||
size_t junk;
|
||||
s = tostring(args[0], "string.split");
|
||||
delim = tostring(args[1], "string.split");
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
dlen = cv_len((struct cvalue *)ptr(args[1]));
|
||||
tokend = tokstart = i = 0;
|
||||
first = c = FL_NIL;
|
||||
fl_gc_handle(&first);
|
||||
fl_gc_handle(&last);
|
||||
|
||||
do {
|
||||
// find and allocate next token
|
||||
tokstart = tokend = i;
|
||||
|
|
@ -207,11 +230,14 @@ value_t fl_string_split(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_string_sub(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *s;
|
||||
size_t len, i1, i2;
|
||||
value_t ns;
|
||||
|
||||
if (nargs != 2)
|
||||
argcount("string.sub", nargs, 3);
|
||||
char *s = tostring(args[0], "string.sub");
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
size_t i1, i2;
|
||||
s = tostring(args[0], "string.sub");
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
i1 = toulong(args[1], "string.sub");
|
||||
if (i1 > len)
|
||||
bounds_error("string.sub", args[0], args[1]);
|
||||
|
|
@ -224,20 +250,23 @@ value_t fl_string_sub(value_t *args, uint32_t nargs)
|
|||
}
|
||||
if (i2 <= i1)
|
||||
return cvalue_string(0);
|
||||
value_t ns = cvalue_string(i2 - i1);
|
||||
ns = cvalue_string(i2 - i1);
|
||||
memcpy(cv_data((struct cvalue *)ptr(ns)), &s[i1], i2 - i1);
|
||||
return ns;
|
||||
}
|
||||
|
||||
value_t fl_string_char(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *s;
|
||||
size_t len, i, sl;
|
||||
|
||||
argcount("string.char", nargs, 2);
|
||||
char *s = tostring(args[0], "string.char");
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
size_t i = toulong(args[1], "string.char");
|
||||
s = tostring(args[0], "string.char");
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
i = toulong(args[1], "string.char");
|
||||
if (i >= len)
|
||||
bounds_error("string.char", args[0], args[1]);
|
||||
size_t sl = u8_seqlen(&s[i]);
|
||||
sl = u8_seqlen(&s[i]);
|
||||
if (sl > len || i > len - sl)
|
||||
bounds_error("string.char", args[0], args[1]);
|
||||
return mk_wchar(u8_nextchar(s, &i));
|
||||
|
|
@ -245,16 +274,20 @@ value_t fl_string_char(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_char_upcase(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct cprim *cp;
|
||||
|
||||
argcount("char.upcase", nargs, 1);
|
||||
struct cprim *cp = (struct cprim *)ptr(args[0]);
|
||||
cp = (struct cprim *)ptr(args[0]);
|
||||
if (!iscprim(args[0]) || cp_class(cp) != wchartype)
|
||||
type_error("char.upcase", "wchar", args[0]);
|
||||
return mk_wchar(towupper(*(int32_t *)cp_data(cp)));
|
||||
}
|
||||
value_t fl_char_downcase(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct cprim *cp;
|
||||
|
||||
argcount("char.downcase", nargs, 1);
|
||||
struct cprim *cp = (struct cprim *)ptr(args[0]);
|
||||
cp = (struct cprim *)ptr(args[0]);
|
||||
if (!iscprim(args[0]) || cp_class(cp) != wchartype)
|
||||
type_error("char.downcase", "wchar", args[0]);
|
||||
return mk_wchar(towlower(*(int32_t *)cp_data(cp)));
|
||||
|
|
@ -262,8 +295,10 @@ value_t fl_char_downcase(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_char_alpha(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct cprim *cp;
|
||||
|
||||
argcount("char-alphabetic?", nargs, 1);
|
||||
struct cprim *cp = (struct cprim *)ptr(args[0]);
|
||||
cp = (struct cprim *)ptr(args[0]);
|
||||
if (!iscprim(args[0]) || cp_class(cp) != wchartype)
|
||||
type_error("char-alphabetic?", "wchar", args[0]);
|
||||
return iswalpha(*(int32_t *)cp_data(cp)) ? FL_T : FL_F;
|
||||
|
|
@ -271,7 +306,9 @@ value_t fl_char_alpha(value_t *args, uint32_t nargs)
|
|||
|
||||
static value_t mem_find_byte(char *s, char c, size_t start, size_t len)
|
||||
{
|
||||
char *p = memchr(s + start, c, len - start);
|
||||
char *p;
|
||||
|
||||
p = memchr(s + start, c, len - start);
|
||||
if (p == NULL)
|
||||
return FL_F;
|
||||
return size_wrap((size_t)(p - s));
|
||||
|
|
@ -280,20 +317,25 @@ static value_t mem_find_byte(char *s, char c, size_t start, size_t len)
|
|||
value_t fl_string_find(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char cbuf[8];
|
||||
size_t start = 0;
|
||||
char *s;
|
||||
char *needle;
|
||||
struct cprim *cp;
|
||||
value_t v;
|
||||
size_t start, len, needlesz, i;
|
||||
|
||||
if (nargs == 3)
|
||||
start = toulong(args[2], "string.find");
|
||||
else
|
||||
else {
|
||||
argcount("string.find", nargs, 2);
|
||||
char *s = tostring(args[0], "string.find");
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
start = 0;
|
||||
}
|
||||
s = tostring(args[0], "string.find");
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
if (start > len)
|
||||
bounds_error("string.find", args[0], args[2]);
|
||||
char *needle;
|
||||
size_t needlesz;
|
||||
|
||||
value_t v = args[1];
|
||||
struct cprim *cp = (struct cprim *)ptr(v);
|
||||
v = args[1];
|
||||
cp = (struct cprim *)ptr(v);
|
||||
if (iscprim(v) && cp_class(cp) == wchartype) {
|
||||
uint32_t c = *(uint32_t *)cp_data(cp);
|
||||
if (c <= 0x7f)
|
||||
|
|
@ -315,7 +357,6 @@ value_t fl_string_find(value_t *args, uint32_t nargs)
|
|||
return mem_find_byte(s, needle[0], start, len);
|
||||
else if (needlesz == 0)
|
||||
return size_wrap(start);
|
||||
size_t i;
|
||||
for (i = start; i < len - needlesz + 1; i++) {
|
||||
if (s[i] == needle[0]) {
|
||||
if (!memcmp(&s[i + 1], needle + 1, needlesz - 1))
|
||||
|
|
@ -327,12 +368,15 @@ value_t fl_string_find(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_string_inc(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *s;
|
||||
size_t len, cnt, i;
|
||||
|
||||
if (nargs < 2 || nargs > 3)
|
||||
argcount("string.inc", nargs, 2);
|
||||
char *s = tostring(args[0], "string.inc");
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
size_t i = toulong(args[1], "string.inc");
|
||||
size_t cnt = 1;
|
||||
s = tostring(args[0], "string.inc");
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
i = toulong(args[1], "string.inc");
|
||||
cnt = 1;
|
||||
if (nargs == 3)
|
||||
cnt = toulong(args[2], "string.inc");
|
||||
while (cnt--) {
|
||||
|
|
@ -345,12 +389,15 @@ value_t fl_string_inc(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_string_dec(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *s;
|
||||
size_t len, cnt, i;
|
||||
|
||||
if (nargs < 2 || nargs > 3)
|
||||
argcount("string.dec", nargs, 2);
|
||||
char *s = tostring(args[0], "string.dec");
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
size_t i = toulong(args[1], "string.dec");
|
||||
size_t cnt = 1;
|
||||
s = tostring(args[0], "string.dec");
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
i = toulong(args[1], "string.dec");
|
||||
cnt = 1;
|
||||
if (nargs == 3)
|
||||
cnt = toulong(args[2], "string.dec");
|
||||
// note: i is allowed to start at index len
|
||||
|
|
@ -366,7 +413,9 @@ value_t fl_string_dec(value_t *args, uint32_t nargs)
|
|||
|
||||
static unsigned long get_radix_arg(value_t arg, char *fname)
|
||||
{
|
||||
unsigned long radix = toulong(arg, fname);
|
||||
unsigned long radix;
|
||||
|
||||
radix = toulong(arg, fname);
|
||||
if (radix < 2 || radix > 36)
|
||||
lerrorf(ArgError, "%s: invalid radix", fname);
|
||||
return radix;
|
||||
|
|
@ -374,11 +423,17 @@ static unsigned long get_radix_arg(value_t arg, char *fname)
|
|||
|
||||
value_t fl_numbertostring(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char buf[128];
|
||||
uint64_t num;
|
||||
unsigned long radix;
|
||||
value_t n;
|
||||
char *str;
|
||||
int neg;
|
||||
|
||||
if (nargs < 1 || nargs > 2)
|
||||
argcount("number->string", nargs, 2);
|
||||
value_t n = args[0];
|
||||
int neg = 0;
|
||||
uint64_t num;
|
||||
n = args[0];
|
||||
neg = 0;
|
||||
if (isfixnum(n))
|
||||
num = numval(n);
|
||||
else if (!iscprim(n))
|
||||
|
|
@ -390,11 +445,10 @@ value_t fl_numbertostring(value_t *args, uint32_t nargs)
|
|||
num = -num;
|
||||
neg = 1;
|
||||
}
|
||||
unsigned long radix = 10;
|
||||
radix = 10;
|
||||
if (nargs == 2)
|
||||
radix = get_radix_arg(args[1], "number->string");
|
||||
char buf[128];
|
||||
char *str = uint2str(buf, sizeof(buf), num, radix);
|
||||
str = uint2str(buf, sizeof(buf), num, radix);
|
||||
if (neg && str > &buf[0])
|
||||
*(--str) = '-';
|
||||
return string_from_cstr(str);
|
||||
|
|
@ -402,11 +456,14 @@ value_t fl_numbertostring(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_stringtonumber(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *str;
|
||||
value_t n;
|
||||
unsigned long radix;
|
||||
|
||||
if (nargs < 1 || nargs > 2)
|
||||
argcount("string->number", nargs, 2);
|
||||
char *str = tostring(args[0], "string->number");
|
||||
value_t n;
|
||||
unsigned long radix = 0;
|
||||
str = tostring(args[0], "string->number");
|
||||
radix = 0;
|
||||
if (nargs == 2)
|
||||
radix = get_radix_arg(args[1], "string->number");
|
||||
if (!isnumtok_base(str, &n, (int)radix))
|
||||
|
|
@ -416,9 +473,12 @@ value_t fl_stringtonumber(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_string_isutf8(value_t *args, uint32_t nargs)
|
||||
{
|
||||
char *s;
|
||||
size_t len;
|
||||
|
||||
argcount("string.isutf8", nargs, 1);
|
||||
char *s = tostring(args[0], "string.isutf8");
|
||||
size_t len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
s = tostring(args[0], "string.isutf8");
|
||||
len = cv_len((struct cvalue *)ptr(args[0]));
|
||||
return u8_isvalid(s, len) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
|
|
|
|||
61
c/table.c
61
c/table.c
|
|
@ -70,12 +70,14 @@ void free_htable(value_t self)
|
|||
|
||||
void relocate_htable(value_t oldv, value_t newv)
|
||||
{
|
||||
struct htable *oldh =
|
||||
(struct htable *)cv_data((struct cvalue *)ptr(oldv));
|
||||
struct htable *h = (struct htable *)cv_data((struct cvalue *)ptr(newv));
|
||||
size_t i;
|
||||
struct htable *oldh;
|
||||
struct htable *h;
|
||||
|
||||
oldh = (struct htable *)cv_data((struct cvalue *)ptr(oldv));
|
||||
h = (struct htable *)cv_data((struct cvalue *)ptr(newv));
|
||||
if (oldh->table == &oldh->_space[0])
|
||||
h->table = &h->_space[0];
|
||||
size_t i;
|
||||
for (i = 0; i < h->size; i++) {
|
||||
if (h->table[i] != HT_NOTFOUND)
|
||||
h->table[i] = (void *)relocate_lispvalue((value_t)h->table[i]);
|
||||
|
|
@ -105,10 +107,14 @@ static struct htable *totable(value_t v, char *fname)
|
|||
|
||||
value_t fl_table(value_t *args, uint32_t nargs)
|
||||
{
|
||||
size_t cnt = (size_t)nargs;
|
||||
struct htable *h;
|
||||
value_t nt, k, arg;
|
||||
size_t cnt;
|
||||
uint32_t i;
|
||||
|
||||
cnt = (size_t)nargs;
|
||||
if (cnt & 1)
|
||||
lerror(ArgError, "table: arguments must come in pairs");
|
||||
value_t nt;
|
||||
// prevent small tables from being added to finalizer list
|
||||
if (cnt <= HT_N_INLINE) {
|
||||
tabletype->vtable->finalize = NULL;
|
||||
|
|
@ -117,10 +123,10 @@ value_t fl_table(value_t *args, uint32_t nargs)
|
|||
} else {
|
||||
nt = cvalue(tabletype, 2 * sizeof(void *));
|
||||
}
|
||||
struct htable *h = (struct htable *)cv_data((struct cvalue *)ptr(nt));
|
||||
h = (struct htable *)cv_data((struct cvalue *)ptr(nt));
|
||||
htable_new(h, cnt / 2);
|
||||
uint32_t i;
|
||||
value_t k = FL_NIL, arg = FL_NIL;
|
||||
k = FL_NIL;
|
||||
arg = FL_NIL;
|
||||
FOR_ARGS(i, 0, arg, args)
|
||||
{
|
||||
if (i & 1)
|
||||
|
|
@ -134,9 +140,12 @@ value_t fl_table(value_t *args, uint32_t nargs)
|
|||
// (put! table key value)
|
||||
value_t fl_table_put(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct htable *h;
|
||||
void **table0;
|
||||
|
||||
argcount("put!", nargs, 3);
|
||||
struct htable *h = totable(args[0], "put!");
|
||||
void **table0 = h->table;
|
||||
h = totable(args[0], "put!");
|
||||
table0 = h->table;
|
||||
equalhash_put(h, (void *)args[1], (void *)args[2]);
|
||||
// register finalizer if we outgrew inline space
|
||||
if (table0 == &h->_space[0] && h->table != &h->_space[0]) {
|
||||
|
|
@ -155,10 +164,13 @@ static void key_error(char *fname, value_t key)
|
|||
// (get table key [default])
|
||||
value_t fl_table_get(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct htable *h;
|
||||
value_t v;
|
||||
|
||||
if (nargs != 3)
|
||||
argcount("get", nargs, 2);
|
||||
struct htable *h = totable(args[0], "get");
|
||||
value_t v = (value_t)equalhash_get(h, (void *)args[1]);
|
||||
h = totable(args[0], "get");
|
||||
v = (value_t)equalhash_get(h, (void *)args[1]);
|
||||
if (v == (value_t)HT_NOTFOUND) {
|
||||
if (nargs == 3)
|
||||
return args[2];
|
||||
|
|
@ -170,16 +182,20 @@ value_t fl_table_get(value_t *args, uint32_t nargs)
|
|||
// (has? table key)
|
||||
value_t fl_table_has(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct htable *h;
|
||||
|
||||
argcount("has", nargs, 2);
|
||||
struct htable *h = totable(args[0], "has");
|
||||
h = totable(args[0], "has");
|
||||
return equalhash_has(h, (void *)args[1]) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
// (del! table key)
|
||||
value_t fl_table_del(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct htable *h;
|
||||
|
||||
argcount("del!", nargs, 2);
|
||||
struct htable *h = totable(args[0], "del!");
|
||||
h = totable(args[0], "del!");
|
||||
if (!equalhash_remove(h, (void *)args[1]))
|
||||
key_error("del!", args[1]);
|
||||
return args[0];
|
||||
|
|
@ -187,11 +203,18 @@ value_t fl_table_del(value_t *args, uint32_t nargs)
|
|||
|
||||
value_t fl_table_foldl(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct htable *h;
|
||||
void **table;
|
||||
size_t i, n;
|
||||
value_t f, zero, t;
|
||||
|
||||
argcount("table.foldl", nargs, 3);
|
||||
value_t f = args[0], zero = args[1], t = args[2];
|
||||
struct htable *h = totable(t, "table.foldl");
|
||||
size_t i, n = h->size;
|
||||
void **table = h->table;
|
||||
f = args[0];
|
||||
zero = args[1];
|
||||
t = args[2];
|
||||
h = totable(t, "table.foldl");
|
||||
n = h->size;
|
||||
table = h->table;
|
||||
fl_gc_handle(&f);
|
||||
fl_gc_handle(&zero);
|
||||
fl_gc_handle(&t);
|
||||
|
|
|
|||
22
c/types.h
22
c/types.h
|
|
@ -1,25 +1,25 @@
|
|||
struct fltype *get_type(value_t t)
|
||||
{
|
||||
struct fltype *ft;
|
||||
void **bp;
|
||||
size_t sz;
|
||||
int align, isarray;
|
||||
|
||||
if (issymbol(t)) {
|
||||
ft = ((struct symbol *)ptr(t))->type;
|
||||
if (ft != NULL)
|
||||
return ft;
|
||||
}
|
||||
void **bp = equalhash_bp(&TypeTable, (void *)t);
|
||||
bp = equalhash_bp(&TypeTable, (void *)t);
|
||||
if (*bp != HT_NOTFOUND)
|
||||
return *bp;
|
||||
|
||||
int align,
|
||||
isarray = (iscons(t) && car_(t) == arraysym && iscons(cdr_(t)));
|
||||
size_t sz;
|
||||
if (isarray && !iscons(cdr_(cdr_(t)))) {
|
||||
// special case: incomplete array type
|
||||
sz = 0;
|
||||
} else {
|
||||
sz = ctype_sizeof(t, &align);
|
||||
}
|
||||
|
||||
ft = (struct fltype *)malloc(sizeof(struct fltype));
|
||||
ft->type = t;
|
||||
if (issymbol(t)) {
|
||||
|
|
@ -58,7 +58,9 @@ struct fltype *get_type(value_t t)
|
|||
|
||||
struct fltype *get_array_type(value_t eltype)
|
||||
{
|
||||
struct fltype *et = get_type(eltype);
|
||||
struct fltype *et;
|
||||
|
||||
et = get_type(eltype);
|
||||
if (et->artype == NULL)
|
||||
et->artype = get_type(fl_list2(arraysym, eltype));
|
||||
return et->artype;
|
||||
|
|
@ -67,7 +69,9 @@ struct fltype *get_array_type(value_t eltype)
|
|||
struct fltype *define_opaque_type(value_t sym, size_t sz,
|
||||
struct cvtable *vtab, cvinitfunc_t init)
|
||||
{
|
||||
struct fltype *ft = (struct fltype *)malloc(sizeof(struct fltype));
|
||||
struct fltype *ft;
|
||||
|
||||
ft = (struct fltype *)malloc(sizeof(struct fltype));
|
||||
ft->type = sym;
|
||||
ft->size = sz;
|
||||
ft->numtype = N_NUMTYPES;
|
||||
|
|
@ -82,9 +86,11 @@ struct fltype *define_opaque_type(value_t sym, size_t sz,
|
|||
|
||||
void relocate_typetable(void)
|
||||
{
|
||||
struct htable *h = &TypeTable;
|
||||
struct htable *h;
|
||||
size_t i;
|
||||
void *nv;
|
||||
|
||||
h = &TypeTable;
|
||||
for (i = 0; i < h->size; i += 2) {
|
||||
if (h->table[i] != HT_NOTFOUND) {
|
||||
nv = (void *)relocate((value_t)h->table[i]);
|
||||
|
|
|
|||
31
c/utf8.c
31
c/utf8.c
|
|
@ -391,13 +391,16 @@ char read_escape_control_char(char c)
|
|||
returns number of input characters processed, 0 if error */
|
||||
size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest)
|
||||
{
|
||||
assert(ssz > 0);
|
||||
uint32_t ch;
|
||||
char digs[10];
|
||||
int dno = 0, ndig;
|
||||
size_t i = 1;
|
||||
char c0 = str[0];
|
||||
int dno, ndig;
|
||||
size_t i;
|
||||
char c0;
|
||||
|
||||
assert(ssz > 0);
|
||||
dno = 0;
|
||||
i = 1;
|
||||
c0 = str[0];
|
||||
if (octal_digit(c0)) {
|
||||
i = 0;
|
||||
do {
|
||||
|
|
@ -405,8 +408,19 @@ size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest)
|
|||
} while (i < ssz && octal_digit(str[i]) && dno < 3);
|
||||
digs[dno] = '\0';
|
||||
ch = strtol(digs, NULL, 8);
|
||||
} else if ((c0 == 'x' && (ndig = 2)) || (c0 == 'u' && (ndig = 4)) ||
|
||||
(c0 == 'U' && (ndig = 8))) {
|
||||
*dest = ch;
|
||||
return i;
|
||||
}
|
||||
if (c0 == 'x') {
|
||||
ndig = 2;
|
||||
} else if (c0 == 'u') {
|
||||
ndig = 4;
|
||||
} else if (c0 == 'U') {
|
||||
ndig = 8;
|
||||
} else {
|
||||
ndig = 0;
|
||||
}
|
||||
if (ndig) {
|
||||
while (i < ssz && hex_digit(str[i]) && dno < ndig) {
|
||||
digs[dno++] = str[i++];
|
||||
}
|
||||
|
|
@ -418,7 +432,6 @@ size_t u8_read_escape_sequence(const char *str, size_t ssz, uint32_t *dest)
|
|||
ch = (uint32_t)read_escape_control_char(c0);
|
||||
}
|
||||
*dest = ch;
|
||||
|
||||
return i;
|
||||
}
|
||||
|
||||
|
|
@ -599,11 +612,13 @@ char *u8_memrchr(const char *s, uint32_t ch, size_t sz)
|
|||
|
||||
int u8_is_locale_utf8(const char *locale)
|
||||
{
|
||||
const char *cp;
|
||||
|
||||
if (locale == NULL)
|
||||
return 0;
|
||||
|
||||
/* this code based on libutf8 */
|
||||
const char *cp = locale;
|
||||
cp = locale;
|
||||
|
||||
for (; *cp != '\0' && *cp != '@' && *cp != '+' && *cp != ','; cp++) {
|
||||
if (*cp == '.') {
|
||||
|
|
|
|||
Loading…
Reference in New Issue