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

Run clang-format on all C code for the first time

This commit is contained in:
Lassi Kortela 2019-08-09 14:02:02 +03:00
parent 7ab81c9e56
commit 6a6a7071a9
47 changed files with 5888 additions and 4880 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
builtins.c
View File

@ -38,15 +38,15 @@ static value_t fl_nconc(value_t *args, u_int32_t nargs)
uint32_t i = 0;
while (1) {
lst = args[i++];
if (i >= nargs) break;
if (i >= nargs)
break;
if (iscons(lst)) {
*pcdr = lst;
c = (cons_t *)ptr(lst);
while (iscons(c->cdr))
c = (cons_t *)ptr(c->cdr);
pcdr = &c->cdr;
}
else if (lst != FL_NIL) {
} else if (lst != FL_NIL) {
type_error("nconc", "cons", lst);
}
}
@ -89,23 +89,19 @@ static value_t fl_length(value_t *args, u_int32_t nargs)
cvalue_t *cv;
if (isvector(a)) {
return fixnum(vector_size(a));
}
else if (iscprim(a)) {
} else if (iscprim(a)) {
cv = (cvalue_t *)ptr(a);
if (cp_class(cv) == bytetype)
return fixnum(1);
else if (cp_class(cv) == wchartype)
return fixnum(u8_charlen(*(uint32_t *)cp_data((cprim_t *)cv)));
}
else if (iscvalue(a)) {
} else if (iscvalue(a)) {
cv = (cvalue_t *)ptr(a);
if (cv_class(cv)->eltype != NULL)
return size_wrap(cvalue_arraylen(a));
}
else if (a == FL_NIL) {
} else if (a == FL_NIL) {
return fixnum(0);
}
else if (iscons(a)) {
} else if (iscons(a)) {
return fixnum(llength(a));
}
type_error("length", "sequence", a);
@ -136,8 +132,8 @@ static value_t fl_symbol(value_t *args, u_int32_t nargs)
static value_t fl_keywordp(value_t *args, u_int32_t nargs)
{
argcount("keyword?", nargs, 1);
return (issymbol(args[0]) &&
iskeyword((symbol_t*)ptr(args[0]))) ? FL_T : FL_F;
return (issymbol(args[0]) && iskeyword((symbol_t *)ptr(args[0]))) ? FL_T
: FL_F;
}
static value_t fl_top_level_value(value_t *args, u_int32_t nargs)
@ -203,22 +199,22 @@ static value_t fl_integer_valuedp(value_t *args, u_int32_t nargs)
value_t v = args[0];
if (isfixnum(v)) {
return FL_T;
}
else if (iscprim(v)) {
} else if (iscprim(v)) {
numerictype_t nt = cp_numtype((cprim_t *)ptr(v));
if (nt < T_FLOAT)
return FL_T;
void *data = cp_data((cprim_t *)ptr(v));
if (nt == T_FLOAT) {
float f = *(float *)data;
if (f < 0) f = -f;
if (f < 0)
f = -f;
if (f <= FLT_MAXINT && (float)(int32_t)f == f)
return FL_T;
}
else {
} else {
assert(nt == T_DOUBLE);
double d = *(double *)data;
if (d < 0) d = -d;
if (d < 0)
d = -d;
if (d <= DBL_MAXINT && (double)(int64_t)d == d)
return FL_T;
}
@ -231,8 +227,9 @@ static value_t fl_integerp(value_t *args, u_int32_t nargs)
argcount("integer?", nargs, 1);
value_t v = args[0];
return (isfixnum(v) ||
(iscprim(v) && cp_numtype((cprim_t*)ptr(v)) < T_FLOAT)) ?
FL_T : FL_F;
(iscprim(v) && cp_numtype((cprim_t *)ptr(v)) < T_FLOAT))
? FL_T
: FL_F;
}
static value_t fl_fixnum(value_t *args, u_int32_t nargs)
@ -240,8 +237,7 @@ static value_t fl_fixnum(value_t *args, u_int32_t nargs)
argcount("fixnum", nargs, 1);
if (isfixnum(args[0])) {
return args[0];
}
else if (iscprim(args[0])) {
} else if (iscprim(args[0])) {
cprim_t *cp = (cprim_t *)ptr(args[0]);
return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
}
@ -368,7 +364,8 @@ static value_t fl_os_getenv(value_t *args, uint32_t nargs)
argcount("os.getenv", nargs, 1);
char *name = tostring(args[0], "os.getenv");
char *val = getenv(name);
if (val == NULL) return FL_F;
if (val == NULL)
return FL_F;
if (*val == 0)
return symbol_value(emptystringsym);
return cvalue_static_cstring(val);
@ -386,8 +383,7 @@ static value_t fl_os_setenv(value_t *args, uint32_t nargs)
(void)unsetenv(name);
result = 0;
#endif
}
else {
} else {
char *val = tostring(args[1], "os.setenv");
result = setenv(name, val, 1);
}
@ -398,7 +394,8 @@ static value_t fl_os_setenv(value_t *args, uint32_t nargs)
static value_t fl_rand(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
(void)args;
(void)nargs;
fixnum_t r;
#ifdef BITS64
r = ((((uint64_t)random()) << 32) | random()) & 0x1fffffffffffffffLL;
@ -409,7 +406,8 @@ static value_t fl_rand(value_t *args, u_int32_t nargs)
}
static value_t fl_rand32(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
(void)args;
(void)nargs;
uint32_t r = random();
#ifdef BITS64
return fixnum(r);
@ -419,18 +417,21 @@ static value_t fl_rand32(value_t *args, u_int32_t nargs)
}
static value_t fl_rand64(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
(void)args;
(void)nargs;
uint64_t r = (((uint64_t)random()) << 32) | random();
return mk_uint64(r);
}
static value_t fl_randd(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
(void)args;
(void)nargs;
return mk_double(rand_double());
}
static value_t fl_randf(value_t *args, u_int32_t nargs)
{
(void)args; (void)nargs;
(void)args;
(void)nargs;
return mk_float(rand_float());
}

540
cvalues.c
View File

