diff --git a/c/builtins.c b/c/builtins.c index b574d54..f908d20 100644 --- a/c/builtins.c +++ b/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) diff --git a/c/cvalues.h b/c/cvalues.h index 42caf51..39eb559 100644 --- a/c/cvalues.h +++ b/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); } } diff --git a/c/equal.h b/c/equal.h index 9d4e540..ee2811a 100644 --- a/c/equal.h +++ b/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: diff --git a/c/flisp.c b/c/flisp.c index fa6df66..06ef8ef 100644 --- a/c/flisp.c +++ b/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); diff --git a/c/htable.c b/c/htable.c index 6449d10..b2582cb 100644 --- a/c/htable.c +++ b/c/htable.c @@ -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; } diff --git a/c/htable_inc.h b/c/htable_inc.h index 0cb37ef..db68efe 100644 --- a/c/htable_inc.h +++ b/c/htable_inc.h @@ -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; \ diff --git a/c/ios.c b/c/ios.c index f663ba5..28a14fc 100644 --- a/c/ios.c +++ b/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); diff --git a/c/iostream.c b/c/iostream.c index bdef145..9f8a3a7 100644 --- a/c/iostream.c +++ b/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]); diff --git a/c/lookup3.h b/c/lookup3.h index 3cb35cb..6baa306 100644 --- a/c/lookup3.h +++ b/c/lookup3.h @@ -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]; diff --git a/c/operators.h b/c/operators.h index b11ef1e..53b5925 100644 --- a/c/operators.h +++ b/c/operators.h @@ -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) { diff --git a/c/print.h b/c/print.h index 9297244..ec7c138 100644 --- a/c/print.h +++ b/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 diff --git a/c/read.h b/c/read.h index 0d35748..8a0e2d1 100644 --- a/c/read.h +++ b/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; diff --git a/c/string.c b/c/string.c index 6a44c74..e550635 100644 --- a/c/string.c +++ b/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; } diff --git a/c/table.c b/c/table.c index e17a6cc..cc6f9cc 100644 --- a/c/table.c +++ b/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); diff --git a/c/types.h b/c/types.h index 2a962d3..a1ee1b8 100644 --- a/c/types.h +++ b/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]); diff --git a/c/utf8.c b/c/utf8.c index 8e4ff59..6aac0dc 100644 --- a/c/utf8.c +++ b/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 == '.') {