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

540
cvalues.c
View File

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

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); return eq_class(table, c);
} }
static void eq_union(htable_t *table, value_t a, value_t b, static void eq_union(htable_t *table, value_t a, value_t b, value_t c,
value_t c, value_t cb) value_t cb)
{ {
value_t ca = (c == NIL ? a : c); value_t ca = (c == NIL ? a : c);
if (cb != NIL) 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 la = vector_size(a);
size_t lb = vector_size(b); size_t lb = vector_size(b);
size_t m, i; size_t m, i;
if (eq && (la!=lb)) return fixnum(1); if (eq && (la != lb))
return fixnum(1);
m = la < lb ? la : lb; m = la < lb ? la : lb;
for (i = 0; i < m; i++) { for (i = 0; i < m; i++) {
value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i), value_t d =
bound-1, eq); bounded_compare(vector_elt(a, i), vector_elt(b, i), bound - 1, eq);
if (d==NIL || numval(d)!=0) return d; if (d == NIL || numval(d) != 0)
return d;
} }
if (la < lb) return fixnum(-1); if (la < lb)
if (la > lb) return fixnum(1); return fixnum(-1);
if (la > lb)
return fixnum(1);
return fixnum(0); 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; value_t d;
compare_top: compare_top:
if (a == b) return fixnum(0); if (a == b)
return fixnum(0);
if (bound <= 0) if (bound <= 0)
return NIL; return NIL;
int taga = tag(a); 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); return fixnum(-1);
case TAG_SYM: case TAG_SYM:
if (eq) return fixnum(1); if (eq)
if (tagb < TAG_SYM) return fixnum(1); return fixnum(1);
if (tagb > TAG_SYM) 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))); return fixnum(strcmp(symbol_name(a), symbol_name(b)));
case TAG_VECTOR: case TAG_VECTOR:
if (isvector(b)) 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 (cp_class((cprim_t *)ptr(a)) == wchartype) {
if (!iscprim(b) || cp_class((cprim_t *)ptr(b)) != wchartype) if (!iscprim(b) || cp_class((cprim_t *)ptr(b)) != wchartype)
return fixnum(-1); 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); return fixnum(1);
} }
c = numeric_compare(a, b, eq, 1, NULL); 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 *fa = (function_t *)ptr(a);
function_t *fb = (function_t *)ptr(b); function_t *fb = (function_t *)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, bound - 1, eq); 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); 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); 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 fixnum(0);
} }
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1); return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
} }
break; break;
case TAG_CONS: 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); d = bounded_compare(car_(a), car_(b), bound - 1, eq);
if (d==NIL || numval(d) != 0) return d; if (d == NIL || numval(d) != 0)
a = cdr_(a); b = cdr_(b); return d;
a = cdr_(a);
b = cdr_(b);
bound--; bound--;
goto compare_top; 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; value_t d, xa, xb, ca, cb;
// first try to prove them different with no recursion // 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; m = la < lb ? la : lb;
for (i = 0; i < m; i++) { for (i = 0; i < m; i++) {
xa = vector_elt(a, i); xa = vector_elt(a, i);
xb = vector_elt(b, i); xb = vector_elt(b, i);
if (leafp(xa) || leafp(xb)) { if (leafp(xa) || leafp(xb)) {
d = bounded_compare(xa, xb, 1, eq); d = bounded_compare(xa, xb, 1, eq);
if (d!=NIL && numval(d)!=0) return d; if (d != NIL && numval(d) != 0)
} return d;
else if (tag(xa) < tag(xb)) { } else if (tag(xa) < tag(xb)) {
return fixnum(-1); return fixnum(-1);
} } else if (tag(xa) > tag(xb)) {
else if (tag(xa) > tag(xb)) {
return fixnum(1); 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)
if (la > lb) return fixnum(1); return fixnum(-1);
if (la > lb)
return fixnum(1);
return fixnum(0); 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); return fixnum(0);
if (iscons(a)) { if (iscons(a)) {
if (iscons(b)) { if (iscons(b)) {
value_t aa = car_(a); value_t da = cdr_(a); value_t aa = car_(a);
value_t ab = car_(b); value_t db = cdr_(b); value_t da = cdr_(a);
int tagaa = tag(aa); int tagda = tag(da); value_t ab = car_(b);
int tagab = tag(ab); int tagdb = tag(db); 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)) { if (leafp(aa) || leafp(ab)) {
d = bounded_compare(aa, ab, 1, eq); d = bounded_compare(aa, ab, 1, eq);
if (d!=NIL && numval(d)!=0) return d; if (d != NIL && numval(d) != 0)
} return d;
else if (tagaa < tagab) } else if (tagaa < tagab)
return fixnum(-1); return fixnum(-1);
else if (tagaa > tagab) else if (tagaa > tagab)
return fixnum(1); return fixnum(1);
if (leafp(da) || leafp(db)) { if (leafp(da) || leafp(db)) {
d = bounded_compare(da, db, 1, eq); d = bounded_compare(da, db, 1, eq);
if (d!=NIL && numval(d)!=0) return d; if (d != NIL && numval(d) != 0)
} return d;
else if (tagda < tagdb) } else if (tagda < tagdb)
return fixnum(-1); return fixnum(-1);
else if (tagda > tagdb) else if (tagda > tagdb)
return fixnum(1); 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); eq_union(table, a, b, ca, cb);
d = cyc_compare(aa, ab, table, eq); d = cyc_compare(aa, ab, table, eq);
if (numval(d)!=0) return d; if (numval(d) != 0)
return d;
a = da; a = da;
b = db; b = db;
goto cyc_compare_top; goto cyc_compare_top;
} } else {
else {
return fixnum(1); return fixnum(1);
} }
} } else if (isvector(a) && isvector(b)) {
else if (isvector(a) && isvector(b)) {
return cyc_vector_compare(a, b, table, eq); 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 *fa = (function_t *)ptr(a);
function_t *fb = (function_t *)ptr(b); function_t *fb = (function_t *)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, 1, eq); 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); ca = eq_class(table, a);
cb = eq_class(table, b); 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); eq_union(table, a, b, ca, cb);
d = cyc_compare(fa->vals, fb->vals, table, eq); d = cyc_compare(fa->vals, fb->vals, table, eq);
if (numval(d) != 0) return d; if (numval(d) != 0)
return d;
a = fa->env; a = fa->env;
b = fb->env; b = fb->env;
goto cyc_compare_top; 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; static htable_t equal_eq_hashtable;
void comparehash_init(void) void comparehash_init(void) { htable_new(&equal_eq_hashtable, 512); }
{
htable_new(&equal_eq_hashtable, 512);
}
// 'eq' means unordered comparison is sufficient // 'eq' means unordered comparison is sufficient
static value_t compare_(value_t a, value_t b, int eq) 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; return guess;
} }
value_t fl_compare(value_t a, value_t b) value_t fl_compare(value_t a, value_t b) { return compare_(a, b, 0); }
{
return compare_(a, b, 0);
}
value_t fl_equal(value_t a, value_t b) 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 isforwarded(v) (((value_t *)ptr(v))[0] == TAG_FWD)
#define forwardloc(v) (((value_t *)ptr(v))[1]) #define forwardloc(v) (((value_t *)ptr(v))[1])
#define forward(v,to) do { (((value_t*)ptr(v))[0] = TAG_FWD); \ #define forward(v, to) \
(((value_t*)ptr(v))[1] = to); } while (0) 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_size(v) (((size_t *)ptr(v))[0] >> 2)
#define vector_setsize(v, n) (((size_t *)ptr(v))[0] = ((n) << 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 fn_name(f) (((value_t *)ptr(f))[3])
#define set(s, v) (((symbol_t *)ptr(s))->binding = (v)) #define set(s, v) (((symbol_t *)ptr(s))->binding = (v))
#define setc(s, v) do { ((symbol_t*)ptr(s))->flags |= 1; \ #define setc(s, v) \
((symbol_t*)ptr(s))->binding = (v); } while (0) do { \
((symbol_t *)ptr(s))->flags |= 1; \
((symbol_t *)ptr(s))->binding = (v); \
} while (0)
#define isconstant(s) ((s)->flags & 0x1) #define isconstant(s) ((s)->flags & 0x1)
#define iskeyword(s) ((s)->flags & 0x2) #define iskeyword(s) ((s)->flags & 0x2)
#define symbol_value(s) (((symbol_t *)ptr(s))->binding) #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)) (((unsigned char *)ptr(v)) < fromspace + heapsize))
#define isgensym(x) (issymbol(x) && ismanaged(x)) #define isgensym(x) (issymbol(x) && ismanaged(x))
#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS << 3)) #define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS << 3))
#define isclosure(x) isfunction(x) #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_gc_handle(value_t *pv);
void fl_free_gc_handles(uint32_t n); void fl_free_gc_handles(uint32_t n);
@ -179,28 +187,32 @@ extern uint32_t fl_throwing_frame;
extern value_t fl_lasterror; extern value_t fl_lasterror;
#define FL_TRY_EXTERN \ #define FL_TRY_EXTERN \
fl_exception_context_t _ctx; int l__tr, l__ca; \ fl_exception_context_t _ctx; \
fl_savestate(&_ctx); fl_ctx = &_ctx; \ int l__tr, l__ca; \
fl_savestate(&_ctx); \
fl_ctx = &_ctx; \
if (!setjmp(_ctx.buf)) \ if (!setjmp(_ctx.buf)) \
for (l__tr = 1; l__tr; l__tr = 0, (void)(fl_ctx = fl_ctx->prev)) for (l__tr = 1; l__tr; l__tr = 0, (void)(fl_ctx = fl_ctx->prev))
#define FL_CATCH_EXTERN \ #define FL_CATCH_EXTERN \
else \ else for (l__ca = 1; l__ca; l__ca = 0, fl_restorestate(&_ctx))
for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
void lerrorf(value_t e, char *format, ...) __attribute__((__noreturn__)); void lerrorf(value_t e, char *format, ...) __attribute__((__noreturn__));
void lerror(value_t e, const char *msg) __attribute__((__noreturn__)); void lerror(value_t e, const char *msg) __attribute__((__noreturn__));
void fl_savestate(fl_exception_context_t *_ctx); void fl_savestate(fl_exception_context_t *_ctx);
void fl_restorestate(fl_exception_context_t *_ctx); void fl_restorestate(fl_exception_context_t *_ctx);
void fl_raise(value_t e) __attribute__((__noreturn__)); void fl_raise(value_t e) __attribute__((__noreturn__));
void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__)); void type_error(char *fname, char *expected, value_t got)
void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__)); __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 ArgError, IOError, KeyError, MemoryError, EnumerationError;
extern value_t UnboundError; extern value_t UnboundError;
static inline void argcount(char *fname, uint32_t nargs, uint32_t c) static inline void argcount(char *fname, uint32_t nargs, uint32_t c)
{ {
if (__unlikely(nargs != 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 { typedef struct {
@ -211,8 +223,18 @@ typedef struct {
} cvtable_t; } cvtable_t;
/* functions needed to implement the value interface (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, typedef enum {
T_INT64, T_UINT64, T_FLOAT, T_DOUBLE } numerictype_t; 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) #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 int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
extern value_t int64sym, uint64sym; extern value_t int64sym, uint64sym;
extern value_t longsym, ulongsym, bytesym, wcharsym; 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 stringtypesym, wcstringtypesym, emptystringsym;
extern value_t unionsym, floatsym, doublesym; extern value_t unionsym, floatsym, doublesym;
extern fltype_t *bytetype, *wchartype; extern fltype_t *bytetype, *wchartype;

6
flmain.c
View File

@ -42,7 +42,8 @@ int main(int argc, char *argv[])
value_t args[2]; value_t args[2];
fl_gc_handle(&args[0]); fl_gc_handle(&args[0]);
fl_gc_handle(&args[1]); fl_gc_handle(&args[1]);
FL_TRY_EXTERN { FL_TRY_EXTERN
{
args[0] = cvalue_static_cstring(fname_buf); args[0] = cvalue_static_cstring(fname_buf);
args[1] = symbol(":read"); args[1] = symbol(":read");
value_t f = fl_file(&args[0], 2); 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")), (void)fl_applyn(1, symbol_value(symbol("__start")),
argv_list(argc, argv)); argv_list(argc, argv));
} }
FL_CATCH_EXTERN { FL_CATCH_EXTERN
{
ios_puts("fatal error:\n", ios_stderr); ios_puts("fatal error:\n", ios_stderr);
fl_print(ios_stderr, fl_lasterror); fl_print(ios_stderr, fl_lasterror);
ios_putc('\n', ios_stderr); 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); return value2c(ios_t *, v);
} }
ios_t *fl_toiostream(value_t v, char *fname) ios_t *fl_toiostream(value_t v, char *fname) { return toiostream(v, fname); }
{
return toiostream(v, fname);
}
value_t fl_file(value_t *args, uint32_t nargs) 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); argcount("file", nargs, 1);
int i, r = 0, w = 0, c = 0, t = 0, a = 0; int i, r = 0, w = 0, c = 0, t = 0, a = 0;
for (i = 1; i < (int)nargs; i++) { for (i = 1; i < (int)nargs; i++) {
if (args[i] == wrsym) w = 1; if (args[i] == wrsym)
else if (args[i] == apsym) { a = 1; w = 1; } w = 1;
else if (args[i] == crsym) { c = 1; w = 1; } else if (args[i] == apsym) {
else if (args[i] == truncsym) { t = 1; w = 1; } a = 1;
else if (args[i] == rdsym) r = 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)); value_t f = cvalue(iostreamtype, sizeof(ios_t));
char *fname = tostring(args[0], "file"); char *fname = tostring(args[0], "file");
ios_t *s = value2c(ios_t *, f); ios_t *s = value2c(ios_t *, f);
if (ios_file(s, fname, r, w, c, t) == NULL) if (ios_file(s, fname, r, w, c, t) == NULL)
lerrorf(IOError, "file: could not open \"%s\"", fname); lerrorf(IOError, "file: could not open \"%s\"", fname);
if (a) ios_seek_end(s); if (a)
ios_seek_end(s);
return f; return f;
} }
@ -110,11 +117,9 @@ value_t fl_read(value_t *args, u_int32_t nargs)
value_t arg = 0; value_t arg = 0;
if (nargs > 1) { if (nargs > 1) {
argcount("read", nargs, 1); argcount("read", nargs, 1);
} } else if (nargs == 0) {
else if (nargs == 0) {
arg = symbol_value(instrsym); arg = symbol_value(instrsym);
} } else {
else {
arg = args[0]; arg = args[0];
} }
(void)toiostream(arg, "read"); (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) // form (io.read s type count)
ft = get_array_type(args[1]); ft = get_array_type(args[1]);
n = toulong(args[2], "io.read") * ft->elsz; n = toulong(args[2], "io.read") * ft->elsz;
} } else {
else {
ft = get_type(args[1]); ft = get_type(args[1]);
if (ft->eltype != NULL && !iscons(cdr_(cdr_(args[1])))) if (ft->eltype != NULL && !iscons(cdr_(cdr_(args[1]))))
lerror(ArgError, "io.read: incomplete type"); 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); value_t cv = cvalue(ft, n);
char *data; char *data;
if (iscvalue(cv)) data = cv_data((cvalue_t*)ptr(cv)); if (iscvalue(cv))
else data = cp_data((cprim_t*)ptr(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); size_t got = ios_read(value2c(ios_t *, args[0]), data, n);
if (got < n) if (got < n)
// lerror(IOError, "io.read: end of input reached"); // lerror(IOError, "io.read: end of input reached");
@ -390,9 +396,9 @@ value_t stream_to_string(value_t *ps)
str = cvalue_string(n); str = cvalue_string(n);
memcpy(cvalue_data(str), value2c(ios_t *, *ps)->buf, n); memcpy(cvalue_data(str), value2c(ios_t *, *ps)->buf, n);
ios_trunc(value2c(ios_t *, *ps), 0); ios_trunc(value2c(ios_t *, *ps), 0);
} } else {
else { char *b = ios_takebuf(st, &n);
char *b = ios_takebuf(st, &n); n--; n--;
b[n] = '\0'; b[n] = '\0';
str = cvalue_from_ref(stringtype, b, n, FL_NIL); str = cvalue_from_ref(stringtype, b, n, FL_NIL);
#ifndef BOEHM_GC #ifndef BOEHM_GC
@ -450,14 +456,14 @@ void iostream_init(void)
truncsym = symbol(":truncate"); truncsym = symbol(":truncate");
instrsym = symbol("*input-stream*"); instrsym = symbol("*input-stream*");
outstrsym = symbol("*output-stream*"); outstrsym = symbol("*output-stream*");
iostreamtype = define_opaque_type(iostreamsym, sizeof(ios_t), iostreamtype =
&iostream_vtable, NULL); define_opaque_type(iostreamsym, sizeof(ios_t), &iostream_vtable, NULL);
assign_global_builtins(iostreamfunc_info); assign_global_builtins(iostreamfunc_info);
setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, ios_stdout, setc(symbol("*stdout*"),
sizeof(ios_t), FL_NIL)); cvalue_from_ref(iostreamtype, ios_stdout, sizeof(ios_t), FL_NIL));
setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, ios_stderr, setc(symbol("*stderr*"),
sizeof(ios_t), FL_NIL)); cvalue_from_ref(iostreamtype, ios_stderr, sizeof(ios_t), FL_NIL));
setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, ios_stdin, setc(symbol("*stdin*"),
sizeof(ios_t), FL_NIL)); 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 #ifdef __INTEL_COMPILER
x = _bswap(x); x = _bswap(x);
#else #else
x = (x >> 16) | (x << 16); m = 0xff00ff00; x = (x >> 16) | (x << 16);
m = 0xff00ff00;
x = ((x & m) >> 8) | ((x & ~m) << 8); x = ((x & m) >> 8) | ((x & ~m) << 8);
#endif #endif
m = 0xf0f0f0f0; m = 0xf0f0f0f0;
x = ((x & m) >> 4) | ((x & ~m) << 4); m = 0xcccccccc; x = ((x & m) >> 4) | ((x & ~m) << 4);
x = ((x & m) >> 2) | ((x & ~m) << 2); m = 0xaaaaaaaa; m = 0xcccccccc;
x = ((x & m) >> 2) | ((x & ~m) << 2);
m = 0xaaaaaaaa;
x = ((x & m) >> 1) | ((x & ~m) << 1); x = ((x & m) >> 1) | ((x & ~m) << 1);
return x; 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) void bitvector_shr(u_int32_t *b, size_t n, u_int32_t s)
{ {
u_int32_t i; u_int32_t i;
if (s == 0 || n == 0) return; if (s == 0 || n == 0)
return;
i = (s >> 5); i = (s >> 5);
if (i) { if (i) {
n -= 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) void bitvector_shr_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s)
{ {
u_int32_t i, j; u_int32_t i, j;
if (n == 0) return; if (n == 0)
return;
if (s == 0) { if (s == 0) {
memcpy(dest, b, n * 4); memcpy(dest, b, n * 4);
return; 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) void bitvector_shl(u_int32_t *b, size_t n, u_int32_t s)
{ {
u_int32_t i, scrap = 0, temp; u_int32_t i, scrap = 0, temp;
if (s == 0 || n == 0) return; if (s == 0 || n == 0)
return;
i = (s >> 5); i = (s >> 5);
if (i) { if (i) {
n -= 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) bool_t scrap)
{ {
u_int32_t i, j, sc = 0; u_int32_t i, j, sc = 0;
if (n == 0) return; if (n == 0)
return;
if (s == 0) { if (s == 0) {
memcpy(dest, b, n * 4); memcpy(dest, b, n * 4);
return; 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 // set nbits to c, starting at given bit offset
// assumes offs < 32 // 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; index_t i;
u_int32_t nw, tail; u_int32_t nw, tail;
u_int32_t mask; u_int32_t mask;
if (nbits == 0) return; if (nbits == 0)
return;
nw = (offs + nbits + 31) >> 5; nw = (offs + nbits + 31) >> 5;
if (nw == 1) { if (nw == 1) {
mask = (lomask(nbits) << offs); mask = (lomask(nbits) << offs);
if (c) b[0]|=mask; else b[0]&=(~mask); if (c)
b[0] |= mask;
else
b[0] &= (~mask);
return; return;
} }
mask = lomask(offs); 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++) for (i = 1; i < nw - 1; i++)
b[i] = mask; b[i] = mask;
tail = (offs + nbits) & 31; tail = (offs + nbits) & 31;
if (tail == 0) { if (tail == 0) {
b[i] = mask; b[i] = mask;
} } else {
else {
mask = lomask(tail); 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 nw, tail;
u_int32_t mask; u_int32_t mask;
if (nbits == 0) return; if (nbits == 0)
return;
nw = (offs + nbits + 31) >> 5; nw = (offs + nbits + 31) >> 5;
if (nw == 1) { 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; tail = (offs + nbits) & 31;
if (tail == 0) { if (tail == 0) {
b[i] = ~b[i]; b[i] = ~b[i];
} } else {
else {
mask = lomask(tail); mask = lomask(tail);
b[i] ^= mask; 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 // constant-space bit vector copy in a single pass, with arbitrary
// offsets and lengths. to get this right, there are 16 cases to handle! // offsets and lengths. to get this right, there are 16 cases to handle!
#define BITVECTOR_COPY_OP(name, OP) \ #define BITVECTOR_COPY_OP(name, OP) \
void bitvector_##name(u_int32_t *dest, u_int32_t doffs, \ void bitvector_##name(u_int32_t *dest, u_int32_t doffs, u_int32_t *src, \
u_int32_t *src, u_int32_t soffs, u_int32_t nbits) \ u_int32_t soffs, u_int32_t nbits) \
{ \ { \
index_t i; \ index_t i; \
u_int32_t s, nw, tail, snw; \ u_int32_t s, nw, tail, snw; \
u_int32_t mask, scrap; \ u_int32_t mask, scrap; \
\ \
if (nbits == 0) return; \ if (nbits == 0) \
return; \
nw = (doffs + nbits + 31) >> 5; \ nw = (doffs + nbits + 31) >> 5; \
\ \
if (soffs == doffs) { \ 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++) \ for (i = 1; i < nw - 1; i++) \
dest[i] = OP(src[i]); \ dest[i] = OP(src[i]); \
tail = (doffs + nbits) & 31; \ tail = (doffs + nbits) & 31; \
if (tail==0) { dest[i]=src[i]; } else { \ if (tail == 0) { \
dest[i] = src[i]; \
} else { \
mask = lomask(tail); \ mask = lomask(tail); \
dest[i] = (dest[i] & ~mask) | (OP(src[i]) & mask); } \ dest[i] = (dest[i] & ~mask) | (OP(src[i]) & mask); \
} \
return; \ return; \
} \ } \
snw = (soffs + nbits + 31) >> 5; \ 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); \ scrap = OP(src[i]) >> (32 - s); \
} \ } \
tail = (doffs + nbits) & 31; \ tail = (doffs + nbits) & 31; \
if (tail==0) { mask=ONES32; } else { mask = lomask(tail); } \ if (tail == 0) { \
if (snw == nw) { \ mask = ONES32; \
dest[i] = (dest[i] & ~mask) | (((OP(src[i])<<s)|scrap) & mask); \ } 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) { \ if (snw == 1) { \
dest[i] = (dest[i] & ~mask) | \ dest[i] = (dest[i] & ~mask) | \
(((OP(src[i]) << s) | scrap) & mask); \ (((OP(src[i]) << s) | scrap) & mask); \
} \ } else { \
else { \
dest[i] = (OP(src[i]) << s) | scrap; \ dest[i] = (OP(src[i]) << s) | scrap; \
scrap = OP(src[i]) >> (32 - s); \ scrap = OP(src[i]) >> (32 - s); \
i++; \ i++; \
dest[i] = (dest[i] & ~mask) | (scrap & mask); \ dest[i] = (dest[i] & ~mask) | (scrap & mask); \
} \ } \
} \ } \
} \ } else { \
else { \
s = soffs - doffs; \ s = soffs - doffs; \
if (snw == 1) { \ if (snw == 1) { \
mask = (lomask(nbits) << doffs); \ mask = (lomask(nbits) << doffs); \
@ -258,23 +284,29 @@ void bitvector_##name(u_int32_t *dest, u_int32_t doffs, \
} \ } \
if (nw == 1) { \ if (nw == 1) { \
mask = (lomask(nbits) << doffs); \ mask = (lomask(nbits) << doffs); \
dest[0] = (dest[0] & ~mask) | \ dest[0] = \
(dest[0] & ~mask) | \
(((OP(src[0]) >> s) | (OP(src[1]) << (32 - s))) & mask); \ (((OP(src[0]) >> s) | (OP(src[1]) << (32 - s))) & mask); \
return; \ return; \
} \ } \
mask = ~lomask(doffs); \ mask = ~lomask(doffs); \
dest[0] = (dest[0] & ~mask) | \ dest[0] = \
(dest[0] & ~mask) | \
(((OP(src[0]) >> s) | (OP(src[1]) << (32 - s))) & mask); \ (((OP(src[0]) >> s) | (OP(src[1]) << (32 - s))) & mask); \
for (i = 1; i < nw - 1; i++) { \ for (i = 1; i < nw - 1; i++) { \
dest[i] = (OP(src[i]) >> s) | (OP(src[i + 1]) << (32 - s)); \ dest[i] = (OP(src[i]) >> s) | (OP(src[i + 1]) << (32 - s)); \
} \ } \
tail = (doffs + nbits) & 31; \ 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) { \ if (snw == nw) { \
dest[i] = (dest[i] & ~mask) | ((OP(src[i]) >> s) & mask); \ dest[i] = (dest[i] & ~mask) | ((OP(src[i]) >> s) & mask); \
} \ } else /* snw > nw */ { \
else /* snw > nw */ { \ dest[i] = \
dest[i] = (dest[i] & ~mask) | \ (dest[i] & ~mask) | \
(((OP(src[i]) >> s) | (OP(src[i + 1]) << (32 - s))) & 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 // 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; index_t i;
u_int32_t nw, tail; u_int32_t nw, tail;
if (nbits == 0) return; if (nbits == 0)
return;
nw = (soffs + nbits + 31) >> 5; nw = (soffs + nbits + 31) >> 5;
// first, reverse the words while reversing bit order within each word // 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 nw, tail;
u_int32_t *temp; u_int32_t *temp;
if (nbits == 0) return; if (nbits == 0)
return;
nw = (offs + nbits + 31) >> 5; nw = (offs + nbits + 31) >> 5;
temp = (nw > MALLOC_CUTOFF) ? malloc(nw * 4) : alloca(nw * 4); 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; tail = (offs + nbits) & 31;
bitvector_copy(b, offs, temp, (32 - tail) & 31, nbits); 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) 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_int32_t ntail;
u_int64_t ans; u_int64_t ans;
if (nbits == 0) return 0; if (nbits == 0)
return 0;
nw = ((u_int64_t)offs + nbits + 31) >> 5; nw = ((u_int64_t)offs + nbits + 31) >> 5;
if (nw == 1) { 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; 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; 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 nw, tail;
u_int32_t mask; u_int32_t mask;
if (nbits == 0) return 0; if (nbits == 0)
return 0;
nw = (offs + nbits + 31) >> 5; nw = (offs + nbits + 31) >> 5;
if (nw == 1) { if (nw == 1) {
mask = (lomask(nbits) << offs); mask = (lomask(nbits) << offs);
if ((b[0] & mask) != mask) return 1; if ((b[0] & mask) != mask)
return 1;
return 0; return 0;
} }
mask = ~lomask(offs); mask = ~lomask(offs);
if ((b[0] & mask) != mask) return 1; if ((b[0] & mask) != mask)
return 1;
for (i = 1; i < nw - 1; i++) { for (i = 1; i < nw - 1; i++) {
if (b[i] != ONES32) return 1; if (b[i] != ONES32)
return 1;
} }
tail = (offs + nbits) & 31; tail = (offs + nbits) & 31;
if (tail == 0) { if (tail == 0) {
if (b[i] != ONES32) return 1; if (b[i] != ONES32)
} return 1;
else { } else {
mask = lomask(tail); mask = lomask(tail);
if ((b[i] & mask) != mask) return 1; if ((b[i] & mask) != mask)
return 1;
} }
return 0; 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 nw, tail;
u_int32_t mask; u_int32_t mask;
if (nbits == 0) return 0; if (nbits == 0)
return 0;
nw = (offs + nbits + 31) >> 5; nw = (offs + nbits + 31) >> 5;
if (nw == 1) { if (nw == 1) {
mask = (lomask(nbits) << offs); mask = (lomask(nbits) << offs);
if ((b[0] & mask) != 0) return 1; if ((b[0] & mask) != 0)
return 1;
return 0; return 0;
} }
mask = ~lomask(offs); mask = ~lomask(offs);
if ((b[0] & mask) != 0) return 1; if ((b[0] & mask) != 0)
return 1;
for (i = 1; i < nw - 1; i++) { for (i = 1; i < nw - 1; i++) {
if (b[i] != 0) return 1; if (b[i] != 0)
return 1;
} }
tail = (offs + nbits) & 31; tail = (offs + nbits) & 31;
if (tail == 0) { if (tail == 0) {
if (b[i] != 0) return 1; if (b[i] != 0)
} return 1;
else { } else {
mask = lomask(tail); mask = lomask(tail);
if ((b[i] & mask) != 0) return 1; if ((b[i] & mask) != 0)
return 1;
} }
return 0; 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) \ #define BITVECTOR_BINARY_OP_TO(opname, OP) \
void bitvector_##opname##_to(u_int32_t *dest, u_int32_t doffs, \ void bitvector_##opname##_to( \
u_int32_t *a, u_int32_t aoffs, \ 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 *b, u_int32_t boffs, u_int32_t nbits) \
{ \ { \
u_int32_t nw = (doffs + nbits + 31) >> 5; \ 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; \ u_int32_t i, anw, bnw; \
if (aoffs == boffs) { \ if (aoffs == boffs) { \
anw = (aoffs + nbits + 31) >> 5; \ anw = (aoffs + nbits + 31) >> 5; \
} \ } else if (aoffs == doffs) { \
else if (aoffs == doffs) { \
bnw = (boffs + nbits + 31) >> 5; \ bnw = (boffs + nbits + 31) >> 5; \
adjust_offset_to(temp, b, bnw, boffs, aoffs); \ adjust_offset_to(temp, b, bnw, boffs, aoffs); \
b = temp; anw = nw; \ b = temp; \
} \ anw = nw; \
else { \ } else { \
anw = (aoffs + nbits + 31) >> 5; \ anw = (aoffs + nbits + 31) >> 5; \
bnw = (boffs + nbits + 31) >> 5; \ bnw = (boffs + nbits + 31) >> 5; \
adjust_offset_to(temp, a, anw, aoffs, boffs); \ 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); \ 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)) #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; u_int32_t *p;
size_t sz = ((newsz + 31) >> 5) * sizeof(uint32_t); size_t sz = ((newsz + 31) >> 5) * sizeof(uint32_t);
p = LLT_REALLOC(b, sz); p = LLT_REALLOC(b, sz);
if (p == NULL) return NULL; if (p == NULL)
return NULL;
if (initzero && newsz > oldsz) { if (initzero && newsz > oldsz) {
size_t osz = ((oldsz + 31) >> 5) * sizeof(uint32_t); size_t osz = ((oldsz + 31) >> 5) * sizeof(uint32_t);
memset(&p[osz / sizeof(uint32_t)], 0, sz - osz); 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); return bitvector_resize(NULL, 0, n, initzero);
} }
size_t bitvector_nwords(u_int64_t nbits) size_t bitvector_nwords(u_int64_t nbits) { return ((nbits + 31) >> 5); }
{
return ((nbits+31)>>5);
}
void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c) 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; int n;
if (x == 0) return 32; if (x == 0)
return 32;
n = 1; n = 1;
if ((x & 0x0000FFFF) == 0) {n = n +16; x = x >>16;} if ((x & 0x0000FFFF) == 0) {
if ((x & 0x000000FF) == 0) {n = n + 8; x = x >> 8;} n = n + 16;
if ((x & 0x0000000F) == 0) {n = n + 4; x = x >> 4;} x = x >> 16;
if ((x & 0x00000003) == 0) {n = n + 2; x = x >> 2;} }
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); return n - (x & 1);
} }
@ -95,7 +106,8 @@ static int ntz(uint32_t x)
// returns n if no set bits. // returns n if no set bits.
uint32_t bitvector_next(uint32_t *b, uint64_t n0, uint64_t n) 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 i = n0 >> 5;
uint32_t nb = n0 & 31; 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(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, void bitvector_shl_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s,
bool_t scrap); bool_t scrap);
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,
void bitvector_copy(u_int32_t *dest, u_int32_t doffs, u_int32_t nbits);
u_int32_t *a, u_int32_t aoffs, 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(u_int32_t *b, u_int32_t offs, u_int32_t nbits);
void bitvector_not_to(u_int32_t *dest, u_int32_t doffs, void bitvector_not_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t *a, u_int32_t aoffs, u_int32_t nbits); 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(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, void bitvector_reverse_to(u_int32_t *dest, u_int32_t *src, u_int32_t soffs,
u_int32_t nbits); u_int32_t nbits);
void bitvector_and_to(u_int32_t *dest, u_int32_t doffs, void bitvector_and_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t *a, u_int32_t aoffs, u_int32_t aoffs, u_int32_t *b, u_int32_t boffs,
u_int32_t *b, u_int32_t boffs, u_int32_t nbits); u_int32_t nbits);
void bitvector_or_to(u_int32_t *dest, u_int32_t doffs, void bitvector_or_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t *a, u_int32_t aoffs, u_int32_t aoffs, u_int32_t *b, u_int32_t boffs,
u_int32_t *b, u_int32_t boffs, u_int32_t nbits); u_int32_t nbits);
void bitvector_xor_to(u_int32_t *dest, u_int32_t doffs, void bitvector_xor_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a,
u_int32_t *a, u_int32_t aoffs, u_int32_t aoffs, u_int32_t *b, u_int32_t boffs,
u_int32_t *b, u_int32_t boffs, u_int32_t nbits); u_int32_t nbits);
u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_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_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); 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); char *sep = strrchr(path, PATHSEP);
if (sep != NULL) { if (sep != NULL) {
*sep = '\0'; *sep = '\0';
} } else {
else {
path[0] = '\0'; 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 // calls are a pre-condition for the access(2) call
// later.) // later.)
if ( (path = getenv("PATH")) != NULL && if ((path = getenv("PATH")) != NULL && !setgid(getegid()) &&
!setgid(getegid()) && !setuid(geteuid()) ) { !setuid(geteuid())) {
// The strdup(3) call below, if successful, will // The strdup(3) call below, if successful, will
// allocate memory for the PATH string returned by // allocate memory for the PATH string returned by
@ -159,14 +158,17 @@ char *get_exename(char *buf, size_t size)
pathcpy = path; pathcpy = path;
len = strlen(buf); len = strlen(buf);
while ((p = strsep(&pathcpy, ":")) != NULL) { while ((p = strsep(&pathcpy, ":")) != NULL) {
if (*p == '\0') p = "."; if (*p == '\0')
p = ".";
plen = strlen(p); plen = strlen(p);
// strip trailing '/' // strip trailing '/'
while (p[plen-1] == '/') p[--plen] = '\0'; while (p[plen - 1] == '/')
p[--plen] = '\0';
if (plen + 1 + len < sizeof(filename)) { 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) && if ((stat(filename, &sbuf) == 0) &&
S_ISREG(sbuf.st_mode) && S_ISREG(sbuf.st_mode) &&
access(filename, X_OK) == 0) { 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. free(path); // free the strdup(3) memory allocation.
} }
} } else
else buf = NULL; // call to getenv(3) or [sg]ete?[ug]id(2) failed. buf = NULL; // call to getenv(3) or [sg]ete?[ug]id(2) failed.
} }
if (buf != NULL && *buf != '/') { if (buf != NULL && *buf != '/') {
// buf contains a relative pathname (e.g. "../foo"); // buf contains a relative pathname (e.g. "../foo");
// resolve this to an absolute pathname. // 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) realpath(filename, buf) == NULL)
buf = NULL; buf = NULL;
} }

6
llt/dtypes.h
View File

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

9
llt/hashing.c
View File

@ -13,9 +13,12 @@
uint_t nextipow2(uint_t i) uint_t nextipow2(uint_t i)
{ {
if (i==0) return 1; if (i == 0)
if ((i&(i-1))==0) return i; return 1;
if (i&TOP_BIT) return TOP_BIT; if ((i & (i - 1)) == 0)
return i;
if (i & TOP_BIT)
return TOP_BIT;
// repeatedly clear bottom bit // repeatedly clear bottom bit
while (i & (i - 1)) 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) { if (size <= HT_N_INLINE / 2) {
h->size = size = HT_N_INLINE; h->size = size = HT_N_INLINE;
h->table = &h->_space[0]; h->table = &h->_space[0];
} } else {
else {
size = nextipow2(size); size = nextipow2(size);
size *= 2; // 2 pointers per key/value pair size *= 2; // 2 pointers per key/value pair
size *= 2; // aim for 50% occupancy size *= 2; // aim for 50% occupancy
h->size = size; h->size = size;
h->table = (void **)LLT_ALLOC(size * sizeof(void *)); h->table = (void **)LLT_ALLOC(size * sizeof(void *));
} }
if (h->table == NULL) return NULL; if (h->table == NULL)
return NULL;
size_t i; size_t i;
for (i = 0; i < size; i++) for (i = 0; i < size; i++)
h->table[i] = HT_NOTFOUND; h->table[i] = HT_NOTFOUND;
@ -44,7 +44,8 @@ void htable_reset(htable_t *h, size_t sz)
sz = nextipow2(sz); sz = nextipow2(sz);
if (h->size > sz * 4 && h->size > HT_N_INLINE) { if (h->size > sz * 4 && h->size > HT_N_INLINE) {
size_t newsz = sz * 4; size_t newsz = sz * 4;
void **newtab = (void**)LLT_REALLOC(h->table, newsz*sizeof(void*)); void **newtab =
(void **)LLT_REALLOC(h->table, newsz * sizeof(void *));
if (newtab == NULL) if (newtab == NULL)
return; return;
h->size = newsz; h->size = newsz;

3
llt/int2str.c
View File

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

459
llt/lookup3.c
View File

@ -119,12 +119,24 @@ rotates.
*/ */
#define mix(a, b, c) \ #define mix(a, b, c) \
{ \ { \
a -= c; a ^= rot(c, 4); c += b; \ a -= c; \
b -= a; b ^= rot(a, 6); a += c; \ a ^= rot(c, 4); \
c -= b; c ^= rot(b, 8); b += a; \ c += b; \
a -= c; a ^= rot(c,16); c += b; \ b -= a; \
b -= a; b ^= rot(a,19); a += c; \ b ^= rot(a, 6); \
c -= b; c ^= rot(b, 4); b += a; \ 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) \ #define final(a, b, c) \
{ \ { \
c ^= b; c -= rot(b,14); \ c ^= b; \
a ^= c; a -= rot(c,11); \ c -= rot(b, 14); \
b ^= a; b -= rot(a,25); \ a ^= c; \
c ^= b; c -= rot(b,16); \ a -= rot(c, 11); \
a ^= c; a -= rot(c,4); \ b ^= a; \
b ^= a; b -= rot(a,14); \ b -= rot(a, 25); \
c ^= b; c -= rot(b,24); \ 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. hashlittle() has to dance around fitting the key bytes into registers.
-------------------------------------------------------------------- --------------------------------------------------------------------
*/ */
uint32_t hashword( uint32_t
const uint32_t *k, /* the key, an array of uint32_t values */ hashword(const uint32_t *k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */ size_t length, /* the length of the key, in uint32_ts */
uint32_t initval) /* the previous hash, or an arbitrary value */ 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 */ /* Set up the internal state */
a = b = c = 0xdeadbeef + (((uint32_t)length) << 2) + initval; a = b = c = 0xdeadbeef + (((uint32_t)length) << 2) + initval;
/*------------------------------------------------- handle most of the key */ /*------------------------------------------------- handle most of the key
while (length > 3) */
{ while (length > 3) {
a += k[0]; a += k[0];
b += k[1]; b += k[1];
c += k[2]; c += k[2];
@ -197,17 +216,22 @@ uint32_t initval) /* the previous hash, or an arbitrary value */
k += 3; k += 3;
} }
/*------------------------------------------- handle the last 3 uint32_t's */ /*------------------------------------------- handle the last 3 uint32_t's
*/
switch (length) /* all the case statements fall through */ switch (length) /* all the case statements fall through */
{ {
case 3 : c+=k[2]; case 3:
case 2 : b+=k[1]; c += k[2];
case 1 : a+=k[0]; case 2:
b += k[1];
case 1:
a += k[0];
final(a, b, c); final(a, b, c);
case 0: /* case 0: nothing left to add */ case 0: /* case 0: nothing left to add */
break; break;
} }
/*------------------------------------------------------ report the result */ /*------------------------------------------------------ report the result
*/
return c; 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(). (*pc) will be the same as the return value from hashword().
-------------------------------------------------------------------- --------------------------------------------------------------------
*/ */
void hashword2 ( void hashword2(const uint32_t *k, /* the key, an array of uint32_t values */
const uint32_t *k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */ size_t length, /* the length of the key, in uint32_ts */
uint32_t *pc, /* IN: seed OUT: primary hash value */ uint32_t *pc, /* IN: seed OUT: primary hash value */
uint32_t *pb) /* IN: more seed OUT: secondary 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; a = b = c = 0xdeadbeef + ((uint32_t)(length << 2)) + *pc;
c += *pb; c += *pb;
/*------------------------------------------------- handle most of the key */ /*------------------------------------------------- handle most of the key
while (length > 3) */
{ while (length > 3) {
a += k[0]; a += k[0];
b += k[1]; b += k[1];
c += k[2]; c += k[2];
@ -242,18 +265,24 @@ uint32_t *pb) /* IN: more seed OUT: secondary hash value */
k += 3; k += 3;
} }
/*------------------------------------------- handle the last 3 uint32_t's */ /*------------------------------------------- handle the last 3 uint32_t's
*/
switch (length) /* all the case statements fall through */ switch (length) /* all the case statements fall through */
{ {
case 3 : c+=k[2]; case 3:
case 2 : b+=k[1]; c += k[2];
case 1 : a+=k[0]; case 2:
b += k[1];
case 1:
a += k[0];
final(a, b, c); final(a, b, c);
case 0: /* case 0: nothing left to add */ case 0: /* case 0: nothing left to add */
break; break;
} }
/*------------------------------------------------------ report the result */ /*------------------------------------------------------ report the result
*pc=c; *pb=b; */
*pc = c;
*pb = b;
} }
#if 0 #if 0
@ -471,7 +500,10 @@ void hashlittle2(
uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */ uint32_t *pb) /* IN: secondary initval, OUT: secondary hash */
{ {
uint32_t a, b, c; /* internal state */ 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 */ /* Set up the internal state */
a = b = c = 0xdeadbeef + ((uint32_t)length) + *pc; 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 uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */
const uint8_t *k8; const uint8_t *k8;
/*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ /*------ all but last block: aligned reads and affect 32 bits of
while (length > 12) * (a,b,c) */
{ while (length > 12) {
a += k[0]; a += k[0];
b += k[1]; b += k[1];
c += k[2]; c += k[2];
@ -493,7 +525,8 @@ void hashlittle2(
k += 3; 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 * "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 * then masks off the part it's not allowed to read. Because the
@ -505,41 +538,100 @@ void hashlittle2(
*/ */
#ifndef VALGRIND #ifndef VALGRIND
(void)k8; (void)k8;
switch(length) switch (length) {
{ case 12:
case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; c += k[2];
case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; b += k[1];
case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; a += k[0];
case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; break;
case 8 : b+=k[1]; a+=k[0]; break; case 11:
case 7 : b+=k[1]&0xffffff; a+=k[0]; break; c += k[2] & 0xffffff;
case 6 : b+=k[1]&0xffff; a+=k[0]; break; b += k[1];
case 5 : b+=k[1]&0xff; a+=k[0]; break; a += k[0];
case 4 : a+=k[0]; break; break;
case 3 : a+=k[0]&0xffffff; break; case 10:
case 2 : a+=k[0]&0xffff; break; c += k[2] & 0xffff;
case 1 : a+=k[0]&0xff; break; b += k[1];
case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ 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 */ #else /* make valgrind happy */
k8 = (const uint8_t *)k; k8 = (const uint8_t *)k;
switch(length) switch (length) {
{ case 12:
case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; c += k[2];
case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ b += k[1];
case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ a += k[0];
case 9 : c+=k8[8]; /* fall through */ break;
case 8 : b+=k[1]; a+=k[0]; break; case 11:
case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ c += ((uint32_t)k8[10]) << 16; /* fall through */
case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ case 10:
case 5 : b+=k8[4]; /* fall through */ c += ((uint32_t)k8[9]) << 8; /* fall through */
case 4 : a+=k[0]; break; case 9:
case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ c += k8[8]; /* fall through */
case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ case 8:
case 1 : a+=k8[0]; break; b += k[1];
case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ 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 */ #endif /* !valgrind */
@ -548,9 +640,9 @@ void hashlittle2(
const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */
const uint8_t *k8; const uint8_t *k8;
/*--------------- all but last block: aligned reads and different mixing */ /*--------------- all but last block: aligned reads and different
while (length > 12) * mixing */
{ while (length > 12) {
a += k[0] + (((uint32_t)k[1]) << 16); a += k[0] + (((uint32_t)k[1]) << 16);
b += k[2] + (((uint32_t)k[3]) << 16); b += k[2] + (((uint32_t)k[3]) << 16);
c += k[4] + (((uint32_t)k[5]) << 16); c += k[4] + (((uint32_t)k[5]) << 16);
@ -559,44 +651,59 @@ void hashlittle2(
k += 6; k += 6;
} }
/*----------------------------- handle the last (probably partial) block */ /*----------------------------- handle the last (probably partial)
* block */
k8 = (const uint8_t *)k; k8 = (const uint8_t *)k;
switch(length) switch (length) {
{ case 12:
case 12: c+=k[4]+(((uint32_t)k[5])<<16); c += k[4] + (((uint32_t)k[5]) << 16);
b += k[2] + (((uint32_t)k[3]) << 16); b += k[2] + (((uint32_t)k[3]) << 16);
a += k[0] + (((uint32_t)k[1]) << 16); a += k[0] + (((uint32_t)k[1]) << 16);
break; break;
case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ case 11:
case 10: c+=k[4]; c += ((uint32_t)k8[10]) << 16; /* fall through */
case 10:
c += k[4];
b += k[2] + (((uint32_t)k[3]) << 16); b += k[2] + (((uint32_t)k[3]) << 16);
a += k[0] + (((uint32_t)k[1]) << 16); a += k[0] + (((uint32_t)k[1]) << 16);
break; break;
case 9 : c+=k8[8]; /* fall through */ case 9:
case 8 : b+=k[2]+(((uint32_t)k[3])<<16); c += k8[8]; /* fall through */
case 8:
b += k[2] + (((uint32_t)k[3]) << 16);
a += k[0] + (((uint32_t)k[1]) << 16); a += k[0] + (((uint32_t)k[1]) << 16);
break; break;
case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ case 7:
case 6 : b+=k[2]; b += ((uint32_t)k8[6]) << 16; /* fall through */
case 6:
b += k[2];
a += k[0] + (((uint32_t)k[1]) << 16); a += k[0] + (((uint32_t)k[1]) << 16);
break; break;
case 5 : b+=k8[4]; /* fall through */ case 5:
case 4 : a+=k[0]+(((uint32_t)k[1])<<16); b += k8[4]; /* fall through */
case 4:
a += k[0] + (((uint32_t)k[1]) << 16);
break; break;
case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ case 3:
case 2 : a+=k[0]; a += ((uint32_t)k8[2]) << 16; /* fall through */
case 2:
a += k[0];
break; break;
case 1 : a+=k8[0]; case 1:
a += k8[0];
break; 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 */ } else { /* need to read the key one byte at a time */
const uint8_t *k = (const uint8_t *)key; const uint8_t *k = (const uint8_t *)key;
/*--------------- all but the last block: affect some 32 bits of (a,b,c) */ /*--------------- all but the last block: affect some 32 bits of
while (length > 12) * (a,b,c) */
{ while (length > 12) {
a += k[0]; a += k[0];
a += ((uint32_t)k[1]) << 8; a += ((uint32_t)k[1]) << 8;
a += ((uint32_t)k[2]) << 16; a += ((uint32_t)k[2]) << 16;
@ -614,31 +721,47 @@ void hashlittle2(
k += 12; 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 */ switch (length) /* all the case statements fall through */
{ {
case 12: c+=((uint32_t)k[11])<<24; case 12:
case 11: c+=((uint32_t)k[10])<<16; c += ((uint32_t)k[11]) << 24;
case 10: c+=((uint32_t)k[9])<<8; case 11:
case 9 : c+=k[8]; c += ((uint32_t)k[10]) << 16;
case 8 : b+=((uint32_t)k[7])<<24; case 10:
case 7 : b+=((uint32_t)k[6])<<16; c += ((uint32_t)k[9]) << 8;
case 6 : b+=((uint32_t)k[5])<<8; case 9:
case 5 : b+=k[4]; c += k[8];
case 4 : a+=((uint32_t)k[3])<<24; case 8:
case 3 : a+=((uint32_t)k[2])<<16; b += ((uint32_t)k[7]) << 24;
case 2 : a+=((uint32_t)k[1])<<8; case 7:
case 1 : a+=k[0]; 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; 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); final(a, b, c);
*pc=c; *pb=b; *pc = c;
*pb = b;
} }
#if 0 #if 0
/* /*
* hashbig(): * hashbig():
@ -780,13 +903,14 @@ void driver1()
time_t a, z; time_t a, z;
time(&a); time(&a);
for (i=0; i<256; ++i) buf[i] = 'x'; for (i = 0; i < 256; ++i)
for (i=0; i<1; ++i) buf[i] = 'x';
{ for (i = 0; i < 1; ++i) {
h = hashlittle(&buf[0], 1, h); h = hashlittle(&buf[0], 1, h);
} }
time(&z); 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 */ /* check that every input bit changes every output bit half the time */
@ -803,59 +927,67 @@ void driver2()
uint32_t hlen; uint32_t hlen;
printf("No more than %d trials should ever be needed \n", MAXPAIR / 2); 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; 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) 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 */ /*---- check that every output bit is affected by that
for (k=0; k<MAXPAIR; k+=2) * input bit */
{ for (k = 0; k < MAXPAIR; k += 2) {
uint32_t finished = 1; uint32_t finished = 1;
/* keys have one bit different */ /* keys have one bit different */
for (l=0; l<hlen+1; ++l) {a[l] = b[l] = (uint8_t)0;} for (l = 0; l < hlen + 1; ++l) {
/* have a and b be two keys differing in only one bit */ 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 << j);
a[i] ^= (k >> (8 - j)); a[i] ^= (k >> (8 - j));
c[0] = hashlittle(a, hlen, m); c[0] = hashlittle(a, hlen, m);
b[i] ^= ((k + 1) << j); b[i] ^= ((k + 1) << j);
b[i] ^= ((k + 1) >> (8 - j)); b[i] ^= ((k + 1) >> (8 - j));
d[0] = hashlittle(b, hlen, m); d[0] = hashlittle(b, hlen, m);
/* check every bit is 1, 0, set, and not set at least once */ /* check every bit is 1, 0, set, and not set at least
for (l=0; l<HASHSTATE; ++l) * once */
{ for (l = 0; l < HASHSTATE; ++l) {
e[l] &= (c[l] ^ d[l]); e[l] &= (c[l] ^ d[l]);
f[l] &= ~(c[l] ^ d[l]); f[l] &= ~(c[l] ^ d[l]);
g[l] &= c[l]; g[l] &= c[l];
h[l] &= ~c[l]; h[l] &= ~c[l];
x[l] &= d[l]; x[l] &= d[l];
y[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 > z)
if (k==MAXPAIR) z = k;
{ if (k == MAXPAIR) {
printf("Some bit didn't change: "); printf("Some bit didn't change: ");
printf("%.8x %.8x %.8x %.8x %.8x %.8x ", printf("%.8x %.8x %.8x %.8x %.8x %.8x ", e[0], f[0],
e[0],f[0],g[0],h[0],x[0],y[0]); g[0], h[0], x[0], y[0]);
printf("i %d j %d m %d len %d\n", i, j, m, hlen); 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: done:
if (z < MAXPAIR) if (z < MAXPAIR) {
{
printf("Mix success %2d bytes %2d initvals ", i, m); printf("Mix success %2d bytes %2d initvals ", i, m);
printf("required %d trials\n", z / 2); printf("required %d trials\n", z / 2);
} }
@ -868,23 +1000,30 @@ void driver3()
{ {
uint8_t buf[MAXLEN + 20], *b; uint8_t buf[MAXLEN + 20], *b;
uint32_t len; 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; 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; 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; 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; uint32_t ref, x, y;
uint8_t *p; uint8_t *p;
printf("Endianness. These lines should all be the same (for values filled in):\n"); printf("Endianness. These lines should all be the same (for values "
printf("%.8x %.8x %.8x\n", "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) - 1) / 4, 13),
hashword((const uint32_t *)q, (sizeof(q) - 5) / 4, 13), hashword((const uint32_t *)q, (sizeof(q) - 5) / 4, 13),
hashword((const uint32_t *)q, (sizeof(q) - 9) / 4, 13)); hashword((const uint32_t *)q, (sizeof(q) - 9) / 4, 13));
p = q; 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) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 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), 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) - 9, 13), hashlittle(p, sizeof(q) - 10, 13),
hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13)); hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13));
p = &qq[1]; 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) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 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), 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) - 9, 13), hashlittle(p, sizeof(q) - 10, 13),
hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13)); hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13));
p = &qqq[2]; 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) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 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), 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) - 9, 13), hashlittle(p, sizeof(q) - 10, 13),
hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13)); hashlittle(p, sizeof(q) - 11, 13), hashlittle(p, sizeof(q) - 12, 13));
p = &qqqq[3]; 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) - 1, 13), hashlittle(p, sizeof(q) - 2, 13),
hashlittle(p, sizeof(q) - 3, 13), hashlittle(p, sizeof(q) - 4, 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), hashlittle(p, sizeof(q) - 5, 13), hashlittle(p, sizeof(q) - 6, 13),
@ -918,7 +1060,8 @@ void driver3()
printf("\n"); printf("\n");
/* check that hashlittle2 and hashlittle produce the same results */ /* check that hashlittle2 and hashlittle produce the same results */
i=47; j=0; i = 47;
j = 0;
hashlittle2(q, sizeof(q), &i, &j); hashlittle2(q, sizeof(q), &i, &j);
if (hashlittle(q, sizeof(q), 47) != i) if (hashlittle(q, sizeof(q), 47) != i)
printf("hashlittle2 and hashlittle mismatch\n"); printf("hashlittle2 and hashlittle mismatch\n");
@ -928,16 +1071,15 @@ void driver3()
i = 47, j = 0; i = 47, j = 0;
hashword2(&len, 1, &i, &j); hashword2(&len, 1, &i, &j);
if (hashword(&len, 1, 47) != i) if (hashword(&len, 1, 47) != i)
printf("hashword2 and hashword mismatch %x %x\n", printf("hashword2 and hashword mismatch %x %x\n", i,
i, hashword(&len, 1, 47)); hashword(&len, 1, 47));
/* check hashlittle doesn't read before or after the ends of the string */ /* check hashlittle doesn't read before or after the ends of the string */
for (h=0, b=buf+1; h<8; ++h, ++b) for (h = 0, b = buf + 1; h < 8; ++h, ++b) {
{ for (i = 0; i < MAXLEN; ++i) {
for (i=0; i<MAXLEN; ++i)
{
len = 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 */ /* these should all be equal */
ref = hashlittle(b, len, (uint32_t)1); ref = hashlittle(b, len, (uint32_t)1);
@ -945,8 +1087,7 @@ void driver3()
*(b - 1) = (uint8_t)~0; *(b - 1) = (uint8_t)~0;
x = hashlittle(b, len, (uint32_t)1); x = hashlittle(b, len, (uint32_t)1);
y = 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, printf("alignment error: %.8x %.8x %.8x %d %d\n", ref, x, y,
h, i); h, i);
} }
@ -960,18 +1101,16 @@ void driver3()
uint8_t buf[1]; uint8_t buf[1];
uint32_t h, i, state[HASHSTATE]; uint32_t h, i, state[HASHSTATE];
buf[0] = ~0; 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"); 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); h = hashlittle(buf, 0, h);
printf("%2ld 0-byte strings, hash is %.8x\n", i, h); printf("%2ld 0-byte strings, hash is %.8x\n", i, h);
} }
} }
int main() int main()
{ {
driver1(); /* test that the key is hashed: used for timings */ 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 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 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; mt[0] = s & 0xffffffffU;
for (mti = 1; mti < mtN; mti++) { for (mti = 1; mti < mtN; mti++) {
mt[mti] = mt[mti] = (1812433253U * (mt[mti - 1] ^ (mt[mti - 1] >> 30)) + mti);
(1812433253U * (mt[mti-1] ^ (mt[mti-1] >> 30)) + mti);
/* See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. */ /* See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. */
/* In the previous versions, MSBs of the seed affect */ /* In the previous versions, MSBs of the seed affect */
/* only MSBs of the array mt[]. */ /* 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; int i, j, k;
init_genrand(19650218U); init_genrand(19650218U);
i=1; j=0; i = 1;
j = 0;
k = (mtN > key_length ? mtN : key_length); k = (mtN > key_length ? mtN : key_length);
for (; k; k--) { for (; k; k--) {
mt[i] = (mt[i] ^ ((mt[i-1] ^ (mt[i-1] >> 30)) * 1664525U)) mt[i] = (mt[i] ^ ((mt[i - 1] ^ (mt[i - 1] >> 30)) * 1664525U)) +
+ init_key[j] + j; /* non linear */ 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] &= 0xffffffffU; /* for WORDSIZE > 32 machines */ mt[i] &= 0xffffffffU; /* for WORDSIZE > 32 machines */
i++; 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 */ mt[0] = 0x80000000U; /* MSB is 1; assuring non-zero initial array */

17
llt/socket.c
View File

@ -15,7 +15,6 @@
#include "socket.h" #include "socket.h"
int mysocket(int domain, int type, int protocol) int mysocket(int domain, int type, int protocol)
{ {
int val; int val;
@ -41,10 +40,7 @@ void set_nonblock(int socket, int yes)
} }
#ifdef WIN32 #ifdef WIN32
void bzero(void *s, size_t n) void bzero(void *s, size_t n) { memset(s, 0, n); }
{
memset(s, 0, n);
}
#endif #endif
/* returns a socket on which to accept() connections */ /* 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_family = AF_INET;
serv_addr.sin_addr.s_addr = htonl(INADDR_ANY); serv_addr.sin_addr.s_addr = htonl(INADDR_ANY);
serv_addr.sin_port = htons(*portno); 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)++; (*portno)++;
serv_addr.sin_port = htons(*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_family = AF_INET;
serv_addr.sin_addr.s_addr = htonl(INADDR_ANY); serv_addr.sin_addr.s_addr = htonl(INADDR_ANY);
serv_addr.sin_port = htons(*portno); 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)++; (*portno)++;
serv_addr.sin_port = htons(*portno); serv_addr.sin_port = htons(*portno);
} }
@ -115,10 +113,7 @@ int open_any_udp_port(short *portno)
} }
#ifndef WIN32 #ifndef WIN32
void closesocket(int fd) void closesocket(int fd) { close(fd); }
{
close(fd);
}
#endif #endif
/* returns a socket to use to send data to the given address */ /* 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); localtime_r(&tme, &tm);
strftime(buffer, len, fmt, &tm); strftime(buffer, len, fmt, &tm);
#else #else
static char *wdaystr[] = {"Sun","Mon","Tue","Wed","Thu","Fri","Sat"}; static char *wdaystr[] = {
static char *monthstr[] = {"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug", "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"
"Sep","Oct","Nov","Dec"}; };
static char *monthstr[] = { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
struct tm *tm; struct tm *tm;
int hr; int hr;
tm = localtime(&tme); tm = localtime(&tme);
hr = tm->tm_hour; hr = tm->tm_hour;
if (hr > 12) hr -= 12; if (hr > 12)
if (hr == 0) hr = 12; hr -= 12;
if (hr == 0)
hr = 12;
snprintf(buffer, len, "%s %02d %s %d %02d:%02d:%02d %s %s", snprintf(buffer, len, "%s %02d %s %d %02d:%02d:%02d %s %s",
wdaystr[tm->tm_wday], tm->tm_mday, monthstr[tm->tm_mon], wdaystr[tm->tm_wday], tm->tm_mday, monthstr[tm->tm_mon],
tm->tm_year + 1900, hr, tm->tm_min, tm->tm_sec, 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); res = strptime(str, fmt, &tm);
if (res != NULL) { 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 */ whether daylight saving time is in effect */
t = mktime(&tm); t = mktime(&tm);
if (t == ((time_t)-1)) if (t == ((time_t)-1))

181
llt/utf8.c
View File

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

35
llt/utils.h
View File

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

13
llt/wcwidth.c
View File

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

26
opaque_type_template.c
View File

@ -12,21 +12,13 @@
static value_t TYPEsym; static value_t TYPEsym;
static fltype_t *TYPEtype; 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, cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE,
print_traverse_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)); return (TYPE_t *)cv_data((cvalue_t *)ptr(v));
} }
static builtinspec_t TYPEfunc_info[] = { static builtinspec_t TYPEfunc_info[] = { { "TYPE?", fl_TYPEp },
{ "TYPE?", fl_TYPEp }, { NULL, NULL } };
{ NULL, NULL }
};
void TYPE_init() void TYPE_init()
{ {
TYPEsym = symbol("TYPE"); TYPEsym = symbol("TYPE");
TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t), TYPEtype =
&TYPE_vtable, NULL); define_opaque_type(TYPEsym, sizeof(TYPE_t), &TYPE_vtable, NULL);
assign_global_builtins(TYPEfunc_info); assign_global_builtins(TYPEfunc_info);
} }