@ -50,7 +50,8 @@ void add_finalizer(cvalue_t *cv)
{
if (nfinalizers == maxfinalizers) {
size_t nn = (maxfinalizers == 0 ? 256 : maxfinalizers * 2);
cvalue_t **temp = (cvalue_t**)realloc(Finalizers, nn*sizeof(value_t));
cvalue_t **temp =
(cvalue_t **)realloc(Finalizers, nn * sizeof(value_t));
if (temp == NULL)
lerror(MemoryError, "out of memory");
Finalizers = temp;
@ -74,8 +75,7 @@ static void sweep_finalizers(void)
// object is alive
lst[n] = (cvalue_t *)ptr(forwardloc((value_t)tmp));
n++;
}
else {
} else {
fltype_t *t = cv_class(tmp);
if (t->vtable != NULL && t->vtable->finalize != NULL) {
t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
@ -117,10 +117,7 @@ static void autorelease(cvalue_t *cv)
add_finalizer(cv);
}
void cv_autorelease(cvalue_t *cv)
{
autorelease(cv);
}
void cv_autorelease(cvalue_t *cv) { autorelease(cv); }
static value_t cprim(fltype_t *type, size_t sz)
{
@ -152,8 +149,7 @@ value_t cvalue(fltype_t *type, size_t sz)
pcv->data = &pcv->_space[0];
if (type->vtable != NULL && type->vtable->finalize != NULL)
add_finalizer(pcv);
}
else {
} else {
if (malloc_pressure > ALLOC_LIMIT_TRIGGER)
gc(0);
pcv = (cvalue_t *)alloc_words(CVALUE_NWORDS);
@ -203,10 +199,7 @@ value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent)
return cv;
}
value_t cvalue_string(size_t sz)
{
return cvalue(stringtype, sz);
}
value_t cvalue_string(size_t sz) { return cvalue(stringtype, sz); }
value_t cvalue_static_cstring(const char *str)
{
@ -236,7 +229,8 @@ void cv_pin(cvalue_t *cv)
if (!isinlined(cv))
return;
size_t sz = cv_len(cv);
if (cv_isstr(cv)) sz++;
if (cv_isstr(cv))
sz++;
void *data = malloc(sz);
memcpy(data, cv_data(cv), sz);
cv->data = data;
@ -251,36 +245,32 @@ static int cvalue_##ctype##_init(fltype_t *type, value_t arg, \
(void)type; \
if (isfixnum(arg)) { \
n = numval(arg); \
} \
else if (iscprim(arg)) { \
} else if (iscprim(arg)) { \
cprim_t *cp = (cprim_t *)ptr(arg); \
void *p = cp_data(cp); \
n = (fl_##ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
} \
else { \
} else { \
return 1; \
} \
*((fl_##ctype##_t *)dest) = n; \
return 0; \
}
num_init(int8, int32, T_INT8)
num_init(uint8, uint32, T_UINT8)
num_init(int16, int32, T_INT16)
num_init(uint16, uint32, T_UINT16)
num_init(int32, int32, T_INT32)
num_init(uint32, uint32, T_UINT32)
num_init(int64, int64, T_INT64)
num_init(uint64, uint64, T_UINT64)
num_init(float, double, T_FLOAT)
num_init(double, double, T_DOUBLE)
num_init(int8, int32, T_INT8) num_init(uint8, uint32, T_UINT8)
num_init(int16, int32, T_INT16) num_init(uint16, uint32, T_UINT16)
num_init(int32, int32, T_INT32) num_init(uint32, uint32, T_UINT32)
num_init(int64, int64, T_INT64) num_init(uint64, uint64, T_UINT64)
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, u_int32_t nargs) \
{ \
if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \
if (nargs == 0) { \
PUSH(fixnum(0)); \
args = &Stack[SP - 1]; \
} \
value_t cp = cprim(typenam##type, sizeof(fl_##ctype##_t)); \
if (cvalue_##ctype##_init(typenam##type, \
args[0], cp_data((cprim_t*)ptr(cp)))) \
if (cvalue_##ctype##_init(typenam##type, args[0], \
cp_data((cprim_t *)ptr(cp)))) \
type_error(#typenam, "number", args[0]); \
return cp; \
}
@ -294,28 +284,19 @@ value_t mk_##typenam(fl_##ctype##_t n) \
}
#define num_ctor(typenam, ctype, tag) \
num_ctor_init(typenam, ctype, tag) \
num_ctor_ctor(typenam, ctype, tag)
num_ctor_init(typenam, ctype, tag) num_ctor_ctor(typenam, ctype, tag)
num_ctor(int8, int8, T_INT8)
num_ctor(uint8, uint8, T_UINT8)
num_ctor(int16, int16, T_INT16)
num_ctor(uint16, uint16, T_UINT16)
num_ctor(int32, int32, T_INT32)
num_ctor(uint32, uint32, T_UINT32)
num_ctor(int64, int64, T_INT64)
num_ctor(uint64, uint64, T_UINT64)
num_ctor(byte, uint8, T_UINT8)
num_ctor(wchar, int32, T_INT32)
num_ctor(int8, int8, T_INT8) num_ctor(uint8, uint8, T_UINT8)
num_ctor(int16, int16, T_INT16) num_ctor(uint16, uint16, T_UINT16)
num_ctor(int32, int32, T_INT32) num_ctor(uint32, uint32, T_UINT32)
num_ctor(int64, int64, T_INT64) num_ctor(uint64, uint64, T_UINT64)
num_ctor(byte, uint8, T_UINT8) num_ctor(wchar, int32, T_INT32)
#ifdef BITS64
num_ctor(long, int64, T_INT64)
num_ctor(ulong, uint64, T_UINT64)
num_ctor(long, int64, T_INT64) num_ctor(ulong, uint64, T_UINT64)
#else
num_ctor(long, int32, T_INT32)
num_ctor(ulong, uint32, T_UINT32)
num_ctor(long, int32, T_INT32) num_ctor(ulong, uint32, T_UINT32)
#endif
num_ctor(float, float, T_FLOAT)
num_ctor(double, double, T_DOUBLE)
num_ctor(float, float, T_FLOAT) num_ctor(double, double, T_DOUBLE)
value_t size_wrap(size_t sz)
{
@ -357,12 +338,10 @@ static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
}
if (isfixnum(arg)) {
n = (int)numval(arg);
}
else if (iscprim(arg)) {
} else if (iscprim(arg)) {
cprim_t *cp = (cprim_t *)ptr(arg);
n = conv_to_int32(cp_data(cp), cp_numtype(cp));
}
else {
} else {
type_error("enum", "number", arg);
}
if ((unsigned)n >= vector_size(syms))
@ -423,11 +402,13 @@ static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
dest = (char *)dest + elsize;
}
return 0;
}
else if (iscons(arg) || arg==NIL) {
} else if (iscons(arg) || arg == NIL) {
i = 0;
while (iscons(arg)) {
if (i == cnt) { i++; break; } // trigger error
if (i == cnt) {
i++;
break;
} // trigger error
cvalue_init(eltype, car_(arg), dest);
i++;
dest = (char *)dest + elsize;
@ -436,8 +417,7 @@ static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
if (i != cnt)
lerror(ArgError, "array: size mismatch");
return 0;
}
else if (iscvalue(arg)) {
} else if (iscvalue(arg)) {
cvalue_t *cv = (cvalue_t *)ptr(arg);
if (isarray(arg)) {
fltype_t *aet = cv_class(cv)->eltype;
@ -447,8 +427,7 @@ static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
else
lerror(ArgError, "array: size mismatch");
return 0;
}
else {
} else {
// TODO: initialize array from different type elements
lerror(ArgError, "array: element type mismatch");
}
@ -476,7 +455,8 @@ value_t cvalue_array(value_t *args, u_int32_t nargs)
value_t cv = cvalue(type, sz);
char *dest = cv_data((cvalue_t *)ptr(cv));
FOR_ARGS(i,1,arg,args) {
FOR_ARGS(i, 1, arg, args)
{
cvalue_init(type->eltype, arg, dest);
dest += elsize;
}
@ -490,8 +470,8 @@ size_t cvalue_arraylen(value_t v)
return cv_len(cv) / (cv_class(cv)->elsz);
}
static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
int *palign)
static size_t cvalue_struct_offs(value_t type, value_t field,
int computeTotal, int *palign)
{
value_t fld = car(cdr_(type));
size_t fsz, ssz = 0;
@ -525,8 +505,10 @@ static size_t cvalue_union_size(value_t type, int *palign)
while (iscons(fld)) {
fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
if (al > *palign) *palign = al;
if (fsz > usz) usz = fsz;
if (al > *palign)
*palign = al;
if (fsz > usz)
usz = fsz;
fld = cdr_(fld);
}
return LLT_ALIGN(usz, *palign);
@ -574,14 +556,11 @@ size_t ctype_sizeof(value_t type, int *palign)
value_t n = car_(cdr_(cdr_(type)));
size_t sz = toulong(n, "sizeof");
return sz * ctype_sizeof(t, palign);
}
else if (hed == structsym) {
} else if (hed == structsym) {
return cvalue_struct_offs(type, NIL, 1, palign);
}
else if (hed == unionsym) {
} else if (hed == unionsym) {
return cvalue_union_size(type, palign);
}
else if (hed == enumsym) {
} else if (hed == enumsym) {
*palign = ALIGN4;
return 4;
}
@ -602,14 +581,12 @@ void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz)
*pdata = x->buf;
*psz = x->size;
return;
}
else if (cv_isPOD(pcv)) {
} else if (cv_isPOD(pcv)) {
*pdata = cv_data(pcv);
*psz = cv_len(pcv);
return;
}
}
else if (iscprim(v)) {
} else if (iscprim(v)) {
cprim_t *pcp = (cprim_t *)ptr(v);
*pdata = cp_data(pcp);
*psz = cp_class(pcp)->size;
@ -625,7 +602,8 @@ value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
int a;
return size_wrap(ctype_sizeof(args[0], &a));
}
size_t n; char *data;
size_t n;
char *data;
to_sized_ptr(args[0], "sizeof", &data, &n);
return size_wrap(n);
}
@ -634,11 +612,15 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
{
argcount("typeof", nargs, 1);
switch (tag(args[0])) {
case TAG_CONS: return pairsym;
case TAG_CONS:
return pairsym;
case TAG_NUM1:
case TAG_NUM: return fixnumsym;
case TAG_SYM: return symbolsym;
case TAG_VECTOR: return vectorsym;
case TAG_NUM:
return fixnumsym;
case TAG_SYM:
return symbolsym;
case TAG_VECTOR:
return vectorsym;
case TAG_FUNCTION:
if (args[0] == FL_T || args[0] == FL_F)
return booleansym;
@ -680,11 +662,13 @@ value_t cvalue_copy(value_t v)
cvalue_t *cv = (cvalue_t *)ptr(v);
size_t nw = cv_nwords(cv);
cvalue_t *ncv = (cvalue_t *)alloc_words(nw);
v = POP(); cv = (cvalue_t*)ptr(v);
v = POP();
cv = (cvalue_t *)ptr(v);
memcpy(ncv, cv, nw * sizeof(value_t));
if (!isinlined(cv)) {
size_t len = cv_len(cv);
if (cv_isstr(cv)) len++;
if (cv_isstr(cv))
len++;
ncv->data = malloc(len);
memcpy(ncv->data, cv_data(cv), len);
autorelease(ncv);
@ -692,8 +676,7 @@ value_t cvalue_copy(value_t v)
ncv->type = (fltype_t *)(((uptrint_t)ncv->type) & ~CV_PARENT_BIT);
ncv->parent = NIL;
}
}
else {
} else {
ncv->data = &ncv->_space[0];
}
@ -716,8 +699,9 @@ value_t fl_podp(value_t *args, u_int32_t nargs)
{
argcount("plain-old-data?", nargs, 1);
return (iscprim(args[0]) ||
(iscvalue(args[0]) && cv_isPOD((cvalue_t*)ptr(args[0])))) ?
FL_T : FL_F;
(iscvalue(args[0]) && cv_isPOD((cvalue_t *)ptr(args[0]))))
? FL_T
: FL_F;
}
static void cvalue_init(fltype_t *type, value_t v, void *dest)
@ -796,8 +780,7 @@ value_t cvalue_new(value_t *args, u_int32_t nargs)
cv = cvalue(ft, elsz * cnt);
if (nargs == 2)
cvalue_array_init(ft, args[1], cv_data((cvalue_t *)ptr(cv)));
}
else {
} else {
cv = cvalue(ft, ft->size);
if (nargs == 2)
cvalue_init(ft, args[1], cptr(cv));
@ -839,7 +822,8 @@ static void check_addr_args(char *fname, value_t arr, value_t ind,
static value_t cvalue_array_aref(value_t *args)
{
char *data; ulong_t index;
char *data;
ulong_t index;
fltype_t *eltype = cv_class((cvalue_t *)ptr(args[0]))->eltype;
value_t el = 0;
numerictype_t nt = eltype->numtype;
@ -872,7 +856,8 @@ static value_t cvalue_array_aref(value_t *args)
static value_t cvalue_array_aset(value_t *args)
{
char *data; ulong_t index;
char *data;
ulong_t index;
fltype_t *eltype = cv_class((cvalue_t *)ptr(args[0]))->eltype;
check_addr_args("aset!", args[0], args[1], &data, &index);
char *dest = data + index * eltype->size;
@ -912,13 +897,13 @@ static value_t fl_logxor(value_t *args, u_int32_t nargs);
static value_t fl_lognot(value_t *args, u_int32_t nargs);
static value_t fl_ash(value_t *args, u_int32_t nargs);
static builtinspec_t cvalues_builtin_info[] = {
{ "c-value", cvalue_new },
static builtinspec_t cvalues_builtin_info[] = { { "c-value", cvalue_new },
{ "typeof", cvalue_typeof },
{ "sizeof", cvalue_sizeof },
{ "builtin", fl_builtin },
{ "copy", fl_copy },
{ "plain-old-data?", fl_podp },
{ "plain-old-data?",
fl_podp },
{ "logand", fl_logand },
{ "logior", fl_logior },
@ -926,18 +911,20 @@ static builtinspec_t cvalues_builtin_info[] = {
{ "lognot", fl_lognot },
{ "ash", fl_ash },
// todo: autorelease
{ NULL, NULL }
};
{ NULL, NULL } };
#define cv_intern(tok) tok##sym = symbol(#tok)
#define ctor_cv_intern(tok) \
cv_intern(tok);set(tok##sym, cbuiltin(#tok, cvalue_##tok))
cv_intern(tok); \
set(tok##sym, cbuiltin(#tok, cvalue_##tok))
#define mk_primtype(name) \
name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init
name##type = get_type(name##sym); \
name##type->init = &cvalue_##name##_init
#define mk_primtype_(name, ctype) \
name##type=get_type(name##sym);name##type->init = &cvalue_##ctype##_init
name##type = get_type(name##sym); \
name##type->init = &cvalue_##ctype##_init
static void cvalues_init(void)
{
@ -945,12 +932,29 @@ static void cvalues_init(void)
htable_new(&reverse_dlsym_lookup_table, 256);
// compute struct field alignment required for primitives
ALIGN2 = sizeof(struct { char a; int16_t i; }) - 2;
ALIGN4 = sizeof(struct { char a; int32_t i; }) - 4;
ALIGN8 = sizeof(struct { char a; int64_t i; }) - 8;
ALIGNPTR = sizeof(struct { char a; void *i; }) - sizeof(void*);
ALIGN2 = sizeof(struct {
char a;
int16_t i;
}) -
2;
ALIGN4 = sizeof(struct {
char a;
int32_t i;
}) -
4;
ALIGN8 = sizeof(struct {
char a;
int64_t i;
}) -
8;
ALIGNPTR = sizeof(struct {
char a;
void *i;
}) -
sizeof(void *);
builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
builtintype =
define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
ctor_cv_intern(int8);
ctor_cv_intern(uint8);
@ -1019,11 +1023,9 @@ value_t return_from_uint64(uint64_t Uaccum)
}
if (Uaccum > (uint64_t)S64_MAX) {
RETURN_NUM_AS(Uaccum, uint64);
}
else if (Uaccum > (uint64_t)UINT_MAX) {
} else if (Uaccum > (uint64_t)UINT_MAX) {
RETURN_NUM_AS(Uaccum, int64);
}
else if (Uaccum > (uint64_t)INT_MAX) {
} else if (Uaccum > (uint64_t)INT_MAX) {
RETURN_NUM_AS(Uaccum, uint32);
}
RETURN_NUM_AS(Uaccum, int32);
@ -1036,8 +1038,7 @@ value_t return_from_int64(int64_t Saccum)
}
if (Saccum > (int64_t)UINT_MAX || Saccum < (int64_t)INT_MIN) {
RETURN_NUM_AS(Saccum, int64);
}
else if (Saccum > (int64_t)INT_MAX) {
} else if (Saccum > (int64_t)INT_MAX) {
RETURN_NUM_AS(Saccum, uint32);
}
RETURN_NUM_AS(Saccum, int32);
@ -1052,22 +1053,34 @@ static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
uint32_t i;
value_t arg = NIL;
FOR_ARGS(i,0,arg,args) {
FOR_ARGS(i, 0, arg, args)
{
if (isfixnum(arg)) {
Saccum += numval(arg);
continue;
}
else if (iscprim(arg)) {
} else if (iscprim(arg)) {
cprim_t *cp = (cprim_t *)ptr(arg);
void *a = cp_data(cp);
int64_t i64;
switch (cp_numtype(cp)) {
case T_INT8: Saccum += *(int8_t*)a; break;
case T_UINT8: Saccum += *(uint8_t*)a; break;
case T_INT16: Saccum += *(int16_t*)a; break;
case T_UINT16: Saccum += *(uint16_t*)a; break;
case T_INT32: Saccum += *(int32_t*)a; break;
case T_UINT32: Saccum += *(uint32_t*)a; break;
case T_INT8:
Saccum += *(int8_t *)a;
break;
case T_UINT8:
Saccum += *(uint8_t *)a;
break;
case T_INT16:
Saccum += *(int16_t *)a;
break;
case T_UINT16:
Saccum += *(uint16_t *)a;
break;
case T_INT32:
Saccum += *(int32_t *)a;
break;
case T_UINT32:
Saccum += *(uint32_t *)a;
break;
case T_INT64:
i64 = *(int64_t *)a;
if (i64 > 0)
@ -1075,9 +1088,17 @@ static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
else
Saccum += i64;
break;
case T_UINT64: Uaccum += *(uint64_t*)a; break;
case T_FLOAT: Faccum += *(float*)a; inexact = 1; break;
case T_DOUBLE: Faccum += *(double*)a; inexact = 1; break;
case T_UINT64:
Uaccum += *(uint64_t *)a;
break;
case T_FLOAT:
Faccum += *(float *)a;
inexact = 1;
break;
case T_DOUBLE:
Faccum += *(double *)a;
inexact = 1;
break;
default:
goto add_type_error;
}
@ -1090,8 +1111,7 @@ static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
Faccum += Uaccum;
Faccum += Saccum;
return mk_double(Faccum);
}
else if (Saccum < 0) {
} else if (Saccum < 0) {
uint64_t negpart = (uint64_t)(-Saccum);
if (negpart > Uaccum) {
Saccum += (int64_t)Uaccum;
@ -1105,8 +1125,7 @@ static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
RETURN_NUM_AS(Saccum, int64);
}
Uaccum -= negpart;
}
else {
} else {
Uaccum += (uint64_t)Saccum;
}
// return value in Uaccum
@ -1121,18 +1140,21 @@ static value_t fl_neg(value_t n)
return mk_long(-numval(n)); // negate overflows
else
return s;
}
else if (iscprim(n)) {
} else if (iscprim(n)) {
cprim_t *cp = (cprim_t *)ptr(n);
void *a = cp_data(cp);
uint32_t ui32;
int32_t i32;
int64_t i64;
switch (cp_numtype(cp)) {
case T_INT8: return fixnum(-(int32_t)*(int8_t*)a);
case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a);
case T_INT16: return fixnum(-(int32_t)*(int16_t*)a);
case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a);
case T_INT8:
return fixnum(-(int32_t) * (int8_t *)a);
case T_UINT8:
return fixnum(-(int32_t) * (uint8_t *)a);
case T_INT16:
return fixnum(-(int32_t) * (int16_t *)a);
case T_UINT16:
return fixnum(-(int32_t) * (uint16_t *)a);
case T_INT32:
i32 = *(int32_t *)a;
if (i32 == (int32_t)BIT31)
@ -1140,16 +1162,20 @@ static value_t fl_neg(value_t n)
return mk_int32(-i32);
case T_UINT32:
ui32 = *(uint32_t *)a;
if (ui32 <= ((uint32_t)INT_MAX)+1) return mk_int32(-(int32_t)ui32);
if (ui32 <= ((uint32_t)INT_MAX) + 1)
return mk_int32(-(int32_t)ui32);
return mk_int64(-(int64_t)ui32);
case T_INT64:
i64 = *(int64_t *)a;
if (i64 == (int64_t)BIT63)
return mk_uint64((uint64_t)BIT63);
return mk_int64(-i64);
case T_UINT64: return mk_int64(-(int64_t)*(uint64_t*)a);
case T_FLOAT: return mk_float(-*(float*)a);
case T_DOUBLE: return mk_double(-*(double*)a);
case T_UINT64:
return mk_int64(-(int64_t) * (uint64_t *)a);
case T_FLOAT:
return mk_float(-*(float *)a);
case T_DOUBLE:
return mk_double(-*(double *)a);
break;
}
}
@ -1164,22 +1190,34 @@ static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
uint32_t i;
value_t arg = NIL;
FOR_ARGS(i,0,arg,args) {
FOR_ARGS(i, 0, arg, args)
{
if (isfixnum(arg)) {
Saccum *= numval(arg);
continue;
}
else if (iscprim(arg)) {
} else if (iscprim(arg)) {
cprim_t *cp = (cprim_t *)ptr(arg);
void *a = cp_data(cp);
int64_t i64;
switch (cp_numtype(cp)) {
case T_INT8: Saccum *= *(int8_t*)a; break;
case T_UINT8: Saccum *= *(uint8_t*)a; break;
case T_INT16: Saccum *= *(int16_t*)a; break;
case T_UINT16: Saccum *= *(uint16_t*)a; break;
case T_INT32: Saccum *= *(int32_t*)a; break;
case T_UINT32: Saccum *= *(uint32_t*)a; break;
case T_INT8:
Saccum *= *(int8_t *)a;
break;
case T_UINT8:
Saccum *= *(uint8_t *)a;
break;
case T_INT16:
Saccum *= *(int16_t *)a;
break;
case T_UINT16:
Saccum *= *(uint16_t *)a;
break;
case T_INT32:
Saccum *= *(int32_t *)a;
break;
case T_UINT32:
Saccum *= *(uint32_t *)a;
break;
case T_INT64:
i64 = *(int64_t *)a;
if (i64 > 0)
@ -1187,9 +1225,17 @@ static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
else
Saccum *= i64;
break;
case T_UINT64: Uaccum *= *(uint64_t*)a; break;
case T_FLOAT: Faccum *= *(float*)a; inexact = 1; break;
case T_DOUBLE: Faccum *= *(double*)a; inexact = 1; break;
case T_UINT64:
Uaccum *= *(uint64_t *)a;
break;
case T_FLOAT:
Faccum *= *(float *)a;
inexact = 1;
break;
case T_DOUBLE:
Faccum *= *(double *)a;
inexact = 1;
break;
default:
goto mul_type_error;
}
@ -1202,8 +1248,7 @@ static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
Faccum *= Uaccum;
Faccum *= Saccum;
return mk_double(Faccum);
}
else if (Saccum < 0) {
} else if (Saccum < 0) {
Saccum *= (int64_t)Uaccum;
if (Saccum >= INT_MIN) {
if (fits_fixnum(Saccum)) {
@ -1212,8 +1257,7 @@ static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
RETURN_NUM_AS(Saccum, int32);
}
RETURN_NUM_AS(Saccum, int64);
}
else {
} else {
Uaccum *= (uint64_t)Saccum;
}
return return_from_uint64(Uaccum);
@ -1226,13 +1270,11 @@ static int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
*pi = numval(a);
*pp = pi;
*pt = T_FIXNUM;
}
else if (iscprim(a)) {
} else if (iscprim(a)) {
cp = (cprim_t *)ptr(a);
*pp = cp_data(cp);
*pt = cp_numtype(cp);
}
else {
} else {
return 0;
}
return 1;
@ -1253,21 +1295,30 @@ int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname)
void *aptr, *bptr;
if (bothfixnums(a, b)) {
if (a==b) return 0;
if (numval(a) < numval(b)) return -1;
if (a == b)
return 0;
if (numval(a) < numval(b))
return -1;
return 1;
}
if (!num_to_ptr(a, &ai, &ta, &aptr)) {
if (fname) type_error(fname, "number", a); else return 2;
if (fname)
type_error(fname, "number", a);
else
return 2;
}
if (!num_to_ptr(b, &bi, &tb, &bptr)) {
if (fname) type_error(fname, "number", b); else return 2;
if (fname)
type_error(fname, "number", b);
else
return 2;
}
if (eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT)))
return 1;
if (cmp_eq(aptr, ta, bptr, tb, eqnans))
return 0;
if (eq) return 1;
if (eq)
return 1;
if (cmp_lt(aptr, ta, bptr, tb))
return -1;
return 1;
@ -1318,30 +1369,33 @@ static value_t fl_idiv2(value_t a, value_t b)
if (ta == T_UINT64) {
if (tb == T_UINT64) {
if (*(uint64_t*)bptr == 0) goto div_error;
if (*(uint64_t *)bptr == 0)
goto div_error;
return return_from_uint64(*(uint64_t *)aptr / *(uint64_t *)bptr);
}
b64 = conv_to_int64(bptr, tb);
if (b64 < 0) {
return return_from_int64(-(int64_t)(*(uint64_t*)aptr /
(uint64_t)(-b64)));
return return_from_int64(
-(int64_t)(*(uint64_t *)aptr / (uint64_t)(-b64)));
}
if (b64 == 0)
goto div_error;
return return_from_uint64(*(uint64_t *)aptr / (uint64_t)b64);
}
if (tb == T_UINT64) {
if (*(uint64_t*)bptr == 0) goto div_error;
if (*(uint64_t *)bptr == 0)
goto div_error;
a64 = conv_to_int64(aptr, ta);
if (a64 < 0) {
return return_from_int64(-((int64_t)((uint64_t)(-a64) /
*(uint64_t*)bptr)));
return return_from_int64(
-((int64_t)((uint64_t)(-a64) / *(uint64_t *)bptr)));
}
return return_from_uint64((uint64_t)a64 / *(uint64_t *)bptr);
}
b64 = conv_to_int64(bptr, tb);
if (b64 == 0) goto div_error;
if (b64 == 0)
goto div_error;
return return_from_int64(conv_to_int64(aptr, ta) / b64);
div_error:
@ -1361,52 +1415,83 @@ static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
type_error(fname, "integer", b);
if (ta < tb) {
itmp = ta; ta = tb; tb = itmp;
ptmp = aptr; aptr = bptr; bptr = ptmp;
itmp = ta;
ta = tb;
tb = itmp;
ptmp = aptr;
aptr = bptr;
bptr = ptmp;
}
// now a's type is larger than or same as b's
b64 = conv_to_int64(bptr, tb);
switch (opcode) {
case 0:
switch (ta) {
case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
case T_INT8:
return fixnum(*(int8_t *)aptr & (int8_t)b64);
case T_UINT8:
return fixnum(*(uint8_t *)aptr & (uint8_t)b64);
case T_INT16:
return fixnum(*(int16_t *)aptr & (int16_t)b64);
case T_UINT16:
return fixnum(*(uint16_t *)aptr & (uint16_t)b64);
case T_INT32:
return mk_int32(*(int32_t *)aptr & (int32_t)b64);
case T_UINT32:
return mk_uint32(*(uint32_t *)aptr & (uint32_t)b64);
case T_INT64:
return mk_int64(*(int64_t *)aptr & (int64_t)b64);
case T_UINT64:
return mk_uint64(*(uint64_t *)aptr & (uint64_t)b64);
case T_FLOAT:
case T_DOUBLE: assert(0);
case T_DOUBLE:
assert(0);
}
break;
case 1:
switch (ta) {
case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
case T_INT8:
return fixnum(*(int8_t *)aptr | (int8_t)b64);
case T_UINT8:
return fixnum(*(uint8_t *)aptr | (uint8_t)b64);
case T_INT16:
return fixnum(*(int16_t *)aptr | (int16_t)b64);
case T_UINT16:
return fixnum(*(uint16_t *)aptr | (uint16_t)b64);
case T_INT32:
return mk_int32(*(int32_t *)aptr | (int32_t)b64);
case T_UINT32:
return mk_uint32(*(uint32_t *)aptr | (uint32_t)b64);
case T_INT64:
return mk_int64(*(int64_t *)aptr | (int64_t)b64);
case T_UINT64:
return mk_uint64(*(uint64_t *)aptr | (uint64_t)b64);
case T_FLOAT:
case T_DOUBLE: assert(0);
case T_DOUBLE:
assert(0);
}
break;
case 2:
switch (ta) {
case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
case T_INT8:
return fixnum(*(int8_t *)aptr ^ (int8_t)b64);
case T_UINT8:
return fixnum(*(uint8_t *)aptr ^ (uint8_t)b64);
case T_INT16:
return fixnum(*(int16_t *)aptr ^ (int16_t)b64);
case T_UINT16:
return fixnum(*(uint16_t *)aptr ^ (uint16_t)b64);
case T_INT32:
return mk_int32(*(int32_t *)aptr ^ (int32_t)b64);
case T_UINT32:
return mk_uint32(*(uint32_t *)aptr ^ (uint32_t)b64);
case T_INT64:
return mk_int64(*(int64_t *)aptr ^ (int64_t)b64);
case T_UINT64:
return mk_uint64(*(uint64_t *)aptr ^ (uint64_t)b64);
case T_FLOAT:
case T_DOUBLE: assert(0);
case T_DOUBLE:
assert(0);
}
}
assert(0);
@ -1420,7 +1505,8 @@ static value_t fl_logand(value_t *args, u_int32_t nargs)
if (nargs == 0)
return fixnum(-1);
v = args[0];
FOR_ARGS(i,1,e,args) {
FOR_ARGS(i, 1, e, args)
{
if (bothfixnums(v, e))
v = v & e;
else
@ -1436,7 +1522,8 @@ static value_t fl_logior(value_t *args, u_int32_t nargs)
if (nargs == 0)
return fixnum(0);
v = args[0];
FOR_ARGS(i,1,e,args) {
FOR_ARGS(i, 1, e, args)
{
if (bothfixnums(v, e))
v = v | e;
else
@ -1452,7 +1539,8 @@ static value_t fl_logxor(value_t *args, u_int32_t nargs)
if (nargs == 0)
return fixnum(0);
v = args[0];
FOR_ARGS(i,1,e,args) {
FOR_ARGS(i, 1, e, args)
{
if (bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
@ -1476,14 +1564,22 @@ static value_t fl_lognot(value_t *args, u_int32_t nargs)
ta = cp_numtype(cp);
aptr = cp_data(cp);
switch (ta) {
case T_INT8: return fixnum(~*(int8_t *)aptr);
case T_UINT8: return fixnum(~*(uint8_t *)aptr);
case T_INT16: return fixnum(~*(int16_t *)aptr);
case T_UINT16: return fixnum(~*(uint16_t*)aptr);
case T_INT32: return mk_int32(~*(int32_t *)aptr);
case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
case T_INT64: return mk_int64(~*(int64_t *)aptr);
case T_UINT64: return mk_uint64(~*(uint64_t*)aptr);
case T_INT8:
return fixnum(~*(int8_t *)aptr);
case T_UINT8:
return fixnum(~*(uint8_t *)aptr);
case T_INT16:
return fixnum(~*(int16_t *)aptr);
case T_UINT16:
return fixnum(~*(uint16_t *)aptr);
case T_INT32:
return mk_int32(~*(int32_t *)aptr);
case T_UINT32:
return mk_uint32(~*(uint32_t *)aptr);
case T_INT64:
return mk_int64(~*(int64_t *)aptr);
case T_UINT64:
return mk_uint64(~*(uint64_t *)aptr);
}
}
type_error("lognot", "integer", a);
@ -1509,24 +1605,32 @@ static value_t fl_ash(value_t *args, u_int32_t nargs)
int ta;
void *aptr;
if (iscprim(a)) {
if (n == 0) return a;
if (n == 0)
return a;
cp = (cprim_t *)ptr(a);
ta = cp_numtype(cp);
aptr = cp_data(cp);
if (n < 0) {
n = -n;
switch (ta) {
case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
case T_INT8:
return fixnum((*(int8_t *)aptr) >> n);
case T_UINT8:
return fixnum((*(uint8_t *)aptr) >> n);
case T_INT16:
return fixnum((*(int16_t *)aptr) >> n);
case T_UINT16:
return fixnum((*(uint16_t *)aptr) >> n);
case T_INT32:
return mk_int32((*(int32_t *)aptr) >> n);
case T_UINT32:
return mk_uint32((*(uint32_t *)aptr) >> n);
case T_INT64:
return mk_int64((*(int64_t *)aptr) >> n);
case T_UINT64:
return mk_uint64((*(uint64_t *)aptr) >> n);
}
}
else {
} else {
if (ta == T_UINT64)
return return_from_uint64((*(uint64_t *)aptr) << n);
else if (ta < T_FLOAT) {

123
equal.c
View File

@ -14,8 +14,8 @@ static value_t eq_class(htable_t *table, value_t key)
return eq_class(table, c);
}
static void eq_union(htable_t *table, value_t a, value_t b,
value_t c, value_t cb)
static void eq_union(htable_t *table, value_t a, value_t b, value_t c,
value_t cb)
{
value_t ca = (c == NIL ? a : c);
if (cb != NIL)
@ -32,15 +32,19 @@ static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
size_t la = vector_size(a);
size_t lb = vector_size(b);
size_t m, i;
if (eq && (la!=lb)) return fixnum(1);
if (eq && (la != lb))
return fixnum(1);
m = la < lb ? la : lb;
for (i = 0; i < m; i++) {
value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i),
bound-1, eq);
if (d==NIL || numval(d)!=0) return d;
value_t d =
bounded_compare(vector_elt(a, i), vector_elt(b, i), bound - 1, eq);
if (d == NIL || numval(d) != 0)
return d;
}
if (la < lb) return fixnum(-1);
if (la > lb) return fixnum(1);
if (la < lb)
return fixnum(-1);
if (la > lb)
return fixnum(1);
return fixnum(0);
}
@ -51,7 +55,8 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
value_t d;
compare_top:
if (a == b) return fixnum(0);
if (a == b)
return fixnum(0);
if (bound <= 0)
return NIL;
int taga = tag(a);
@ -70,9 +75,12 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
}
return fixnum(-1);
case TAG_SYM:
if (eq) return fixnum(1);
if (tagb < TAG_SYM) return fixnum(1);
if (tagb > TAG_SYM) return fixnum(-1);
if (eq)
return fixnum(1);
if (tagb < TAG_SYM)
return fixnum(1);
if (tagb > TAG_SYM)
return fixnum(-1);
return fixnum(strcmp(symbol_name(a), symbol_name(b)));
case TAG_VECTOR:
if (isvector(b))
@ -82,8 +90,7 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
if (cp_class((cprim_t *)ptr(a)) == wchartype) {
if (!iscprim(b) || cp_class((cprim_t *)ptr(b)) != wchartype)
return fixnum(-1);
}
else if (iscprim(b) && cp_class((cprim_t*)ptr(b)) == wchartype) {
} else if (iscprim(b) && cp_class((cprim_t *)ptr(b)) == wchartype) {
return fixnum(1);
}
c = numeric_compare(a, b, eq, 1, NULL);
@ -103,21 +110,27 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
function_t *fa = (function_t *)ptr(a);
function_t *fb = (function_t *)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, bound - 1, eq);
if (d==NIL || numval(d) != 0) return d;
if (d == NIL || numval(d) != 0)
return d;
d = bounded_compare(fa->vals, fb->vals, bound - 1, eq);
if (d==NIL || numval(d) != 0) return d;
if (d == NIL || numval(d) != 0)
return d;
d = bounded_compare(fa->env, fb->env, bound - 1, eq);
if (d==NIL || numval(d) != 0) return d;
if (d == NIL || numval(d) != 0)
return d;
return fixnum(0);
}
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
}
break;
case TAG_CONS:
if (tagb < TAG_CONS) return fixnum(1);
if (tagb < TAG_CONS)
return fixnum(1);
d = bounded_compare(car_(a), car_(b), bound - 1, eq);
if (d==NIL || numval(d) != 0) return d;
a = cdr_(a); b = cdr_(b);
if (d == NIL || numval(d) != 0)
return d;
a = cdr_(a);
b = cdr_(b);
bound--;
goto compare_top;
}
@ -133,19 +146,19 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
value_t d, xa, xb, ca, cb;
// first try to prove them different with no recursion
if (eq && (la!=lb)) return fixnum(1);
if (eq && (la != lb))
return fixnum(1);
m = la < lb ? la : lb;
for (i = 0; i < m; i++) {
xa = vector_elt(a, i);
xb = vector_elt(b, i);
if (leafp(xa) || leafp(xb)) {
d = bounded_compare(xa, xb, 1, eq);
if (d!=NIL && numval(d)!=0) return d;
}
else if (tag(xa) < tag(xb)) {
if (d != NIL && numval(d) != 0)
return d;
} else if (tag(xa) < tag(xb)) {
return fixnum(-1);
}
else if (tag(xa) > tag(xb)) {
} else if (tag(xa) > tag(xb)) {
return fixnum(1);
}
}
@ -167,8 +180,10 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
}
}
if (la < lb) return fixnum(-1);
if (la > lb) return fixnum(1);
if (la < lb)
return fixnum(-1);
if (la > lb)
return fixnum(1);
return fixnum(0);
}
@ -180,23 +195,27 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
return fixnum(0);
if (iscons(a)) {
if (iscons(b)) {
value_t aa = car_(a); value_t da = cdr_(a);
value_t ab = car_(b); value_t db = cdr_(b);
int tagaa = tag(aa); int tagda = tag(da);
int tagab = tag(ab); int tagdb = tag(db);
value_t aa = car_(a);
value_t da = cdr_(a);
value_t ab = car_(b);
value_t db = cdr_(b);
int tagaa = tag(aa);
int tagda = tag(da);
int tagab = tag(ab);
int tagdb = tag(db);
if (leafp(aa) || leafp(ab)) {
d = bounded_compare(aa, ab, 1, eq);
if (d!=NIL && numval(d)!=0) return d;
}
else if (tagaa < tagab)
if (d != NIL && numval(d) != 0)
return d;
} else if (tagaa < tagab)
return fixnum(-1);
else if (tagaa > tagab)
return fixnum(1);
if (leafp(da) || leafp(db)) {
d = bounded_compare(da, db, 1, eq);
if (d!=NIL && numval(d)!=0) return d;
}
else if (tagda < tagdb)
if (d != NIL && numval(d) != 0)
return d;
} else if (tagda < tagdb)
return fixnum(-1);
else if (tagda > tagdb)
return fixnum(1);
@ -208,23 +227,22 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
eq_union(table, a, b, ca, cb);
d = cyc_compare(aa, ab, table, eq);
if (numval(d)!=0) return d;
if (numval(d) != 0)
return d;
a = da;
b = db;
goto cyc_compare_top;
}
else {
} else {
return fixnum(1);
}
}
else if (isvector(a) && isvector(b)) {
} else if (isvector(a) && isvector(b)) {
return cyc_vector_compare(a, b, table, eq);
}
else if (isclosure(a) && isclosure(b)) {
} else if (isclosure(a) && isclosure(b)) {
function_t *fa = (function_t *)ptr(a);
function_t *fb = (function_t *)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
if (numval(d) != 0) return d;
if (numval(d) != 0)
return d;
ca = eq_class(table, a);
cb = eq_class(table, b);
@ -233,7 +251,8 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
eq_union(table, a, b, ca, cb);
d = cyc_compare(fa->vals, fb->vals, table, eq);
if (numval(d) != 0) return d;
if (numval(d) != 0)
return d;
a = fa->env;
b = fb->env;
goto cyc_compare_top;
@ -242,10 +261,7 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
}
static htable_t equal_eq_hashtable;
void comparehash_init(void)
{
htable_new(&equal_eq_hashtable, 512);
}
void comparehash_init(void) { htable_new(&equal_eq_hashtable, 512); }
// 'eq' means unordered comparison is sufficient
static value_t compare_(value_t a, value_t b, int eq)
@ -258,10 +274,7 @@ static value_t compare_(value_t a, value_t b, int eq)
return guess;
}
value_t fl_compare(value_t a, value_t b)
{
return compare_(a, b, 0);
}
value_t fl_compare(value_t a, value_t b) { return compare_(a, b, 0); }
value_t fl_equal(value_t a, value_t b)
{

947
flisp.c
View File

File diff suppressed because it is too large Load Diff

55
flisp.h
View File

@ -79,8 +79,11 @@ typedef struct {
#define isforwarded(v) (((value_t *)ptr(v))[0] == TAG_FWD)
#define forwardloc(v) (((value_t *)ptr(v))[1])
#define forward(v,to) do { (((value_t*)ptr(v))[0] = TAG_FWD); \
(((value_t*)ptr(v))[1] = to); } while (0)
#define forward(v, to) \
do { \
(((value_t *)ptr(v))[0] = TAG_FWD); \
(((value_t *)ptr(v))[1] = to); \
} while (0)
#define vector_size(v) (((size_t *)ptr(v))[0] >> 2)
#define vector_setsize(v, n) (((size_t *)ptr(v))[0] = ((n) << 2))
@ -97,18 +100,23 @@ typedef struct {
#define fn_name(f) (((value_t *)ptr(f))[3])
#define set(s, v) (((symbol_t *)ptr(s))->binding = (v))
#define setc(s, v) do { ((symbol_t*)ptr(s))->flags |= 1; \
((symbol_t*)ptr(s))->binding = (v); } while (0)
#define setc(s, v) \
do { \
((symbol_t *)ptr(s))->flags |= 1; \
((symbol_t *)ptr(s))->binding = (v); \
} while (0)
#define isconstant(s) ((s)->flags & 0x1)
#define iskeyword(s) ((s)->flags & 0x2)
#define symbol_value(s) (((symbol_t *)ptr(s))->binding)
#define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \
#define ismanaged(v) \
((((unsigned char *)ptr(v)) >= fromspace) && \
(((unsigned char *)ptr(v)) < fromspace + heapsize))
#define isgensym(x) (issymbol(x) && ismanaged(x))
#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS << 3))
#define isclosure(x) isfunction(x)
#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
#define iscbuiltin(x) \
(iscvalue(x) && (cv_class((cvalue_t *)ptr(x)) == builtintype))
void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(uint32_t n);
@ -179,28 +187,32 @@ extern uint32_t fl_throwing_frame;
extern value_t fl_lasterror;
#define FL_TRY_EXTERN \
fl_exception_context_t _ctx; int l__tr, l__ca; \
fl_savestate(&_ctx); fl_ctx = &_ctx; \
fl_exception_context_t _ctx; \
int l__tr, l__ca; \
fl_savestate(&_ctx); \
fl_ctx = &_ctx; \
if (!setjmp(_ctx.buf)) \
for (l__tr = 1; l__tr; l__tr = 0, (void)(fl_ctx = fl_ctx->prev))
#define FL_CATCH_EXTERN \
else \
for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
else for (l__ca = 1; l__ca; l__ca = 0, fl_restorestate(&_ctx))
void lerrorf(value_t e, char *format, ...) __attribute__((__noreturn__));
void lerror(value_t e, const char *msg) __attribute__((__noreturn__));
void fl_savestate(fl_exception_context_t *_ctx);
void fl_restorestate(fl_exception_context_t *_ctx);
void fl_raise(value_t e) __attribute__((__noreturn__));
void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));
void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));
void type_error(char *fname, char *expected, value_t got)
__attribute__((__noreturn__));
void bounds_error(char *fname, value_t arr, value_t ind)
__attribute__((__noreturn__));
extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
extern value_t UnboundError;
static inline void argcount(char *fname, uint32_t nargs, uint32_t c)
{
if (__unlikely(nargs != c))
lerrorf(ArgError,"%s: too %s arguments", fname, nargs<c ? "few":"many");
lerrorf(ArgError, "%s: too %s arguments", fname,
nargs < c ? "few" : "many");
}
typedef struct {
@ -211,8 +223,18 @@ typedef struct {
} cvtable_t;
/* functions needed to implement the value interface (cvtable_t) */
typedef enum { T_INT8, T_UINT8, T_INT16, T_UINT16, T_INT32, T_UINT32,
T_INT64, T_UINT64, T_FLOAT, T_DOUBLE } numerictype_t;
typedef enum {
T_INT8,
T_UINT8,
T_INT16,
T_UINT16,
T_INT32,
T_UINT32,
T_INT64,
T_UINT64,
T_FLOAT,
T_DOUBLE
} numerictype_t;
#define N_NUMTYPES ((int)T_DOUBLE + 1)
@ -321,7 +343,8 @@ extern value_t QUOTE;
extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
extern value_t int64sym, uint64sym;
extern value_t longsym, ulongsym, bytesym, wcharsym;
extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym,
pointersym;
extern value_t stringtypesym, wcstringtypesym, emptystringsym;
extern value_t unionsym, floatsym, doublesym;
extern fltype_t *bytetype, *wchartype;

6
flmain.c
View File

@ -42,7 +42,8 @@ int main(int argc, char *argv[])
value_t args[2];
fl_gc_handle(&args[0]);
fl_gc_handle(&args[1]);
FL_TRY_EXTERN {
FL_TRY_EXTERN
{
args[0] = cvalue_static_cstring(fname_buf);
args[1] = symbol(":read");
value_t f = fl_file(&args[0], 2);
@ -54,7 +55,8 @@ int main(int argc, char *argv[])
(void)fl_applyn(1, symbol_value(symbol("__start")),
argv_list(argc, argv));
}
FL_CATCH_EXTERN {
FL_CATCH_EXTERN
{
ios_puts("fatal error:\n", ios_stderr);
fl_print(ios_stderr, fl_lasterror);
ios_putc('\n', ios_stderr);

66
iostream.c
View File

@ -67,10 +67,7 @@ static ios_t *toiostream(value_t v, char *fname)
return value2c(ios_t *, v);
}
ios_t *fl_toiostream(value_t v, char *fname)
{
return toiostream(v, fname);
}
ios_t *fl_toiostream(value_t v, char *fname) { return toiostream(v, fname); }
value_t fl_file(value_t *args, uint32_t nargs)
{
@ -78,19 +75,29 @@ value_t fl_file(value_t *args, uint32_t nargs)
argcount("file", nargs, 1);
int i, r = 0, w = 0, c = 0, t = 0, a = 0;
for (i = 1; i < (int)nargs; i++) {
if (args[i] == wrsym) w = 1;
else if (args[i] == apsym) { a = 1; w = 1; }
else if (args[i] == crsym) { c = 1; w = 1; }
else if (args[i] == truncsym) { t = 1; w = 1; }
else if (args[i] == rdsym) r = 1;
if (args[i] == wrsym)
w = 1;
else if (args[i] == apsym) {
a = 1;
w = 1;
} else if (args[i] == crsym) {
c = 1;
w = 1;
} else if (args[i] == truncsym) {
t = 1;
w = 1;
} else if (args[i] == rdsym)
r = 1;
}
if ((r|w|c|t|a) == 0) r = 1; // default to reading
if ((r | w | c | t | a) == 0)
r = 1; // default to reading
value_t f = cvalue(iostreamtype, sizeof(ios_t));
char *fname = tostring(args[0], "file");
ios_t *s = value2c(ios_t *, f);
if (ios_file(s, fname, r, w, c, t) == NULL)
lerrorf(IOError, "file: could not open \"%s\"", fname);
if (a) ios_seek_end(s);
if (a)
ios_seek_end(s);
return f;
}
@ -110,11 +117,9 @@ value_t fl_read(value_t *args, u_int32_t nargs)
value_t arg = 0;
if (nargs > 1) {
argcount("read", nargs, 1);
}
else if (nargs == 0) {
} else if (nargs == 0) {
arg = symbol_value(instrsym);
}
else {
} else {
arg = args[0];
}
(void)toiostream(arg, "read");
@ -247,8 +252,7 @@ value_t fl_ioread(value_t *args, u_int32_t nargs)
// form (io.read s type count)
ft = get_array_type(args[1]);
n = toulong(args[2], "io.read") * ft->elsz;
}
else {
} else {
ft = get_type(args[1]);
if (ft->eltype != NULL && !iscons(cdr_(cdr_(args[1]))))
lerror(ArgError, "io.read: incomplete type");
@ -256,8 +260,10 @@ value_t fl_ioread(value_t *args, u_int32_t nargs)
}
value_t cv = cvalue(ft, n);
char *data;
if (iscvalue(cv)) data = cv_data((cvalue_t*)ptr(cv));
else data = cp_data((cprim_t*)ptr(cv));
if (iscvalue(cv))
data = cv_data((cvalue_t *)ptr(cv));
else
data = cp_data((cprim_t *)ptr(cv));
size_t got = ios_read(value2c(ios_t *, args[0]), data, n);
if (got < n)
// lerror(IOError, "io.read: end of input reached");
@ -390,9 +396,9 @@ value_t stream_to_string(value_t *ps)
str = cvalue_string(n);
memcpy(cvalue_data(str), value2c(ios_t *, *ps)->buf, n);
ios_trunc(value2c(ios_t *, *ps), 0);
}
else {
char *b = ios_takebuf(st, &n); n--;
} else {
char *b = ios_takebuf(st, &n);
n--;
b[n] = '\0';
str = cvalue_from_ref(stringtype, b, n, FL_NIL);
#ifndef BOEHM_GC
@ -450,14 +456,14 @@ void iostream_init(void)
truncsym = symbol(":truncate");
instrsym = symbol("*input-stream*");
outstrsym = symbol("*output-stream*");
iostreamtype = define_opaque_type(iostreamsym, sizeof(ios_t),
&iostream_vtable, NULL);
iostreamtype =
define_opaque_type(iostreamsym, sizeof(ios_t), &iostream_vtable, NULL);
assign_global_builtins(iostreamfunc_info);
setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, ios_stdout,
sizeof(ios_t), FL_NIL));
setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, ios_stderr,
sizeof(ios_t), FL_NIL));
setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, ios_stdin,
sizeof(ios_t), FL_NIL));
setc(symbol("*stdout*"),
cvalue_from_ref(iostreamtype, ios_stdout, sizeof(ios_t), FL_NIL));
setc(symbol("*stderr*"),
cvalue_from_ref(iostreamtype, ios_stderr, sizeof(ios_t), FL_NIL));
setc(symbol("*stdin*"),
cvalue_from_ref(iostreamtype, ios_stdin, sizeof(ios_t), FL_NIL));
}

192
llt/bitvector-ops.c
View File

@ -20,12 +20,15 @@ u_int32_t bitreverse(u_int32_t x)
#ifdef __INTEL_COMPILER
x = _bswap(x);
#else
x = (x >> 16) | (x << 16); m = 0xff00ff00;
x = (x >> 16) | (x << 16);
m = 0xff00ff00;
x = ((x & m) >> 8) | ((x & ~m) << 8);
#endif
m = 0xf0f0f0f0;
x = ((x & m) >> 4) | ((x & ~m) << 4); m = 0xcccccccc;
x = ((x & m) >> 2) | ((x & ~m) << 2); m = 0xaaaaaaaa;
x = ((x & m) >> 4) | ((x & ~m) << 4);
m = 0xcccccccc;
x = ((x & m) >> 2) | ((x & ~m) << 2);
m = 0xaaaaaaaa;
x = ((x & m) >> 1) | ((x & ~m) << 1);
return x;
@ -38,7 +41,8 @@ u_int32_t bitreverse(u_int32_t x)
void bitvector_shr(u_int32_t *b, size_t n, u_int32_t s)
{
u_int32_t i;
if (s == 0 || n == 0) return;
if (s == 0 || n == 0)
return;
i = (s >> 5);
if (i) {
n -= i;
@ -59,7 +63,8 @@ void bitvector_shr(u_int32_t *b, size_t n, u_int32_t s)
void bitvector_shr_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s)
{
u_int32_t i, j;
if (n == 0) return;
if (n == 0)
return;
if (s == 0) {
memcpy(dest, b, n * 4);
return;
@ -80,7 +85,8 @@ void bitvector_shr_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s)
void bitvector_shl(u_int32_t *b, size_t n, u_int32_t s)
{
u_int32_t i, scrap = 0, temp;
if (s == 0 || n == 0) return;
if (s == 0 || n == 0)
return;
i = (s >> 5);
if (i) {
n -= i;
@ -102,7 +108,8 @@ void bitvector_shl_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s,
bool_t scrap)
{
u_int32_t i, j, sc = 0;
if (n == 0) return;
if (n == 0)
return;
if (s == 0) {
memcpy(dest, b, n * 4);
return;
@ -124,35 +131,48 @@ void bitvector_shl_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s,
// set nbits to c, starting at given bit offset
// assumes offs < 32
void bitvector_fill(u_int32_t *b, u_int32_t offs, u_int32_t c, u_int32_t nbits)
void bitvector_fill(u_int32_t *b, u_int32_t offs, u_int32_t c,
u_int32_t nbits)
{
index_t i;
u_int32_t nw, tail;
u_int32_t mask;
if (nbits == 0) return;
if (nbits == 0)
return;
nw = (offs + nbits + 31) >> 5;
if (nw == 1) {
mask = (lomask(nbits) << offs);
if (c) b[0]|=mask; else b[0]&=(~mask);
if (c)
b[0] |= mask;
else
b[0] &= (~mask);
return;
}
mask = lomask(offs);
if (c) b[0]|=(~mask); else b[0]&=mask;
if (c)
b[0] |= (~mask);
else
b[0] &= mask;
if (c) mask=ONES32; else mask = 0;
if (c)
mask = ONES32;
else
mask = 0;
for (i = 1; i < nw - 1; i++)
b[i] = mask;
tail = (offs + nbits) & 31;
if (tail == 0) {
b[i] = mask;
}
else {
} else {
mask = lomask(tail);
if (c) b[i]|=mask; else b[i]&=(~mask);
if (c)
b[i] |= mask;
else
b[i] &= (~mask);
}
}
@ -162,7 +182,8 @@ void bitvector_not(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
u_int32_t nw, tail;
u_int32_t mask;
if (nbits == 0) return;
if (nbits == 0)
return;
nw = (offs + nbits + 31) >> 5;
if (nw == 1) {
@ -180,8 +201,7 @@ void bitvector_not(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
tail = (offs + nbits) & 31;
if (tail == 0) {
b[i] = ~b[i];
}
else {
} else {
mask = lomask(tail);
b[i] ^= mask;
}
@ -190,14 +210,15 @@ void bitvector_not(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
// constant-space bit vector copy in a single pass, with arbitrary
// offsets and lengths. to get this right, there are 16 cases to handle!
#define BITVECTOR_COPY_OP(name, OP) \
void bitvector_##name(u_int32_t *dest, u_int32_t doffs, \
u_int32_t *src, u_int32_t soffs, u_int32_t nbits) \
void bitvector_##name(u_int32_t *dest, u_int32_t doffs, u_int32_t *src, \
u_int32_t soffs, u_int32_t nbits) \
{ \
index_t i; \
u_int32_t s, nw, tail, snw; \
u_int32_t mask, scrap; \
\
if (nbits == 0) return; \
if (nbits == 0) \
return; \
nw = (doffs + nbits + 31) >> 5; \
\
if (soffs == doffs) { \
@ -211,9 +232,12 @@ void bitvector_##name(u_int32_t *dest, u_int32_t doffs, \
for (i = 1; i < nw - 1; i++) \
dest[i] = OP(src[i]); \
tail = (doffs + nbits) & 31; \
if (tail==0) { dest[i]=src[i]; } else { \
if (tail == 0) { \
dest[i] = src[i]; \
} else { \
mask = lomask(tail); \
dest[i] = (dest[i] & ~mask) | (OP(src[i]) & mask); } \
dest[i] = (dest[i] & ~mask) | (OP(src[i]) & mask); \
} \
return; \
} \
snw = (soffs + nbits + 31) >> 5; \
@ -232,24 +256,26 @@ void bitvector_##name(u_int32_t *dest, u_int32_t doffs, \
scrap = OP(src[i]) >> (32 - s); \
} \
tail = (doffs + nbits) & 31; \
if (tail==0) { mask=ONES32; } else { mask = lomask(tail); } \
if (snw == nw) { \
dest[i] = (dest[i] & ~mask) | (((OP(src[i])<<s)|scrap) & mask); \
if (tail == 0) { \
mask = ONES32; \
} else { \
mask = lomask(tail); \
} \
else /* snw < nw */ { \
if (snw == nw) { \
dest[i] = \
(dest[i] & ~mask) | (((OP(src[i]) << s) | scrap) & mask); \
} else /* snw < nw */ { \
if (snw == 1) { \
dest[i] = (dest[i] & ~mask) | \
(((OP(src[i]) << s) | scrap) & mask); \
} \
else { \
} else { \
dest[i] = (OP(src[i]) << s) | scrap; \
scrap = OP(src[i]) >> (32 - s); \
i++; \
dest[i] = (dest[i] & ~mask) | (scrap & mask); \
} \
} \
} \
else { \
} else { \
s = soffs - doffs; \
if (snw == 1) { \
mask = (lomask(nbits) << doffs); \
@ -258,23 +284,29 @@ void bitvector_##name(u_int32_t *dest, u_int32_t doffs, \
} \
if (nw == 1) { \
mask = (lomask(nbits) << doffs); \
dest[0] = (dest[0] & ~mask) | \
dest[0] = \
(dest[0] & ~mask) | \
(((OP(src[0]) >> s) | (OP(src[1]) << (32 - s))) & mask); \
return; \
} \
mask = ~lomask(doffs); \
dest[0] = (dest[0] & ~mask) | \
dest[0] = \
(dest[0] & ~mask) | \
(((OP(src[0]) >> s) | (OP(src[1]) << (32 - s))) & mask); \
for (i = 1; i < nw - 1; i++) { \
dest[i] = (OP(src[i]) >> s) | (OP(src[i + 1]) << (32 - s)); \
} \
tail = (doffs + nbits) & 31; \
if (tail==0) { mask=ONES32; } else { mask = lomask(tail); } \
if (tail == 0) { \
mask = ONES32; \
} else { \
mask = lomask(tail); \
} \
if (snw == nw) { \
dest[i] = (dest[i] & ~mask) | ((OP(src[i]) >> s) & mask); \
} \
else /* snw > nw */ { \
dest[i] = (dest[i] & ~mask) | \
} else /* snw > nw */ { \
dest[i] = \
(dest[i] & ~mask) | \
(((OP(src[i]) >> s) | (OP(src[i + 1]) << (32 - s))) & mask); \
} \
} \
@ -287,7 +319,8 @@ BITVECTOR_COPY_OP(not_to, BV_NOT)
// right-shift the bits in one logical "row" of a long 2d bit vector
/*
void bitvector_shr_row(u_int32_t *b, u_int32_t offs, size_t nbits, u_int32_t s)
void bitvector_shr_row(u_int32_t *b, u_int32_t offs, size_t nbits, u_int32_t
s)
{
}
*/
@ -302,7 +335,8 @@ void bitvector_reverse_to(u_int32_t *dest, u_int32_t *src, u_int32_t soffs,
index_t i;
u_int32_t nw, tail;
if (nbits == 0) return;
if (nbits == 0)
return;
nw = (soffs + nbits + 31) >> 5;
// first, reverse the words while reversing bit order within each word
@ -324,7 +358,8 @@ void bitvector_reverse(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
u_int32_t nw, tail;
u_int32_t *temp;
if (nbits == 0) return;
if (nbits == 0)
return;
nw = (offs + nbits + 31) >> 5;
temp = (nw > MALLOC_CUTOFF) ? malloc(nw * 4) : alloca(nw * 4);
@ -337,7 +372,8 @@ void bitvector_reverse(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
tail = (offs + nbits) & 31;
bitvector_copy(b, offs, temp, (32 - tail) & 31, nbits);
if (nw > MALLOC_CUTOFF) free(temp);
if (nw > MALLOC_CUTOFF)
free(temp);
}
u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_t nbits)
@ -346,7 +382,8 @@ u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_t nbits)
u_int32_t ntail;
u_int64_t ans;
if (nbits == 0) return 0;
if (nbits == 0)
return 0;
nw = ((u_int64_t)offs + nbits + 31) >> 5;
if (nw == 1) {
@ -370,7 +407,8 @@ u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_t nbits)
}
ntail = (offs + (u_int32_t)nbits) & 31;
ans += count_bits(b[i]&(ntail>0?lomask(ntail):ONES32)); // last end cap
ans +=
count_bits(b[i] & (ntail > 0 ? lomask(ntail) : ONES32)); // last end cap
return ans;
}
@ -381,29 +419,34 @@ u_int32_t bitvector_any0(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
u_int32_t nw, tail;
u_int32_t mask;
if (nbits == 0) return 0;
if (nbits == 0)
return 0;
nw = (offs + nbits + 31) >> 5;
if (nw == 1) {
mask = (lomask(nbits) << offs);
if ((b[0] & mask) != mask) return 1;
if ((b[0] & mask) != mask)
return 1;
return 0;
}
mask = ~lomask(offs);
if ((b[0] & mask) != mask) return 1;
if ((b[0] & mask) != mask)
return 1;
for (i = 1; i < nw - 1; i++) {
if (b[i] != ONES32) return 1;
if (b[i] != ONES32)
return 1;
}
tail = (offs + nbits) & 31;
if (tail == 0) {
if (b[i] != ONES32) return 1;
}
else {
if (b[i] != ONES32)
return 1;
} else {
mask = lomask(tail);
if ((b[i] & mask) != mask) return 1;
if ((b[i] & mask) != mask)
return 1;
}
return 0;
}
@ -414,29 +457,34 @@ u_int32_t bitvector_any1(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
u_int32_t nw, tail;
u_int32_t mask;
if (nbits == 0) return 0;
if (nbits == 0)
return 0;
nw = (offs + nbits + 31) >> 5;
if (nw == 1) {
mask = (lomask(nbits) << offs);
if ((b[0] & mask) != 0) return 1;
if ((b[0] & mask) != 0)
return 1;
return 0;
}
mask = ~lomask(offs);
if ((b[0] & mask) != 0) return 1;
if ((b[0] & mask) != 0)
return 1;
for (i = 1; i < nw - 1; i++) {
if (b[i] != 0) return 1;
if (b[i] != 0)
return 1;
}
tail = (offs + nbits) & 31;
if (tail == 0) {
if (b[i] != 0) return 1;
}
else {
if (b[i] != 0)
return 1;
} else {
mask = lomask(tail);
if ((b[i] & mask) != 0) return 1;
if ((b[i] & mask) != 0)
return 1;
}
return 0;
}
@ -451,30 +499,34 @@ static void adjust_offset_to(u_int32_t *dest, u_int32_t *src, u_int32_t nw,
}
#define BITVECTOR_BINARY_OP_TO(opname, OP) \
void bitvector_##opname##_to(u_int32_t *dest, u_int32_t doffs, \
u_int32_t *a, u_int32_t aoffs, \
void bitvector_##opname##_to( \
u_int32_t *dest, u_int32_t doffs, u_int32_t *a, u_int32_t aoffs, \
u_int32_t *b, u_int32_t boffs, u_int32_t nbits) \
{ \
u_int32_t nw = (doffs + nbits + 31) >> 5; \
u_int32_t *temp = nw>MALLOC_CUTOFF ? malloc((nw+1)*4) : alloca((nw+1)*4);\
u_int32_t *temp = \
nw > MALLOC_CUTOFF ? malloc((nw + 1) * 4) : alloca((nw + 1) * 4); \
u_int32_t i, anw, bnw; \
if (aoffs == boffs) { \
anw = (aoffs + nbits + 31) >> 5; \
} \
else if (aoffs == doffs) { \
} else if (aoffs == doffs) { \
bnw = (boffs + nbits + 31) >> 5; \
adjust_offset_to(temp, b, bnw, boffs, aoffs); \
b = temp; anw = nw; \
} \
else { \
b = temp; \
anw = nw; \
} else { \
anw = (aoffs + nbits + 31) >> 5; \
bnw = (boffs + nbits + 31) >> 5; \
adjust_offset_to(temp, a, anw, aoffs, boffs); \
a = temp; aoffs = boffs; anw = bnw; \
a = temp; \
aoffs = boffs; \
anw = bnw; \
} \
for(i=0; i < anw; i++) temp[i] = OP(a[i], b[i]); \
for (i = 0; i < anw; i++) \
temp[i] = OP(a[i], b[i]); \
bitvector_copy(dest, doffs, temp, aoffs, nbits); \
if (nw>MALLOC_CUTOFF) free(temp); \
if (nw > MALLOC_CUTOFF) \
free(temp); \
}
#define BV_AND(a, b) ((a) & (b))

34
llt/bitvector.c
View File

@ -46,7 +46,8 @@ u_int32_t *bitvector_resize(u_int32_t *b, uint64_t oldsz, uint64_t newsz,
u_int32_t *p;
size_t sz = ((newsz + 31) >> 5) * sizeof(uint32_t);
p = LLT_REALLOC(b, sz);
if (p == NULL) return NULL;
if (p == NULL)
return NULL;
if (initzero && newsz > oldsz) {
size_t osz = ((oldsz + 31) >> 5) * sizeof(uint32_t);
memset(&p[osz / sizeof(uint32_t)], 0, sz - osz);
@ -59,10 +60,7 @@ u_int32_t *bitvector_new(u_int64_t n, int initzero)
return bitvector_resize(NULL, 0, n, initzero);
}
size_t bitvector_nwords(u_int64_t nbits)
{
return ((nbits+31)>>5);
}
size_t bitvector_nwords(u_int64_t nbits) { return ((nbits + 31) >> 5); }
void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c)
{
@ -81,12 +79,25 @@ static int ntz(uint32_t x)
{
int n;
if (x == 0) return 32;
if (x == 0)
return 32;
n = 1;
if ((x & 0x0000FFFF) == 0) {n = n +16; x = x >>16;}
if ((x & 0x000000FF) == 0) {n = n + 8; x = x >> 8;}
if ((x & 0x0000000F) == 0) {n = n + 4; x = x >> 4;}
if ((x & 0x00000003) == 0) {n = n + 2; x = x >> 2;}
if ((x & 0x0000FFFF) == 0) {
n = n + 16;
x = x >> 16;
}
if ((x & 0x000000FF) == 0) {
n = n + 8;
x = x >> 8;
}
if ((x & 0x0000000F) == 0) {
n = n + 4;
x = x >> 4;
}
if ((x & 0x00000003) == 0) {
n = n + 2;
x = x >> 2;
}
return n - (x & 1);
}
@ -95,7 +106,8 @@ static int ntz(uint32_t x)
// returns n if no set bits.
uint32_t bitvector_next(uint32_t *b, uint64_t n0, uint64_t n)
{
if (n0 >= n) return n;
if (n0 >= n)
return n;
uint32_t i = n0 >> 5;
uint32_t nb = n0 & 31;

29
llt/bitvector.h
View File

@ -45,24 +45,25 @@ void bitvector_shr_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s);
void bitvector_shl(u_int32_t *b, size_t n, u_int32_t s);
void bitvector_shl_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s,
bool_t scrap);
void bitvector_fill(u_int32_t *b,u_int32_t offs, u_int32_t c, u_int32_t nbits);
void bitvector_copy(u_int32_t *dest, u_int32_t doffs,
u_int32_t *a, u_int32_t aoffs, u_int32_t nbits);
void bitvector_fill(u_int32_t *b, u_int32_t offs, u_int32_t c,
u_int32_t nbits);
void bitvector_copy(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t aoffs, u_int32_t nbits);
void bitvector_not(u_int32_t *b, u_int32_t offs, u_int32_t nbits);
void bitvector_not_to(u_int32_t *dest, u_int32_t doffs,
u_int32_t *a, u_int32_t aoffs, u_int32_t nbits);
void bitvector_not_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t aoffs, u_int32_t nbits);
void bitvector_reverse(u_int32_t *b, u_int32_t offs, u_int32_t nbits);
void bitvector_reverse_to(u_int32_t *dest, u_int32_t *src, u_int32_t soffs,
u_int32_t nbits);
void bitvector_and_to(u_int32_t *dest, u_int32_t doffs,
u_int32_t *a, u_int32_t aoffs,
u_int32_t *b, u_int32_t boffs, u_int32_t nbits);
void bitvector_or_to(u_int32_t *dest, u_int32_t doffs,
u_int32_t *a, u_int32_t aoffs,
u_int32_t *b, u_int32_t boffs, u_int32_t nbits);
void bitvector_xor_to(u_int32_t *dest, u_int32_t doffs,
u_int32_t *a, u_int32_t aoffs,
u_int32_t *b, u_int32_t boffs, u_int32_t nbits);
void bitvector_and_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t aoffs, u_int32_t *b, u_int32_t boffs,
u_int32_t nbits);
void bitvector_or_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t aoffs, u_int32_t *b, u_int32_t boffs,
u_int32_t nbits);
void bitvector_xor_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t aoffs, u_int32_t *b, u_int32_t boffs,
u_int32_t nbits);
u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_t nbits);
u_int32_t bitvector_any0(u_int32_t *b, u_int32_t offs, u_int32_t nbits);
u_int32_t bitvector_any1(u_int32_t *b, u_int32_t offs, u_int32_t nbits);

23
llt/dirpath.c
View File