176
opcodes.h
View File

@ -2,34 +2,109 @@
#define OPCODES_H #define OPCODES_H
enum { enum {
OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT, OP_NOP = 0,
OP_JMPL, OP_BRFL, OP_BRTL, OP_RET, 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_EQ,
OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP, OP_EQV,
OP_FIXNUMP, OP_FUNCTIONP, 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_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_LOADT,
OP_LOADV, OP_LOADVL, OP_LOADF,
OP_LOADG, OP_LOADGL, OP_LOADNIL,
OP_LOADA, OP_LOADAL, OP_LOADC, OP_LOADCL, OP_LOAD0,
OP_SETG, OP_SETGL, OP_LOAD1,
OP_SETA, OP_SETAL, OP_SETC, OP_SETCL, 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_CLOSURE,
OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC, OP_ARGC,
OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL, OP_VARGC,
OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL, OP_TRYCATCH,
OP_OPTARGS, OP_BRBOUND, OP_KEYARGS, 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 N_OPCODES
}; };
@ -37,59 +112,54 @@ enum {
#ifdef USE_COMPUTED_GOTO #ifdef USE_COMPUTED_GOTO
#define VM_LABELS \ #define VM_LABELS \
static void *vm_labels[] = { \ static void *vm_labels[] = { \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \ NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, \
&&L_OP_BRF, &&L_OP_BRT, \ &&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_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_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, \
&&L_OP_NULLP, &&L_OP_BOOLEANP, \ &&L_OP_NOT, &&L_OP_NULLP, &&L_OP_BOOLEANP, &&L_OP_SYMBOLP, \
&&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \ &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, &&L_OP_BUILTINP, \
&&L_OP_BUILTINP, &&L_OP_VECTORP, \ &&L_OP_VECTORP, &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
&&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
\ \
&&L_OP_CONS, &&L_OP_LIST, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \ &&L_OP_CONS, &&L_OP_LIST, &&L_OP_CAR, &&L_OP_CDR, \
&&L_OP_SETCDR, &&L_OP_APPLY, \ &&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_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, \
&&L_OP_LT, &&L_OP_COMPARE, \ &&L_OP_IDIV, &&L_OP_NUMEQ, &&L_OP_LT, &&L_OP_COMPARE, \
\ \
&&L_OP_VECTOR, &&L_OP_AREF, &&L_OP_ASET, \ &&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_LOADT, &&L_OP_LOADF, &&L_OP_LOADNIL, &&L_OP_LOAD0, \
&&L_OP_LOADI8, \ &&L_OP_LOAD1, &&L_OP_LOADI8, &&L_OP_LOADV, &&L_OP_LOADVL, \
&&L_OP_LOADV, &&L_OP_LOADVL, \ &&L_OP_LOADG, &&L_OP_LOADGL, &&L_OP_LOADA, &&L_OP_LOADAL, \
&&L_OP_LOADG, &&L_OP_LOADGL, \ &&L_OP_LOADC, &&L_OP_LOADCL, &&L_OP_SETG, &&L_OP_SETGL, \
&&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_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \
\ \
&&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \ &&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \
&&L_OP_FOR, \ &&L_OP_FOR, &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, \
&&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \ &&L_OP_NEG, &&L_OP_LARGC, &&L_OP_LVARGC, &&L_OP_LOADA0, \
&&L_OP_LVARGC, \ &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, &&L_OP_CALLL, \
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \ &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR, \
&&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_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \
&&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \ &&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \
} }
#define VM_APPLY_LABELS \ #define VM_APPLY_LABELS \
static void *vm_apply_labels[] = { \ static void *vm_apply_labels[] = { \
NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \ NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, \
&&L_OP_BRF, &&L_OP_BRT, \ &&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_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_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, \
&&L_OP_NULLP, &&L_OP_BOOLEANP, \ &&L_OP_NOT, &&L_OP_NULLP, &&L_OP_BOOLEANP, &&L_OP_SYMBOLP, \
&&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \ &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, &&L_OP_BUILTINP, \
&&L_OP_BUILTINP, &&L_OP_VECTORP, \ &&L_OP_VECTORP, &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
&&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
\ \
&&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \ &&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, \
&&L_OP_SETCDR, &&apply_apply, \ &&L_OP_SETCAR, &&L_OP_SETCDR, &&apply_apply, \
\ \
&&apply_add, &&apply_sub, &&apply_mul, &&apply_div, &&L_OP_IDIV, &&L_OP_NUMEQ, \ &&apply_add, &&apply_sub, &&apply_mul, &&apply_div, \
&&L_OP_LT, &&L_OP_COMPARE, \ &&L_OP_IDIV, &&L_OP_NUMEQ, &&L_OP_LT, &&L_OP_COMPARE, \
\ \
&&apply_vector, &&L_OP_AREF, &&L_OP_ASET \ &&apply_vector, &&L_OP_AREF, &&L_OP_ASET \
} }

267
operators.c
View File

@ -6,10 +6,7 @@
extern double trunc(double x); extern double trunc(double x);
STATIC_INLINE double fpart(double arg) STATIC_INLINE double fpart(double arg) { return arg - trunc(arg); }
{
return arg - trunc(arg);
}
// given a number, determine an appropriate type for storing it // given a number, determine an appropriate type for storing it
#if 0 #if 0
@ -49,11 +46,9 @@ numerictype_t effective_numerictype(double r)
fp = fpart(r); fp = fpart(r);
if (fp != 0 || r > U64_MAX || r < S64_MIN) { if (fp != 0 || r > U64_MAX || r < S64_MIN) {
return T_DOUBLE; return T_DOUBLE;
} } else if (r >= INT_MIN && r <= INT_MAX) {
else if (r >= INT_MIN && r <= INT_MAX) {
return T_INT32; return T_INT32;
} } else if (r <= S64_MAX) {
else if (r <= S64_MAX) {
return T_INT64; return T_INT64;
} }
return T_UINT64; return T_UINT64;
@ -64,20 +59,37 @@ double conv_to_double(void *data, numerictype_t tag)
{ {
double d = 0; double d = 0;
switch (tag) { switch (tag) {
case T_INT8: d = (double)*(int8_t*)data; break; case T_INT8:
case T_UINT8: d = (double)*(uint8_t*)data; break; d = (double)*(int8_t *)data;
case T_INT16: d = (double)*(int16_t*)data; break; break;
case T_UINT16: d = (double)*(uint16_t*)data; break; case T_UINT8:
case T_INT32: d = (double)*(int32_t*)data; break; d = (double)*(uint8_t *)data;
case T_UINT32: d = (double)*(uint32_t*)data; break; 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: case T_INT64:
d = (double)*(int64_t *)data; d = (double)*(int64_t *)data;
if (d > 0 && *(int64_t *)data < 0) // can happen! if (d > 0 && *(int64_t *)data < 0) // can happen!
d = -d; d = -d;
break; break;
case T_UINT64: d = (double)*(uint64_t*)data; break; case T_UINT64:
case T_FLOAT: d = (double)*(float*)data; break; d = (double)*(uint64_t *)data;
case T_DOUBLE: return *(double*)data; break;
case T_FLOAT:
d = (double)*(float *)data;
break;
case T_DOUBLE:
return *(double *)data;
} }
return d; 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) void conv_from_double(void *dest, double d, numerictype_t tag)
{ {
switch (tag) { switch (tag) {
case T_INT8: *(int8_t*)dest = d; break; case T_INT8:
case T_UINT8: *(uint8_t*)dest = d; break; *(int8_t *)dest = d;
case T_INT16: *(int16_t*)dest = d; break; break;
case T_UINT16: *(uint16_t*)dest = d; break; case T_UINT8:
case T_INT32: *(int32_t*)dest = d; break; *(uint8_t *)dest = d;
case T_UINT32: *(uint32_t*)dest = d; break; 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: case T_INT64:
*(int64_t *)dest = d; *(int64_t *)dest = d;
if (d > 0 && *(int64_t *)dest < 0) // 0x8000000000000000 is a bitch if (d > 0 && *(int64_t *)dest < 0) // 0x8000000000000000 is a bitch
*(int64_t *)dest = S64_MAX; *(int64_t *)dest = S64_MAX;
break; break;
case T_UINT64: *(uint64_t*)dest = (int64_t)d; break; case T_UINT64:
case T_FLOAT: *(float*)dest = d; break; *(uint64_t *)dest = (int64_t)d;
case T_DOUBLE: *(double*)dest = d; break; 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; \ type##_t i = 0; \
switch (tag) { \ switch (tag) { \
case T_INT8: i = (type##_t)*(int8_t*)data; break; \ case T_INT8: \
case T_UINT8: i = (type##_t)*(uint8_t*)data; break; \ i = (type##_t) * (int8_t *)data; \
case T_INT16: i = (type##_t)*(int16_t*)data; break; \ break; \
case T_UINT16: i = (type##_t)*(uint16_t*)data; break; \ case T_UINT8: \
case T_INT32: i = (type##_t)*(int32_t*)data; break; \ i = (type##_t) * (uint8_t *)data; \
case T_UINT32: i = (type##_t)*(uint32_t*)data; break; \ break; \
case T_INT64: i = (type##_t)*(int64_t*)data; break; \ case T_INT16: \
case T_UINT64: i = (type##_t)*(uint64_t*)data; break; \ i = (type##_t) * (int16_t *)data; \
case T_FLOAT: i = (type##_t)*(float*)data; break; \ break; \
case T_DOUBLE: i = (type##_t)*(double*)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; \ return i; \
} }
@ -132,14 +182,30 @@ uint64_t conv_to_uint64(void *data, numerictype_t tag)
{ {
uint64_t i = 0; uint64_t i = 0;
switch (tag) { switch (tag) {
case T_INT8: i = (uint64_t)*(int8_t*)data; break; case T_INT8:
case T_UINT8: i = (uint64_t)*(uint8_t*)data; break; i = (uint64_t) * (int8_t *)data;
case T_INT16: i = (uint64_t)*(int16_t*)data; break; break;
case T_UINT16: i = (uint64_t)*(uint16_t*)data; break; case T_UINT8:
case T_INT32: i = (uint64_t)*(int32_t*)data; break; i = (uint64_t) * (uint8_t *)data;
case T_UINT32: i = (uint64_t)*(uint32_t*)data; break; break;
case T_INT64: i = (uint64_t)*(int64_t*)data; break; case T_INT16:
case T_UINT64: i = (uint64_t)*(uint64_t*)data; break; 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: case T_FLOAT:
if (*(float *)data >= 0) if (*(float *)data >= 0)
i = (uint64_t) * (float *)data; 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) int cmp_same_lt(void *a, void *b, numerictype_t tag)
{ {
switch (tag) { switch (tag) {
case T_INT8: return *(int8_t*)a < *(int8_t*)b; case T_INT8:
case T_UINT8: return *(uint8_t*)a < *(uint8_t*)b; return *(int8_t *)a < *(int8_t *)b;
case T_INT16: return *(int16_t*)a < *(int16_t*)b; case T_UINT8:
case T_UINT16: return *(uint16_t*)a < *(uint16_t*)b; return *(uint8_t *)a < *(uint8_t *)b;
case T_INT32: return *(int32_t*)a < *(int32_t*)b; case T_INT16:
case T_UINT32: return *(uint32_t*)a < *(uint32_t*)b; return *(int16_t *)a < *(int16_t *)b;
case T_INT64: return *(int64_t*)a < *(int64_t*)b; case T_UINT16:
case T_UINT64: return *(uint64_t*)a < *(uint64_t*)b; return *(uint16_t *)a < *(uint16_t *)b;
case T_FLOAT: return *(float*)a < *(float*)b; case T_INT32:
case T_DOUBLE: return *(double*)a < *(double*)b; 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; 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) int cmp_same_eq(void *a, void *b, numerictype_t tag)
{ {
switch (tag) { switch (tag) {
case T_INT8: return *(int8_t*)a == *(int8_t*)b; case T_INT8:
case T_UINT8: return *(uint8_t*)a == *(uint8_t*)b; return *(int8_t *)a == *(int8_t *)b;
case T_INT16: return *(int16_t*)a == *(int16_t*)b; case T_UINT8:
case T_UINT16: return *(uint16_t*)a == *(uint16_t*)b; return *(uint8_t *)a == *(uint8_t *)b;
case T_INT32: return *(int32_t*)a == *(int32_t*)b; case T_INT16:
case T_UINT32: return *(uint32_t*)a == *(uint32_t*)b; return *(int16_t *)a == *(int16_t *)b;
case T_INT64: return *(int64_t*)a == *(int64_t*)b; case T_UINT16:
case T_UINT64: return *(uint64_t*)a == *(uint64_t*)b; return *(uint16_t *)a == *(uint16_t *)b;
case T_FLOAT: return *(float*)a == *(float*)b; case T_INT32:
case T_DOUBLE: return *(double*)a == *(double*)b; 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; 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 (*(uint64_t *)a < (uint64_t) * (int64_t *)b);
} }
return ((int64_t) * (uint64_t *)a < *(int64_t *)b); return ((int64_t) * (uint64_t *)a < *(int64_t *)b);
} } else if (btag == T_DOUBLE) {
else if (btag == T_DOUBLE) { if (db != db)
if (db != db) return 0; return 0;
return (*(uint64_t *)a < (uint64_t) * (double *)b); return (*(uint64_t *)a < (uint64_t) * (double *)b);
} }
} } else if (atag == T_INT64) {
else if (atag == T_INT64) {
if (btag == T_UINT64) { if (btag == T_UINT64) {
if (*(int64_t *)a >= 0) { if (*(int64_t *)a >= 0) {
return ((uint64_t) * (int64_t *)a < *(uint64_t *)b); return ((uint64_t) * (int64_t *)a < *(uint64_t *)b);
} }
return (*(int64_t *)a < (int64_t) * (uint64_t *)b); return (*(int64_t *)a < (int64_t) * (uint64_t *)b);
} } else if (btag == T_DOUBLE) {
else if (btag == T_DOUBLE) { if (db != db)
if (db != db) return 0; return 0;
return (*(int64_t *)a < (int64_t) * (double *)b); return (*(int64_t *)a < (int64_t) * (double *)b);
} }
} }
if (btag == T_UINT64) { if (btag == T_UINT64) {
if (atag == T_DOUBLE) { if (atag == T_DOUBLE) {
if (da != da) return 0; if (da != da)
return 0;
return (*(uint64_t *)b > (uint64_t) * (double *)a); return (*(uint64_t *)b > (uint64_t) * (double *)a);
} }
} } else if (btag == T_INT64) {
else if (btag == T_INT64) {
if (atag == T_DOUBLE) { if (atag == T_DOUBLE) {
if (da != da) return 0; if (da != da)
return 0;
return (*(int64_t *)b > (int64_t) * (double *)a); 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 cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag,
int equalnans) 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)) if (atag == btag && (!equalnans || atag < T_FLOAT))
return cmp_same_eq(a, b, atag); 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 ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) {
if (equalnans) { if (equalnans) {
u.d = da; v.d = db; u.d = da;
v.d = db;
return u.i64 == v.i64; return u.i64 == v.i64;
} }
return (da == db); 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. // we would already have concluded that it's bigger than b.
if (btag == T_INT64) { if (btag == T_INT64) {
return ((int64_t) * (uint64_t *)a == *(int64_t *)b); 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); return (*(uint64_t *)a == (uint64_t)(int64_t) * (double *)b);
} }
} } else if (atag == T_INT64) {
else if (atag == T_INT64) {
if (btag == T_UINT64) { if (btag == T_UINT64) {
return (*(int64_t *)a == (int64_t) * (uint64_t *)b); 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); return (*(int64_t *)a == (int64_t) * (double *)b);
} }
} } else if (btag == T_UINT64) {
else if (btag == T_UINT64) {
if (atag == T_INT64) { if (atag == T_INT64) {
return ((int64_t) * (uint64_t *)b == *(int64_t *)a); 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); return (*(uint64_t *)b == (uint64_t)(int64_t) * (double *)a);
} }
} } else if (btag == T_INT64) {
else if (btag == T_INT64) {
if (atag == T_UINT64) { if (atag == T_UINT64) {
return (*(int64_t *)b == (int64_t) * (uint64_t *)a); 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); 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; return n0;
} }
void fl_print_chr(char c, ios_t *f) void fl_print_chr(char c, ios_t *f) { outc(c, f); }
{
outc(c, f);
}
void fl_print_str(char *s, ios_t *f) void fl_print_str(char *s, ios_t *f) { outs(s, f); }
{
outs(s, f);
}
void print_traverse(value_t v) void print_traverse(value_t v)
{ {
@ -88,18 +82,15 @@ void print_traverse(value_t v)
unsigned int i; unsigned int i;
for (i = 0; i < vector_size(v); i++) for (i = 0; i < vector_size(v); i++)
print_traverse(vector_elt(v, i)); print_traverse(vector_elt(v, i));
} } else if (iscprim(v)) {
else if (iscprim(v)) {
// don't consider shared references to e.g. chars // don't consider shared references to e.g. chars
} } else if (isclosure(v)) {
else if (isclosure(v)) {
mark_cons(v); mark_cons(v);
function_t *f = (function_t *)ptr(v); function_t *f = (function_t *)ptr(v);
print_traverse(f->bcode); print_traverse(f->bcode);
print_traverse(f->vals); print_traverse(f->vals);
print_traverse(f->env); print_traverse(f->env);
} } else {
else {
assert(iscvalue(v)); assert(iscvalue(v));
cvalue_t *cv = (cvalue_t *)ptr(v); cvalue_t *cv = (cvalue_t *)ptr(v);
// don't consider shared references to "" // 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; int i, escape = 0, charescape = 0;
if ((name[0] == '\0') || if ((name[0] == '\0') || (name[0] == '.' && name[1] == '\0') ||
(name[0] == '.' && name[1] == '\0') || (name[0] == '#') || isnumtok(name, NULL))
(name[0] == '#') ||
isnumtok(name, NULL))
escape = 1; escape = 1;
i = 0; i = 0;
while (name[i]) { while (name[i]) {
@ -142,14 +131,12 @@ static void print_symbol_name(ios_t *f, char *name)
i++; i++;
} }
outc('|', f); outc('|', f);
} } else {
else {
outc('|', f); outc('|', f);
outs(name, f); outs(name, f);
outc('|', f); outc('|', f);
} }
} } else {
else {
outs(name, f); outs(name, f);
} }
} }
@ -170,17 +157,19 @@ static inline int tinyp(value_t v)
return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN); return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
if (fl_isstring(v)) if (fl_isstring(v))
return (cv_len((cvalue_t *)ptr(v)) < SMALL_STR_LEN); return (cv_len((cvalue_t *)ptr(v)) < SMALL_STR_LEN);
return (isfixnum(v) || isbuiltin(v) || v==FL_F || v==FL_T || v==FL_NIL || return (isfixnum(v) || isbuiltin(v) || v == FL_F || v == FL_T ||
v == FL_EOF || iscprim(v)); v == FL_NIL || v == FL_EOF || iscprim(v));
} }
static int smallp(value_t v) static int smallp(value_t v)
{ {
if (tinyp(v)) return 1; if (tinyp(v))
if (fl_isnumber(v)) return 1; return 1;
if (fl_isnumber(v))
return 1;
if (iscons(v)) { if (iscons(v)) {
if (tinyp(car_(v)) && (tinyp(cdr_(v)) || if (tinyp(car_(v)) &&
(iscons(cdr_(v)) && tinyp(car_(cdr_(v))) && (tinyp(cdr_(v)) || (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) &&
cdr_(cdr_(v)) == NIL))) cdr_(cdr_(v)) == NIL)))
return 1; return 1;
return 0; return 0;
@ -188,8 +177,7 @@ static int smallp(value_t v)
if (isvector(v)) { if (isvector(v)) {
size_t s = vector_size(v); size_t s = vector_size(v);
return (s == 0 || (tinyp(vector_elt(v, 0)) && return (s == 0 || (tinyp(vector_elt(v, 0)) &&
(s == 1 || (s == 2 && (s == 1 || (s == 2 && tinyp(vector_elt(v, 1))))));
tinyp(vector_elt(v,1))))));
} }
return 0; return 0;
} }
@ -283,7 +271,8 @@ static void print_pair(ios_t *f, value_t v)
outc('(', f); outc('(', f);
int newindent = HPOS, blk = blockindent(v); int newindent = HPOS, blk = blockindent(v);
int lastv, n = 0, si, ind = 0, est, always = 0, nextsmall, thistiny; 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); value_t head = car_(v);
int after3 = indentafter3(head, v); int after3 = indentafter3(head, v);
int after2 = indentafter2(head, v); int after2 = indentafter2(head, v);
@ -306,17 +295,15 @@ static void print_pair(ios_t *f, value_t v)
break; break;
} }
if (!print_pretty || if (!print_pretty || ((head == LAMBDA) && n == 0)) {
((head == LAMBDA) && n == 0)) {
// never break line before lambda-list // never break line before lambda-list
ind = 0; ind = 0;
} } else {
else {
est = lengthestimate(car_(cd)); est = lengthestimate(car_(cd));
nextsmall = smallp(car_(cd)); nextsmall = smallp(car_(cd));
thistiny = tinyp(car_(v)); thistiny = tinyp(car_(v));
ind = (((VPOS > lastv) || ind = (((VPOS > lastv) || (HPOS > SCR_WIDTH / 2 && !nextsmall &&
(HPOS>SCR_WIDTH/2 && !nextsmall && !thistiny && n>0)) || !thistiny && n > 0)) ||
(HPOS > SCR_WIDTH - 4) || (HPOS > SCR_WIDTH - 4) ||
@ -326,8 +313,7 @@ static void print_pair(ios_t *f, value_t v)
(n > 0 && always) || (n > 0 && always) ||
(n == 2 && after3) || (n == 2 && after3) || (n == 1 && after2) ||
(n == 1 && after2) ||
(n_unindented >= 3 && !nextsmall) || (n_unindented >= 3 && !nextsmall) ||
@ -337,8 +323,7 @@ static void print_pair(ios_t *f, value_t v)
if (ind) { if (ind) {
newindent = outindent(newindent, f); newindent = outindent(newindent, f);
n_unindented = 1; n_unindented = 1;
} } else {
else {
n_unindented++; n_unindented++;
outc(' ', f); outc(' ', f);
if (n == 0) { if (n == 0) {
@ -385,7 +370,9 @@ void fl_print_child(ios_t *f, value_t v)
switch (tag(v)) { switch (tag(v)) {
case TAG_NUM: 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: case TAG_SYM:
name = symbol_name(v); name = symbol_name(v);
if (print_princ) if (print_princ)
@ -393,39 +380,36 @@ void fl_print_child(ios_t *f, value_t v)
else if (ismanaged(v)) { else if (ismanaged(v)) {
outsn("#:", f, 2); outsn("#:", f, 2);
outs(name, f); outs(name, f);
} } else
else
print_symbol_name(f, name); print_symbol_name(f, name);
break; break;
case TAG_FUNCTION: case TAG_FUNCTION:
if (v == FL_T) { if (v == FL_T) {
outsn("#t", f, 2); outsn("#t", f, 2);
} } else if (v == FL_F) {
else if (v == FL_F) {
outsn("#f", f, 2); outsn("#f", f, 2);
} } else if (v == FL_NIL) {
else if (v == FL_NIL) {
outsn("()", f, 2); outsn("()", f, 2);
} } else if (v == FL_EOF) {
else if (v == FL_EOF) {
outsn("#<eof>", f, 6); outsn("#<eof>", f, 6);
} } else if (isbuiltin(v)) {
else if (isbuiltin(v)) {
if (!print_princ) if (!print_princ)
outsn("#.", f, 2); outsn("#.", f, 2);
outs(builtin_names[uintval(v)], f); outs(builtin_names[uintval(v)], f);
} } else {
else {
assert(isclosure(v)); assert(isclosure(v));
if (!print_princ) { if (!print_princ) {
if (print_circle_prefix(f, v)) break; if (print_circle_prefix(f, v))
break;
function_t *fn = (function_t *)ptr(v); function_t *fn = (function_t *)ptr(v);
outs("#fn(", f); outs("#fn(", f);
char *data = cvalue_data(fn->bcode); char *data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(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); 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); outc(' ', f);
fl_print_child(f, fn->vals); fl_print_child(f, fn->vals);
if (fn->env != NIL) { if (fn->env != NIL) {
@ -437,8 +421,7 @@ void fl_print_child(ios_t *f, value_t v)
fl_print_child(f, fn->name); fl_print_child(f, fn->name);
} }
outc(')', f); outc(')', f);
} } else {
else {
outs("#<function>", f); outs("#<function>", f);
} }
} }
@ -452,7 +435,8 @@ void fl_print_child(ios_t *f, value_t v)
case TAG_CVALUE: case TAG_CVALUE:
case TAG_VECTOR: case TAG_VECTOR:
case TAG_CONS: case TAG_CONS:
if (!print_princ && print_circle_prefix(f, v)) break; if (!print_princ && print_circle_prefix(f, v))
break;
if (isvector(v)) { if (isvector(v)) {
outc('[', f); outc('[', f);
int newindent = HPOS, est; int newindent = HPOS, est;
@ -466,8 +450,7 @@ void fl_print_child(ios_t *f, value_t v)
if (i < sz - 1) { if (i < sz - 1) {
if (!print_pretty) { if (!print_pretty) {
outc(' ', f); outc(' ', f);
} } else {
else {
est = lengthestimate(vector_elt(v, i + 1)); est = lengthestimate(vector_elt(v, i + 1));
if (HPOS > SCR_WIDTH - 4 || if (HPOS > SCR_WIDTH - 4 ||
(est != -1 && (HPOS + est > SCR_WIDTH - 2)) || (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); outc(hexdig[c & 0xf], f);
} }
} }
} } else {
else {
while (i < sz) { while (i < sz) {
size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0); size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0);
outsn(buf, f, n - 1); outsn(buf, f, n - 1);
@ -579,8 +561,7 @@ void snprint_real(char *s, size_t cnt, double r,
num_format[1] = 'e'; num_format[1] = 'e';
temp = r / pow(10, mag); /* see if number will have a decimal */ temp = r / pow(10, mag); /* see if number will have a decimal */
fpart = temp - floor(temp); /* when written in scientific notation */ fpart = temp - floor(temp); /* when written in scientific notation */
} } else {
else {
num_format[1] = 'f'; num_format[1] = 'f';
fpart = r - floor(r); fpart = r - floor(r);
} }
@ -588,8 +569,7 @@ void snprint_real(char *s, size_t cnt, double r,
dec = 0; dec = 0;
if (width == 0) { if (width == 0) {
snprintf(format, 8, "%%.%d%s", dec, num_format); snprintf(format, 8, "%%.%d%s", dec, num_format);
} } else {
else {
snprintf(format, 8, "%%%d.%d%s", width, dec, num_format); snprintf(format, 8, "%%%d.%d%s", width, dec, num_format);
} }
sz = snprintf(s, cnt, format, r); 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); HPOS += ios_printf(f, "0x%hhx", ch);
else else
HPOS += ios_printf(f, "#byte(0x%hhx)", ch); HPOS += ios_printf(f, "#byte(0x%hhx)", ch);
} } else if (type == wcharsym) {
else if (type == wcharsym) {
uint32_t wc = *(uint32_t *)data; uint32_t wc = *(uint32_t *)data;
char seq[8]; char seq[8];
size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1); 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); ios_putc(0, f);
else else
outs(seq, f); outs(seq, f);
} } else {
else {
outsn("#\\", f, 2); outsn("#\\", f, 2);
if (wc == 0x00) outsn("nul", f, 3); if (wc == 0x00)
else if (wc == 0x07) outsn("alarm", f, 5); outsn("nul", f, 3);
else if (wc == 0x08) outsn("backspace", f, 9); else if (wc == 0x07)
else if (wc == 0x09) outsn("tab", f, 3); 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("linefeed", f, 8);
else if (wc == 0x0A) outsn("newline", f, 7); else if (wc == 0x0A)
else if (wc == 0x0B) outsn("vtab", f, 4); outsn("newline", f, 7);
else if (wc == 0x0C) outsn("page", f, 4); else if (wc == 0x0B)
else if (wc == 0x0D) outsn("return", f, 6); outsn("vtab", f, 4);
else if (wc == 0x1B) outsn("esc", f, 3); 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 == 0x20) outsn("space", f, 5);
else if (wc == 0x7F) outsn("delete", f, 6); else if (wc == 0x7F)
else if (iswprint(wc)) outs(seq, f); outsn("delete", f, 6);
else HPOS+=ios_printf(f, "x%04x", (int)wc); 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]; char buf[64];
double d; double d;
int ndec; int ndec;
if (type == floatsym) { d = (double)*(float*)data; ndec = 8; } if (type == floatsym) {
else { d = *(double*)data; ndec = 16; } d = (double)*(float *)data;
ndec = 8;
} else {
d = *(double *)data;
ndec = 16;
}
if (!DFINITE(d)) { if (!DFINITE(d)) {
char *rep; char *rep;
if (isnan(d)) 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); HPOS += ios_printf(f, "#%s(%s)", symbol_name(type), rep);
else else
outs(rep, f); outs(rep, f);
} } else if (d == 0) {
else if (d == 0) {
if (1 / d < 0) if (1 / d < 0)
outsn("-0.0", f, 4); outsn("-0.0", f, 4);
else else
outsn("0.0", f, 3); outsn("0.0", f, 3);
if (type == floatsym && !print_princ && !weak) if (type == floatsym && !print_princ && !weak)
outc('f', f); outc('f', f);
} } else {
else {
snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10); snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
int hasdec = (strpbrk(buf, ".eE") != NULL); int hasdec = (strpbrk(buf, ".eE") != NULL);
outs(buf, f); outs(buf, f);
if (!hasdec) outsn(".0", f, 2); if (!hasdec)
outsn(".0", f, 2);
if (type == floatsym && !print_princ && !weak) if (type == floatsym && !print_princ && !weak)
outc('f', f); outc('f', f);
} }
} } else if (type == uint64sym
else if (type == uint64sym
#ifdef BITS64 #ifdef BITS64
|| type == ulongsym || type == ulongsym
#endif #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); HPOS += ios_printf(f, "%llu", ui64);
else else
HPOS += ios_printf(f, "#%s(%llu)", symbol_name(type), ui64); 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 // handle other integer prims. we know it's smaller than uint64
// at this point, so int64 is big enough to capture everything. // at this point, so int64 is big enough to capture everything.
numerictype_t nt = sym_to_numtype(type); numerictype_t nt = sym_to_numtype(type);
if (nt == N_NUMTYPES) { if (nt == N_NUMTYPES) {
HPOS += ios_printf(f, "#<%s>", symbol_name(type)); HPOS += ios_printf(f, "#<%s>", symbol_name(type));
} } else {
else {
int64_t i64 = conv_to_int64(data, nt); int64_t i64 = conv_to_int64(data, nt);
if (weak || print_princ) if (weak || print_princ)
HPOS += ios_printf(f, "%lld", i64); HPOS += ios_printf(f, "%lld", i64);
else else
HPOS += ios_printf(f, "#%s(%lld)", symbol_name(type), i64); HPOS += ios_printf(f, "#%s(%lld)", symbol_name(type), i64);
} }
} } else if (iscons(type)) {
else if (iscons(type)) {
if (car_(type) == arraysym) { if (car_(type) == arraysym) {
value_t eltype = car(cdr_(type)); value_t eltype = car(cdr_(type));
size_t cnt, elsize; size_t cnt, elsize;
if (iscons(cdr_(cdr_(type)))) { if (iscons(cdr_(cdr_(type)))) {
cnt = toulong(car_(cdr_(cdr_(type))), "length"); cnt = toulong(car_(cdr_(cdr_(type))), "length");
elsize = cnt ? len / cnt : 0; elsize = cnt ? len / cnt : 0;
} } else {
else {
// incomplete array type // incomplete array type
int junk; int junk;
elsize = ctype_sizeof(eltype, &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 else
HPOS += u8_strwidth(data); HPOS += u8_strwidth(data);
*/ */
} } else {
else {
print_string(f, (char *)data, len); print_string(f, (char *)data, len);
} }
return; return;
} } else if (eltype == wcharsym) {
else if (eltype == wcharsym) {
// TODO wchar // TODO wchar
} } else {
else {
} }
size_t i; size_t i;
if (!weak) { if (!weak) {
if (eltype == uint8sym) { if (eltype == uint8sym) {
outsn("#vu8(", f, 5); outsn("#vu8(", f, 5);
} } else {
else {
outsn("#array(", f, 7); outsn("#array(", f, 7);
fl_print_child(f, eltype); fl_print_child(f, eltype);
if (cnt > 0) if (cnt > 0)
outc(' ', f); outc(' ', f);
} }
} } else {
else {
outc('[', f); outc('[', f);
} }
for (i = 0; i < cnt; i++) { 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); outc(')', f);
else else
outc(']', f); outc(']', f);
} } else if (car_(type) == enumsym) {
else if (car_(type) == enumsym) {
int n = *(int *)data; int n = *(int *)data;
value_t syms = car(cdr_(type)); value_t syms = car(cdr_(type));
assert(isvector(syms)); 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)) { if (n >= (int)vector_size(syms)) {
cvalue_printdata(f, data, len, int32sym, 1); cvalue_printdata(f, data, len, int32sym, 1);
} } else {
else {
fl_print_child(f, vector_elt(syms, n)); fl_print_child(f, vector_elt(syms, n));
} }
if (!weak) if (!weak)
@ -813,25 +794,21 @@ static void cvalue_print(ios_t *f, value_t v)
void *fptr = *(void **)data; void *fptr = *(void **)data;
label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, cv); label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, cv);
if (label == (value_t)HT_NOTFOUND) { if (label == (value_t)HT_NOTFOUND) {
HPOS += ios_printf(f, "#<builtin @0x%08zx>", HPOS +=
(size_t)(builtin_t)fptr); ios_printf(f, "#<builtin @0x%08zx>", (size_t)(builtin_t)fptr);
} } else {
else {
if (print_princ) { if (print_princ) {
outs(symbol_name(label), f); outs(symbol_name(label), f);
} } else {
else {
outsn("#fn(", f, 4); outsn("#fn(", f, 4);
outs(symbol_name(label), f); outs(symbol_name(label), f);
outc(')', 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 != NULL) {
cv_class(cv)->vtable->print(v, f); cv_class(cv)->vtable->print(v, f);
} } else {
else {
value_t type = cv_type(cv); value_t type = cv_type(cv);
size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv); size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
cvalue_printdata(f, data, len, type, 0); 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) static void set_print_width(void)
{ {
value_t pw = symbol_value(printwidthsym); value_t pw = symbol_value(printwidthsym);
if (!isfixnum(pw)) return; if (!isfixnum(pw))
return;
SCR_WIDTH = numval(pw); SCR_WIDTH = numval(pw);
} }
@ -853,15 +831,20 @@ void fl_print(ios_t *f, value_t v)
print_princ = (symbol_value(printreadablysym) == FL_F); print_princ = (symbol_value(printreadablysym) == FL_F);
value_t pl = symbol_value(printlengthsym); value_t pl = symbol_value(printlengthsym);
if (isfixnum(pl)) print_length = numval(pl); if (isfixnum(pl))
else print_length = -1; print_length = numval(pl);
else
print_length = -1;
pl = symbol_value(printlevelsym); pl = symbol_value(printlevelsym);
if (isfixnum(pl)) print_level = numval(pl); if (isfixnum(pl))
else print_level = -1; print_level = numval(pl);
else
print_level = -1;
P_LEVEL = 0; P_LEVEL = 0;
printlabel = 0; printlabel = 0;
if (!print_princ) print_traverse(v); if (!print_princ)
print_traverse(v);
HPOS = VPOS = 0; HPOS = VPOS = 0;
fl_print_child(f, v); fl_print_child(f, v);

245
read.c
View File

@ -1,8 +1,25 @@
enum { enum {
TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM, TOK_NONE,
TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT, TOK_OPEN,
TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN, TOK_CLOSE,
TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE 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) #define F value2c(ios_t *, readstate->source)
@ -29,49 +46,55 @@ int isnumtok_base(char *tok, value_t *pval, int base)
strpbrk(tok, ".eEpP")) { strpbrk(tok, ".eEpP")) {
d = strtod(tok, &end); d = strtod(tok, &end);
if (*end == '\0') { if (*end == '\0') {
if (pval) *pval = mk_double(d); if (pval)
*pval = mk_double(d);
return 1; return 1;
} }
// floats can end in f or f0 // floats can end in f or f0
if (end > tok && end[0] == 'f' && if (end > tok && end[0] == 'f' &&
(end[1] == '\0' || (end[1] == '\0' || (end[1] == '0' && end[2] == '\0'))) {
(end[1] == '0' && end[2] == '\0'))) { if (pval)
if (pval) *pval = mk_float((float)d); *pval = mk_float((float)d);
return 1; return 1;
} }
} }
if (tok[0] == '+') { if (tok[0] == '+') {
if (!strcmp(tok, "+NaN") || !strcasecmp(tok, "+nan.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; return 1;
} }
if (!strcmp(tok, "+Inf") || !strcasecmp(tok, "+inf.0")) { if (!strcmp(tok, "+Inf") || !strcasecmp(tok, "+inf.0")) {
if (pval) *pval = mk_double(D_PINF); if (pval)
*pval = mk_double(D_PINF);
return 1; return 1;
} }
} } else if (tok[0] == '-') {
else if (tok[0] == '-') {
if (!strcmp(tok, "-NaN") || !strcasecmp(tok, "-nan.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; return 1;
} }
if (!strcmp(tok, "-Inf") || !strcasecmp(tok, "-inf.0")) { if (!strcmp(tok, "-Inf") || !strcasecmp(tok, "-inf.0")) {
if (pval) *pval = mk_double(D_NINF); if (pval)
*pval = mk_double(D_NINF);
return 1; return 1;
} }
errno = 0; errno = 0;
i64 = strtoll(tok, &end, base); i64 = strtoll(tok, &end, base);
if (errno) if (errno)
return 0; return 0;
if (pval) *pval = return_from_int64(i64); if (pval)
*pval = return_from_int64(i64);
return (*end == '\0'); return (*end == '\0');
} }
errno = 0; errno = 0;
ui64 = strtoull(tok, &end, base); ui64 = strtoull(tok, &end, base);
if (errno) if (errno)
return 0; return 0;
if (pval) *pval = return_from_uint64(ui64); if (pval)
*pval = return_from_uint64(ui64);
return (*end == '\0'); return (*end == '\0');
} }
@ -103,8 +126,7 @@ static char nextchar(void)
do { do {
if (f->bpos < f->size) { if (f->bpos < f->size) {
ch = f->buf[f->bpos++]; ch = f->buf[f->bpos++];
} } else {
else {
ch = ios_getc(f); ch = ios_getc(f);
if (ch == IOS_EOF) if (ch == IOS_EOF)
return 0; return 0;
@ -123,10 +145,7 @@ static char nextchar(void)
return c; return c;
} }
static void take(void) static void take(void) { toktype = TOK_NONE; }
{
toktype = TOK_NONE;
}
static void accumchar(char c, int *pi) static void accumchar(char c, int *pi)
{ {
@ -151,18 +170,15 @@ static int read_token(char c, int digits)
if (c == '|') { if (c == '|') {
issym = 1; issym = 1;
escaped = !escaped; escaped = !escaped;
} } else if (c == '\\') {
else if (c == '\\') {
issym = 1; issym = 1;
ch = ios_getc(F); ch = ios_getc(F);
if (ch == IOS_EOF) if (ch == IOS_EOF)
goto terminate; goto terminate;
accumchar((char)ch, &i); accumchar((char)ch, &i);
} } else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
break; break;
} } else {
else {
accumchar(c, &i); accumchar(c, &i);
} }
} }
@ -183,42 +199,36 @@ static u_int32_t peek(void)
if (toktype != TOK_NONE) if (toktype != TOK_NONE)
return toktype; return toktype;
c = nextchar(); c = nextchar();
if (ios_eof(F)) return TOK_NONE; if (ios_eof(F))
return TOK_NONE;
if (c == '(') { if (c == '(') {
toktype = TOK_OPEN; toktype = TOK_OPEN;
} } else if (c == ')') {
else if (c == ')') {
toktype = TOK_CLOSE; toktype = TOK_CLOSE;
} } else if (c == '[') {
else if (c == '[') {
toktype = TOK_OPENB; toktype = TOK_OPENB;
} } else if (c == ']') {
else if (c == ']') {
toktype = TOK_CLOSEB; toktype = TOK_CLOSEB;
} } else if (c == '\'') {
else if (c == '\'') {
toktype = TOK_QUOTE; toktype = TOK_QUOTE;
} } else if (c == '`') {
else if (c == '`') {
toktype = TOK_BQ; toktype = TOK_BQ;
} } else if (c == '"') {
else if (c == '"') {
toktype = TOK_DOUBLEQUOTE; toktype = TOK_DOUBLEQUOTE;
} } else if (c == '#') {
else if (c == '#') { ch = ios_getc(F);
ch = ios_getc(F); c = (char)ch; c = (char)ch;
if (ch == IOS_EOF) if (ch == IOS_EOF)
lerror(ParseError, "read: invalid read macro"); lerror(ParseError, "read: invalid read macro");
if (c == '.') { if (c == '.') {
toktype = TOK_SHARPDOT; toktype = TOK_SHARPDOT;
} } else if (c == '\'') {
else if (c == '\'') {
toktype = TOK_SHARPQUOTE; toktype = TOK_SHARPQUOTE;
} } else if (c == '\\') {
else if (c == '\\') {
uint32_t cval; uint32_t cval;
if (ios_getutf8(F, &cval) == IOS_EOF) 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' || if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
cval == (uint32_t)'x') { cval == (uint32_t)'x') {
read_token('u', 0); read_token('u', 0);
@ -228,36 +238,45 @@ static u_int32_t peek(void)
"read: invalid hex character constant"); "read: invalid hex character constant");
cval = numval(tokval); cval = numval(tokval);
} }
} } else if (cval >= 'a' && cval <= 'z') {
else if (cval >= 'a' && cval <= 'z') {
read_token((char)cval, 0); read_token((char)cval, 0);
tokval = symbol(buf); tokval = symbol(buf);
if (buf[1] == '\0') /* one character */; if (buf[1] == '\0') /* one character */
else if (tokval == nulsym) cval = 0x00; ;
else if (tokval == alarmsym) cval = 0x07; else if (tokval == nulsym)
else if (tokval == backspacesym) cval = 0x08; cval = 0x00;
else if (tokval == tabsym) cval = 0x09; else if (tokval == alarmsym)
else if (tokval == linefeedsym) cval = 0x0A; cval = 0x07;
else if (tokval == newlinesym) cval = 0x0A; else if (tokval == backspacesym)
else if (tokval == vtabsym) cval = 0x0B; cval = 0x08;
else if (tokval == pagesym) cval = 0x0C; else if (tokval == tabsym)
else if (tokval == returnsym) cval = 0x0D; cval = 0x09;
else if (tokval == escsym) cval = 0x1B; else if (tokval == linefeedsym)
else if (tokval == spacesym) cval = 0x20; cval = 0x0A;
else if (tokval == deletesym) cval = 0x7F; 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 else
lerrorf(ParseError, "read: unknown character #\\%s", buf); lerrorf(ParseError, "read: unknown character #\\%s", buf);
} }
toktype = TOK_NUM; toktype = TOK_NUM;
tokval = mk_wchar(cval); tokval = mk_wchar(cval);
} } else if (c == '(') {
else if (c == '(') {
toktype = TOK_SHARPOPEN; toktype = TOK_SHARPOPEN;
} } else if (c == '<') {
else if (c == '<') {
lerror(ParseError, "read: unreadable object"); lerror(ParseError, "read: unreadable object");
} } else if (isdigit(c)) {
else if (isdigit(c)) {
read_token(c, 1); read_token(c, 1);
c = (char)ios_getc(F); c = (char)ios_getc(F);
if (c == '#') if (c == '#')
@ -271,15 +290,13 @@ static u_int32_t peek(void)
if (*end != '\0' || errno) if (*end != '\0' || errno)
lerror(ParseError, "read: invalid label"); lerror(ParseError, "read: invalid label");
tokval = fixnum(x); tokval = fixnum(x);
} } else if (c == '!') {
else if (c == '!') {
// #! single line comment for shbang script support // #! single line comment for shbang script support
do { do {
ch = ios_getc(F); ch = ios_getc(F);
} while (ch != IOS_EOF && (char)ch != '\n'); } while (ch != IOS_EOF && (char)ch != '\n');
return peek(); return peek();
} } else if (c == '|') {
else if (c == '|') {
// multiline comment // multiline comment
int commentlevel = 1; int commentlevel = 1;
while (1) { while (1) {
@ -297,8 +314,7 @@ static u_int32_t peek(void)
continue; continue;
} }
goto hashpipe_gotc; goto hashpipe_gotc;
} } else if ((char)ch == '#') {
else if ((char)ch == '#') {
ch = ios_getc(F); ch = ios_getc(F);
if ((char)ch == '|') if ((char)ch == '|')
commentlevel++; commentlevel++;
@ -308,13 +324,11 @@ static u_int32_t peek(void)
} }
// this was whitespace, so keep peeking // this was whitespace, so keep peeking
return peek(); return peek();
} } else if (c == ';') {
else if (c == ';') {
// datum comment // datum comment
(void)do_read_sexpr(UNBOUND); // skip (void)do_read_sexpr(UNBOUND); // skip
return peek(); return peek();
} } else if (c == ':') {
else if (c == ':') {
// gensym // gensym
ch = ios_getc(F); ch = ios_getc(F);
if ((char)ch == 'g') if ((char)ch == 'g')
@ -326,29 +340,24 @@ static u_int32_t peek(void)
lerror(ParseError, "read: invalid gensym label"); lerror(ParseError, "read: invalid gensym label");
toktype = TOK_GENSYM; toktype = TOK_GENSYM;
tokval = fixnum(x); tokval = fixnum(x);
} } else if (symchar(c)) {
else if (symchar(c)) {
read_token(ch, 0); read_token(ch, 0);
if (((c == 'b' && (base= 2)) || if (((c == 'b' && (base = 2)) || (c == 'o' && (base = 8)) ||
(c == 'o' && (base= 8)) || (c == 'd' && (base = 10)) || (c == 'x' && (base = 16))) &&
(c == 'd' && (base=10)) || (isdigit_base(buf[1], base) || buf[1] == '-')) {
(c == 'x' && (base=16))) &&
(isdigit_base(buf[1],base) ||
buf[1]=='-')) {
if (!read_numtok(&buf[1], &tokval, base)) if (!read_numtok(&buf[1], &tokval, base))
lerrorf(ParseError, "read: invalid base %d constant", base); lerrorf(ParseError, "read: invalid base %d constant",
base);
return (toktype = TOK_NUM); return (toktype = TOK_NUM);
} }
toktype = TOK_SHARPSYM; toktype = TOK_SHARPSYM;
tokval = symbol(buf); tokval = symbol(buf);
} } else {
else {
lerror(ParseError, "read: unknown read macro"); lerror(ParseError, "read: unknown read macro");
} }
} } else if (c == ',') {
else if (c == ',') {
toktype = TOK_COMMA; toktype = TOK_COMMA;
ch = ios_getc(F); ch = ios_getc(F);
if (ch == IOS_EOF) if (ch == IOS_EOF)
@ -359,13 +368,11 @@ static u_int32_t peek(void)
toktype = TOK_COMMADOT; toktype = TOK_COMMADOT;
else else
ios_ungetc((char)ch, F); ios_ungetc((char)ch, F);
} } else {
else {
if (!read_token(c, 0)) { if (!read_token(c, 0)) {
if (buf[0] == '.' && buf[1] == '\0') { if (buf[0] == '.' && buf[1] == '\0') {
return (toktype = TOK_DOT); return (toktype = TOK_DOT);
} } else {
else {
if (read_numtok(buf, &tokval, 0)) if (read_numtok(buf, &tokval, 0))
return (toktype = TOK_NUM); return (toktype = TOK_NUM);
} }
@ -464,23 +471,24 @@ static value_t read_string(void)
eseq[j++] = c; eseq[j++] = c;
c = ios_getc(F); c = ios_getc(F);
} while (octal_digit(c) && j < 3 && (c != IOS_EOF)); } 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'; eseq[j] = '\0';
wc = strtol(eseq, NULL, 8); wc = strtol(eseq, NULL, 8);
// \DDD and \xXX read bytes, not characters // \DDD and \xXX read bytes, not characters
buf[i++] = ((char)wc); buf[i++] = ((char)wc);
} } else if ((c == 'x' && (ndig = 2)) || (c == 'u' && (ndig = 4)) ||
else if ((c=='x' && (ndig=2)) ||
(c=='u' && (ndig=4)) ||
(c == 'U' && (ndig = 8))) { (c == 'U' && (ndig = 8))) {
c = ios_getc(F); c = ios_getc(F);
while (hex_digit(c) && j < ndig && (c != IOS_EOF)) { while (hex_digit(c) && j < ndig && (c != IOS_EOF)) {
eseq[j++] = c; eseq[j++] = c;
c = ios_getc(F); c = ios_getc(F);
} }
if (c!=IOS_EOF) ios_ungetc(c, F); if (c != IOS_EOF)
ios_ungetc(c, F);
eseq[j] = '\0'; eseq[j] = '\0';
if (j) wc = strtol(eseq, NULL, 16); if (j)
wc = strtol(eseq, NULL, 16);
if (!j || wc > 0x10ffff) { if (!j || wc > 0x10ffff) {
free(buf); free(buf);
lerror(ParseError, "read: invalid escape sequence"); lerror(ParseError, "read: invalid escape sequence");
@ -489,12 +497,10 @@ static value_t read_string(void)
buf[i++] = ((char)wc); buf[i++] = ((char)wc);
else else
i += u8_wc_toutf8(&buf[i], wc); i += u8_wc_toutf8(&buf[i], wc);
} } else {
else {
buf[i++] = read_escape_control_char((char)c); buf[i++] = read_escape_control_char((char)c);
} }
} } else {
else {
buf[i++] = c; buf[i++] = c;
} }
} }
@ -518,11 +524,11 @@ static void read_list(value_t *pval, value_t label)
while (t != TOK_CLOSE) { while (t != TOK_CLOSE) {
if (ios_eof(F)) if (ios_eof(F))
lerror(ParseError, "read: unexpected end of input"); 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)) { if (iscons(*pc)) {
cdr_(*pc) = c; cdr_(*pc) = c;
} } else {
else {
*pval = c; *pval = c;
if (label != UNBOUND) if (label != UNBOUND)
ptrhash_put(&readstate->backrefs, (void *)label, (void *)c); ptrhash_put(&readstate->backrefs, (void *)label, (void *)c);
@ -570,13 +576,17 @@ static value_t do_read_sexpr(value_t label)
case TOK_NUM: case TOK_NUM:
return tokval; return tokval;
case TOK_COMMA: case TOK_COMMA:
head = &COMMA; goto listwith; head = &COMMA;
goto listwith;
case TOK_COMMAAT: case TOK_COMMAAT:
head = &COMMAAT; goto listwith; head = &COMMAAT;
goto listwith;
case TOK_COMMADOT: case TOK_COMMADOT:
head = &COMMADOT; goto listwith; head = &COMMADOT;
goto listwith;
case TOK_BQ: case TOK_BQ:
head = &BACKQUOTE; goto listwith; head = &BACKQUOTE;
goto listwith;
case TOK_QUOTE: case TOK_QUOTE:
head = &QUOTE; head = &QUOTE;
listwith: listwith:
@ -615,8 +625,7 @@ static value_t do_read_sexpr(value_t label)
if (sym == vu8sym) { if (sym == vu8sym) {
sym = arraysym; sym = arraysym;
Stack[SP - 1] = fl_cons(uint8sym, Stack[SP - 1]); Stack[SP - 1] = fl_cons(uint8sym, Stack[SP - 1]);
} } else if (sym == fnsym) {
else if (sym == fnsym) {
sym = FUNCTION; sym = FUNCTION;
} }
v = symbol_value(sym); v = symbol_value(sym);
@ -629,8 +638,8 @@ static value_t do_read_sexpr(value_t label)
return read_vector(label, TOK_CLOSE); return read_vector(label, TOK_CLOSE);
case TOK_SHARPDOT: case TOK_SHARPDOT:
// eval-when-read // eval-when-read
// evaluated expressions can refer to existing backreferences, but they // evaluated expressions can refer to existing backreferences, but
// cannot see pending labels. in other words: // they cannot see pending labels. in other words:
// (... #2=#.#0# ... ) OK // (... #2=#.#0# ... ) OK
// (... #2=#.(#2#) ... ) DO NOT WANT // (... #2=#.(#2#) ... ) DO NOT WANT
sym = do_read_sexpr(UNBOUND); 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; int term = 0;
if (nargs == 2) { if (nargs == 2) {
term = (args[1] != FL_F); term = (args[1] != FL_F);
} } else {
else {
argcount("string.decode", nargs, 1); argcount("string.decode", nargs, 1);
} }
if (!fl_isstring(args[0])) 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 nb = cv_len(cv);
size_t nc = u8_charnum(ptr, nb); size_t nc = u8_charnum(ptr, nb);
size_t newsz = nc * sizeof(uint32_t); 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); value_t wcstr = cvalue(wcstringtype, newsz);
ptr = cv_data((cvalue_t *)ptr(args[0])); // relocatable pointer ptr = cv_data((cvalue_t *)ptr(args[0])); // relocatable pointer
uint32_t *pwc = cvalue_data(wcstr); uint32_t *pwc = cvalue_data(wcstr);
u8_toucs(pwc, nc, ptr, nb); u8_toucs(pwc, nc, ptr, nb);
if (term) pwc[nc] = 0; if (term)
pwc[nc] = 0;
return wcstr; return wcstr;
} }
@ -133,9 +134,7 @@ value_t fl_string(value_t *args, u_int32_t nargs)
value_t oldpp = symbol_value(printprettysym); value_t oldpp = symbol_value(printprettysym);
set(printreadablysym, FL_F); set(printreadablysym, FL_F);
set(printprettysym, FL_F); set(printprettysym, FL_F);
FOR_ARGS(i,0,arg,args) { FOR_ARGS(i, 0, arg, args) { fl_print(s, args[i]); }
fl_print(s, args[i]);
}
set(printreadablysym, oldpr); set(printreadablysym, oldpr);
set(printprettysym, oldpp); set(printprettysym, oldpp);
value_t outp = stream_to_string(&buf); 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])); s = cv_data((cvalue_t *)ptr(args[0]));
delim = cv_data((cvalue_t *)ptr(args[1])); 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 // link new cell
if (last == FL_NIL) 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"); i2 = toulong(args[2], "string.sub");
if (i2 > len) if (i2 > len)
bounds_error("string.sub", args[0], args[2]); bounds_error("string.sub", args[0], args[2]);
} } else {
else {
i2 = len; i2 = len;
} }
if (i2 <= i1) 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])); size_t len = cv_len((cvalue_t *)ptr(args[0]));
if (start > len) if (start > len)
bounds_error("string.find", args[0], args[2]); bounds_error("string.find", args[0], args[2]);
char *needle; size_t needlesz; char *needle;
size_t needlesz;
value_t v = args[1]; value_t v = args[1];
cprim_t *cp = (cprim_t *)ptr(v); 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); return mem_find_byte(s, (char)c, start, len);
needlesz = u8_toutf8(cbuf, sizeof(cbuf), &c, 1); needlesz = u8_toutf8(cbuf, sizeof(cbuf), &c, 1);
needle = cbuf; 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); 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); cvalue_t *cv = (cvalue_t *)ptr(v);
needlesz = cv_len(cv); needlesz = cv_len(cv);
needle = (char *)cv_data(cv); needle = (char *)cv_data(cv);
} } else {
else {
type_error("string.find", "string", args[1]); type_error("string.find", "string", args[1]);
} }
if (needlesz > len - start) if (needlesz > len - start)
@ -363,9 +360,12 @@ value_t fl_numbertostring(value_t *args, u_int32_t nargs)
value_t n = args[0]; value_t n = args[0];
int neg = 0; int neg = 0;
uint64_t num; uint64_t num;
if (isfixnum(n)) num = numval(n); if (isfixnum(n))
else if (!iscprim(n)) type_error("number->string", "integer", n); num = numval(n);
else num = conv_to_uint64(cp_data((cprim_t*)ptr(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))); cp_numtype((cprim_t *)ptr(n)));
if (numval(fl_compare(args[0], fixnum(0))) < 0) { if (numval(fl_compare(args[0], fixnum(0))) < 0) {
num = -num; num = -num;
@ -429,7 +429,4 @@ static builtinspec_t stringfunc_info[] = {
{ NULL, NULL } { NULL, NULL }
}; };
void stringfuncs_init(void) void stringfuncs_init(void) { assign_global_builtins(stringfunc_info); }
{
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); fl_print_str("#table(", f);
for (i = 0; i < h->size; i += 2) { for (i = 0; i < h->size; i += 2) {
if (h->table[i + 1] != HT_NOTFOUND) { 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_child(f, (value_t)h->table[i]);
fl_print_chr(' ', f); fl_print_chr(' ', f);
fl_print_child(f, (value_t)h->table[i + 1]); 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; tabletype->vtable->finalize = NULL;
nt = cvalue(tabletype, sizeof(htable_t)); nt = cvalue(tabletype, sizeof(htable_t));
tabletype->vtable->finalize = free_htable; tabletype->vtable->finalize = free_htable;
} } else {
else {
nt = cvalue(tabletype, 2 * sizeof(void *)); nt = cvalue(tabletype, 2 * sizeof(void *));
} }
htable_t *h = (htable_t *)cv_data((cvalue_t *)ptr(nt)); htable_t *h = (htable_t *)cv_data((cvalue_t *)ptr(nt));
htable_new(h, cnt / 2); htable_new(h, cnt / 2);
uint32_t i; uint32_t i;
value_t k = FL_NIL, arg = FL_NIL; value_t k = FL_NIL, arg = FL_NIL;
FOR_ARGS(i,0,arg,args) { FOR_ARGS(i, 0, arg, args)
{
if (i & 1) if (i & 1)
equalhash_put(h, (void *)k, (void *)arg); equalhash_put(h, (void *)k, (void *)arg);
else else
@ -176,10 +177,8 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
fl_gc_handle(&t); fl_gc_handle(&t);
for (i = 0; i < n; i += 2) { for (i = 0; i < n; i += 2) {
if (table[i + 1] != HT_NOTFOUND) { if (table[i + 1] != HT_NOTFOUND) {
zero = fl_applyn(3, f, zero =
(value_t)table[i], fl_applyn(3, f, (value_t)table[i], (value_t)table[i + 1], zero);
(value_t)table[i+1],
zero);
// reload pointer // reload pointer
h = (htable_t *)cv_data((cvalue_t *)ptr(t)); h = (htable_t *)cv_data((cvalue_t *)ptr(t));
if (h->size != n) if (h->size != n)
@ -191,21 +190,19 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
return zero; return zero;
} }
static builtinspec_t tablefunc_info[] = { static builtinspec_t tablefunc_info[] = { { "table", fl_table },
{ "table", fl_table },
{ "table?", fl_tablep }, { "table?", fl_tablep },
{ "put!", fl_table_put }, { "put!", fl_table_put },
{ "get", fl_table_get }, { "get", fl_table_get },
{ "has?", fl_table_has }, { "has?", fl_table_has },
{ "del!", fl_table_del }, { "del!", fl_table_del },
{ "table.foldl", fl_table_foldl }, { "table.foldl", fl_table_foldl },
{ NULL, NULL } { NULL, NULL } };
};
void table_init(void) void table_init(void)
{ {
tablesym = symbol("table"); tablesym = symbol("table");
tabletype = define_opaque_type(tablesym, sizeof(htable_t), tabletype =
&table_vtable, NULL); define_opaque_type(tablesym, sizeof(htable_t), &table_vtable, NULL);
assign_global_builtins(tablefunc_info); 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; u_int32_t *p;
size_t sz = ((n + 31) >> 5) * 4; size_t sz = ((n + 31) >> 5) * 4;
p = realloc(b, sz); p = realloc(b, sz);
if (p == NULL) return NULL; if (p == NULL)
return NULL;
memset(p, 0, sz); memset(p, 0, sz);
return p; return p;
} }
u_int32_t *mk_bitvector(size_t n) u_int32_t *mk_bitvector(size_t n) { return bitvector_resize(NULL, n); }
{
return bitvector_resize(NULL, n);
}
void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c) 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)); t->items = (unsigned long *)malloc(n * sizeof(unsigned long));
} }
void ltable_clear(ltable_t *t) void ltable_clear(ltable_t *t) { t->n = 0; }
{
t->n = 0;
}
void ltable_insert(ltable_t *t, unsigned long item) 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) { if (t->n == t->maxsize) {
p = realloc(t->items, (t->maxsize * 2) * sizeof(unsigned long)); p = realloc(t->items, (t->maxsize * 2) * sizeof(unsigned long));
if (p == NULL) return; if (p == NULL)
return;
t->items = p; t->items = p;
t->maxsize *= 2; t->maxsize *= 2;
} }
@ -73,20 +69,22 @@ void ltable_adjoin(ltable_t *t, unsigned long item)
ltable_insert(t, item); ltable_insert(t, item);
} }
static const u_int32_t offsetsFromUTF8[6] = { static const u_int32_t offsetsFromUTF8[6] = { 0x00000000UL, 0x00003080UL,
0x00000000UL, 0x00003080UL, 0x000E2080UL, 0x000E2080UL, 0x03C82080UL,
0x03C82080UL, 0xFA082080UL, 0x82082080UL 0xFA082080UL, 0x82082080UL };
};
static const char trailingBytesForUTF8[256] = { 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,0,0,0,0,0,0,0,0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
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,
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) int u8_seqlen(const char c)

217
tiny/lisp-nontail.c
View File

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

237
tiny/lisp.c
View File

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

379
tiny/lisp2.c
View File

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

240
tiny/lispf.c
View File

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

15
types.c
View File

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