@ -54,8 +54,7 @@ void path_to_dirname(char *path)
char *sep = strrchr(path, PATHSEP);
if (sep != NULL) {
*sep = '\0';
}
else {
} else {
path[0] = '\0';
}
}
@ -144,8 +143,8 @@ char *get_exename(char *buf, size_t size)
// calls are a pre-condition for the access(2) call
// later.)
if ( (path = getenv("PATH")) != NULL &&
!setgid(getegid()) && !setuid(geteuid()) ) {
if ((path = getenv("PATH")) != NULL && !setgid(getegid()) &&
!setuid(geteuid())) {
// The strdup(3) call below, if successful, will
// allocate memory for the PATH string returned by
@ -159,14 +158,17 @@ char *get_exename(char *buf, size_t size)
pathcpy = path;
len = strlen(buf);
while ((p = strsep(&pathcpy, ":")) != NULL) {
if (*p == '\0') p = ".";
if (*p == '\0')
p = ".";
plen = strlen(p);
// strip trailing '/'
while (p[plen-1] == '/') p[--plen] = '\0';
while (p[plen - 1] == '/')
p[--plen] = '\0';
if (plen + 1 + len < sizeof(filename)) {
snprintf(filename, sizeof(filename), "%s/%s", p, buf);
snprintf(filename, sizeof(filename), "%s/%s", p,
buf);
if ((stat(filename, &sbuf) == 0) &&
S_ISREG(sbuf.st_mode) &&
access(filename, X_OK) == 0) {
@ -177,13 +179,14 @@ char *get_exename(char *buf, size_t size)
}
free(path); // free the strdup(3) memory allocation.
}
}
else buf = NULL; // call to getenv(3) or [sg]ete?[ug]id(2) failed.
} else
buf = NULL; // call to getenv(3) or [sg]ete?[ug]id(2) failed.
}
if (buf != NULL && *buf != '/') {
// buf contains a relative pathname (e.g. "../foo");
// resolve this to an absolute pathname.
if ( strlcpy(filename, buf, sizeof(filename)) >= sizeof(filename) ||
if (strlcpy(filename, buf, sizeof(filename)) >=
sizeof(filename) ||
realpath(filename, buf) == NULL)
buf = NULL;
}

6
llt/dtypes.h
View File

@ -16,7 +16,6 @@
We assume the LP64 convention for 64-bit platforms.
*/
#if defined(__gnu_linux__)
#define LINUX
#elif defined(__APPLE__) && defined(__MACH__)
@ -52,7 +51,6 @@
#endif
#endif
#if defined(WIN32)
#define STDCALL __stdcall
#if defined(IMPORT_EXPORTS)
@ -92,7 +90,6 @@
#error "unknown platform"
#endif
#ifdef BOEHM_GC
// boehm GC allocator
#include <gc.h>
@ -202,7 +199,8 @@ typedef u_ptrint_t uptrint_t;
#define sign_bit(r) ((*(int64_t *)&(r)) & BIT63)
#define LABS(n) (((n) ^ ((n) >> (NBITS - 1))) - ((n) >> (NBITS - 1)))
#define NBABS(n, nb) (((n) ^ ((n) >> ((nb)-1))) - ((n) >> ((nb)-1)))
#define DFINITE(d) (((*(int64_t*)&(d))&0x7ff0000000000000LL)!=0x7ff0000000000000LL)
#define DFINITE(d) \
(((*(int64_t *)&(d)) & 0x7ff0000000000000LL) != 0x7ff0000000000000LL)
#define DNAN(d) ((d) != (d))
extern double D_PNAN;

9
llt/hashing.c
View File

@ -13,9 +13,12 @@
uint_t nextipow2(uint_t i)
{
if (i==0) return 1;
if ((i&(i-1))==0) return i;
if (i&TOP_BIT) return TOP_BIT;
if (i == 0)
return 1;
if ((i & (i - 1)) == 0)
return i;
if (i & TOP_BIT)
return TOP_BIT;
// repeatedly clear bottom bit
while (i & (i - 1))

9
llt/htable.c
View File

@ -17,15 +17,15 @@ htable_t *htable_new(htable_t *h, size_t size)
if (size <= HT_N_INLINE / 2) {
h->size = size = HT_N_INLINE;
h->table = &h->_space[0];
}
else {
} else {
size = nextipow2(size);
size *= 2; // 2 pointers per key/value pair
size *= 2; // aim for 50% occupancy
h->size = size;
h->table = (void **)LLT_ALLOC(size * sizeof(void *));
}
if (h->table == NULL) return NULL;
if (h->table == NULL)
return NULL;
size_t i;
for (i = 0; i < size; i++)
h->table[i] = HT_NOTFOUND;
@ -44,7 +44,8 @@ void htable_reset(htable_t *h, size_t sz)
sz = nextipow2(sz);
if (h->size > sz * 4 && h->size > HT_N_INLINE) {
size_t newsz = sz * 4;
void **newtab = (void**)LLT_REALLOC(h->table, newsz*sizeof(void*));
void **newtab =
(void **)LLT_REALLOC(h->table, newsz * sizeof(void *));
if (newtab == NULL)
return;
h->size = newsz;

3
llt/int2str.c
View File

@ -26,8 +26,7 @@ int isdigit_base(char c, int base)
{
if (base < 11)
return (c >= '0' && c < '0' + base);
return ((c >= '0' && c <= '9') ||
(c >= 'a' && c < 'a'+base-10) ||
return ((c >= '0' && c <= '9') || (c >= 'a' && c < 'a' + base - 10) ||
(c >= 'A' && c < 'A' + base - 10));
}

104
llt/ios.c
View File

@ -145,7 +145,6 @@ static int _os_write_all(long fd, void *buf, size_t n, size_t *nwritten)
return 0;
}
/* internal utility functions */
static char *_buf_realloc(ios_t *s, size_t sz)
@ -161,7 +160,8 @@ static char *_buf_realloc(ios_t *s, size_t sz)
return s->buf;
}
if (sz <= s->maxsize) return s->buf;
if (sz <= s->maxsize)
return s->buf;
if (s->ownbuf && s->buf != &s->local[0]) {
// if we own the buffer we're free to resize it
@ -170,8 +170,7 @@ static char *_buf_realloc(ios_t *s, size_t sz)
temp = LLT_REALLOC(s->buf, sz + 1);
if (temp == NULL)
return NULL;
}
else {
} else {
temp = LLT_ALLOC(sz + 1);
if (temp == NULL)
return NULL;
@ -221,7 +220,6 @@ static size_t _write_grow(ios_t *s, char *data, size_t n)
return n;
}
/* interface functions, low level */
static size_t _ios_read(ios_t *s, char *dest, size_t n, int all)
@ -268,8 +266,7 @@ static size_t _ios_read(ios_t *s, char *dest, size_t n, int all)
if (got == 0)
s->_eof = 1;
return tot;
}
else {
} else {
// refill buffer
if (_os_read(s->fd, s->buf, s->maxsize, &got)) {
s->_eof = 1;
@ -313,14 +310,14 @@ size_t ios_readprep(ios_t *s, size_t n)
memmove(s->buf, s->buf + s->bpos, space);
s->size -= s->bpos;
s->bpos = 0;
}
else {
} else {
if (_buf_realloc(s, s->bpos + n) == NULL)
return space;
}
}
size_t got;
int result = _os_read(s->fd, s->buf+s->size, s->maxsize - s->size, &got);
int result =
_os_read(s->fd, s->buf + s->size, s->maxsize - s->size, &got);
if (result)
return space;
s->size += got;
@ -329,38 +326,40 @@ size_t ios_readprep(ios_t *s, size_t n)
static void _write_update_pos(ios_t *s)
{
if (s->bpos > s->ndirty) s->ndirty = s->bpos;
if (s->bpos > s->size) s->size = s->bpos;
if (s->bpos > s->ndirty)
s->ndirty = s->bpos;
if (s->bpos > s->size)
s->size = s->bpos;
}
size_t ios_write(ios_t *s, char *data, size_t n)
{
if (s->readonly) return 0;
if (n == 0) return 0;
if (s->readonly)
return 0;
if (n == 0)
return 0;
size_t space;
size_t wrote = 0;
if (s->state == bst_none) s->state = bst_wr;
if (s->state == bst_none)
s->state = bst_wr;
if (s->state == bst_rd) {
if (!s->rereadable) {
s->size = 0;
s->bpos = 0;
}
space = s->size - s->bpos;
}
else {
} else {
space = s->maxsize - s->bpos;
}
if (s->bm == bm_mem) {
wrote = _write_grow(s, data, n);
}
else if (s->bm == bm_none) {
} else if (s->bm == bm_none) {
s->fpos = -1;
_os_write_all(s->fd, data, n, &wrote);
return wrote;
}
else if (n <= space) {
} else if (n <= space) {
if (s->bm == bm_line) {
char *nl;
if ((nl = (char *)memrchr(data, '\n', n)) != NULL) {
@ -376,8 +375,7 @@ size_t ios_write(ios_t *s, char *data, size_t n)
memcpy(s->buf + s->bpos, data, n);
s->bpos += n;
wrote += n;
}
else {
} else {
s->state = bst_wr;
ios_flush(s);
if (n > MOST_OF(s->maxsize)) {
@ -397,8 +395,7 @@ off_t ios_seek(ios_t *s, off_t pos)
if ((size_t)pos > s->size)
return -1;
s->bpos = pos;
}
else {
} else {
ios_flush(s);
off_t fdpos = lseek(s->fd, pos, SEEK_SET);
if (fdpos == (off_t)-1)
@ -413,8 +410,7 @@ off_t ios_seek_end(ios_t *s)
s->_eof = 1;
if (s->bm == bm_mem) {
s->bpos = s->size;
}
else {
} else {
ios_flush(s);
off_t fdpos = lseek(s->fd, 0, SEEK_END);
if (fdpos == (off_t)-1)
@ -431,19 +427,16 @@ off_t ios_skip(ios_t *s, off_t offs)
if (offs <= (off_t)(s->size - s->bpos)) {
s->bpos += offs;
return 0;
}
else if (s->bm == bm_mem) {
} else if (s->bm == bm_mem) {
// TODO: maybe grow buffer
return -1;
}
}
else if (offs < 0) {
} else if (offs < 0) {
if (-offs <= (off_t)s->bpos) {
s->bpos += offs;
s->_eof = 0;
return 0;
}
else if (s->bm == bm_mem) {
} else if (s->bm == bm_mem) {
return -1;
}
}
@ -489,8 +482,7 @@ size_t ios_trunc(ios_t *s, size_t size)
if (size < s->size) {
if (s->bpos > size)
s->bpos = size;
}
else {
} else {
if (_buf_realloc(s, size) == NULL)
return s->size;
}
@ -532,8 +524,7 @@ int ios_flush(ios_t *s)
if (s->state == bst_rd) {
if (lseek(s->fd, s->size - nw, SEEK_CUR) == (off_t)-1) {
}
}
else if (s->state == bst_wr) {
} else if (s->state == bst_wr) {
if (s->bpos != nw &&
lseek(s->fd, (off_t)s->bpos - (off_t)nw, SEEK_CUR) == (off_t)-1) {
}
@ -575,8 +566,7 @@ static void _buf_init(ios_t *s, bufmode_t bm)
if (s->bm == bm_mem || s->bm == bm_none) {
s->buf = &s->local[0];
s->maxsize = IOS_INLSIZE;
}
else {
} else {
s->buf = NULL;
_buf_realloc(s, IOS_BUFSIZE);
}
@ -595,8 +585,7 @@ char *ios_takebuf(ios_t *s, size_t *psize)
return NULL;
if (s->size)
memcpy(buf, s->buf, s->size);
}
else {
} else {
buf = s->buf;
}
buf[s->size] = '\0';
@ -642,7 +631,8 @@ int ios_bufmode(ios_t *s, bufmode_t mode)
void ios_set_readonly(ios_t *s)
{
if (s->readonly) return;
if (s->readonly)
return;
ios_flush(s);
s->state = bst_none;
s->readonly = 1;
@ -705,8 +695,7 @@ size_t ios_copyuntil(ios_t *to, ios_t *from, char delim)
from->bpos += avail;
total += written;
avail = 0;
}
else {
} else {
size_t ntowrite = pd - (from->buf + from->bpos) + 1;
written = ios_write(to, from->buf + from->bpos, ntowrite);
from->bpos += ntowrite;
@ -749,8 +738,10 @@ ios_t *ios_file(ios_t *s, char *fname, int rd, int wr, int create, int trunc)
// must specify read and/or write
goto open_file_err;
int flags = wr ? (rd ? O_RDWR : O_WRONLY) : O_RDONLY;
if (create) flags |= O_CREAT;
if (trunc) flags |= O_TRUNC;
if (create)
flags |= O_CREAT;
if (trunc)
flags |= O_TRUNC;
fd = open(fname, flags, S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH /*644*/);
s = ios_fd(s, fd, 1, 1);
if (fd == -1)
@ -774,7 +765,8 @@ ios_t *ios_mem(ios_t *s, size_t initsize)
ios_t *ios_str(ios_t *s, char *str)
{
size_t n = strlen(str);
if (ios_mem(s, n+1)==NULL) return NULL;
if (ios_mem(s, n + 1) == NULL)
return NULL;
ios_write(s, str, n + 1);
ios_seek(s, 0);
return s;
@ -793,7 +785,8 @@ ios_t *ios_fd(ios_t *s, long fd, int isfile, int own)
{
_ios_init(s);
s->fd = fd;
if (isfile) s->rereadable = 1;
if (isfile)
s->rereadable = 1;
_buf_init(s, bm_block);
s->ownfd = own;
if (fd == STDERR_FILENO)
@ -840,13 +833,14 @@ int ios_getc(ios_t *s)
char ch;
if (s->state == bst_rd && s->bpos < s->size) {
ch = s->buf[s->bpos++];
}
else {
if (s->_eof) return IOS_EOF;
} else {
if (s->_eof)
return IOS_EOF;
if (ios_read(s, &ch, 1) < 1)
return IOS_EOF;
}
if (ch == '\n') s->lineno++;
if (ch == '\n')
s->lineno++;
return (unsigned char)ch;
}
@ -854,9 +848,11 @@ int ios_peekc(ios_t *s)
{
if (s->bpos < s->size)
return (unsigned char)s->buf[s->bpos];
if (s->_eof) return IOS_EOF;
if (s->_eof)
return IOS_EOF;
size_t n = ios_readprep(s, 1);
if (n == 0) return IOS_EOF;
if (n == 0)
return IOS_EOF;
return (unsigned char)s->buf[s->bpos];
}

459
llt/lookup3.c
View File

@ -119,12 +119,24 @@ rotates.
*/
#define mix(a, b, c) \
{ \
a -= c; a ^= rot(c, 4); c += b; \
b -= a; b ^= rot(a, 6); a += c; \
c -= b; c ^= rot(b, 8); b += a; \
a -= c; a ^= rot(c,16); c += b; \
b -= a; b ^= rot(a,19); a += c; \
c -= b; c ^= rot(b, 4); b += a; \
a -= c; \
a ^= rot(c, 4); \
c += b; \
b -= a; \
b ^= rot(a, 6); \
a += c; \
c -= b; \
c ^= rot(b, 8); \
b += a; \
a -= c; \
a ^= rot(c, 16); \
c += b; \
b -= a; \
b ^= rot(a, 19); \
a += c; \
c -= b; \
c ^= rot(b, 4); \
b += a; \
}
/*
@ -154,13 +166,20 @@ and these came close:
*/
#define final(a, b, c) \
{ \
c ^= b; c -= rot(b,14); \
a ^= c; a -= rot(c,11); \
b ^= a; b -= rot(a,25); \
c ^= b; c -= rot(b,16); \
a ^= c; a -= rot(c,4); \
b ^= a; b -= rot(a,14); \
c ^= b; c -= rot(b,24); \
c ^= b; \
c -= rot(b, 14); \
a ^= c; \
a -= rot(c, 11); \
b ^= a; \
b -= rot(a, 25); \
c ^= b; \
c -= rot(b, 16); \
a ^= c; \
a -= rot(c, 4); \
b ^= a; \
b -= rot(a, 14); \
c ^= b; \
c -= rot(b, 24); \
}
/*
@ -176,8 +195,8 @@ and these came close:
hashlittle() has to dance around fitting the key bytes into registers.
--------------------------------------------------------------------
*/
uint32_t hashword(
const uint32_t *k, /* the key, an array of uint32_t values */
uint32_t
hashword(const uint32_t *k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */
uint32_t initval) /* the previous hash, or an arbitrary value */
{
@ -186,9 +205,9 @@ uint32_t initval) /* the previous hash, or an arbitrary value */
/* Set up the internal state */
a = b = c = 0xdeadbeef + (((uint32_t)length) << 2) + initval;
/*------------------------------------------------- handle most of the key */
while (length > 3)
{
/*------------------------------------------------- handle most of the key
*/
while (length > 3) {
a += k[0];
b += k[1];
c += k[2];
@ -197,17 +216,22 @@ uint32_t initval) /* the previous hash, or an arbitrary value */
k += 3;
}
/*------------------------------------------- handle the last 3 uint32_t's */
/*------------------------------------------- handle the last 3 uint32_t's
*/
switch (length) /* all the case statements fall through */
{
case 3 : c+=k[2];
case 2 : b+=k[1];
case 1 : a+=k[0];
case 3:
c += k[2];
case 2:
b += k[1];
case 1:
a += k[0];
final(a, b, c);
case 0: /* case 0: nothing left to add */
break;
}
/*------------------------------------------------------ report the result */
/*------------------------------------------------------ report the result
*/
return c;
}
@ -219,8 +243,7 @@ both be initialized with seeds. If you pass in (*pb)==0, the output
(*pc) will be the same as the return value from hashword().
--------------------------------------------------------------------
*/
void hashword2 (
const uint32_t *k, /* the key, an array of uint32_t values */
void hashword2(const uint32_t *k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */
uint32_t *pc, /* IN: seed OUT: primary hash value */
uint32_t *pb) /* IN: more seed OUT: secondary hash value */
@ -231,9 +254,9 @@ uint32_t *pb) /* IN: more seed OUT: secondary hash value */
a = b = c = 0xdeadbeef + ((uint32_t)(length << 2)) + *pc;
c += *pb;
/*------------------------------------------------- handle most of the key */
while (length > 3)
{
/*------------------------------------------------- handle most of the key
*/
while (length > 3) {
a += k[0];
b += k[1];
c += k[2];
@ -242,18 +265,24 @@ uint32_t *pb) /* IN: more seed OUT: secondary hash value */
k += 3;
}
/*------------------------------------------- handle the last 3 uint32_t's */
/*------------------------------------------- handle the last 3 uint32_t's
*/
switch (length) /* all the case statements fall through */
{
case 3 : c+=k[2];
case 2 : b+=k[1];
case 1 : a+=k[0];
case 3:
c += k[2];
case 2:
b += k[1];
case 1:
a += k[0];
final(a, b, c);
case 0: /* case 0: nothing left to add */
break;
}
/*------------------------------------------------------ report the result */
*pc=c; *pb=b;
/*------------------------------------------------------ report the result
*/
*pc = c;
*pb = b;
}
#if 0
@ -471,7 +500,10 @@ void hashlittle2(
uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
{
uint32_t a, b, c; /* internal state */
union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */
union {
const void *ptr;
size_t i;
} u; /* needed for Mac Powerbook G4 */
/* Set up the internal state */
a = b = c = 0xdeadbeef + ((uint32_t)length) + *pc;
@ -482,9 +514,9 @@ void hashlittle2(
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) */
while (length > 12)
{
/*------ all but last block: aligned reads and affect 32 bits of
* (a,b,c) */
while (length > 12) {
a += k[0];
b += k[1];
c += k[2];
@ -493,7 +525,8 @@ void hashlittle2(
k += 3;
}
/*----------------------------- handle the last (probably partial) block */
/*----------------------------- handle the last (probably partial)
* block */
/*
* "k[2]&0xffffff" actually reads beyond the end of the string, but
* then masks off the part it's not allowed to read. Because the
@ -505,41 +538,100 @@ void hashlittle2(
*/
#ifndef VALGRIND
(void)k8;
switch(length)
{
case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;
case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break;
case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break;
case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break;
case 8 : b+=k[1]; a+=k[0]; break;
case 7 : b+=k[1]&0xffffff; a+=k[0]; break;
case 6 : b+=k[1]&0xffff; a+=k[0]; break;
case 5 : b+=k[1]&0xff; a+=k[0]; break;
case 4 : a+=k[0]; break;
case 3 : a+=k[0]&0xffffff; break;
case 2 : a+=k[0]&0xffff; break;
case 1 : a+=k[0]&0xff; break;
case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */
switch (length) {
case 12:
c += k[2];
b += k[1];
a += k[0];
break;
case 11:
c += k[2] & 0xffffff;
b += k[1];
a += k[0];
break;
case 10:
c += k[2] & 0xffff;
b += k[1];
a += k[0];
break;
case 9:
c += k[2] & 0xff;
b += k[1];
a += k[0];
break;
case 8:
b += k[1];
a += k[0];
break;
case 7:
b += k[1] & 0xffffff;
a += k[0];
break;
case 6:
b += k[1] & 0xffff;
a += k[0];
break;
case 5:
b += k[1] & 0xff;
a += k[0];
break;
case 4:
a += k[0];
break;
case 3:
a += k[0] & 0xffffff;
break;
case 2:
a += k[0] & 0xffff;
break;
case 1:
a += k[0] & 0xff;
break;
case 0:
*pc = c;
*pb = b;
return; /* zero length strings require no mixing */
}
#else /* make valgrind happy */
k8 = (const uint8_t *)k;
switch(length)
{
case 12: c+=k[2]; b+=k[1]; a+=k[0]; break;
case 11: c+=((uint32_t)k8[10])<<16; /* fall through */
case 10: c+=((uint32_t)k8[9])<<8; /* fall through */
case 9 : c+=k8[8]; /* fall through */
case 8 : b+=k[1]; a+=k[0]; break;
case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */
case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */
case 5 : b+=k8[4]; /* fall through */
case 4 : a+=k[0]; break;
case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */
case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */
case 1 : a+=k8[0]; break;
case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */
switch (length) {
case 12:
c += k[2];
b += k[1];
a += k[0];
break;
case 11:
c += ((uint32_t)k8[10]) << 16; /* fall through */
case 10:
c += ((uint32_t)k8[9]) << 8; /* fall through */
case 9:
c += k8[8]; /* fall through */
case 8:
b += k[1];
a += k[0];
break;
case 7:
b += ((uint32_t)k8[6]) << 16; /* fall through */
case 6:
b += ((uint32_t)k8[5]) << 8; /* fall through */
case 5:
b += k8[4]; /* fall through */
case 4:
a += k[0];
break;
case 3:
a += ((uint32_t)k8[2]) << 16; /* fall through */
case 2:
a += ((uint32_t)k8[1]) << 8; /* fall through */
case 1:
a += k8[0];
break;
case 0:
*pc = c;
*pb = b;
return; /* zero length strings require no mixing */
}
#endif /* !valgrind */
@ -548,9 +640,9 @@ void hashlittle2(
const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */
const uint8_t *k8;
/*--------------- all but last block: aligned reads and different mixing */
while (length > 12)
{
/*--------------- all but last block: aligned reads and different
* mixing */
while (length > 12) {
a += k[0] + (((uint32_t)k[1]) << 16);
b += k[2] + (((uint32_t)k[3]) << 16);
c += k[4] + (((uint32_t)k[5]) << 16);
@ -559,44 +651,59 @@ void hashlittle2(
k += 6;
}
/*----------------------------- handle the last (probably partial) block */
/*----------------------------- handle the last (probably partial)
* block */
k8 = (const uint8_t *)k;
switch(length)
{
case 12: c+=k[4]+(((uint32_t)k[5])<<16);
switch (length) {
case 12:
c += k[4] + (((uint32_t)k[5]) << 16);
b += k[2] + (((uint32_t)k[3]) << 16);
a += k[0] + (((uint32_t)k[1]) << 16);
break;
case 11: c+=((uint32_t)k8[10])<<16; /* fall through */
case 10: c+=k[4];
case 11:
c += ((uint32_t)k8[10]) << 16; /* fall through */
case 10:
c += k[4];
b += k[2] + (((uint32_t)k[3]) << 16);
a += k[0] + (((uint32_t)k[1]) << 16);
break;
case 9 : c+=k8[8]; /* fall through */
case 8 : b+=k[2]+(((uint32_t)k[3])<<16);
case 9:
c += k8[8]; /* fall through */
case 8:
b += k[2] + (((uint32_t)k[3]) << 16);
a += k[0] + (((uint32_t)k[1]) << 16);
break;
case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */
case 6 : b+=k[2];
case 7:
b += ((uint32_t)k8[6]) << 16; /* fall through */
case 6:
b += k[2];
a += k[0] + (((uint32_t)k[1]) << 16);
break;
case 5 : b+=k8[4]; /* fall through */
case 4 : a+=k[0]+(((uint32_t)k[1])<<16);
case 5:
b += k8[4]; /* fall through */
case 4:
a += k[0] + (((uint32_t)k[1]) << 16);
break;
case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */
case 2 : a+=k[0];
case 3:
a += ((uint32_t)k8[2]) << 16; /* fall through */
case 2:
a += k[0];
break;
case 1 : a+=k8[0];
case 1:
a += k8[0];
break;
case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */
case 0:
*pc = c;
*pb = b;
return; /* zero length strings require no mixing */
}
} else { /* need to read the key one byte at a time */
const uint8_t *k = (const uint8_t *)key;
/*--------------- all but the last block: affect some 32 bits of (a,b,c) */
while (length > 12)
{
/*--------------- all but the last block: affect some 32 bits of
* (a,b,c) */
while (length > 12) {
a += k[0];
a += ((uint32_t)k[1]) << 8;
a += ((uint32_t)k[2]) << 16;
@ -614,31 +721,47 @@ void hashlittle2(
k += 12;
}
/*-------------------------------- last block: affect all 32 bits of (c) */
/*-------------------------------- last block: affect all 32 bits of
* (c) */
switch (length) /* all the case statements fall through */
{
case 12: c+=((uint32_t)k[11])<<24;
case 11: c+=((uint32_t)k[10])<<16;
case 10: c+=((uint32_t)k[9])<<8;
case 9 : c+=k[8];
case 8 : b+=((uint32_t)k[7])<<24;
case 7 : b+=((uint32_t)k[6])<<16;
case 6 : b+=((uint32_t)k[5])<<8;
case 5 : b+=k[4];
case 4 : a+=((uint32_t)k[3])<<24;
case 3 : a+=((uint32_t)k[2])<<16;
case 2 : a+=((uint32_t)k[1])<<8;
case 1 : a+=k[0];
case 12:
c += ((uint32_t)k[11]) << 24;
case 11:
c += ((uint32_t)k[10]) << 16;
case 10:
c += ((uint32_t)k[9]) << 8;
case 9:
c += k[8];
case 8:
b += ((uint32_t)k[7]) << 24;
case 7:
b += ((uint32_t)k[6]) << 16;
case 6:
b += ((uint32_t)k[5]) << 8;
case 5:
b += k[4];
case 4:
a += ((uint32_t)k[3]) << 24;
case 3:
a += ((uint32_t)k[2]) << 16;
case 2:
a += ((uint32_t)k[1]) << 8;
case 1:
a += k[0];
break;
case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */
case 0:
*pc = c;
*pb = b;
return; /* zero length strings require no mixing */
}
}
final(a, b, c);
*pc=c; *pb=b;
*pc = c;
*pb = b;
}
#if 0
/*
* hashbig():
@ -780,13 +903,14 @@ void driver1()
time_t a, z;
time(&a);
for (i=0; i<256; ++i) buf[i] = 'x';
for (i=0; i<1; ++i)
{
for (i = 0; i < 256; ++i)
buf[i] = 'x';
for (i = 0; i < 1; ++i) {
h = hashlittle(&buf[0], 1, h);
}
time(&z);
if (z-a > 0) printf("time %d %.8x\n", z-a, h);
if (z - a > 0)
printf("time %d %.8x\n", z - a, h);
}
/* check that every input bit changes every output bit half the time */
@ -803,59 +927,67 @@ void driver2()
uint32_t hlen;
printf("No more than %d trials should ever be needed \n", MAXPAIR / 2);
for (hlen=0; hlen < MAXLEN; ++hlen)
{
for (hlen = 0; hlen < MAXLEN; ++hlen) {
z = 0;
for (i=0; i<hlen; ++i) /*----------------------- for each input byte, */
for (i = 0; i < hlen;
++i) /*----------------------- for each input byte, */
{
for (j=0; j<8; ++j) /*------------------------ for each input bit, */
for (j = 0; j < 8;
++j) /*------------------------ for each input bit, */
{
for (m=1; m<8; ++m) /*------------ for serveral possible initvals, */
for (m = 1; m < 8;
++m) /*------------ for serveral possible initvals, */
{
for (l = 0; l < HASHSTATE; ++l)
e[l]=f[l]=g[l]=h[l]=x[l]=y[l]=~((uint32_t)0);
e[l] = f[l] = g[l] = h[l] = x[l] = y[l] =
~((uint32_t)0);
/*---- check that every output bit is affected by that input bit */
for (k=0; k<MAXPAIR; k+=2)
{
/*---- check that every output bit is affected by that
* input bit */
for (k = 0; k < MAXPAIR; k += 2) {
uint32_t finished = 1;
/* keys have one bit different */
for (l=0; l<hlen+1; ++l) {a[l] = b[l] = (uint8_t)0;}
/* have a and b be two keys differing in only one bit */
for (l = 0; l < hlen + 1; ++l) {
a[l] = b[l] = (uint8_t)0;
}
/* have a and b be two keys differing in only one bit
*/
a[i] ^= (k << j);
a[i] ^= (k >> (8 - j));
c[0] = hashlittle(a, hlen, m);
b[i] ^= ((k + 1) << j);
b[i] ^= ((k + 1) >> (8 - j));
d[0] = hashlittle(b, hlen, m);
/* check every bit is 1, 0, set, and not set at least once */
for (l=0; l<HASHSTATE; ++l)
{
/* check every bit is 1, 0, set, and not set at least
* once */
for (l = 0; l < HASHSTATE; ++l) {
e[l] &= (c[l] ^ d[l]);
f[l] &= ~(c[l] ^ d[l]);
g[l] &= c[l];
h[l] &= ~c[l];
x[l] &= d[l];
y[l] &= ~d[l];
if (e[l]|f[l]|g[l]|h[l]|x[l]|y[l]) finished=0;
if (e[l] | f[l] | g[l] | h[l] | x[l] | y[l])
finished = 0;
}
if (finished) break;
if (finished)
break;
}
if (k>z) z=k;
if (k==MAXPAIR)
{
if (k > z)
z = k;
if (k == MAXPAIR) {
printf("Some bit didn't change: ");
printf("%.8x %.8x %.8x %.8x %.8x %.8x ",
e[0],f[0],g[0],h[0],x[0],y[0]);
printf("%.8x %.8x %.8x %.8x %.8x %.8x ", e[0], f[0],
g[0], h[0], x[0], y[0]);
printf("i %d j %d m %d len %d\n", i, j, m, hlen);
}
if (z==MAXPAIR) goto done;
if (z == MAXPAIR)
goto done;
}
}
}
done:
if (z < MAXPAIR)
{
if (z < MAXPAIR) {
printf("Mix success %2d bytes %2d initvals ", i, m);
printf("required %d trials\n", z / 2);
}
@ -868,23 +1000,30 @@ void driver3()
{
uint8_t buf[MAXLEN + 20], *b;
uint32_t len;
uint8_t q[] = "This is the time for all good men to come to the aid of their country...";
uint8_t q[] = "This is the time for all good men to come to the aid of "
"their country...";
uint32_t h;
uint8_t qq[] = "xThis is the time for all good men to come to the aid of their country...";
uint8_t qq[] = "xThis is the time for all good men to come to the aid of "
"their country...";
uint32_t i;
uint8_t qqq[] = "xxThis is the time for all good men to come to the aid of their country...";
uint8_t qqq[] = "xxThis is the time for all good men to come to the aid "
"of their country...";
uint32_t j;
uint8_t qqqq[] = "xxxThis is the time for all good men to come to the aid of their country...";
uint8_t qqqq[] = "xxxThis is the time for all good men to come to the "
"aid of their country...";
uint32_t ref, x, y;
uint8_t *p;
printf("Endianness. These lines should all be the same (for values filled in):\n");
printf("%.8x %.8x %.8x\n",
printf("Endianness. These lines should all be the same (for values "
"filled in):\n");
printf(
"%.8x %.8x %.8x\n",
hashword((const uint32_t *)q, (sizeof(q) - 1) / 4, 13),
hashword((const uint32_t *)q, (sizeof(q) - 5) / 4, 13),
hashword((const uint32_t *)q, (sizeof(q) - 9) / 4, 13));
p = q;
printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
printf(
"%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
hashlittle(p, sizeof(q) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 13),
hashlittle(p, sizeof(q) - 5, 13), hashlittle(p, sizeof(q) - 6, 13),
@ -892,7 +1031,8 @@ void driver3()
hashlittle(p, sizeof(q) - 9, 13), hashlittle(p, sizeof(q) - 10, 13),
hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13));
p = &qq[1];
printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
printf(
"%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
hashlittle(p, sizeof(q) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 13),
hashlittle(p, sizeof(q) - 5, 13), hashlittle(p, sizeof(q) - 6, 13),
@ -900,7 +1040,8 @@ void driver3()
hashlittle(p, sizeof(q) - 9, 13), hashlittle(p, sizeof(q) - 10, 13),
hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13));
p = &qqq[2];
printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
printf(
"%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
hashlittle(p, sizeof(q) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 13),
hashlittle(p, sizeof(q) - 5, 13), hashlittle(p, sizeof(q) - 6, 13),
@ -908,7 +1049,8 @@ void driver3()
hashlittle(p, sizeof(q) - 9, 13), hashlittle(p, sizeof(q) - 10, 13),
hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13));
p = &qqqq[3];
printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
printf(
"%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n",
hashlittle(p, sizeof(q) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 13),
hashlittle(p, sizeof(q) - 5, 13), hashlittle(p, sizeof(q) - 6, 13),
@ -918,7 +1060,8 @@ void driver3()
printf("\n");
/* check that hashlittle2 and hashlittle produce the same results */
i=47; j=0;
i = 47;
j = 0;
hashlittle2(q, sizeof(q), &i, &j);
if (hashlittle(q, sizeof(q), 47) != i)
printf("hashlittle2 and hashlittle mismatch\n");
@ -928,16 +1071,15 @@ void driver3()
i = 47, j = 0;
hashword2(&len, 1, &i, &j);
if (hashword(&len, 1, 47) != i)
printf("hashword2 and hashword mismatch %x %x\n",
i, hashword(&len, 1, 47));
printf("hashword2 and hashword mismatch %x %x\n", i,
hashword(&len, 1, 47));
/* check hashlittle doesn't read before or after the ends of the string */
for (h=0, b=buf+1; h<8; ++h, ++b)
{
for (i=0; i<MAXLEN; ++i)
{
for (h = 0, b = buf + 1; h < 8; ++h, ++b) {
for (i = 0; i < MAXLEN; ++i) {
len = i;
for (j=0; j<i; ++j) *(b+j)=0;
for (j = 0; j < i; ++j)
*(b + j) = 0;
/* these should all be equal */
ref = hashlittle(b, len, (uint32_t)1);
@ -945,8 +1087,7 @@ void driver3()
*(b - 1) = (uint8_t)~0;
x = hashlittle(b, len, (uint32_t)1);
y = hashlittle(b, len, (uint32_t)1);
if ((ref != x) || (ref != y))
{
if ((ref != x) || (ref != y)) {
printf("alignment error: %.8x %.8x %.8x %d %d\n", ref, x, y,
h, i);
}
@ -960,18 +1101,16 @@ void driver3()
uint8_t buf[1];
uint32_t h, i, state[HASHSTATE];
buf[0] = ~0;
for (i=0; i<HASHSTATE; ++i) state[i] = 1;
for (i = 0; i < HASHSTATE; ++i)
state[i] = 1;
printf("These should all be different\n");
for (i=0, h=0; i<8; ++i)
{
for (i = 0, h = 0; i < 8; ++i) {
h = hashlittle(buf, 0, h);
printf("%2ld 0-byte strings, hash is %.8x\n", i, h);
}
}
int main()
{
driver1(); /* test that the key is hashed: used for timings */

40
llt/mt19937ar.c
View File

@ -26,8 +26,8 @@
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
@ -58,8 +58,7 @@ void init_genrand(uint32_t s)
{
mt[0] = s & 0xffffffffU;
for (mti = 1; mti < mtN; mti++) {
mt[mti] =
(1812433253U * (mt[mti-1] ^ (mt[mti-1] >> 30)) + mti);
mt[mti] = (1812433253U * (mt[mti - 1] ^ (mt[mti - 1] >> 30)) + mti);
/* See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. */
/* In the previous versions, MSBs of the seed affect */
/* only MSBs of the array mt[]. */
@ -77,22 +76,31 @@ void init_by_array(uint32_t init_key[], int key_length)
{
int i, j, k;
init_genrand(19650218U);
i=1; j=0;
i = 1;
j = 0;
k = (mtN > key_length ? mtN : key_length);
for (; k; k--) {
mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1664525U))
+ init_key[j] + j; /* non linear */
mt[i] &= 0xffffffffU; /* for WORDSIZE > 32 machines */
i++; j++;
if (i>=mtN) { mt[0] = mt[mtN-1]; i=1; }
if (j>=key_length) j=0;
}
for (k=mtN-1; k; k--) {
mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1566083941U))
- i; /* non linear */
mt[i] = (mt[i] ^ ((mt[i - 1] ^ (mt[i - 1] >> 30)) * 1664525U)) +
init_key[j] + j; /* non linear */
mt[i] &= 0xffffffffU; /* for WORDSIZE > 32 machines */
i++;
if (i>=mtN) { mt[0] = mt[mtN-1]; i=1; }
j++;
if (i >= mtN) {
mt[0] = mt[mtN - 1];
i = 1;
}
if (j >= key_length)
j = 0;
}
for (k = mtN - 1; k; k--) {
mt[i] = (mt[i] ^ ((mt[i - 1] ^ (mt[i - 1] >> 30)) * 1566083941U)) -
i; /* non linear */
mt[i] &= 0xffffffffU; /* for WORDSIZE > 32 machines */
i++;
if (i >= mtN) {
mt[0] = mt[mtN - 1];
i = 1;
}
}
mt[0] = 0x80000000U; /* MSB is 1; assuring non-zero initial array */

17
llt/socket.c
View File

@ -15,7 +15,6 @@
#include "socket.h"
int mysocket(int domain, int type, int protocol)
{
int val;
@ -41,10 +40,7 @@ void set_nonblock(int socket, int yes)
}
#ifdef WIN32
void bzero(void *s, size_t n)
{
memset(s, 0, n);
}
void bzero(void *s, size_t n) { memset(s, 0, n); }
#endif
/* returns a socket on which to accept() connections */
@ -83,7 +79,8 @@ int open_any_tcp_port(short *portno)
serv_addr.sin_family = AF_INET;
serv_addr.sin_addr.s_addr = htonl(INADDR_ANY);
serv_addr.sin_port = htons(*portno);
while (bind(sockfd, (struct sockaddr*)&serv_addr, sizeof(serv_addr)) < 0) {
while (bind(sockfd, (struct sockaddr *)&serv_addr, sizeof(serv_addr)) <
0) {
(*portno)++;
serv_addr.sin_port = htons(*portno);
}
@ -106,7 +103,8 @@ int open_any_udp_port(short *portno)
serv_addr.sin_family = AF_INET;
serv_addr.sin_addr.s_addr = htonl(INADDR_ANY);
serv_addr.sin_port = htons(*portno);
while (bind(sockfd, (struct sockaddr*)&serv_addr, sizeof(serv_addr)) < 0) {
while (bind(sockfd, (struct sockaddr *)&serv_addr, sizeof(serv_addr)) <
0) {
(*portno)++;
serv_addr.sin_port = htons(*portno);
}
@ -115,10 +113,7 @@ int open_any_udp_port(short *portno)
}
#ifndef WIN32
void closesocket(int fd)
{
close(fd);
}
void closesocket(int fd) { close(fd); }
#endif
/* returns a socket to use to send data to the given address */

17
llt/timefuncs.c
View File

@ -89,16 +89,20 @@ void timestring(double seconds, char *buffer, size_t len)
localtime_r(&tme, &tm);
strftime(buffer, len, fmt, &tm);
#else
static char *wdaystr[] = {"Sun","Mon","Tue","Wed","Thu","Fri","Sat"};
static char *monthstr[] = {"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug",
"Sep","Oct","Nov","Dec"};
static char *wdaystr[] = {
"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"
};
static char *monthstr[] = { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
struct tm *tm;
int hr;
tm = localtime(&tme);
hr = tm->tm_hour;
if (hr > 12) hr -= 12;
if (hr == 0) hr = 12;
if (hr > 12)
hr -= 12;
if (hr == 0)
hr = 12;
snprintf(buffer, len, "%s %02d %s %d %02d:%02d:%02d %s %s",
wdaystr[tm->tm_wday], tm->tm_mday, monthstr[tm->tm_mon],
tm->tm_year + 1900, hr, tm->tm_min, tm->tm_sec,
@ -117,7 +121,8 @@ double parsetime(const char *str)
res = strptime(str, fmt, &tm);
if (res != NULL) {
tm.tm_isdst = -1; /* Not set by strptime(); tells mktime() to determine
tm.tm_isdst =
-1; /* Not set by strptime(); tells mktime() to determine
whether daylight saving time is in effect */
t = mktime(&tm);
if (t == ((time_t)-1))

181
llt/utf8.c
View File

@ -34,20 +34,22 @@
#include "utf8.h"
static const u_int32_t offsetsFromUTF8[6] = {
0x00000000UL, 0x00003080UL, 0x000E2080UL,
0x03C82080UL, 0xFA082080UL, 0x82082080UL
};
static const u_int32_t offsetsFromUTF8[6] = { 0x00000000UL, 0x00003080UL,
0x000E2080UL, 0x03C82080UL,
0xFA082080UL, 0x82082080UL };
static const char trailingBytesForUTF8[256] = {
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5
};
/* returns length of next utf-8 sequence */
@ -102,7 +104,8 @@ size_t u8_toucs(u_int32_t *dest, size_t sz, const char *src, size_t srcsz)
if (!isutf(*src)) { // invalid sequence
dest[i++] = 0xFFFD;
src++;
if (src >= src_end) break;
if (src >= src_end)
break;
continue;
}
nb = trailingBytesForUTF8[(unsigned char)*src];
@ -111,12 +114,23 @@ size_t u8_toucs(u_int32_t *dest, size_t sz, const char *src, size_t srcsz)
ch = 0;
switch (nb) {
/* these fall through deliberately */
case 5: ch += (unsigned char)*src++; ch <<= 6;
case 4: ch += (unsigned char)*src++; ch <<= 6;
case 3: ch += (unsigned char)*src++; ch <<= 6;
case 2: ch += (unsigned char)*src++; ch <<= 6;
case 1: ch += (unsigned char)*src++; ch <<= 6;
case 0: ch += (unsigned char)*src++;
case 5:
ch += (unsigned char)*src++;
ch <<= 6;
case 4:
ch += (unsigned char)*src++;
ch <<= 6;
case 3:
ch += (unsigned char)*src++;
ch <<= 6;
case 2:
ch += (unsigned char)*src++;
ch <<= 6;
case 1:
ch += (unsigned char)*src++;
ch <<= 6;
case 0:
ch += (unsigned char)*src++;
}
ch -= offsetsFromUTF8[nb];
dest[i++] = ch;
@ -143,21 +157,18 @@ size_t u8_toutf8(char *dest, size_t sz, const u_int32_t *src, size_t srcsz)
if (dest >= dest_end)
break;
*dest++ = (char)ch;
}
else if (ch < 0x800) {
} else if (ch < 0x800) {
if (dest >= dest_end - 1)
break;
*dest++ = (ch >> 6) | 0xC0;
*dest++ = (ch & 0x3F) | 0x80;
}
else if (ch < 0x10000) {
} else if (ch < 0x10000) {
if (dest >= dest_end - 2)
break;
*dest++ = (ch >> 12) | 0xE0;
*dest++ = ((ch >> 6) & 0x3F) | 0x80;
*dest++ = (ch & 0x3F) | 0x80;
}
else if (ch < 0x110000) {
} else if (ch < 0x110000) {
if (dest >= dest_end - 3)
break;
*dest++ = (ch >> 18) | 0xF0;
@ -236,7 +247,8 @@ size_t u8_strlen(const char *s)
while (s[i] > 0)
i++;
count += (i - lasti);
if (s[i++]==0) break;
if (s[i++] == 0)
break;
(void)(isutf(s[++i]) || isutf(s[++i]) || ++i);
count++;
}
@ -257,24 +269,40 @@ size_t u8_strwidth(const char *s)
while ((sc = (signed char)*s) != 0) {
if (sc >= 0) {
s++;
if (sc) tot++;
if (sc)
tot++;
} else {
if (!isutf(sc)) {
tot++;
s++;
continue;
}
else {
if (!isutf(sc)) { tot++; s++; continue; }
nb = trailingBytesForUTF8[(unsigned char)sc];
ch = 0;
switch (nb) {
/* these fall through deliberately */
case 5: ch += (unsigned char)*s++; ch <<= 6;
case 4: ch += (unsigned char)*s++; ch <<= 6;
case 3: ch += (unsigned char)*s++; ch <<= 6;
case 2: ch += (unsigned char)*s++; ch <<= 6;
case 1: ch += (unsigned char)*s++; ch <<= 6;
case 0: ch += (unsigned char)*s++;
case 5:
ch += (unsigned char)*s++;
ch <<= 6;
case 4:
ch += (unsigned char)*s++;
ch <<= 6;
case 3:
ch += (unsigned char)*s++;
ch <<= 6;
case 2:
ch += (unsigned char)*s++;
ch <<= 6;
case 1:
ch += (unsigned char)*s++;
ch <<= 6;
case 0:
ch += (unsigned char)*s++;
}
ch -= offsetsFromUTF8[nb];
w = wcwidth(ch); // might return -1
if (w > 0) tot += w;
if (w > 0)
tot += w;
}
}
return tot;
@ -314,23 +342,21 @@ u_int32_t u8_nextmemchar(const char *s, size_t *i)
void u8_inc(const char *s, size_t *i)
{
(void)(isutf(s[++(*i)]) || isutf(s[++(*i)]) || isutf(s[++(*i)]) || ++(*i));
(void)(isutf(s[++(*i)]) || isutf(s[++(*i)]) || isutf(s[++(*i)]) ||
++(*i));
}
void u8_dec(const char *s, size_t *i)
{
(void)(isutf(s[--(*i)]) || isutf(s[--(*i)]) || isutf(s[--(*i)]) || --(*i));
(void)(isutf(s[--(*i)]) || isutf(s[--(*i)]) || isutf(s[--(*i)]) ||
--(*i));
}
int octal_digit(char c)
{
return (c >= '0' && c <= '7');
}
int octal_digit(char c) { return (c >= '0' && c <= '7'); }
int hex_digit(char c)
{
return ((c >= '0' && c <= '9') ||
(c >= 'A' && c <= 'F') ||
return ((c >= '0' && c <= '9') || (c >= 'A' && c <= 'F') ||
(c >= 'a' && c <= 'f'));
}
@ -373,18 +399,16 @@ size_t u8_read_escape_sequence(const char *str, size_t ssz, u_int32_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)) ||
} else if ((c0 == 'x' && (ndig = 2)) || (c0 == 'u' && (ndig = 4)) ||
(c0 == 'U' && (ndig = 8))) {
while (i < ssz && hex_digit(str[i]) && dno < ndig) {
digs[dno++] = str[i++];
}
if (dno == 0) return 0;
if (dno == 0)
return 0;
digs[dno] = '\0';
ch = strtol(digs, NULL, 16);
}
else {
} else {
ch = (u_int32_t)read_escape_control_char(c0);
}
*dest = ch;
@ -405,8 +429,7 @@ size_t u8_unescape(char *buf, size_t sz, const char *src)
if (*src == '\\') {
src++;
amt = u8_read_escape_sequence(src, 1000, &ch);
}
else {
} else {
ch = (u_int32_t)*src;
amt = 1;
}
@ -463,8 +486,8 @@ int u8_escape_wchar(char *buf, size_t sz, u_int32_t ch)
return 1;
}
size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end,
int escape_quotes, int ascii)
size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi,
size_t end, int escape_quotes, int ascii)
{
size_t i = *pi, i0;
u_int32_t ch;
@ -477,18 +500,15 @@ size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end,
if (escape_quotes && src[i] == '"') {
buf += buf_put2c(buf, "\\\"");
i++;
}
else if (src[i] == '\\') {
} else if (src[i] == '\\') {
buf += buf_put2c(buf, "\\\\");
i++;
}
else {
} else {
i0 = i;
ch = u8_nextmemchar(src, &i);
if (ascii || !iswprint((wint_t)ch)) {
buf += u8_escape_wchar(buf, sz - (buf - start), ch);
}
else {
} else {
i = i0;
do {
*buf++ = src[i++];
@ -549,9 +569,11 @@ char *u8_memrchr(const char *s, u_int32_t ch, size_t sz)
size_t i = sz - 1, tempi = 0;
u_int32_t c;
if (sz == 0) return NULL;
if (sz == 0)
return NULL;
while (i && !isutf(s[i])) i--;
while (i && !isutf(s[i]))
i--;
while (1) {
tempi = i;
@ -571,7 +593,8 @@ char *u8_memrchr(const char *s, u_int32_t ch, size_t sz)
int u8_is_locale_utf8(const char *locale)
{
if (locale == NULL) return 0;
if (locale == NULL)
return 0;
/* this code based on libutf8 */
const char *cp = locale;
@ -579,10 +602,11 @@ int u8_is_locale_utf8(const char *locale)
for (; *cp != '\0' && *cp != '@' && *cp != '+' && *cp != ','; cp++) {
if (*cp == '.') {
const char *encoding = ++cp;
for (; *cp != '\0' && *cp != '@' && *cp != '+' && *cp != ','; cp++)
for (; *cp != '\0' && *cp != '@' && *cp != '+' && *cp != ',';
cp++)
;
if ((cp-encoding == 5 && !strncmp(encoding, "UTF-8", 5))
|| (cp-encoding == 4 && !strncmp(encoding, "utf8", 4)))
if ((cp - encoding == 5 && !strncmp(encoding, "UTF-8", 5)) ||
(cp - encoding == 4 && !strncmp(encoding, "utf8", 4)))
return 1; /* it's UTF-8 */
break;
}
@ -610,7 +634,8 @@ size_t u8_vprintf(const char *fmt, va_list ap)
nc = u8_toucs(wcs, cnt + 1, buf, cnt);
wcs[nc] = 0;
printf("%ls", (wchar_t *)wcs);
if (needfree) free(buf);
if (needfree)
free(buf);
return nc;
}
@ -657,35 +682,40 @@ int u8_isvalid(const char *str, int length)
switch (ab) {
/* Check for xx00 000x */
case 1:
if ((c & 0x3e) == 0) return 0;
if ((c & 0x3e) == 0)
return 0;
continue; /* We know there aren't any more bytes to check */
/* Check for 1110 0000, xx0x xxxx */
case 2:
if (c == 0xe0 && (*p & 0x20) == 0) return 0;
if (c == 0xe0 && (*p & 0x20) == 0)
return 0;
break;
/* Check for 1111 0000, xx00 xxxx */
case 3:
if (c == 0xf0 && (*p & 0x30) == 0) return 0;
if (c == 0xf0 && (*p & 0x30) == 0)
return 0;
break;
/* Check for 1111 1000, xx00 0xxx */
case 4:
if (c == 0xf8 && (*p & 0x38) == 0) return 0;
if (c == 0xf8 && (*p & 0x38) == 0)
return 0;
break;
/* Check for leading 0xfe or 0xff,
and then for 1111 1100, xx00 00xx */
case 5:
if (c == 0xfe || c == 0xff ||
(c == 0xfc && (*p & 0x3c) == 0)) return 0;
if (c == 0xfe || c == 0xff || (c == 0xfc && (*p & 0x3c) == 0))
return 0;
break;
}
/* Check for valid bytes after the 2nd, if any; all must start 10 */
while (--ab > 0) {
if ((*(++p) & 0xc0) != 0x80) return 0;
if ((*(++p) & 0xc0) != 0x80)
return 0;
}
}
@ -704,8 +734,7 @@ int u8_reverse(char *dest, char * src, size_t len)
di--;
dest[di] = c;
si++;
}
else {
} else {
switch (c >> 4) {
case 0xC:
case 0xD:

4
llt/utf8.h
View File

@ -91,8 +91,8 @@ size_t u8_unescape(char *buf, size_t sz, const char *src);
returns number of bytes placed in buf, including a NUL terminator.
*/
size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi, size_t end,
int escape_quotes, int ascii);
size_t u8_escape(char *buf, size_t sz, const char *src, size_t *pi,
size_t end, int escape_quotes, int ascii);
/* utility predicates used by the above */
int octal_digit(char c);

35
llt/utils.h
View File

@ -1,7 +1,6 @@
#ifndef __UTILS_H_
#define __UTILS_H_
#if defined(__amd64__) || defined(_M_AMD64)
#define ARCH_X86_64
#define __CPU__ 686
@ -27,7 +26,6 @@
#error "unknown architecture"
#endif
char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base);
int str2int(char *str, size_t len, int64_t *res, uint32_t base);
int isdigit_base(char c, int base);
@ -41,9 +39,7 @@ int isdigit_base(char c, int base);
#if !defined(__INTEL_COMPILER) && (defined(ARCH_X86) || defined(ARCH_X86_64))
STATIC_INLINE u_int16_t ByteSwap16(u_int16_t x)
{
__asm("xchgb %b0,%h0" :
LEGACY_REGS (x) :
"0" (x));
__asm("xchgb %b0,%h0" : LEGACY_REGS(x) : "0"(x));
return x;
}
#define bswap_16(x) ByteSwap16(x)
@ -51,13 +47,15 @@ STATIC_INLINE u_int16_t ByteSwap16(u_int16_t x)
STATIC_INLINE u_int32_t ByteSwap32(u_int32_t x)
{
#if __CPU__ > 386
__asm("bswap %0":
"=r" (x) :
__asm("bswap %0"
: "=r"(x)
:
#else
__asm("xchgb %b0,%h0\n"\
__asm("xchgb %b0,%h0\n"
" rorl $16,%0\n"
" xchgb %b0,%h0":
LEGACY_REGS (x) :
" xchgb %b0,%h0"
: LEGACY_REGS(x)
:
#endif
"0"(x));
return x;
@ -68,16 +66,17 @@ STATIC_INLINE u_int32_t ByteSwap32(u_int32_t x)
STATIC_INLINE u_int64_t ByteSwap64(u_int64_t x)
{
#ifdef ARCH_X86_64
__asm("bswap %0":
"=r" (x) :
"0" (x));
__asm("bswap %0" : "=r"(x) : "0"(x));
return x;
#else
register union { __extension__ u_int64_t __ll;
u_int32_t __l[2]; } __x;
asm("xchgl %0,%1":
"=r"(__x.__l[0]),"=r"(__x.__l[1]):
"0"(bswap_32((unsigned long)x)),"1"(bswap_32((unsigned long)(x>>32))));
register union {
__extension__ u_int64_t __ll;
u_int32_t __l[2];
} __x;
asm("xchgl %0,%1"
: "=r"(__x.__l[0]), "=r"(__x.__l[1])
: "0"(bswap_32((unsigned long)x)),
"1"(bswap_32((unsigned long)(x >> 32))));
return __x.__ll;
#endif
}

13
llt/wcwidth.c
View File

@ -70,7 +70,8 @@ struct interval {
};
/* auxiliary function for binary search in interval table */
static int bisearch(uint32_t ucs, const struct interval *table, int max) {
static int bisearch(uint32_t ucs, const struct interval *table, int max)
{
int min = 0;
int mid;
@ -89,7 +90,6 @@ static int bisearch(uint32_t ucs, const struct interval *table, int max) {
return 0;
}
/* The following two functions define the column width of an ISO 10646
* character as follows:
*
@ -128,7 +128,8 @@ static int bisearch(uint32_t ucs, const struct interval *table, int max) {
DLLEXPORT int wcwidth(uint32_t ucs)
{
/* sorted list of non-overlapping intervals of non-spacing characters */
/* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */
/* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c"
*/
static const struct interval combining[] = {
{ 0x0300, 0x036F }, { 0x0483, 0x0486 }, { 0x0488, 0x0489 },
{ 0x0591, 0x05BD }, { 0x05BF, 0x05BF }, { 0x05C1, 0x05C2 },
@ -200,7 +201,8 @@ DLLEXPORT int wcwidth(uint32_t ucs)
(ucs >= 0x2e80 && ucs <= 0xa4cf &&
ucs != 0x303f) || /* CJK ... Yi */
(ucs >= 0xac00 && ucs <= 0xd7a3) || /* Hangul Syllables */
(ucs >= 0xf900 && ucs <= 0xfaff) || /* CJK Compatibility Ideographs */
(ucs >= 0xf900 &&
ucs <= 0xfaff) || /* CJK Compatibility Ideographs */
(ucs >= 0xfe10 && ucs <= 0xfe19) || /* Vertical forms */
(ucs >= 0xfe30 && ucs <= 0xfe6f) || /* CJK Compatibility Forms */
(ucs >= 0xff00 && ucs <= 0xff60) || /* Fullwidth Forms */
@ -209,7 +211,6 @@ DLLEXPORT int wcwidth(uint32_t ucs)
(ucs >= 0x30000 && ucs <= 0x3fffd)));
}
int wcswidth(const uint32_t *pwcs, size_t n)
{
int w, width = 0;
@ -223,7 +224,6 @@ int wcswidth(const uint32_t *pwcs, size_t n)
return width;
}
/*
* The following functions are the same as wcwidth() and
* wcswidth(), except that spacing characters in the East Asian
@ -300,7 +300,6 @@ int wcwidth_cjk(uint32_t ucs)
return wcwidth(ucs);
}
int wcswidth_cjk(const uint32_t *pwcs, size_t n)
{
int w, width = 0;

26
opaque_type_template.c
View File

@ -12,21 +12,13 @@
static value_t TYPEsym;
static fltype_t *TYPEtype;
void print_TYPE(value_t v, ios_t *f, int princ)
{
}
void print_TYPE(value_t v, ios_t *f, int princ) {}
void print_traverse_TYPE(value_t self)
{
}
void print_traverse_TYPE(value_t self) {}
void free_TYPE(value_t self)
{
}
void free_TYPE(value_t self) {}
void relocate_TYPE(value_t oldv, value_t newv)
{
}
void relocate_TYPE(value_t oldv, value_t newv) {}
cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE,
print_traverse_TYPE };
@ -49,15 +41,13 @@ static TYPE_t *toTYPE(value_t v, char *fname)
return (TYPE_t *)cv_data((cvalue_t *)ptr(v));
}
static builtinspec_t TYPEfunc_info[] = {
{ "TYPE?", fl_TYPEp },
{ NULL, NULL }
};
static builtinspec_t TYPEfunc_info[] = { { "TYPE?", fl_TYPEp },
{ NULL, NULL } };
void TYPE_init()
{
TYPEsym = symbol("TYPE");
TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t),
&TYPE_vtable, NULL);
TYPEtype =
define_opaque_type(TYPEsym, sizeof(TYPE_t), &TYPE_vtable, NULL);
assign_global_builtins(TYPEfunc_info);
}

176
opcodes.h
View File

@ -2,34 +2,109 @@
#define OPCODES_H
enum {
OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT,
OP_JMPL, OP_BRFL, OP_BRTL, OP_RET,
OP_NOP = 0,
OP_DUP,
OP_POP,
OP_CALL,
OP_TCALL,
OP_JMP,
OP_BRF,
OP_BRT,
OP_JMPL,
OP_BRFL,
OP_BRTL,
OP_RET,
OP_EQ, OP_EQV, OP_EQUAL, OP_ATOMP, OP_NOT, OP_NULLP, OP_BOOLEANP,
OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP,
OP_FIXNUMP, OP_FUNCTIONP,
OP_EQ,
OP_EQV,
OP_EQUAL,
OP_ATOMP,
OP_NOT,
OP_NULLP,
OP_BOOLEANP,
OP_SYMBOLP,
OP_NUMBERP,
OP_BOUNDP,
OP_PAIRP,
OP_BUILTINP,
OP_VECTORP,
OP_FIXNUMP,
OP_FUNCTIONP,
OP_CONS, OP_LIST, OP_CAR, OP_CDR, OP_SETCAR, OP_SETCDR,
OP_CONS,
OP_LIST,
OP_CAR,
OP_CDR,
OP_SETCAR,
OP_SETCDR,
OP_APPLY,
OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_IDIV, OP_NUMEQ, OP_LT, OP_COMPARE,
OP_ADD,
OP_SUB,
OP_MUL,
OP_DIV,
OP_IDIV,
OP_NUMEQ,
OP_LT,
OP_COMPARE,
OP_VECTOR, OP_AREF, OP_ASET,
OP_VECTOR,
OP_AREF,
OP_ASET,
OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADI8,
OP_LOADV, OP_LOADVL,
OP_LOADG, OP_LOADGL,
OP_LOADA, OP_LOADAL, OP_LOADC, OP_LOADCL,
OP_SETG, OP_SETGL,
OP_SETA, OP_SETAL, OP_SETC, OP_SETCL,
OP_LOADT,
OP_LOADF,
OP_LOADNIL,
OP_LOAD0,
OP_LOAD1,
OP_LOADI8,
OP_LOADV,
OP_LOADVL,
OP_LOADG,
OP_LOADGL,
OP_LOADA,
OP_LOADAL,
OP_LOADC,
OP_LOADCL,
OP_SETG,
OP_SETGL,
OP_SETA,
OP_SETAL,
OP_SETC,
OP_SETCL,
OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_FOR,
OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
OP_CLOSURE,
OP_ARGC,
OP_VARGC,
OP_TRYCATCH,
OP_FOR,
OP_TAPPLY,
OP_ADD2,
OP_SUB2,
OP_NEG,
OP_LARGC,
OP_LVARGC,
OP_LOADA0,
OP_LOADA1,
OP_LOADC00,
OP_LOADC01,
OP_CALLL,
OP_TCALLL,
OP_BRNE,
OP_BRNEL,
OP_CADR,
OP_BRNN,
OP_BRNNL,
OP_BRN,
OP_BRNL,
OP_OPTARGS,
OP_BRBOUND,
OP_KEYARGS,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_EOF_OBJECT,
OP_BOOL_CONST_T,
OP_BOOL_CONST_F,
OP_THE_EMPTY_LIST,
OP_EOF_OBJECT,
N_OPCODES
};
@ -37,59 +112,54 @@ enum {
#ifdef USE_COMPUTED_GOTO
#define VM_LABELS \
static void *vm_labels[] = { \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
&&L_OP_BRF, &&L_OP_BRT, \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, \
&&L_OP_TCALL, &&L_OP_JMP, &&L_OP_BRF, &&L_OP_BRT, \
&&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\
&&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
&&L_OP_NULLP, &&L_OP_BOOLEANP, \
&&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
&&L_OP_BUILTINP, &&L_OP_VECTORP, \
&&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
&&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, \
&&L_OP_NOT, &&L_OP_NULLP, &&L_OP_BOOLEANP, &&L_OP_SYMBOLP, \
&&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, &&L_OP_BUILTINP, \
&&L_OP_VECTORP, &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
\
&&L_OP_CONS, &&L_OP_LIST, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
&&L_OP_SETCDR, &&L_OP_APPLY, \
&&L_OP_CONS, &&L_OP_LIST, &&L_OP_CAR, &&L_OP_CDR, \
&&L_OP_SETCAR, &&L_OP_SETCDR, &&L_OP_APPLY, \
\
&&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_IDIV, &&L_OP_NUMEQ, \
&&L_OP_LT, &&L_OP_COMPARE, \
&&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, \
&&L_OP_IDIV, &&L_OP_NUMEQ, &&L_OP_LT, &&L_OP_COMPARE, \
\
&&L_OP_VECTOR, &&L_OP_AREF, &&L_OP_ASET, \
\
&&L_OP_LOADT, &&L_OP_LOADF, &&L_OP_LOADNIL, &&L_OP_LOAD0, &&L_OP_LOAD1, \
&&L_OP_LOADI8, \
&&L_OP_LOADV, &&L_OP_LOADVL, \
&&L_OP_LOADG, &&L_OP_LOADGL, \
&&L_OP_LOADA, &&L_OP_LOADAL, &&L_OP_LOADC, &&L_OP_LOADCL, \
&&L_OP_SETG, &&L_OP_SETGL, \
&&L_OP_LOADT, &&L_OP_LOADF, &&L_OP_LOADNIL, &&L_OP_LOAD0, \
&&L_OP_LOAD1, &&L_OP_LOADI8, &&L_OP_LOADV, &&L_OP_LOADVL, \
&&L_OP_LOADG, &&L_OP_LOADGL, &&L_OP_LOADA, &&L_OP_LOADAL, \
&&L_OP_LOADC, &&L_OP_LOADCL, &&L_OP_SETG, &&L_OP_SETGL, \
&&L_OP_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \
\
&&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \
&&L_OP_FOR, \
&&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \
&&L_OP_LVARGC, \
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \
&&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
&&L_OP_FOR, &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, \
&&L_OP_NEG, &&L_OP_LARGC, &&L_OP_LVARGC, &&L_OP_LOADA0, \
&&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, &&L_OP_CALLL, \
&&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR, \
&&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \
&&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \
}
#define VM_APPLY_LABELS \
static void *vm_apply_labels[] = { \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
&&L_OP_BRF, &&L_OP_BRT, \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, \
&&L_OP_TCALL, &&L_OP_JMP, &&L_OP_BRF, &&L_OP_BRT, \
&&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
\
&&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
&&L_OP_NULLP, &&L_OP_BOOLEANP, \
&&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
&&L_OP_BUILTINP, &&L_OP_VECTORP, \
&&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
&&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, \
&&L_OP_NOT, &&L_OP_NULLP, &&L_OP_BOOLEANP, &&L_OP_SYMBOLP, \
&&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, &&L_OP_BUILTINP, \
&&L_OP_VECTORP, &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
\
&&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
&&L_OP_SETCDR, &&apply_apply, \
&&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, \
&&L_OP_SETCAR, &&L_OP_SETCDR, &&apply_apply, \
\
&&apply_add, &&apply_sub, &&apply_mul, &&apply_div, &&L_OP_IDIV, &&L_OP_NUMEQ, \
&&L_OP_LT, &&L_OP_COMPARE, \
&&apply_add, &&apply_sub, &&apply_mul, &&apply_div, \
&&L_OP_IDIV, &&L_OP_NUMEQ, &&L_OP_LT, &&L_OP_COMPARE, \
\
&&apply_vector, &&L_OP_AREF, &&L_OP_ASET \
}

267
operators.c
View File

@ -6,10 +6,7 @@
extern double trunc(double x);
STATIC_INLINE double fpart(double arg)
{
return arg - trunc(arg);
}
STATIC_INLINE double fpart(double arg) { return arg - trunc(arg); }
// given a number, determine an appropriate type for storing it
#if 0
@ -49,11 +46,9 @@ numerictype_t effective_numerictype(double r)
fp = fpart(r);
if (fp != 0 || r > U64_MAX || r < S64_MIN) {
return T_DOUBLE;
}
else if (r >= INT_MIN && r <= INT_MAX) {
} else if (r >= INT_MIN && r <= INT_MAX) {
return T_INT32;
}
else if (r <= S64_MAX) {
} else if (r <= S64_MAX) {
return T_INT64;
}
return T_UINT64;
@ -64,20 +59,37 @@ double conv_to_double(void *data, numerictype_t tag)
{
double d = 0;
switch (tag) {
case T_INT8: d = (double)*(int8_t*)data; break;
case T_UINT8: d = (double)*(uint8_t*)data; break;
case T_INT16: d = (double)*(int16_t*)data; break;
case T_UINT16: d = (double)*(uint16_t*)data; break;
case T_INT32: d = (double)*(int32_t*)data; break;
case T_UINT32: d = (double)*(uint32_t*)data; break;
case T_INT8:
d = (double)*(int8_t *)data;
break;
case T_UINT8:
d = (double)*(uint8_t *)data;
break;
case T_INT16:
d = (double)*(int16_t *)data;
break;
case T_UINT16:
d = (double)*(uint16_t *)data;
break;
case T_INT32:
d = (double)*(int32_t *)data;
break;
case T_UINT32:
d = (double)*(uint32_t *)data;
break;
case T_INT64:
d = (double)*(int64_t *)data;
if (d > 0 && *(int64_t *)data < 0) // can happen!
d = -d;
break;
case T_UINT64: d = (double)*(uint64_t*)data; break;
case T_FLOAT: d = (double)*(float*)data; break;
case T_DOUBLE: return *(double*)data;
case T_UINT64:
d = (double)*(uint64_t *)data;
break;
case T_FLOAT:
d = (double)*(float *)data;
break;
case T_DOUBLE:
return *(double *)data;
}
return d;
}
@ -85,20 +97,38 @@ double conv_to_double(void *data, numerictype_t tag)
void conv_from_double(void *dest, double d, numerictype_t tag)
{
switch (tag) {
case T_INT8: *(int8_t*)dest = d; break;
case T_UINT8: *(uint8_t*)dest = d; break;
case T_INT16: *(int16_t*)dest = d; break;
case T_UINT16: *(uint16_t*)dest = d; break;
case T_INT32: *(int32_t*)dest = d; break;
case T_UINT32: *(uint32_t*)dest = d; break;
case T_INT8:
*(int8_t *)dest = d;
break;
case T_UINT8:
*(uint8_t *)dest = d;
break;
case T_INT16:
*(int16_t *)dest = d;
break;
case T_UINT16:
*(uint16_t *)dest = d;
break;
case T_INT32:
*(int32_t *)dest = d;
break;
case T_UINT32:
*(uint32_t *)dest = d;
break;
case T_INT64:
*(int64_t *)dest = d;
if (d > 0 && *(int64_t *)dest < 0) // 0x8000000000000000 is a bitch
*(int64_t *)dest = S64_MAX;
break;
case T_UINT64: *(uint64_t*)dest = (int64_t)d; break;
case T_FLOAT: *(float*)dest = d; break;
case T_DOUBLE: *(double*)dest = d; break;
case T_UINT64:
*(uint64_t *)dest = (int64_t)d;
break;
case T_FLOAT:
*(float *)dest = d;
break;
case T_DOUBLE:
*(double *)dest = d;
break;
}
}
@ -107,16 +137,36 @@ type##_t conv_to_##type(void *data, numerictype_t tag) \
{ \
type##_t i = 0; \
switch (tag) { \
case T_INT8: i = (type##_t)*(int8_t*)data; break; \
case T_UINT8: i = (type##_t)*(uint8_t*)data; break; \
case T_INT16: i = (type##_t)*(int16_t*)data; break; \
case T_UINT16: i = (type##_t)*(uint16_t*)data; break; \
case T_INT32: i = (type##_t)*(int32_t*)data; break; \
case T_UINT32: i = (type##_t)*(uint32_t*)data; break; \
case T_INT64: i = (type##_t)*(int64_t*)data; break; \
case T_UINT64: i = (type##_t)*(uint64_t*)data; break; \
case T_FLOAT: i = (type##_t)*(float*)data; break; \
case T_DOUBLE: i = (type##_t)*(double*)data; break; \
case T_INT8: \
i = (type##_t) * (int8_t *)data; \
break; \
case T_UINT8: \
i = (type##_t) * (uint8_t *)data; \
break; \
case T_INT16: \
i = (type##_t) * (int16_t *)data; \
break; \
case T_UINT16: \
i = (type##_t) * (uint16_t *)data; \
break; \
case T_INT32: \
i = (type##_t) * (int32_t *)data; \
break; \
case T_UINT32: \
i = (type##_t) * (uint32_t *)data; \
break; \
case T_INT64: \
i = (type##_t) * (int64_t *)data; \
break; \
case T_UINT64: \
i = (type##_t) * (uint64_t *)data; \
break; \
case T_FLOAT: \
i = (type##_t) * (float *)data; \
break; \
case T_DOUBLE: \
i = (type##_t) * (double *)data; \
break; \
} \
return i; \
}
@ -132,14 +182,30 @@ uint64_t conv_to_uint64(void *data, numerictype_t tag)
{
uint64_t i = 0;
switch (tag) {
case T_INT8: i = (uint64_t)*(int8_t*)data; break;
case T_UINT8: i = (uint64_t)*(uint8_t*)data; break;
case T_INT16: i = (uint64_t)*(int16_t*)data; break;
case T_UINT16: i = (uint64_t)*(uint16_t*)data; break;
case T_INT32: i = (uint64_t)*(int32_t*)data; break;
case T_UINT32: i = (uint64_t)*(uint32_t*)data; break;
case T_INT64: i = (uint64_t)*(int64_t*)data; break;
case T_UINT64: i = (uint64_t)*(uint64_t*)data; break;
case T_INT8:
i = (uint64_t) * (int8_t *)data;
break;
case T_UINT8:
i = (uint64_t) * (uint8_t *)data;
break;
case T_INT16:
i = (uint64_t) * (int16_t *)data;
break;
case T_UINT16:
i = (uint64_t) * (uint16_t *)data;
break;
case T_INT32:
i = (uint64_t) * (int32_t *)data;
break;
case T_UINT32:
i = (uint64_t) * (uint32_t *)data;
break;
case T_INT64:
i = (uint64_t) * (int64_t *)data;
break;
case T_UINT64:
i = (uint64_t) * (uint64_t *)data;
break;
case T_FLOAT:
if (*(float *)data >= 0)
i = (uint64_t) * (float *)data;
@ -159,16 +225,26 @@ uint64_t conv_to_uint64(void *data, numerictype_t tag)
int cmp_same_lt(void *a, void *b, numerictype_t tag)
{
switch (tag) {
case T_INT8: return *(int8_t*)a < *(int8_t*)b;
case T_UINT8: return *(uint8_t*)a < *(uint8_t*)b;
case T_INT16: return *(int16_t*)a < *(int16_t*)b;
case T_UINT16: return *(uint16_t*)a < *(uint16_t*)b;
case T_INT32: return *(int32_t*)a < *(int32_t*)b;
case T_UINT32: return *(uint32_t*)a < *(uint32_t*)b;
case T_INT64: return *(int64_t*)a < *(int64_t*)b;
case T_UINT64: return *(uint64_t*)a < *(uint64_t*)b;
case T_FLOAT: return *(float*)a < *(float*)b;
case T_DOUBLE: return *(double*)a < *(double*)b;
case T_INT8:
return *(int8_t *)a < *(int8_t *)b;
case T_UINT8:
return *(uint8_t *)a < *(uint8_t *)b;
case T_INT16:
return *(int16_t *)a < *(int16_t *)b;
case T_UINT16:
return *(uint16_t *)a < *(uint16_t *)b;
case T_INT32:
return *(int32_t *)a < *(int32_t *)b;
case T_UINT32:
return *(uint32_t *)a < *(uint32_t *)b;
case T_INT64:
return *(int64_t *)a < *(int64_t *)b;
case T_UINT64:
return *(uint64_t *)a < *(uint64_t *)b;
case T_FLOAT:
return *(float *)a < *(float *)b;
case T_DOUBLE:
return *(double *)a < *(double *)b;
}
return 0;
}
@ -176,16 +252,26 @@ int cmp_same_lt(void *a, void *b, numerictype_t tag)
int cmp_same_eq(void *a, void *b, numerictype_t tag)
{
switch (tag) {
case T_INT8: return *(int8_t*)a == *(int8_t*)b;
case T_UINT8: return *(uint8_t*)a == *(uint8_t*)b;
case T_INT16: return *(int16_t*)a == *(int16_t*)b;
case T_UINT16: return *(uint16_t*)a == *(uint16_t*)b;
case T_INT32: return *(int32_t*)a == *(int32_t*)b;
case T_UINT32: return *(uint32_t*)a == *(uint32_t*)b;
case T_INT64: return *(int64_t*)a == *(int64_t*)b;
case T_UINT64: return *(uint64_t*)a == *(uint64_t*)b;
case T_FLOAT: return *(float*)a == *(float*)b;
case T_DOUBLE: return *(double*)a == *(double*)b;
case T_INT8:
return *(int8_t *)a == *(int8_t *)b;
case T_UINT8:
return *(uint8_t *)a == *(uint8_t *)b;
case T_INT16:
return *(int16_t *)a == *(int16_t *)b;
case T_UINT16:
return *(uint16_t *)a == *(uint16_t *)b;
case T_INT32:
return *(int32_t *)a == *(int32_t *)b;
case T_UINT32:
return *(uint32_t *)a == *(uint32_t *)b;
case T_INT64:
return *(int64_t *)a == *(int64_t *)b;
case T_UINT64:
return *(uint64_t *)a == *(uint64_t *)b;
case T_FLOAT:
return *(float *)a == *(float *)b;
case T_DOUBLE:
return *(double *)a == *(double *)b;
}
return 0;
}
@ -211,33 +297,33 @@ int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag)
return (*(uint64_t *)a < (uint64_t) * (int64_t *)b);
}
return ((int64_t) * (uint64_t *)a < *(int64_t *)b);
}
else if (btag == T_DOUBLE) {
if (db != db) return 0;
} else if (btag == T_DOUBLE) {
if (db != db)
return 0;
return (*(uint64_t *)a < (uint64_t) * (double *)b);
}
}
else if (atag == T_INT64) {
} else if (atag == T_INT64) {
if (btag == T_UINT64) {
if (*(int64_t *)a >= 0) {
return ((uint64_t) * (int64_t *)a < *(uint64_t *)b);
}
return (*(int64_t *)a < (int64_t) * (uint64_t *)b);
}
else if (btag == T_DOUBLE) {
if (db != db) return 0;
} else if (btag == T_DOUBLE) {
if (db != db)
return 0;
return (*(int64_t *)a < (int64_t) * (double *)b);
}
}
if (btag == T_UINT64) {
if (atag == T_DOUBLE) {
if (da != da) return 0;
if (da != da)
return 0;
return (*(uint64_t *)b > (uint64_t) * (double *)a);
}
}
else if (btag == T_INT64) {
} else if (btag == T_INT64) {
if (atag == T_DOUBLE) {
if (da != da) return 0;
if (da != da)
return 0;
return (*(int64_t *)b > (int64_t) * (double *)a);
}
}
@ -247,7 +333,10 @@ 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)
{
union { double d; int64_t i64; } u, v;
union {
double d;
int64_t i64;
} u, v;
if (atag == btag && (!equalnans || atag < T_FLOAT))
return cmp_same_eq(a, b, atag);
@ -256,7 +345,8 @@ int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag,
if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) {
if (equalnans) {
u.d = da; v.d = db;
u.d = da;
v.d = db;
return u.i64 == v.i64;
}
return (da == db);
@ -270,32 +360,25 @@ int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag,
// we would already have concluded that it's bigger than b.
if (btag == T_INT64) {
return ((int64_t) * (uint64_t *)a == *(int64_t *)b);
}
else if (btag == T_DOUBLE) {
} else if (btag == T_DOUBLE) {
return (*(uint64_t *)a == (uint64_t)(int64_t) * (double *)b);
}
}
else if (atag == T_INT64) {
} else if (atag == T_INT64) {
if (btag == T_UINT64) {
return (*(int64_t *)a == (int64_t) * (uint64_t *)b);
}
else if (btag == T_DOUBLE) {
} else if (btag == T_DOUBLE) {
return (*(int64_t *)a == (int64_t) * (double *)b);
}
}
else if (btag == T_UINT64) {
} else if (btag == T_UINT64) {
if (atag == T_INT64) {
return ((int64_t) * (uint64_t *)b == *(int64_t *)a);
}
else if (atag == T_DOUBLE) {
} else if (atag == T_DOUBLE) {
return (*(uint64_t *)b == (uint64_t)(int64_t) * (double *)a);
}
}
else if (btag == T_INT64) {
} else if (btag == T_INT64) {
if (atag == T_UINT64) {
return (*(int64_t *)b == (int64_t) * (uint64_t *)a);
}
else if (atag == T_DOUBLE) {
} else if (atag == T_DOUBLE) {
return (*(int64_t *)b == (int64_t) * (double *)a);
}
}

249
print.c
View File

@ -50,15 +50,9 @@ static int outindent(int n, ios_t *f)
return n0;
}
void fl_print_chr(char c, ios_t *f)
{
outc(c, f);
}
void fl_print_chr(char c, ios_t *f) { outc(c, f); }
void fl_print_str(char *s, ios_t *f)
{
outs(s, f);
}
void fl_print_str(char *s, ios_t *f) { outs(s, f); }
void print_traverse(value_t v)
{
@ -88,18 +82,15 @@ void print_traverse(value_t v)
unsigned int i;
for (i = 0; i < vector_size(v); i++)
print_traverse(vector_elt(v, i));
}
else if (iscprim(v)) {
} else if (iscprim(v)) {
// don't consider shared references to e.g. chars
}
else if (isclosure(v)) {
} else if (isclosure(v)) {
mark_cons(v);
function_t *f = (function_t *)ptr(v);
print_traverse(f->bcode);
print_traverse(f->vals);
print_traverse(f->env);
}
else {
} else {
assert(iscvalue(v));
cvalue_t *cv = (cvalue_t *)ptr(v);
// don't consider shared references to ""
@ -115,10 +106,8 @@ static void print_symbol_name(ios_t *f, char *name)
{
int i, escape = 0, charescape = 0;
if ((name[0] == '\0') ||
(name[0] == '.' && name[1] == '\0') ||
(name[0] == '#') ||
isnumtok(name, NULL))
if ((name[0] == '\0') || (name[0] == '.' && name[1] == '\0') ||
(name[0] == '#') || isnumtok(name, NULL))
escape = 1;
i = 0;
while (name[i]) {
@ -142,14 +131,12 @@ static void print_symbol_name(ios_t *f, char *name)
i++;
}
outc('|', f);
}
else {
} else {
outc('|', f);
outs(name, f);
outc('|', f);
}
}
else {
} else {
outs(name, f);
}
}
@ -170,17 +157,19 @@ static inline int tinyp(value_t v)
return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
if (fl_isstring(v))
return (cv_len((cvalue_t *)ptr(v)) < SMALL_STR_LEN);
return (isfixnum(v) || isbuiltin(v) || v==FL_F || v==FL_T || v==FL_NIL ||
v == FL_EOF || iscprim(v));
return (isfixnum(v) || isbuiltin(v) || v == FL_F || v == FL_T ||
v == FL_NIL || v == FL_EOF || iscprim(v));
}
static int smallp(value_t v)
{
if (tinyp(v)) return 1;
if (fl_isnumber(v)) return 1;
if (tinyp(v))
return 1;
if (fl_isnumber(v))
return 1;
if (iscons(v)) {
if (tinyp(car_(v)) && (tinyp(cdr_(v)) ||
(iscons(cdr_(v)) && tinyp(car_(cdr_(v))) &&
if (tinyp(car_(v)) &&
(tinyp(cdr_(v)) || (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) &&
cdr_(cdr_(v)) == NIL)))
return 1;
return 0;
@ -188,8 +177,7 @@ static int smallp(value_t v)
if (isvector(v)) {
size_t s = vector_size(v);
return (s == 0 || (tinyp(vector_elt(v, 0)) &&
(s == 1 || (s == 2 &&
tinyp(vector_elt(v,1))))));
(s == 1 || (s == 2 && tinyp(vector_elt(v, 1))))));
}
return 0;
}
@ -283,7 +271,8 @@ static void print_pair(ios_t *f, value_t v)
outc('(', f);
int newindent = HPOS, blk = blockindent(v);
int lastv, n = 0, si, ind = 0, est, always = 0, nextsmall, thistiny;
if (!blk) always = indentevery(v);
if (!blk)
always = indentevery(v);
value_t head = car_(v);
int after3 = indentafter3(head, v);
int after2 = indentafter2(head, v);
@ -306,17 +295,15 @@ static void print_pair(ios_t *f, value_t v)
break;
}
if (!print_pretty ||
((head == LAMBDA) && n == 0)) {
if (!print_pretty || ((head == LAMBDA) && n == 0)) {
// never break line before lambda-list
ind = 0;
}
else {
} else {
est = lengthestimate(car_(cd));
nextsmall = smallp(car_(cd));
thistiny = tinyp(car_(v));
ind = (((VPOS > lastv) ||
(HPOS>SCR_WIDTH/2 && !nextsmall && !thistiny && n>0)) ||
ind = (((VPOS > lastv) || (HPOS > SCR_WIDTH / 2 && !nextsmall &&
!thistiny && n > 0)) ||
(HPOS > SCR_WIDTH - 4) ||
@ -326,8 +313,7 @@ static void print_pair(ios_t *f, value_t v)
(n > 0 && always) ||
(n == 2 && after3) ||
(n == 1 && after2) ||
(n == 2 && after3) || (n == 1 && after2) ||
(n_unindented >= 3 && !nextsmall) ||
@ -337,8 +323,7 @@ static void print_pair(ios_t *f, value_t v)
if (ind) {
newindent = outindent(newindent, f);
n_unindented = 1;
}
else {
} else {
n_unindented++;
outc(' ', f);
if (n == 0) {
@ -385,7 +370,9 @@ void fl_print_child(ios_t *f, value_t v)
switch (tag(v)) {
case TAG_NUM:
case TAG_NUM1: HPOS+=ios_printf(f, "%ld", numval(v)); break;
case TAG_NUM1:
HPOS += ios_printf(f, "%ld", numval(v));
break;
case TAG_SYM:
name = symbol_name(v);
if (print_princ)
@ -393,39 +380,36 @@ void fl_print_child(ios_t *f, value_t v)
else if (ismanaged(v)) {
outsn("#:", f, 2);
outs(name, f);
}
else
} else
print_symbol_name(f, name);
break;
case TAG_FUNCTION:
if (v == FL_T) {
outsn("#t", f, 2);
}
else if (v == FL_F) {
} else if (v == FL_F) {
outsn("#f", f, 2);
}
else if (v == FL_NIL) {
} else if (v == FL_NIL) {
outsn("()", f, 2);
}
else if (v == FL_EOF) {
} else if (v == FL_EOF) {
outsn("#<eof>", f, 6);
}
else if (isbuiltin(v)) {
} else if (isbuiltin(v)) {
if (!print_princ)
outsn("#.", f, 2);
outs(builtin_names[uintval(v)], f);
}
else {
} else {
assert(isclosure(v));
if (!print_princ) {
if (print_circle_prefix(f, v)) break;
if (print_circle_prefix(f, v))
break;
function_t *fn = (function_t *)ptr(v);
outs("#fn(", f);
char *data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(fn->bcode);
for(i=0; i < sz; i++) data[i] += 48;
for (i = 0; i < sz; i++)
data[i] += 48;
fl_print_child(f, fn->bcode);
for(i=0; i < sz; i++) data[i] -= 48;
for (i = 0; i < sz; i++)
data[i] -= 48;
outc(' ', f);
fl_print_child(f, fn->vals);
if (fn->env != NIL) {
@ -437,8 +421,7 @@ void fl_print_child(ios_t *f, value_t v)
fl_print_child(f, fn->name);
}
outc(')', f);
}
else {
} else {
outs("#<function>", f);
}
}
@ -452,7 +435,8 @@ void fl_print_child(ios_t *f, value_t v)
case TAG_CVALUE:
case TAG_VECTOR:
case TAG_CONS:
if (!print_princ && print_circle_prefix(f, v)) break;
if (!print_princ && print_circle_prefix(f, v))
break;
if (isvector(v)) {
outc('[', f);
int newindent = HPOS, est;
@ -466,8 +450,7 @@ void fl_print_child(ios_t *f, value_t v)
if (i < sz - 1) {
if (!print_pretty) {
outc(' ', f);
}
else {
} else {
est = lengthestimate(vector_elt(v, i + 1));
if (HPOS > SCR_WIDTH - 4 ||
(est != -1 && (HPOS + est > SCR_WIDTH - 2)) ||
@ -516,8 +499,7 @@ static void print_string(ios_t *f, char *str, size_t sz)
outc(hexdig[c & 0xf], f);
}
}
}
else {
} else {
while (i < sz) {
size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0);
outsn(buf, f, n - 1);
@ -579,8 +561,7 @@ void snprint_real(char *s, size_t cnt, double r,
num_format[1] = 'e';
temp = r / pow(10, mag); /* see if number will have a decimal */
fpart = temp - floor(temp); /* when written in scientific notation */
}
else {
} else {
num_format[1] = 'f';
fpart = r - floor(r);
}
@ -588,8 +569,7 @@ void snprint_real(char *s, size_t cnt, double r,
dec = 0;
if (width == 0) {
snprintf(format, 8, "%%.%d%s", dec, num_format);
}
else {
} else {
snprintf(format, 8, "%%%d.%d%s", width, dec, num_format);
}
sz = snprintf(s, cnt, format, r);
@ -630,8 +610,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
HPOS += ios_printf(f, "0x%hhx", ch);
else
HPOS += ios_printf(f, "#byte(0x%hhx)", ch);
}
else if (type == wcharsym) {
} else if (type == wcharsym) {
uint32_t wc = *(uint32_t *)data;
char seq[8];
size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
@ -642,31 +621,46 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
ios_putc(0, f);
else
outs(seq, f);
}
else {
} else {
outsn("#\\", f, 2);
if (wc == 0x00) outsn("nul", f, 3);
else if (wc == 0x07) outsn("alarm", f, 5);
else if (wc == 0x08) outsn("backspace", f, 9);
else if (wc == 0x09) outsn("tab", f, 3);
if (wc == 0x00)
outsn("nul", f, 3);
else if (wc == 0x07)
outsn("alarm", f, 5);
else if (wc == 0x08)
outsn("backspace", f, 9);
else if (wc == 0x09)
outsn("tab", f, 3);
// else if (wc == 0x0A) outsn("linefeed", f, 8);
else if (wc == 0x0A) outsn("newline", f, 7);
else if (wc == 0x0B) outsn("vtab", f, 4);
else if (wc == 0x0C) outsn("page", f, 4);
else if (wc == 0x0D) outsn("return", f, 6);
else if (wc == 0x1B) outsn("esc", f, 3);
else if (wc == 0x0A)
outsn("newline", f, 7);
else if (wc == 0x0B)
outsn("vtab", f, 4);
else if (wc == 0x0C)
outsn("page", f, 4);
else if (wc == 0x0D)
outsn("return", f, 6);
else if (wc == 0x1B)
outsn("esc", f, 3);
// else if (wc == 0x20) outsn("space", f, 5);
else if (wc == 0x7F) outsn("delete", f, 6);
else if (iswprint(wc)) outs(seq, f);
else HPOS+=ios_printf(f, "x%04x", (int)wc);
else if (wc == 0x7F)
outsn("delete", f, 6);
else if (iswprint(wc))
outs(seq, f);
else
HPOS += ios_printf(f, "x%04x", (int)wc);
}
}
else if (type == floatsym || type == doublesym) {
} else if (type == floatsym || type == doublesym) {
char buf[64];
double d;
int ndec;
if (type == floatsym) { d = (double)*(float*)data; ndec = 8; }
else { d = *(double*)data; ndec = 16; }
if (type == floatsym) {
d = (double)*(float *)data;
ndec = 8;
} else {
d = *(double *)data;
ndec = 16;
}
if (!DFINITE(d)) {
char *rep;
if (isnan(d))
@ -677,25 +671,23 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
HPOS += ios_printf(f, "#%s(%s)", symbol_name(type), rep);
else
outs(rep, f);
}
else if (d == 0) {
} else if (d == 0) {
if (1 / d < 0)
outsn("-0.0", f, 4);
else
outsn("0.0", f, 3);
if (type == floatsym && !print_princ && !weak)
outc('f', f);
}
else {
} else {
snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
int hasdec = (strpbrk(buf, ".eE") != NULL);
outs(buf, f);
if (!hasdec) outsn(".0", f, 2);
if (!hasdec)
outsn(".0", f, 2);
if (type == floatsym && !print_princ && !weak)
outc('f', f);
}
}
else if (type == uint64sym
} else if (type == uint64sym
#ifdef BITS64
|| type == ulongsym
#endif
@ -705,31 +697,27 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
HPOS += ios_printf(f, "%llu", ui64);
else
HPOS += ios_printf(f, "#%s(%llu)", symbol_name(type), ui64);
}
else if (issymbol(type)) {
} else if (issymbol(type)) {
// handle other integer prims. we know it's smaller than uint64
// at this point, so int64 is big enough to capture everything.
numerictype_t nt = sym_to_numtype(type);
if (nt == N_NUMTYPES) {
HPOS += ios_printf(f, "#<%s>", symbol_name(type));
}
else {
} else {
int64_t i64 = conv_to_int64(data, nt);
if (weak || print_princ)
HPOS += ios_printf(f, "%lld", i64);
else
HPOS += ios_printf(f, "#%s(%lld)", symbol_name(type), i64);
}
}
else if (iscons(type)) {
} else if (iscons(type)) {
if (car_(type) == arraysym) {
value_t eltype = car(cdr_(type));
size_t cnt, elsize;
if (iscons(cdr_(cdr_(type)))) {
cnt = toulong(car_(cdr_(cdr_(type))), "length");
elsize = cnt ? len / cnt : 0;
}
else {
} else {
// incomplete array type
int junk;
elsize = ctype_sizeof(eltype, &junk);
@ -745,30 +733,25 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
else
HPOS += u8_strwidth(data);
*/
}
else {
} else {
print_string(f, (char *)data, len);
}
return;
}
else if (eltype == wcharsym) {
} else if (eltype == wcharsym) {
// TODO wchar
}
else {
} else {
}
size_t i;
if (!weak) {
if (eltype == uint8sym) {
outsn("#vu8(", f, 5);
}
else {
} else {
outsn("#array(", f, 7);
fl_print_child(f, eltype);
if (cnt > 0)
outc(' ', f);
}
}
else {
} else {
outc('[', f);
}
for (i = 0; i < cnt; i++) {
@ -781,8 +764,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
outc(')', f);
else
outc(']', f);
}
else if (car_(type) == enumsym) {
} else if (car_(type) == enumsym) {
int n = *(int *)data;
value_t syms = car(cdr_(type));
assert(isvector(syms));
@ -793,8 +775,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
}
if (n >= (int)vector_size(syms)) {
cvalue_printdata(f, data, len, int32sym, 1);
}
else {
} else {
fl_print_child(f, vector_elt(syms, n));
}
if (!weak)
@ -813,25 +794,21 @@ static void cvalue_print(ios_t *f, value_t v)
void *fptr = *(void **)data;
label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, cv);
if (label == (value_t)HT_NOTFOUND) {
HPOS += ios_printf(f, "#<builtin @0x%08zx>",
(size_t)(builtin_t)fptr);
}
else {
HPOS +=
ios_printf(f, "#<builtin @0x%08zx>", (size_t)(builtin_t)fptr);
} else {
if (print_princ) {
outs(symbol_name(label), f);
}
else {
} else {
outsn("#fn(", f, 4);
outs(symbol_name(label), f);
outc(')', f);
}
}
}
else if (cv_class(cv)->vtable != NULL &&
} else if (cv_class(cv)->vtable != NULL &&
cv_class(cv)->vtable->print != NULL) {
cv_class(cv)->vtable->print(v, f);
}
else {
} else {
value_t type = cv_type(cv);
size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
cvalue_printdata(f, data, len, type, 0);
@ -841,7 +818,8 @@ static void cvalue_print(ios_t *f, value_t v)
static void set_print_width(void)
{
value_t pw = symbol_value(printwidthsym);
if (!isfixnum(pw)) return;
if (!isfixnum(pw))
return;
SCR_WIDTH = numval(pw);
}
@ -853,15 +831,20 @@ void fl_print(ios_t *f, value_t v)
print_princ = (symbol_value(printreadablysym) == FL_F);
value_t pl = symbol_value(printlengthsym);
if (isfixnum(pl)) print_length = numval(pl);
else print_length = -1;
if (isfixnum(pl))
print_length = numval(pl);
else
print_length = -1;
pl = symbol_value(printlevelsym);
if (isfixnum(pl)) print_level = numval(pl);
else print_level = -1;
if (isfixnum(pl))
print_level = numval(pl);
else
print_level = -1;
P_LEVEL = 0;
printlabel = 0;
if (!print_princ) print_traverse(v);
if (!print_princ)
print_traverse(v);
HPOS = VPOS = 0;
fl_print_child(f, v);

245
read.c
View File

@ -1,8 +1,25 @@
enum {
TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE
TOK_NONE,
TOK_OPEN,
TOK_CLOSE,
TOK_DOT,
TOK_QUOTE,
TOK_SYM,
TOK_NUM,
TOK_BQ,
TOK_COMMA,
TOK_COMMAAT,
TOK_COMMADOT,
TOK_SHARPDOT,
TOK_LABEL,
TOK_BACKREF,
TOK_SHARPQUOTE,
TOK_SHARPOPEN,
TOK_OPENB,
TOK_CLOSEB,
TOK_SHARPSYM,
TOK_GENSYM,
TOK_DOUBLEQUOTE
};
#define F value2c(ios_t *, readstate->source)
@ -29,49 +46,55 @@ int isnumtok_base(char *tok, value_t *pval, int base)
strpbrk(tok, ".eEpP")) {
d = strtod(tok, &end);
if (*end == '\0') {
if (pval) *pval = mk_double(d);
if (pval)
*pval = mk_double(d);
return 1;
}
// floats can end in f or f0
if (end > tok && end[0] == 'f' &&
(end[1] == '\0' ||
(end[1] == '0' && end[2] == '\0'))) {
if (pval) *pval = mk_float((float)d);
(end[1] == '\0' || (end[1] == '0' && end[2] == '\0'))) {
if (pval)
*pval = mk_float((float)d);
return 1;
}
}
if (tok[0] == '+') {
if (!strcmp(tok, "+NaN") || !strcasecmp(tok, "+nan.0")) {
if (pval) *pval = mk_double(D_PNAN);
if (pval)
*pval = mk_double(D_PNAN);
return 1;
}
if (!strcmp(tok, "+Inf") || !strcasecmp(tok, "+inf.0")) {
if (pval) *pval = mk_double(D_PINF);
if (pval)
*pval = mk_double(D_PINF);
return 1;
}
}
else if (tok[0] == '-') {
} else if (tok[0] == '-') {
if (!strcmp(tok, "-NaN") || !strcasecmp(tok, "-nan.0")) {
if (pval) *pval = mk_double(D_NNAN);
if (pval)
*pval = mk_double(D_NNAN);
return 1;
}
if (!strcmp(tok, "-Inf") || !strcasecmp(tok, "-inf.0")) {
if (pval) *pval = mk_double(D_NINF);
if (pval)
*pval = mk_double(D_NINF);
return 1;
}
errno = 0;
i64 = strtoll(tok, &end, base);
if (errno)
return 0;
if (pval) *pval = return_from_int64(i64);
if (pval)
*pval = return_from_int64(i64);
return (*end == '\0');
}
errno = 0;
ui64 = strtoull(tok, &end, base);
if (errno)
return 0;
if (pval) *pval = return_from_uint64(ui64);
if (pval)
*pval = return_from_uint64(ui64);
return (*end == '\0');
}
@ -103,8 +126,7 @@ static char nextchar(void)
do {
if (f->bpos < f->size) {
ch = f->buf[f->bpos++];
}
else {
} else {
ch = ios_getc(f);
if (ch == IOS_EOF)
return 0;
@ -123,10 +145,7 @@ static char nextchar(void)
return c;
}
static void take(void)
{
toktype = TOK_NONE;
}
static void take(void) { toktype = TOK_NONE; }
static void accumchar(char c, int *pi)
{
@ -151,18 +170,15 @@ static int read_token(char c, int digits)
if (c == '|') {
issym = 1;
escaped = !escaped;
}
else if (c == '\\') {
} else if (c == '\\') {
issym = 1;
ch = ios_getc(F);
if (ch == IOS_EOF)
goto terminate;
accumchar((char)ch, &i);
}
else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
} else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
break;
}
else {
} else {
accumchar(c, &i);
}
}
@ -183,42 +199,36 @@ static u_int32_t peek(void)
if (toktype != TOK_NONE)
return toktype;
c = nextchar();
if (ios_eof(F)) return TOK_NONE;
if (ios_eof(F))
return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
} else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '[') {
} else if (c == '[') {
toktype = TOK_OPENB;
}
else if (c == ']') {
} else if (c == ']') {
toktype = TOK_CLOSEB;
}
else if (c == '\'') {
} else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (c == '`') {
} else if (c == '`') {
toktype = TOK_BQ;
}
else if (c == '"') {
} else if (c == '"') {
toktype = TOK_DOUBLEQUOTE;
}
else if (c == '#') {
ch = ios_getc(F); c = (char)ch;
} else if (c == '#') {
ch = ios_getc(F);
c = (char)ch;
if (ch == IOS_EOF)
lerror(ParseError, "read: invalid read macro");
if (c == '.') {
toktype = TOK_SHARPDOT;
}
else if (c == '\'') {
} else if (c == '\'') {
toktype = TOK_SHARPQUOTE;
}
else if (c == '\\') {
} else if (c == '\\') {
uint32_t cval;
if (ios_getutf8(F, &cval) == IOS_EOF)
lerror(ParseError, "read: end of input in character constant");
lerror(ParseError,
"read: end of input in character constant");
if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
cval == (uint32_t)'x') {
read_token('u', 0);
@ -228,36 +238,45 @@ static u_int32_t peek(void)
"read: invalid hex character constant");
cval = numval(tokval);
}
}
else if (cval >= 'a' && cval <= 'z') {
} else if (cval >= 'a' && cval <= 'z') {
read_token((char)cval, 0);
tokval = symbol(buf);
if (buf[1] == '\0') /* one character */;
else if (tokval == nulsym) cval = 0x00;
else if (tokval == alarmsym) cval = 0x07;
else if (tokval == backspacesym) cval = 0x08;
else if (tokval == tabsym) cval = 0x09;
else if (tokval == linefeedsym) cval = 0x0A;
else if (tokval == newlinesym) cval = 0x0A;
else if (tokval == vtabsym) cval = 0x0B;
else if (tokval == pagesym) cval = 0x0C;
else if (tokval == returnsym) cval = 0x0D;
else if (tokval == escsym) cval = 0x1B;
else if (tokval == spacesym) cval = 0x20;
else if (tokval == deletesym) cval = 0x7F;
if (buf[1] == '\0') /* one character */
;
else if (tokval == nulsym)
cval = 0x00;
else if (tokval == alarmsym)
cval = 0x07;
else if (tokval == backspacesym)
cval = 0x08;
else if (tokval == tabsym)
cval = 0x09;
else if (tokval == linefeedsym)
cval = 0x0A;
else if (tokval == newlinesym)
cval = 0x0A;
else if (tokval == vtabsym)
cval = 0x0B;
else if (tokval == pagesym)
cval = 0x0C;
else if (tokval == returnsym)
cval = 0x0D;
else if (tokval == escsym)
cval = 0x1B;
else if (tokval == spacesym)
cval = 0x20;
else if (tokval == deletesym)
cval = 0x7F;
else
lerrorf(ParseError, "read: unknown character #\\%s", buf);
}
toktype = TOK_NUM;
tokval = mk_wchar(cval);
}
else if (c == '(') {
} else if (c == '(') {
toktype = TOK_SHARPOPEN;
}
else if (c == '<') {
} else if (c == '<') {
lerror(ParseError, "read: unreadable object");
}
else if (isdigit(c)) {
} else if (isdigit(c)) {
read_token(c, 1);
c = (char)ios_getc(F);
if (c == '#')
@ -271,15 +290,13 @@ static u_int32_t peek(void)
if (*end != '\0' || errno)
lerror(ParseError, "read: invalid label");
tokval = fixnum(x);
}
else if (c == '!') {
} else if (c == '!') {
// #! single line comment for shbang script support
do {
ch = ios_getc(F);
} while (ch != IOS_EOF && (char)ch != '\n');
return peek();
}
else if (c == '|') {
} else if (c == '|') {
// multiline comment
int commentlevel = 1;
while (1) {
@ -297,8 +314,7 @@ static u_int32_t peek(void)
continue;
}
goto hashpipe_gotc;
}
else if ((char)ch == '#') {
} else if ((char)ch == '#') {
ch = ios_getc(F);
if ((char)ch == '|')
commentlevel++;
@ -308,13 +324,11 @@ static u_int32_t peek(void)
}
// this was whitespace, so keep peeking
return peek();
}
else if (c == ';') {
} else if (c == ';') {
// datum comment
(void)do_read_sexpr(UNBOUND); // skip
return peek();
}
else if (c == ':') {
} else if (c == ':') {
// gensym
ch = ios_getc(F);
if ((char)ch == 'g')
@ -326,29 +340,24 @@ static u_int32_t peek(void)
lerror(ParseError, "read: invalid gensym label");
toktype = TOK_GENSYM;
tokval = fixnum(x);
}
else if (symchar(c)) {
} 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)) || (c == 'o' && (base = 8)) ||
(c == 'd' && (base = 10)) || (c == 'x' && (base = 16))) &&
(isdigit_base(buf[1], base) || buf[1] == '-')) {
if (!read_numtok(&buf[1], &tokval, base))
lerrorf(ParseError, "read: invalid base %d constant", base);
lerrorf(ParseError, "read: invalid base %d constant",
base);
return (toktype = TOK_NUM);
}
toktype = TOK_SHARPSYM;
tokval = symbol(buf);
}
else {
} else {
lerror(ParseError, "read: unknown read macro");
}
}
else if (c == ',') {
} else if (c == ',') {
toktype = TOK_COMMA;
ch = ios_getc(F);
if (ch == IOS_EOF)
@ -359,13 +368,11 @@ static u_int32_t peek(void)
toktype = TOK_COMMADOT;
else
ios_ungetc((char)ch, F);
}
else {
} else {
if (!read_token(c, 0)) {
if (buf[0] == '.' && buf[1] == '\0') {
return (toktype = TOK_DOT);
}
else {
} else {
if (read_numtok(buf, &tokval, 0))
return (toktype = TOK_NUM);
}
@ -464,23 +471,24 @@ static value_t read_string(void)
eseq[j++] = c;
c = ios_getc(F);
} while (octal_digit(c) && j < 3 && (c != IOS_EOF));
if (c!=IOS_EOF) ios_ungetc(c, F);
if (c != IOS_EOF)
ios_ungetc(c, F);
eseq[j] = '\0';
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)) ||
} else if ((c == 'x' && (ndig = 2)) || (c == 'u' && (ndig = 4)) ||
(c == 'U' && (ndig = 8))) {
c = ios_getc(F);
while (hex_digit(c) && j < ndig && (c != IOS_EOF)) {
eseq[j++] = c;
c = ios_getc(F);
}
if (c!=IOS_EOF) ios_ungetc(c, F);
if (c != IOS_EOF)
ios_ungetc(c, F);
eseq[j] = '\0';
if (j) wc = strtol(eseq, NULL, 16);
if (j)
wc = strtol(eseq, NULL, 16);
if (!j || wc > 0x10ffff) {
free(buf);
lerror(ParseError, "read: invalid escape sequence");
@ -489,12 +497,10 @@ static value_t read_string(void)
buf[i++] = ((char)wc);
else
i += u8_wc_toutf8(&buf[i], wc);
}
else {
} else {
buf[i++] = read_escape_control_char((char)c);
}
}
else {
} else {
buf[i++] = c;
}
}
@ -518,11 +524,11 @@ static void read_list(value_t *pval, value_t label)
while (t != TOK_CLOSE) {
if (ios_eof(F))
lerror(ParseError, "read: unexpected end of input");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
c = mk_cons();
car_(c) = cdr_(c) = NIL;
if (iscons(*pc)) {
cdr_(*pc) = c;
}
else {
} else {
*pval = c;
if (label != UNBOUND)
ptrhash_put(&readstate->backrefs, (void *)label, (void *)c);
@ -570,13 +576,17 @@ static value_t do_read_sexpr(value_t label)
case TOK_NUM:
return tokval;
case TOK_COMMA:
head = &COMMA; goto listwith;
head = &COMMA;
goto listwith;
case TOK_COMMAAT:
head = &COMMAAT; goto listwith;
head = &COMMAAT;
goto listwith;
case TOK_COMMADOT:
head = &COMMADOT; goto listwith;
head = &COMMADOT;
goto listwith;
case TOK_BQ:
head = &BACKQUOTE; goto listwith;
head = &BACKQUOTE;
goto listwith;
case TOK_QUOTE:
head = &QUOTE;
listwith:
@ -615,8 +625,7 @@ static value_t do_read_sexpr(value_t label)
if (sym == vu8sym) {
sym = arraysym;
Stack[SP - 1] = fl_cons(uint8sym, Stack[SP - 1]);
}
else if (sym == fnsym) {
} else if (sym == fnsym) {
sym = FUNCTION;
}
v = symbol_value(sym);
@ -629,8 +638,8 @@ static value_t do_read_sexpr(value_t label)
return read_vector(label, TOK_CLOSE);
case TOK_SHARPDOT:
// eval-when-read
// evaluated expressions can refer to existing backreferences, but they
// cannot see pending labels. in other words:
// evaluated expressions can refer to existing backreferences, but
// they cannot see pending labels. in other words:
// (... #2=#.#0# ... ) OK
// (... #2=#.(#2#) ... ) DO NOT WANT
sym = do_read_sexpr(UNBOUND);

45
string.c
View File

@ -98,8 +98,7 @@ value_t fl_string_decode(value_t *args, u_int32_t nargs)
int term = 0;
if (nargs == 2) {
term = (args[1] != FL_F);
}
else {
} else {
argcount("string.decode", nargs, 1);
}
if (!fl_isstring(args[0]))
@ -109,12 +108,14 @@ value_t fl_string_decode(value_t *args, u_int32_t nargs)
size_t nb = cv_len(cv);
size_t nc = u8_charnum(ptr, nb);
size_t newsz = nc * sizeof(uint32_t);
if (term) newsz += sizeof(uint32_t);
if (term)
newsz += sizeof(uint32_t);
value_t wcstr = cvalue(wcstringtype, newsz);
ptr = cv_data((cvalue_t *)ptr(args[0])); // relocatable pointer
uint32_t *pwc = cvalue_data(wcstr);
u8_toucs(pwc, nc, ptr, nb);
if (term) pwc[nc] = 0;
if (term)
pwc[nc] = 0;
return wcstr;
}
@ -133,9 +134,7 @@ value_t fl_string(value_t *args, u_int32_t nargs)
value_t oldpp = symbol_value(printprettysym);
set(printreadablysym, FL_F);
set(printprettysym, FL_F);
FOR_ARGS(i,0,arg,args) {
fl_print(s, args[i]);
}
FOR_ARGS(i, 0, arg, args) { fl_print(s, args[i]); }
set(printreadablysym, oldpr);
set(printprettysym, oldpp);
value_t outp = stream_to_string(&buf);
@ -170,7 +169,8 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
s = cv_data((cvalue_t *)ptr(args[0]));
delim = cv_data((cvalue_t *)ptr(args[1]));
if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz);
if (ssz)
memcpy(cv_data((cvalue_t *)ptr(car_(c))), &s[tokstart], ssz);
// link new cell
if (last == FL_NIL)
@ -200,8 +200,7 @@ value_t fl_string_sub(value_t *args, u_int32_t nargs)
i2 = toulong(args[2], "string.sub");
if (i2 > len)
bounds_error("string.sub", args[0], args[2]);
}
else {
} else {
i2 = len;
}
if (i2 <= i1)
@ -271,7 +270,8 @@ value_t fl_string_find(value_t *args, u_int32_t nargs)
size_t len = cv_len((cvalue_t *)ptr(args[0]));
if (start > len)
bounds_error("string.find", args[0], args[2]);
char *needle; size_t needlesz;
char *needle;
size_t needlesz;
value_t v = args[1];
cprim_t *cp = (cprim_t *)ptr(v);
@ -281,16 +281,13 @@ value_t fl_string_find(value_t *args, u_int32_t nargs)
return mem_find_byte(s, (char)c, start, len);
needlesz = u8_toutf8(cbuf, sizeof(cbuf), &c, 1);
needle = cbuf;
}
else if (iscprim(v) && cp_class(cp) == bytetype) {
} else if (iscprim(v) && cp_class(cp) == bytetype) {
return mem_find_byte(s, *(char *)cp_data(cp), start, len);
}
else if (fl_isstring(v)) {
} else if (fl_isstring(v)) {
cvalue_t *cv = (cvalue_t *)ptr(v);
needlesz = cv_len(cv);
needle = (char *)cv_data(cv);
}
else {
} else {
type_error("string.find", "string", args[1]);
}
if (needlesz > len - start)
@ -363,9 +360,12 @@ value_t fl_numbertostring(value_t *args, u_int32_t nargs)
value_t n = args[0];
int neg = 0;
uint64_t num;
if (isfixnum(n)) num = numval(n);
else if (!iscprim(n)) type_error("number->string", "integer", n);
else num = conv_to_uint64(cp_data((cprim_t*)ptr(n)),
if (isfixnum(n))
num = numval(n);
else if (!iscprim(n))
type_error("number->string", "integer", n);
else
num = conv_to_uint64(cp_data((cprim_t *)ptr(n)),
cp_numtype((cprim_t *)ptr(n)));
if (numval(fl_compare(args[0], fixnum(0))) < 0) {
num = -num;
@ -429,7 +429,4 @@ static builtinspec_t stringfunc_info[] = {
{ NULL, NULL }
};
void stringfuncs_init(void)
{
assign_global_builtins(stringfunc_info);
}
void stringfuncs_init(void) { assign_global_builtins(stringfunc_info); }

25
table.c
View File

@ -20,7 +20,8 @@ void print_htable(value_t v, ios_t *f)
fl_print_str("#table(", f);
for (i = 0; i < h->size; i += 2) {
if (h->table[i + 1] != HT_NOTFOUND) {
if (!first) fl_print_str(" ", f);
if (!first)
fl_print_str(" ", f);
fl_print_child(f, (value_t)h->table[i]);
fl_print_chr(' ', f);
fl_print_child(f, (value_t)h->table[i + 1]);
@ -93,15 +94,15 @@ value_t fl_table(value_t *args, uint32_t nargs)
tabletype->vtable->finalize = NULL;
nt = cvalue(tabletype, sizeof(htable_t));
tabletype->vtable->finalize = free_htable;
}
else {
} else {
nt = cvalue(tabletype, 2 * sizeof(void *));
}
htable_t *h = (htable_t *)cv_data((cvalue_t *)ptr(nt));
htable_new(h, cnt / 2);
uint32_t i;
value_t k = FL_NIL, arg = FL_NIL;
FOR_ARGS(i,0,arg,args) {
FOR_ARGS(i, 0, arg, args)
{
if (i & 1)
equalhash_put(h, (void *)k, (void *)arg);
else
@ -176,10 +177,8 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
fl_gc_handle(&t);
for (i = 0; i < n; i += 2) {
if (table[i + 1] != HT_NOTFOUND) {
zero = fl_applyn(3, f,
(value_t)table[i],
(value_t)table[i+1],
zero);
zero =
fl_applyn(3, f, (value_t)table[i], (value_t)table[i + 1], zero);
// reload pointer
h = (htable_t *)cv_data((cvalue_t *)ptr(t));
if (h->size != n)
@ -191,21 +190,19 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
return zero;
}
static builtinspec_t tablefunc_info[] = {
{ "table", fl_table },
static builtinspec_t tablefunc_info[] = { { "table", fl_table },
{ "table?", fl_tablep },
{ "put!", fl_table_put },
{ "get", fl_table_get },
{ "has?", fl_table_has },
{ "del!", fl_table_del },
{ "table.foldl", fl_table_foldl },
{ NULL, NULL }
};
{ NULL, NULL } };
void table_init(void)
{
tablesym = symbol("table");
tabletype = define_opaque_type(tablesym, sizeof(htable_t),
&table_vtable, NULL);
tabletype =
define_opaque_type(tablesym, sizeof(htable_t), &table_vtable, NULL);
assign_global_builtins(tablefunc_info);
}

42
tiny/flutils.c
View File

@ -3,15 +3,13 @@ u_int32_t *bitvector_resize(u_int32_t *b, size_t n)
u_int32_t *p;
size_t sz = ((n + 31) >> 5) * 4;
p = realloc(b, sz);
if (p == NULL) return NULL;
if (p == NULL)
return NULL;
memset(p, 0, sz);
return p;
}
u_int32_t *mk_bitvector(size_t n)
{
return bitvector_resize(NULL, n);
}
u_int32_t *mk_bitvector(size_t n) { return bitvector_resize(NULL, n); }
void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c)
{
@ -38,10 +36,7 @@ void ltable_init(ltable_t *t, size_t n)
t->items = (unsigned long *)malloc(n * sizeof(unsigned long));
}
void ltable_clear(ltable_t *t)
{
t->n = 0;
}
void ltable_clear(ltable_t *t) { t->n = 0; }
void ltable_insert(ltable_t *t, unsigned long item)
{
@ -49,7 +44,8 @@ void ltable_insert(ltable_t *t, unsigned long item)
if (t->n == t->maxsize) {
p = realloc(t->items, (t->maxsize * 2) * sizeof(unsigned long));
if (p == NULL) return;
if (p == NULL)
return;
t->items = p;
t->maxsize *= 2;
}
@ -73,20 +69,22 @@ void ltable_adjoin(ltable_t *t, unsigned long item)
ltable_insert(t, item);
}
static const u_int32_t offsetsFromUTF8[6] = {
0x00000000UL, 0x00003080UL, 0x000E2080UL,
0x03C82080UL, 0xFA082080UL, 0x82082080UL
};
static const u_int32_t offsetsFromUTF8[6] = { 0x00000000UL, 0x00003080UL,
0x000E2080UL, 0x03C82080UL,
0xFA082080UL, 0x82082080UL };
static const char trailingBytesForUTF8[256] = {
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5
};
int u8_seqlen(const char c)

217
tiny/lisp-nontail.c
View File

@ -68,20 +68,51 @@ typedef struct _symbol_t {
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
F_QUOTE = 0,
F_COND,
F_IF,
F_AND,
F_OR,
F_WHILE,
F_LAMBDA,
F_MACRO,
F_LABEL,
F_PROGN,
// functions
F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
F_EQ,
F_ATOM,
F_CONS,
F_CAR,
F_CDR,
F_READ,
F_EVAL,
F_PRINT,
F_SET,
F_NOT,
F_LOAD,
F_SYMBOLP,
F_NUMBERP,
F_ADD,
F_SUB,
F_MUL,
F_DIV,
F_LT,
F_PROG1,
F_APPLY,
F_RPLACA,
F_RPLACD,
F_BOUNDP,
N_BUILTINS
};
#define isspecial(v) (intval(v) <= (int)F_PROGN)
static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",
"progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
"set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp" };
static char *builtin_names[] = {
"quote", "cond", "if", "and", "or", "while", "lambda",
"macro", "label", "progn", "eq", "atom", "cons", "car",
"cdr", "read", "eval", "print", "set", "not", "load",
"symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp"
};
static char *stack_bottom;
#define PROCESS_STACK_SIZE (2 * 1024 * 1024)
@ -99,7 +130,8 @@ void print(FILE *f, value_t v);
value_t eval_sexpr(value_t e, value_t *penv);
value_t load_file(char *fname);
// error utilities ------------------------------------------------------------
// error utilities
// ------------------------------------------------------------
jmp_buf toplevel;
@ -115,10 +147,12 @@ void lerror(char *format, ...)
void type_error(char *fname, char *expected, value_t got)
{
fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
print(stderr, got); lerror("\n");
print(stderr, got);
lerror("\n");
}
// safe cast operators --------------------------------------------------------
// safe cast operators
// --------------------------------------------------------
#define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(value_t v, char *fname) \
@ -132,7 +166,8 @@ SAFECAST_OP(cons, cons_t*, ptr)
SAFECAST_OP(symbol, symbol_t *, ptr)
SAFECAST_OP(number, number_t, numval)
// symbol table ---------------------------------------------------------------
// symbol table
// ---------------------------------------------------------------
static symbol_t *symtab = NULL;
@ -173,7 +208,8 @@ value_t symbol(char *str)
return tagptr(*pnode, TAG_SYM);
}
// initialization -------------------------------------------------------------
// initialization
// -------------------------------------------------------------
static unsigned char *fromspace;
static unsigned char *tospace;
@ -190,8 +226,10 @@ void lisp_init(void)
curheap = fromspace;
lim = curheap + heapsize - sizeof(cons_t);
NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("t"); setc(T, T);
NIL = symbol("nil");
setc(NIL, NIL);
T = symbol("t");
setc(T, T);
LAMBDA = symbol("lambda");
MACRO = symbol("macro");
LABEL = symbol("label");
@ -201,7 +239,8 @@ void lisp_init(void)
setc(symbol("princ"), builtin(F_PRINT));
}
// conses ---------------------------------------------------------------------
// conses
// ---------------------------------------------------------------------
void gc(void);
@ -219,19 +258,22 @@ static value_t mk_cons(void)
static value_t cons_(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
car_(c) = *pcar;
cdr_(c) = *pcdr;
return c;
}
value_t *cons(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
car_(c) = *pcar;
cdr_(c) = *pcdr;
PUSH(c);
return &Stack[SP - 1];
}
// collector ------------------------------------------------------------------
// collector
// ------------------------------------------------------------------
static value_t relocate(value_t v)
{
@ -242,8 +284,10 @@ static value_t relocate(value_t v)
if (car_(v) == UNBOUND)
return cdr_(v);
nc = mk_cons();
a = car_(v); d = cdr_(v);
car_(v) = UNBOUND; cdr_(v) = nc;
a = car_(v);
d = cdr_(v);
car_(v) = UNBOUND;
cdr_(v) = nc;
car_(nc) = relocate(a);
cdr_(nc) = relocate(d);
return nc;
@ -271,7 +315,8 @@ void gc(void)
Stack[i] = relocate(Stack[i]);
trace_globals(symtab);
#ifdef VERBOSEGC
printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);
printf("gc found %d/%d live conses\n", (curheap - tospace) / 8,
heapsize / 8);
#endif
temp = tospace;
tospace = fromspace;
@ -293,11 +338,10 @@ void gc(void)
gc();
}
// read -----------------------------------------------------------------------
// read
// -----------------------------------------------------------------------
enum {
TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
};
enum { TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM };
static int symchar(char c)
{
@ -332,10 +376,7 @@ static char nextchar(FILE *f)
return c;
}
static void take(void)
{
toktype = TOK_NONE;
}
static void take(void) { toktype = TOK_NONE; }
static void accumchar(char c, int *pi)
{
@ -356,17 +397,14 @@ static int read_token(FILE *f, char c)
c = (char)ch;
if (c == '|') {
escaped = !escaped;
}
else if (c == '\\') {
} else if (c == '\\') {
ch = fgetc(f);
if (ch == EOF)
goto terminate;
accumchar((char)ch, &i);
}
else if (!escaped && !symchar(c)) {
} else if (!escaped && !symchar(c)) {
break;
}
else {
} else {
accumchar(c, &i);
}
}
@ -384,36 +422,31 @@ static u_int32_t peek(FILE *f)
if (toktype != TOK_NONE)
return toktype;
c = nextchar(f);
if (feof(f)) return TOK_NONE;
if (feof(f))
return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
} else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '\'') {
} else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (isdigit(c) || c=='-') {
} else if (isdigit(c) || c == '-') {
read_token(f, c);
if (buf[0] == '-' && !isdigit(buf[1])) {
toktype = TOK_SYM;
tokval = symbol(buf);
}
else {
} else {
x = strtol(buf, &end, 10);
if (*end != '\0')
lerror("read: error: invalid integer constant\n");
toktype = TOK_NUM;
tokval = number(x);
}
}
else {
} else {
read_token(f, c);
if (!strcmp(buf, ".")) {
toktype = TOK_DOT;
}
else {
} else {
toktype = TOK_SYM;
tokval = symbol(buf);
}
@ -435,7 +468,8 @@ static void read_list(FILE *f, value_t *pval)
while (t != TOK_CLOSE) {
if (feof(f))
lerror("read: error: unexpected end of input\n");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
c = mk_cons();
car_(c) = cdr_(c) = NIL;
if (iscons(*pc))
cdr_(*pc) = c;
else
@ -491,17 +525,23 @@ value_t read_sexpr(FILE *f)
return NIL;
}
// print ----------------------------------------------------------------------
// print
// ----------------------------------------------------------------------
void print(FILE *f, value_t v)
{
value_t cd;
switch (tag(v)) {
case TAG_NUM: fprintf(f, "%d", numval(v)); break;
case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
builtin_names[intval(v)]); break;
case TAG_NUM:
fprintf(f, "%d", numval(v));
break;
case TAG_SYM:
fprintf(f, "%s", ((symbol_t *)ptr(v))->name);
break;
case TAG_BUILTIN:
fprintf(f, "#<builtin %s>", builtin_names[intval(v)]);
break;
case TAG_CONS:
fprintf(f, "(");
while (1) {
@ -522,12 +562,14 @@ void print(FILE *f, value_t v)
}
}
// eval -----------------------------------------------------------------------
// eval
// -----------------------------------------------------------------------
static inline void argcount(char *fname, int nargs, int c)
{
if (nargs != c)
lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");
lerror("%s: error: too %s arguments\n", fname,
nargs < c ? "few" : "many");
}
#define eval(e, env) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), env))
@ -544,7 +586,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (issymbol(e)) {
sym = (symbol_t *)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
if (sym->constant != UNBOUND)
return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
@ -556,7 +599,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
if ((unsigned)(char *)&nargs < (unsigned)stack_bottom ||
SP >= (N_STACK - 100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
@ -618,7 +662,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
if ((v = eval(c->car, penv)) != NIL) {
@ -635,7 +680,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = T;
pv = &Stack[saveSP];
v = T;
while (iscons(*pv)) {
if ((v = eval(car_(*pv), penv)) == NIL)
break;
@ -644,7 +690,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
if ((v = eval(car_(*pv), penv)) != NIL)
break;
@ -656,7 +703,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
body = &Stack[SP - 1];
Stack[saveSP] = car_(cdr_(Stack[saveSP]));
value_t *cond = &Stack[saveSP];
PUSH(NIL); pv = &Stack[SP-1];
PUSH(NIL);
pv = &Stack[SP - 1];
while (eval(*cond, penv) != NIL)
*pv = eval(*body, penv);
v = *pv;
@ -664,7 +712,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
v = eval(car_(*pv), penv);
*pv = cdr_(*pv);
@ -680,7 +729,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v = Stack[SP - 1]);
SP=saveSP; return v;
SP = saveSP;
return v;
}
v = cdr_(v);
}
@ -813,7 +863,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
"%s\n",
builtin_names[intval(f)]);
while (iscons(v)) {
PUSH(car_(v));
v = cdr_(v);
@ -825,8 +876,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
}
SP = saveSP;
return v;
}
else {
} else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
@ -872,7 +922,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (!issymbol(asym))
lerror("apply: error: formal argument not a symbol\n");
v = car_(v);
if (!noeval) v = eval(v, penv);
if (!noeval)
v = eval(v, penv);
PUSH(v);
*lenv = cons_(cons(&asym, &Stack[SP - 1]), lenv);
POPN(2);
@ -883,8 +934,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
} else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP - 1];
@ -904,8 +954,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
}
*lenv = cons_(cons(argsyms, &Stack[SP - 2]), lenv);
}
}
else if (iscons(*argsyms)) {
} else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
@ -923,7 +972,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
return NIL;
}
// repl -----------------------------------------------------------------------
// repl
// -----------------------------------------------------------------------
static char *infile = NULL;
@ -933,10 +983,12 @@ value_t load_file(char *fname)
char *lastfile = infile;
FILE *f = fopen(fname, "r");
infile = fname;
if (f == NULL) lerror("file not found\n");
if (f == NULL)
lerror("file not found\n");
while (1) {
e = read_sexpr(f);
if (feof(f)) break;
if (feof(f))
break;
v = eval(e, &NIL);
}
infile = lastfile;
@ -960,13 +1012,18 @@ int main(int argc, char* argv[])
goto repl;
}
load_file("system.lsp");
if (argc > 1) { load_file(argv[1]); return 0; }
printf("Welcome to femtoLisp ----------------------------------------------------------\n");
if (argc > 1) {
load_file(argv[1]);
return 0;
}
printf("Welcome to femtoLisp "
"----------------------------------------------------------\n");
repl:
while (1) {
printf("> ");
v = read_sexpr(stdin);
if (feof(stdin)) break;
if (feof(stdin))
break;
print(stdout, v = eval(v, &NIL));
set(symbol("that"), v);
printf("\n\n");

237
tiny/lisp.c
View File

@ -73,20 +73,51 @@ typedef struct _symbol_t {
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
F_QUOTE = 0,
F_COND,
F_IF,
F_AND,
F_OR,
F_WHILE,
F_LAMBDA,
F_MACRO,
F_LABEL,
F_PROGN,
// functions
F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
F_EQ,
F_ATOM,
F_CONS,
F_CAR,
F_CDR,
F_READ,
F_EVAL,
F_PRINT,
F_SET,
F_NOT,
F_LOAD,
F_SYMBOLP,
F_NUMBERP,
F_ADD,
F_SUB,
F_MUL,
F_DIV,
F_LT,
F_PROG1,
F_APPLY,
F_RPLACA,
F_RPLACD,
F_BOUNDP,
N_BUILTINS
};
#define isspecial(v) (intval(v) <= (int)F_PROGN)
static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",
"progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
"set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp" };
static char *builtin_names[] = {
"quote", "cond", "if", "and", "or", "while", "lambda",
"macro", "label", "progn", "eq", "atom", "cons", "car",
"cdr", "read", "eval", "print", "set", "not", "load",
"symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp"
};
static char *stack_bottom;
#define PROCESS_STACK_SIZE (2 * 1024 * 1024)
@ -104,7 +135,8 @@ void print(FILE *f, value_t v);
value_t eval_sexpr(value_t e, value_t *penv);
value_t load_file(char *fname);
// error utilities ------------------------------------------------------------
// error utilities
// ------------------------------------------------------------
jmp_buf toplevel;
@ -120,10 +152,12 @@ void lerror(char *format, ...)
void type_error(char *fname, char *expected, value_t got)
{
fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
print(stderr, got); lerror("\n");
print(stderr, got);
lerror("\n");
}
// safe cast operators --------------------------------------------------------
// safe cast operators
// --------------------------------------------------------
#define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(value_t v, char *fname) \
@ -137,7 +171,8 @@ SAFECAST_OP(cons, cons_t*, ptr)
SAFECAST_OP(symbol, symbol_t *, ptr)
SAFECAST_OP(number, number_t, numval)
// symbol table ---------------------------------------------------------------
// symbol table
// ---------------------------------------------------------------
static symbol_t *symtab = NULL;
@ -178,7 +213,8 @@ value_t symbol(char *str)
return tagptr(*pnode, TAG_SYM);
}
// initialization -------------------------------------------------------------
// initialization
// -------------------------------------------------------------
static unsigned char *fromspace;
static unsigned char *tospace;
@ -195,8 +231,10 @@ void lisp_init(void)
curheap = fromspace;
lim = curheap + heapsize - sizeof(cons_t);
NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("t"); setc(T, T);
NIL = symbol("nil");
setc(NIL, NIL);
T = symbol("t");
setc(T, T);
LAMBDA = symbol("lambda");
MACRO = symbol("macro");
LABEL = symbol("label");
@ -206,7 +244,8 @@ void lisp_init(void)
setc(symbol("princ"), builtin(F_PRINT));
}
// conses ---------------------------------------------------------------------
// conses
// ---------------------------------------------------------------------
void gc(void);
@ -224,19 +263,22 @@ static value_t mk_cons(void)
static value_t cons_(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
car_(c) = *pcar;
cdr_(c) = *pcdr;
return c;
}
value_t *cons(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
car_(c) = *pcar;
cdr_(c) = *pcdr;
PUSH(c);
return &Stack[SP - 1];
}
// collector ------------------------------------------------------------------
// collector
// ------------------------------------------------------------------
static value_t relocate(value_t v)
{
@ -247,8 +289,10 @@ static value_t relocate(value_t v)
if (car_(v) == UNBOUND)
return cdr_(v);
nc = mk_cons();
a = car_(v); d = cdr_(v);
car_(v) = UNBOUND; cdr_(v) = nc;
a = car_(v);
d = cdr_(v);
car_(v) = UNBOUND;
cdr_(v) = nc;
car_(nc) = relocate(a);
cdr_(nc) = relocate(d);
return nc;
@ -276,7 +320,8 @@ void gc(void)
Stack[i] = relocate(Stack[i]);
trace_globals(symtab);
#ifdef VERBOSEGC
printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);
printf("gc found %d/%d live conses\n", (curheap - tospace) / 8,
heapsize / 8);
#endif
temp = tospace;
tospace = fromspace;
@ -298,11 +343,10 @@ void gc(void)
gc();
}
// read -----------------------------------------------------------------------
// read
// -----------------------------------------------------------------------
enum {
TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
};
enum { TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM };
static int symchar(char c)
{
@ -337,10 +381,7 @@ static char nextchar(FILE *f)
return c;
}
static void take(void)
{
toktype = TOK_NONE;
}
static void take(void) { toktype = TOK_NONE; }
static void accumchar(char c, int *pi)
{
@ -356,23 +397,21 @@ static int read_token(FILE *f, char c)
ungetc(c, f);
while (1) {
ch = fgetc(f); totread++;
ch = fgetc(f);
totread++;
if (ch == EOF)
goto terminate;
c = (char)ch;
if (c == '|') {
escaped = !escaped;
}
else if (c == '\\') {
} else if (c == '\\') {
ch = fgetc(f);
if (ch == EOF)
goto terminate;
accumchar((char)ch, &i);
}
else if (!escaped && !symchar(c)) {
} else if (!escaped && !symchar(c)) {
break;
}
else {
} else {
accumchar(c, &i);
}
}
@ -390,33 +429,28 @@ static u_int32_t peek(FILE *f)
if (toktype != TOK_NONE)
return toktype;
c = nextchar(f);
if (feof(f)) return TOK_NONE;
if (feof(f))
return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
} else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '\'') {
} else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (isdigit(c) || c=='-' || c=='+') {
} else if (isdigit(c) || c == '-' || c == '+') {
read_token(f, c);
x = strtol(buf, &end, 0);
if (*end != '\0') {
toktype = TOK_SYM;
tokval = symbol(buf);
}
else {
} else {
toktype = TOK_NUM;
tokval = number(x);
}
}
else {
} else {
if (read_token(f, c)) {
toktype = TOK_DOT;
}
else {
} else {
toktype = TOK_SYM;
tokval = symbol(buf);
}
@ -438,7 +472,8 @@ static void read_list(FILE *f, value_t *pval)
while (t != TOK_CLOSE) {
if (feof(f))
lerror("read: error: unexpected end of input\n");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
c = mk_cons();
car_(c) = cdr_(c) = NIL;
if (iscons(*pc))
cdr_(*pc) = c;
else
@ -494,17 +529,23 @@ value_t read_sexpr(FILE *f)
return NIL;
}
// print ----------------------------------------------------------------------
// print
// ----------------------------------------------------------------------
void print(FILE *f, value_t v)
{
value_t cd;
switch (tag(v)) {
case TAG_NUM: fprintf(f, "%ld", numval(v)); break;
case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
builtin_names[intval(v)]); break;
case TAG_NUM:
fprintf(f, "%ld", numval(v));
break;
case TAG_SYM:
fprintf(f, "%s", ((symbol_t *)ptr(v))->name);
break;
case TAG_BUILTIN:
fprintf(f, "#<builtin %s>", builtin_names[intval(v)]);
break;
case TAG_CONS:
fprintf(f, "(");
while (1) {
@ -525,18 +566,28 @@ void print(FILE *f, value_t v)
}
}
// eval -----------------------------------------------------------------------
// eval
// -----------------------------------------------------------------------
static inline void argcount(char *fname, int nargs, int c)
{
if (nargs != c)
lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");
lerror("%s: error: too %s arguments\n", fname,
nargs < c ? "few" : "many");
}
#define eval(e, env) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), env))
#define tail_eval(xpr, env) do { SP = saveSP; \
if (tag(xpr)<0x2) { return (xpr); } \
else { e=(xpr); *penv=(env); goto eval_top; } } while (0)
#define tail_eval(xpr, env) \
do { \
SP = saveSP; \
if (tag(xpr) < 0x2) { \
return (xpr); \
} else { \
e = (xpr); \
*penv = (env); \
goto eval_top; \
} \
} while (0)
value_t eval_sexpr(value_t e, value_t *penv)
{
@ -551,7 +602,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
eval_top:
if (issymbol(e)) {
sym = (symbol_t *)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
if (sym->constant != UNBOUND)
return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
@ -563,7 +615,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned long)(char*)&nargs < (unsigned long)stack_bottom || SP>=(N_STACK-100))
if ((unsigned long)(char *)&nargs < (unsigned long)stack_bottom ||
SP >= (N_STACK - 100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
@ -628,7 +681,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car, penv);
@ -651,11 +705,13 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = T;
pv = &Stack[saveSP];
v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v = eval(car_(*pv), penv)) == NIL) {
SP = saveSP; return NIL;
SP = saveSP;
return NIL;
}
*penv = Stack[saveSP + 1];
*pv = cdr_(*pv);
@ -665,11 +721,13 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v = eval(car_(*pv), penv)) != NIL) {
SP = saveSP; return v;
SP = saveSP;
return v;
}
*penv = Stack[saveSP + 1];
*pv = cdr_(*pv);
@ -699,7 +757,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
@ -719,7 +778,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v = Stack[SP - 1]);
SP=saveSP; return v;
SP = saveSP;
return v;
}
v = cdr_(v);
}
@ -853,7 +913,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
"%s\n",
builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
@ -866,8 +927,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
}
SP = saveSP;
return v;
}
else {
} else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
@ -927,8 +987,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
} else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP - 1];
@ -949,8 +1008,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
}
*lenv = cons_(cons(argsyms, &Stack[SP - 2]), lenv);
}
}
else if (iscons(*argsyms)) {
} else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
@ -962,8 +1020,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
lenv = &Stack[SP - 1];
v = eval(*body, lenv);
tail_eval(v, *penv);
}
else {
} else {
tail_eval(*body, *lenv);
}
// not reached
@ -972,7 +1029,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
return NIL;
}
// repl -----------------------------------------------------------------------
// repl
// -----------------------------------------------------------------------
static char *infile = NULL;
@ -992,10 +1050,12 @@ value_t load_file(char *fname)
char *lastfile = infile;
FILE *f = fopen(fname, "r");
infile = fname;
if (f == NULL) lerror("file not found\n");
if (f == NULL)
lerror("file not found\n");
while (1) {
e = read_sexpr(f);
if (feof(f)) break;
if (feof(f))
break;
v = toplevel_eval(e);
}
infile = lastfile;
@ -1019,13 +1079,18 @@ int main(int argc, char* argv[])
goto repl;
}
load_file("system.lsp");
if (argc > 1) { load_file(argv[1]); return 0; }
printf("Welcome to femtoLisp ----------------------------------------------------------\n");
if (argc > 1) {
load_file(argv[1]);
return 0;
}
printf("Welcome to femtoLisp "
"----------------------------------------------------------\n");
repl:
while (1) {
printf("> ");
v = read_sexpr(stdin);
if (feof(stdin)) break;
if (feof(stdin))
break;
print(stdout, v = toplevel_eval(v));
set(symbol("that"), v);
printf("\n\n");

379
tiny/lisp2.c
View File

@ -89,23 +89,57 @@ typedef struct _symbol_t {
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
F_QUOTE = 0,
F_COND,
F_IF,
F_AND,
F_OR,
F_WHILE,
F_LAMBDA,
F_MACRO,
F_LABEL,
F_PROGN,
// functions
F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP,
F_ASSOC, N_BUILTINS
F_EQ,
F_ATOM,
F_CONS,
F_CAR,
F_CDR,
F_READ,
F_EVAL,
F_PRINT,
F_SET,
F_NOT,
F_LOAD,
F_SYMBOLP,
F_NUMBERP,
F_ADD,
F_SUB,
F_MUL,
F_DIV,
F_LT,
F_PROG1,
F_APPLY,
F_RPLACA,
F_RPLACD,
F_BOUNDP,
F_ERROR,
F_EXIT,
F_PRINC,
F_CONSP,
F_ASSOC,
N_BUILTINS
};
#define isspecial(v) (intval(v) <= (number_t)F_PROGN)
static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",
"progn",
"eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
"set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ",
"consp", "assoc" };
static char *builtin_names[] = {
"quote", "cond", "if", "and", "or", "while", "lambda",
"macro", "label", "progn", "eq", "atom", "cons", "car",
"cdr", "read", "eval", "print", "set", "not", "load",
"symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit",
"princ", "consp", "assoc"
};
static char *stack_bottom;
#define PROCESS_STACK_SIZE (2 * 1024 * 1024)
@ -134,7 +168,8 @@ typedef struct _readstate_t {
} readstate_t;
static readstate_t *readstate = NULL;
// error utilities ------------------------------------------------------------
// error utilities
// ------------------------------------------------------------
jmp_buf toplevel;
@ -157,10 +192,12 @@ void lerror(char *format, ...)
void type_error(char *fname, char *expected, value_t got)
{
fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
print(stderr, got, 0); lerror("\n");
print(stderr, got, 0);
lerror("\n");
}
// safe cast operators --------------------------------------------------------
// safe cast operators
// --------------------------------------------------------
#define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(value_t v, char *fname) \
@ -174,7 +211,8 @@ SAFECAST_OP(cons, cons_t*, ptr)
SAFECAST_OP(symbol, symbol_t *, ptr)
SAFECAST_OP(number, number_t, numval)
// symbol table ---------------------------------------------------------------
// symbol table
// ---------------------------------------------------------------
static symbol_t *symtab = NULL;
@ -215,7 +253,8 @@ value_t symbol(char *str)
return tagptr(*pnode, TAG_SYM);
}
// initialization -------------------------------------------------------------
// initialization
// -------------------------------------------------------------
static unsigned char *fromspace;
static unsigned char *tospace;
@ -237,8 +276,10 @@ void lisp_init(void)
ltable_init(&printconses, 32);
NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("t"); setc(T, T);
NIL = symbol("nil");
setc(NIL, NIL);
T = symbol("t");
setc(T, T);
LAMBDA = symbol("lambda");
MACRO = symbol("macro");
LABEL = symbol("label");
@ -251,7 +292,8 @@ void lisp_init(void)
setc(symbol(builtin_names[i]), builtin(i));
}
// conses ---------------------------------------------------------------------
// conses
// ---------------------------------------------------------------------
void gc(int mustgrow);
@ -288,7 +330,8 @@ static value_t cons_reserve(int n)
#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
// collector ------------------------------------------------------------------
// collector
// ------------------------------------------------------------------
static value_t relocate(value_t v)
{
@ -305,7 +348,8 @@ static value_t relocate(value_t v)
}
*pcdr = nc = mk_cons();
d = cdr_(v);
car_(v) = UNBOUND; cdr_(v) = nc;
car_(v) = UNBOUND;
cdr_(v) = nc;
car_(nc) = relocate(a);
pcdr = &cdr_(nc);
v = d;
@ -361,8 +405,7 @@ void gc(int mustgrow)
tospace = temp;
if (!grew) {
heapsize *= 2;
}
else {
} else {
temp = bitvector_resize(consflags, heapsize / sizeof(cons_t));
if (temp == NULL)
lerror("out of memory\n");
@ -374,12 +417,25 @@ void gc(int mustgrow)
gc(0);
}
// read -----------------------------------------------------------------------
// read
// -----------------------------------------------------------------------
enum {
TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE
TOK_NONE,
TOK_OPEN,
TOK_CLOSE,
TOK_DOT,
TOK_QUOTE,
TOK_SYM,
TOK_NUM,
TOK_BQ,
TOK_COMMA,
TOK_COMMAAT,
TOK_COMMADOT,
TOK_SHARPDOT,
TOK_LABEL,
TOK_BACKREF,
TOK_SHARPQUOTE
};
// defines which characters are ordinary symbol characters.
@ -418,10 +474,7 @@ static char nextchar(FILE *f)
return c;
}
static void take(void)
{
toktype = TOK_NONE;
}
static void take(void) { toktype = TOK_NONE; }
static void accumchar(char c, int *pi)
{
@ -437,23 +490,21 @@ static int read_token(FILE *f, char c, int digits)
ungetc(c, f);
while (1) {
ch = fgetc(f); totread++;
ch = fgetc(f);
totread++;
if (ch == EOF)
goto terminate;
c = (char)ch;
if (c == '|') {
escaped = !escaped;
}
else if (c == '\\') {
} else if (c == '\\') {
ch = fgetc(f);
if (ch == EOF)
goto terminate;
accumchar((char)ch, &i);
}
else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
} else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
break;
}
else {
} else {
accumchar(c, &i);
}
}
@ -472,35 +523,29 @@ static u_int32_t peek(FILE *f)
if (toktype != TOK_NONE)
return toktype;
c = nextchar(f);
if (feof(f)) return TOK_NONE;
if (feof(f))
return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
} else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '\'') {
} else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (c == '`') {
} else if (c == '`') {
toktype = TOK_BQ;
}
else if (c == '#') {
} else if (c == '#') {
ch = fgetc(f);
if (ch == EOF)
lerror("read: error: invalid read macro\n");
if ((char)ch == '.') {
toktype = TOK_SHARPDOT;
}
else if ((char)ch == '\'') {
} else if ((char)ch == '\'') {
toktype = TOK_SHARPQUOTE;
}
else if ((char)ch == '\\') {
} else if ((char)ch == '\\') {
u_int32_t cval = u8_fgetc(f);
toktype = TOK_NUM;
tokval = number(cval);
}
else if (isdigit((char)ch)) {
} else if (isdigit((char)ch)) {
read_token(f, (char)ch, 1);
c = (char)fgetc(f);
if (c == '#')
@ -511,12 +556,10 @@ static u_int32_t peek(FILE *f)
lerror("read: error: invalid label\n");
x = strtol(buf, &end, 10);
tokval = number(x);
}
else {
} else {
lerror("read: error: unknown read macro\n");
}
}
else if (c == ',') {
} else if (c == ',') {
toktype = TOK_COMMA;
ch = fgetc(f);
if (ch == EOF)
@ -527,24 +570,20 @@ static u_int32_t peek(FILE *f)
toktype = TOK_COMMADOT;
else
ungetc((char)ch, f);
}
else if (isdigit(c) || c=='-' || c=='+') {
} else if (isdigit(c) || c == '-' || c == '+') {
read_token(f, c, 0);
x = strtol(buf, &end, 0);
if (*end != '\0') {
toktype = TOK_SYM;
tokval = symbol(buf);
}
else {
} else {
toktype = TOK_NUM;
tokval = number(x);
}
}
else {
} else {
if (read_token(f, c, 0)) {
toktype = TOK_DOT;
}
else {
} else {
toktype = TOK_SYM;
tokval = symbol(buf);
}
@ -568,17 +607,18 @@ static void read_list(FILE *f, value_t *pval, int fixup)
while (t != TOK_CLOSE) {
if (feof(f))
lerror("read: error: unexpected end of input\n");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
c = mk_cons();
car_(c) = cdr_(c) = NIL;
if (iscons(*pc)) {
cdr_(*pc) = c;
}
else {
} else {
*pval = c;
if (fixup != -1)
readstate->exprs.items[fixup] = c;
}
*pc = c;
c = do_read_sexpr(f,-1); // must be on separate lines due to undefined
c =
do_read_sexpr(f, -1); // must be on separate lines due to undefined
car_(*pc) = c; // evaluation order
t = peek(f);
@ -615,13 +655,17 @@ static value_t do_read_sexpr(FILE *f, int fixup)
case TOK_NUM:
return tokval;
case TOK_COMMA:
head = &COMMA; goto listwith;
head = &COMMA;
goto listwith;
case TOK_COMMAAT:
head = &COMMAAT; goto listwith;
head = &COMMAAT;
goto listwith;
case TOK_COMMADOT:
head = &COMMADOT; goto listwith;
head = &COMMADOT;
goto listwith;
case TOK_BQ:
head = &BACKQUOTE; goto listwith;
head = &BACKQUOTE;
goto listwith;
case TOK_QUOTE:
head = &QUOTE;
listwith:
@ -644,8 +688,8 @@ static value_t do_read_sexpr(FILE *f, int fixup)
return POP();
case TOK_SHARPDOT:
// eval-when-read
// evaluated expressions can refer to existing backreferences, but they
// cannot see pending labels. in other words:
// evaluated expressions can refer to existing backreferences, but
// they cannot see pending labels. in other words:
// (... #2=#.#0# ... ) OK
// (... #2=#.(#2#) ... ) DO NOT WANT
v = do_read_sexpr(f, -1);
@ -690,7 +734,8 @@ value_t read_sexpr(FILE *f)
return v;
}
// print ----------------------------------------------------------------------
// print
// ----------------------------------------------------------------------
static void print_traverse(value_t v)
{
@ -742,12 +787,10 @@ static void print_symbol(FILE *f, char *name)
i++;
}
fprintf(f, "|");
}
else {
} else {
fprintf(f, "|%s|", name);
}
}
else {
} else {
fprintf(f, "%s", name);
}
}
@ -759,7 +802,9 @@ static void do_print(FILE *f, value_t v, int princ)
char *name;
switch (tag(v)) {
case TAG_NUM: fprintf(f, "%d", numval(v)); break;
case TAG_NUM:
fprintf(f, "%d", numval(v));
break;
case TAG_SYM:
name = ((symbol_t *)ptr(v))->name;
if (princ)
@ -767,7 +812,9 @@ static void do_print(FILE *f, value_t v, int princ)
else
print_symbol(f, name);
break;
case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break;
case TAG_BUILTIN:
fprintf(f, "#.%s", builtin_names[intval(v)]);
break;
case TAG_CONS:
if ((label = ltable_lookup(&printconses, v)) != NOTFOUND) {
if (!ismarked(v)) {
@ -788,8 +835,7 @@ static void do_print(FILE *f, value_t v, int princ)
}
fprintf(f, ")");
break;
}
else {
} else {
if ((label = ltable_lookup(&printconses, cd)) != NOTFOUND) {
fprintf(f, " . ");
do_print(f, cd, princ);
@ -811,12 +857,14 @@ void print(FILE *f, value_t v, int princ)
do_print(f, v, princ);
}
// eval -----------------------------------------------------------------------
// eval
// -----------------------------------------------------------------------
static inline void argcount(char *fname, int nargs, int c)
{
if (nargs != c)
lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");
lerror("%s: error: too %s arguments\n", fname,
nargs < c ? "few" : "many");
}
// return a cons element of v whose car is item
@ -835,9 +883,16 @@ static value_t assoc(value_t item, value_t v)
#define eval(e) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), penv, 0, envend))
#define topeval(e, env) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), env, 1, SP))
#define tail_eval(xpr) do { SP = saveSP; \
if (tag(xpr)<0x2) { return (xpr); } \
else { e=(xpr); goto eval_top; } } while (0)
#define tail_eval(xpr) \
do { \
SP = saveSP; \
if (tag(xpr) < 0x2) { \
return (xpr); \
} else { \
e = (xpr); \
goto eval_top; \
} \
} while (0)
/* stack setup on entry:
n n+1 ...
@ -868,7 +923,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
eval_top:
if (issymbol(e)) {
sym = (symbol_t *)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
if (sym->constant != UNBOUND)
return sym->constant;
while (issymbol(*penv)) { // 1. try lookup in argument env
if (*penv == NIL)
goto get_global;
@ -883,14 +939,18 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
if ((unsigned)(char *)&nargs < (unsigned)stack_bottom ||
SP >= (N_STACK - 100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
v = car_(e);
if (tag(v)<0x2) f = v;
else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ;
else f = eval_sexpr(v, penv, 0, envend);
if (tag(v) < 0x2)
f = v;
else if (issymbol(v) && (f = ((symbol_t *)ptr(v))->constant) != UNBOUND)
;
else
f = eval_sexpr(v, penv, 0, envend);
if (isbuiltin(f)) {
// handle builtin function
if (!isspecial(f)) {
@ -908,7 +968,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
// special forms
case F_QUOTE:
v = cdr_(Stack[saveSP]);
if (!iscons(v)) lerror("quote: error: expected argument\n");
if (!iscons(v))
lerror("quote: error: expected argument\n");
v = car_(v);
break;
case F_MACRO:
@ -928,7 +989,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
(c + 1)->car = penv[0];
(c + 1)->cdr = penv[1];
nargs--;
if (nargs==0) break;
if (nargs == 0)
break;
penv += 2;
c->cdr = tagptr(c + 2, TAG_CONS);
c += 2;
@ -939,8 +1001,7 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
// the new representation so everybody can see it
*lenv = Stack[SP - 1];
}
}
else {
} else {
PUSH(*penv); // env has already been captured; share
}
v = cdr_(Stack[saveSP]);
@ -948,9 +1009,11 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
PUSH(car(cdr_(v)));
c = (cons_t *)ptr(v = cons_reserve(3));
c->car = (intval(f) == F_LAMBDA ? LAMBDA : MACRO);
c->cdr = tagptr(c+1, TAG_CONS); c++;
c->cdr = tagptr(c + 1, TAG_CONS);
c++;
c->car = Stack[SP - 2]; // argsyms
c->cdr = tagptr(c+1, TAG_CONS); c++;
c->cdr = tagptr(c + 1, TAG_CONS);
c++;
c->car = Stack[SP - 1]; // body
c->cdr = Stack[SP - 3]; // env
break;
@ -964,7 +1027,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
*body = eval(*body); // evaluate lambda
c = (cons_t *)ptr(cons_reserve(2));
c->car = Stack[SP - 2]; // name
c->cdr = v = *body; c++;
c->cdr = v = *body;
c++;
c->car = tagptr(c - 1, TAG_CONS);
f = cdr(cdr(v));
c->cdr = cdr(f);
@ -981,7 +1045,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car);
@ -1002,11 +1067,13 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = T;
pv = &Stack[saveSP];
v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v = eval(car_(*pv))) == NIL) {
SP = saveSP; return NIL;
SP = saveSP;
return NIL;
}
*pv = cdr_(*pv);
}
@ -1015,11 +1082,13 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v = eval(car_(*pv))) != NIL) {
SP = saveSP; return v;
SP = saveSP;
return v;
}
*pv = cdr_(*pv);
}
@ -1046,7 +1115,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv));
@ -1065,13 +1135,15 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
goto set_global;
if (*penv == e) {
penv[1] = Stack[SP - 1];
SP=saveSP; return penv[1];
SP = saveSP;
return penv[1];
}
penv += 2;
}
if ((v = assoc(e, *penv)) != NIL) {
cdr_(v) = (e = Stack[SP - 1]);
SP=saveSP; return e;
SP = saveSP;
return e;
}
set_global:
tosymbol(e, "set")->binding = (v = Stack[SP - 1]);
@ -1135,7 +1207,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
v = number(s);
break;
case F_SUB:
if (nargs < 1) lerror("-: error: too few arguments\n");
if (nargs < 1)
lerror("-: error: too few arguments\n");
i = saveSP + 1;
s = (nargs == 1) ? 0 : tonumber(Stack[i++], "-");
for (; i < (int)SP; i++) {
@ -1153,12 +1226,14 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
v = number(s);
break;
case F_DIV:
if (nargs < 1) lerror("/: error: too few arguments\n");
if (nargs < 1)
lerror("/: error: too few arguments\n");
i = saveSP + 1;
s = (nargs == 1) ? 1 : tonumber(Stack[i++], "/");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "/");
if (n == 0) lerror("/: error: division by zero\n");
if (n == 0)
lerror("/: error: division by zero\n");
s /= n;
}
v = number(s);
@ -1171,19 +1246,21 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
// ordering: number < builtin < symbol < cons
if (tag(Stack[SP - 2]) != tag(Stack[SP - 1])) {
v = (tag(Stack[SP - 2]) < tag(Stack[SP - 1]) ? T : NIL);
}
else {
} else {
switch (tag(Stack[SP - 2])) {
case TAG_NUM:
v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
v =
(numval(Stack[SP - 2]) < numval(Stack[SP - 1])) ? T : NIL;
break;
case TAG_SYM:
v = (strcmp(((symbol_t *)ptr(Stack[SP - 2]))->name,
((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ?
T : NIL;
((symbol_t *)ptr(Stack[SP - 1]))->name) < 0)
? T
: NIL;
break;
case TAG_BUILTIN:
v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL;
v =
(intval(Stack[SP - 2]) < intval(Stack[SP - 1])) ? T : NIL;
break;
case TAG_CONS:
lerror("<: error: expected atom\n");
@ -1197,13 +1274,16 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
case F_EVAL:
argcount("eval", nargs, 1);
v = Stack[SP - 1];
if (tag(v)<0x2) { SP=saveSP; return v; }
if (tag(v) < 0x2) {
SP = saveSP;
return v;
}
if (tail) {
*penv = NIL;
envend = SP = (u_int32_t)(penv - &Stack[0]) + 1;
e=v; goto eval_top;
}
else {
e = v;
goto eval_top;
} else {
PUSH(NIL);
v = eval_sexpr(v, &Stack[SP - 1], 1, SP);
}
@ -1235,7 +1315,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
break;
case F_PROG1:
// return first arg
if (nargs < 1) lerror("prog1: error: too few arguments\n");
if (nargs < 1)
lerror("prog1: error: too few arguments\n");
v = Stack[saveSP + 1];
break;
case F_ASSOC:
@ -1250,7 +1331,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
"%s\n",
builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
@ -1263,8 +1345,7 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
}
SP = saveSP;
return v;
}
else {
} else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
@ -1306,8 +1387,7 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
PUSH(*argsyms);
if (noeval) {
PUSH(Stack[saveSP]);
}
else {
} else {
// this version uses collective allocation. about 7-10%
// faster for lists with > 2 elements, but uses more
// stack space
@ -1330,8 +1410,7 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
POPN(nargs);
}
}
}
else if (iscons(*argsyms)) {
} else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
@ -1341,14 +1420,19 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
e = car_(Stack[saveSP + 1]);
// macro: evaluate expansion in the calling environment
if (headsym == MACRO) {
if (tag(e)<0x2) ;
else e = eval_sexpr(e, argenv, 1, SP);
if (tag(e) < 0x2)
;
else
e = eval_sexpr(e, argenv, 1, SP);
SP = saveSP;
if (tag(e)<0x2) return(e);
if (tag(e) < 0x2)
return (e);
goto eval_top;
} else {
if (tag(e) < 0x2) {
SP = saveSP;
return (e);
}
else {
if (tag(e)<0x2) { SP=saveSP; return(e); }
if (tail) {
// ok to overwrite environment
nargs = (int)(&Stack[SP] - argenv);
@ -1356,8 +1440,7 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
penv[i] = argenv[i];
envend = SP = (u_int32_t)((penv + nargs) - &Stack[0]);
goto eval_top;
}
else {
} else {
v = eval_sexpr(e, argenv, 1, SP);
SP = saveSP;
return v;
@ -1369,7 +1452,8 @@ value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
return NIL;
}
// repl -----------------------------------------------------------------------
// repl
// -----------------------------------------------------------------------
static char *infile = NULL;
@ -1389,10 +1473,12 @@ value_t load_file(char *fname)
char *lastfile = infile;
FILE *f = fopen(fname, "r");
infile = fname;
if (f == NULL) lerror("file not found\n");
if (f == NULL)
lerror("file not found\n");
while (1) {
e = read_sexpr(f);
if (feof(f)) break;
if (feof(f))
break;
v = toplevel_eval(e);
}
infile = lastfile;
@ -1416,16 +1502,21 @@ int main(int argc, char* argv[])
goto repl;
}
load_file("system.lsp");
if (argc > 1) { load_file(argv[1]); return 0; }
if (argc > 1) {
load_file(argv[1]);
return 0;
}
printf("; _ \n");
printf("; |_ _ _ |_ _ | . _ _ 2\n");
printf("; | (-||||_(_)|__|_)|_)\n");
printf(";-------------------|----------------------------------------------------------\n\n");
printf(";-------------------|--------------------------------------------"
"--------------\n\n");
repl:
while (1) {
printf("> ");
v = read_sexpr(stdin);
if (feof(stdin)) break;
if (feof(stdin))
break;
print(stdout, v = toplevel_eval(v), 0);
set(symbol("that"), v);
printf("\n\n");

240
tiny/lispf.c
View File

@ -88,20 +88,51 @@ extern float strtof(const char *nptr, char **endptr);
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
F_QUOTE = 0,
F_COND,
F_IF,
F_AND,
F_OR,
F_WHILE,
F_LAMBDA,
F_MACRO,
F_LABEL,
F_PROGN,
// functions
F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
F_EQ,
F_ATOM,
F_CONS,
F_CAR,
F_CDR,
F_READ,
F_EVAL,
F_PRINT,
F_SET,
F_NOT,
F_LOAD,
F_SYMBOLP,
F_NUMBERP,
F_ADD,
F_SUB,
F_MUL,
F_DIV,
F_LT,
F_PROG1,
F_APPLY,
F_RPLACA,
F_RPLACD,
F_BOUNDP,
N_BUILTINS
};
#define isspecial(v) (intval(v) <= (int)F_PROGN)
static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",
"progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
"set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp" };
static char *builtin_names[] = {
"quote", "cond", "if", "and", "or", "while", "lambda",
"macro", "label", "progn", "eq", "atom", "cons", "car",
"cdr", "read", "eval", "print", "set", "not", "load",
"symbolp", "numberp", "+", "-", "*", "/", "<",
"prog1", "apply", "rplaca", "rplacd", "boundp"
};
static char *stack_bottom;
#define PROCESS_STACK_SIZE (2 * 1024 * 1024)
@ -119,7 +150,8 @@ void print(FILE *f, value_t v);
value_t eval_sexpr(value_t e, value_t *penv);
value_t load_file(char *fname);
// error utilities ------------------------------------------------------------
// error utilities
// ------------------------------------------------------------
jmp_buf toplevel;
@ -135,10 +167,12 @@ void lerror(char *format, ...)
void type_error(char *fname, char *expected, value_t got)
{
fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
print(stderr, got); lerror("\n");
print(stderr, got);
lerror("\n");
}
// safe cast operators --------------------------------------------------------
// safe cast operators
// --------------------------------------------------------
#define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(value_t v, char *fname) \
@ -152,7 +186,8 @@ SAFECAST_OP(cons, cons_t*, ptr)
SAFECAST_OP(symbol, symbol_t *, ptr)
SAFECAST_OP(number, number_t, numval)
// symbol table ---------------------------------------------------------------
// symbol table
// ---------------------------------------------------------------
static symbol_t *symtab = NULL;
@ -193,7 +228,8 @@ value_t symbol(char *str)
return tagptr(*pnode, TAG_SYM);
}
// initialization -------------------------------------------------------------
// initialization
// -------------------------------------------------------------
static unsigned char *fromspace;
static unsigned char *tospace;
@ -210,8 +246,10 @@ void lisp_init(void)
curheap = fromspace;
lim = curheap + heapsize - sizeof(cons_t);
NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("t"); setc(T, T);
NIL = symbol("nil");
setc(NIL, NIL);
T = symbol("t");
setc(T, T);
LAMBDA = symbol("lambda");
MACRO = symbol("macro");
LABEL = symbol("label");
@ -221,7 +259,8 @@ void lisp_init(void)
setc(symbol("princ"), builtin(F_PRINT));
}
// conses ---------------------------------------------------------------------
// conses
// ---------------------------------------------------------------------
void gc(void);
@ -239,19 +278,22 @@ static value_t mk_cons(void)
static value_t cons_(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
car_(c) = *pcar;
cdr_(c) = *pcdr;
return c;
}
value_t *cons(value_t *pcar, value_t *pcdr)
{
value_t c = mk_cons();
car_(c) = *pcar; cdr_(c) = *pcdr;
car_(c) = *pcar;
cdr_(c) = *pcdr;
PUSH(c);
return &Stack[SP - 1];
}
// collector ------------------------------------------------------------------
// collector
// ------------------------------------------------------------------
static value_t relocate(value_t v)
{
@ -261,9 +303,12 @@ static value_t relocate(value_t v)
return v;
if (car_(v) == UNBOUND)
return cdr_(v);
nc = mk_cons(); car_(nc) = NIL;
a = car_(v); d = cdr_(v);
car_(v) = UNBOUND; cdr_(v) = nc;
nc = mk_cons();
car_(nc) = NIL;
a = car_(v);
d = cdr_(v);
car_(v) = UNBOUND;
cdr_(v) = nc;
car_(nc) = relocate(a);
cdr_(nc) = relocate(d);
return nc;
@ -291,7 +336,8 @@ void gc(void)
Stack[i] = relocate(Stack[i]);
trace_globals(symtab);
#ifdef VERBOSEGC
printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);
printf("gc found %d/%d live conses\n", (curheap - tospace) / 8,
heapsize / 8);
#endif
temp = tospace;
tospace = fromspace;
@ -313,11 +359,10 @@ void gc(void)
gc();
}
// read -----------------------------------------------------------------------
// read
// -----------------------------------------------------------------------
enum {
TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
};
enum { TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM };
static int symchar(char c)
{
@ -352,10 +397,7 @@ static char nextchar(FILE *f)
return c;
}
static void take(void)
{
toktype = TOK_NONE;
}
static void take(void) { toktype = TOK_NONE; }
static void accumchar(char c, int *pi)
{
@ -376,17 +418,14 @@ static int read_token(FILE *f, char c)
c = (char)ch;
if (c == '|') {
escaped = !escaped;
}
else if (c == '\\') {
} else if (c == '\\') {
ch = fgetc(f);
if (ch == EOF)
goto terminate;
accumchar((char)ch, &i);
}
else if (!escaped && !symchar(c)) {
} else if (!escaped && !symchar(c)) {
break;
}
else {
} else {
accumchar(c, &i);
}
}
@ -404,36 +443,31 @@ static u_int32_t peek(FILE *f)
if (toktype != TOK_NONE)
return toktype;
c = nextchar(f);
if (feof(f)) return TOK_NONE;
if (feof(f))
return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
} else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '\'') {
} else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (isdigit(c) || c=='-') {
} else if (isdigit(c) || c == '-') {
read_token(f, c);
if (buf[0] == '-' && !isdigit(buf[1])) {
toktype = TOK_SYM;
tokval = symbol(buf);
}
else {
} else {
x = strtonum(buf, &end);
if (*end != '\0')
lerror("read: error: invalid constant\n");
toktype = TOK_NUM;
tokval = number(x);
}
}
else {
} else {
read_token(f, c);
if (!strcmp(buf, ".")) {
toktype = TOK_DOT;
}
else {
} else {
toktype = TOK_SYM;
tokval = symbol(buf);
}
@ -455,7 +489,8 @@ static void read_list(FILE *f, value_t *pval)
while (t != TOK_CLOSE) {
if (feof(f))
lerror("read: error: unexpected end of input\n");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
c = mk_cons();
car_(c) = cdr_(c) = NIL;
if (iscons(*pc))
cdr_(*pc) = c;
else
@ -511,17 +546,23 @@ value_t read_sexpr(FILE *f)
return NIL;
}
// print ----------------------------------------------------------------------
// print
// ----------------------------------------------------------------------
void print(FILE *f, value_t v)
{
value_t cd;
switch (tag(v)) {
case TAG_NUM: fprintf(f, NUM_FORMAT, numval(v)); break;
case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
builtin_names[intval(v)]); break;
case TAG_NUM:
fprintf(f, NUM_FORMAT, numval(v));
break;
case TAG_SYM:
fprintf(f, "%s", ((symbol_t *)ptr(v))->name);
break;
case TAG_BUILTIN:
fprintf(f, "#<builtin %s>", builtin_names[intval(v)]);
break;
case TAG_CONS:
fprintf(f, "(");
while (1) {
@ -542,18 +583,28 @@ void print(FILE *f, value_t v)
}
}
// eval -----------------------------------------------------------------------
// eval
// -----------------------------------------------------------------------
static inline void argcount(char *fname, int nargs, int c)
{
if (nargs != c)
lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");
lerror("%s: error: too %s arguments\n", fname,
nargs < c ? "few" : "many");
}
#define eval(e, penv) ((tag(e) < 0x2) ? (e) : eval_sexpr((e), penv))
#define tail_eval(xpr, env) do { SP = saveSP; \
if (tag(xpr)<0x2) { return (xpr); } \
else { e=(xpr); *penv=(env); goto eval_top; } } while (0)
#define tail_eval(xpr, env) \
do { \
SP = saveSP; \
if (tag(xpr) < 0x2) { \
return (xpr); \
} else { \
e = (xpr); \
*penv = (env); \
goto eval_top; \
} \
} while (0)
value_t eval_sexpr(value_t e, value_t *penv)
{
@ -568,7 +619,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
eval_top:
if (issymbol(e)) {
sym = (symbol_t *)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
if (sym->constant != UNBOUND)
return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
@ -580,7 +632,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
if ((unsigned)(char *)&nargs < (unsigned)stack_bottom ||
SP >= (N_STACK - 100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
@ -645,7 +698,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car, penv);
@ -668,11 +722,13 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = T;
pv = &Stack[saveSP];
v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v = eval(car_(*pv), penv)) == NIL) {
SP = saveSP; return NIL;
SP = saveSP;
return NIL;
}
*penv = Stack[saveSP + 1];
*pv = cdr_(*pv);
@ -682,11 +738,13 @@ value_t eval_sexpr(value_t e, value_t *penv)
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v = eval(car_(*pv), penv)) != NIL) {
SP = saveSP; return v;
SP = saveSP;
return v;
}
*penv = Stack[saveSP + 1];
*pv = cdr_(*pv);
@ -699,7 +757,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
body = &Stack[SP - 1];
Stack[saveSP] = car_(cdr_(Stack[saveSP]));
value_t *cond = &Stack[saveSP];
PUSH(NIL); pv = &Stack[SP-1];
PUSH(NIL);
pv = &Stack[SP - 1];
while (eval(*cond, penv) != NIL) {
*penv = Stack[saveSP + 1];
*pv = eval(*body, penv);
@ -710,7 +769,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP]; v = NIL;
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
@ -730,7 +790,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v = Stack[SP - 1]);
SP=saveSP; return v;
SP = saveSP;
return v;
}
v = cdr_(v);
}
@ -863,7 +924,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
"%s\n",
builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
@ -876,8 +938,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
}
SP = saveSP;
return v;
}
else {
} else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
@ -937,8 +998,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
} else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP - 1];
@ -959,8 +1019,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
}
*lenv = cons_(cons(argsyms, &Stack[SP - 2]), lenv);
}
}
else if (iscons(*argsyms)) {
} else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
@ -972,8 +1031,7 @@ value_t eval_sexpr(value_t e, value_t *penv)
lenv = &Stack[SP - 1];
v = eval(*body, lenv);
tail_eval(v, *penv);
}
else {
} else {
tail_eval(*body, *lenv);
}
// not reached
@ -982,7 +1040,8 @@ value_t eval_sexpr(value_t e, value_t *penv)
return NIL;
}
// repl -----------------------------------------------------------------------
// repl
// -----------------------------------------------------------------------
static char *infile = NULL;
@ -1001,10 +1060,12 @@ value_t load_file(char *fname)
char *lastfile = infile;
FILE *f = fopen(fname, "r");
infile = fname;
if (f == NULL) lerror("file not found\n");
if (f == NULL)
lerror("file not found\n");
while (1) {
e = read_sexpr(f);
if (feof(f)) break;
if (feof(f))
break;
v = toplevel_eval(e);
}
infile = lastfile;
@ -1028,13 +1089,18 @@ int main(int argc, char* argv[])
goto repl;
}
load_file("system.lsp");
if (argc > 1) { load_file(argv[1]); return 0; }
printf("Welcome to femtoLisp ----------------------------------------------------------\n");
if (argc > 1) {
load_file(argv[1]);
return 0;
}
printf("Welcome to femtoLisp "
"----------------------------------------------------------\n");
repl:
while (1) {
printf("> ");
v = read_sexpr(stdin);
if (feof(stdin)) break;
if (feof(stdin))
break;
print(stdout, v = toplevel_eval(v));
set(symbol("that"), v);
printf("\n\n");

15
types.c
View File

@ -12,13 +12,13 @@ fltype_t *get_type(value_t t)
if (*bp != HT_NOTFOUND)
return *bp;
int align, isarray=(iscons(t) && car_(t) == arraysym && iscons(cdr_(t)));
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 {
} else {
sz = ctype_sizeof(t, &align);
}
@ -27,8 +27,7 @@ fltype_t *get_type(value_t t)
if (issymbol(t)) {
ft->numtype = sym_to_numtype(t);
((symbol_t *)ptr(t))->type = ft;
}
else {
} else {
ft->numtype = N_NUMTYPES;
}
ft->size = sz;
@ -48,9 +47,9 @@ fltype_t *get_type(value_t t)
ft->elsz = eltype->size;
ft->eltype = eltype;
ft->init = &cvalue_array_init;
//eltype->artype = ft; -- this is a bad idea since some types carry array sizes
}
else if (car_(t) == enumsym) {
// eltype->artype = ft; -- this is a bad idea since some types
// carry array sizes
} else if (car_(t) == enumsym) {
ft->numtype = T_INT32;
ft->init = &cvalue_enum_init;
}