ref: 2601e0b75a29fd1d112bc6049dee5d131dcb1d93
parent: 79bb6bfb032a4cd74bdbaf99d46a304d80506c46
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Wed Mar 15 13:43:54 EDT 2023
simplify ctypes logic a bit; remove lerror
--- a/Makefile
+++ b/Makefile
@@ -4,7 +4,7 @@
TARG=flisp
LLT=llt/libllt.a
-CFLAGS?=-O2 -pipe -g
+CFLAGS?=-O2 -g
CFLAGS+=-Wall -Wextra -falign-functions -Wno-strict-aliasing -std=c99 -D_DEFAULT_SOURCE
LDFLAGS?=
LDFLAGS+=${LLT} -lm--- a/builtins.c
+++ b/builtins.c
@@ -275,10 +275,10 @@
fixnum_t i;
value_t f, v;
if (nargs == 0)
- lerror(ArgError, "vector.alloc: too few arguments");
+ lerrorf(ArgError, "vector.alloc: too few arguments");
i = (fixnum_t)toulong(args[0], "vector.alloc");
if (i < 0)
- lerror(ArgError, "vector.alloc: invalid size");
+ lerrorf(ArgError, "vector.alloc: invalid size");
v = alloc_vector((unsigned)i, 0);
if (nargs == 2)
f = args[1];
@@ -376,7 +376,7 @@
result = setenv(name, val, 1);
}
if (result != 0)
- lerror(ArgError, "os.setenv: invalid environment variable");
+ lerrorf(ArgError, "os.setenv: invalid environment variable");
return FL_T;
}
--- a/cvalues.c
+++ b/cvalues.c
@@ -6,8 +6,6 @@
#define NWORDS(sz) (((sz)+3)>>2)
#endif
-static int ALIGN2, ALIGN4, ALIGN8, ALIGNPTR;
-
value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
value_t int64sym, uint64sym;
value_t longsym, ulongsym, bytesym, wcharsym;
@@ -52,7 +50,7 @@
size_t nn = (maxfinalizers==0 ? 256 : maxfinalizers*2);
cvalue_t **temp = realloc(Finalizers, nn*sizeof(cvalue_t*));
if (temp == NULL)
- lerror(MemoryError, "out of memory");
+ lerrorf(MemoryError, "out of memory");
Finalizers = temp;
maxfinalizers = nn;
}
@@ -134,9 +132,9 @@
cvalue_t *pcv;
int str=0;
- if (valid_numtype(type->numtype)) {+ if (valid_numtype(type->numtype))
return cprim(type, sz);
- }
+
if (type->eltype == bytetype) {if (sz == 0)
return symbol_value(emptystringsym);
@@ -351,7 +349,7 @@
return 0;
}
}
- lerror(ArgError, "enum: invalid enum value");
+ lerrorf(ArgError, "enum: invalid enum value");
}
if (isfixnum(arg)) {n = (int)numval(arg);
@@ -364,7 +362,7 @@
type_error("enum", "number", arg);}
if ((unsigned)n >= vector_size(syms))
- lerror(ArgError, "enum: value out of range");
+ lerrorf(ArgError, "enum: value out of range");
*(int*)dest = n;
return 0;
}
@@ -409,7 +407,7 @@
if (iscons(cdr_(cdr_(type)))) {size_t tc = toulong(car_(cdr_(cdr_(type))), "array");
if (tc != cnt)
- lerror(ArgError, "array: size mismatch");
+ lerrorf(ArgError, "array: size mismatch");
}
sz = elsize * cnt;
@@ -432,7 +430,7 @@
arg = cdr_(arg);
}
if (i != cnt)
- lerror(ArgError, "array: size mismatch");
+ lerrorf(ArgError, "array: size mismatch");
return 0;
}
else if (iscvalue(arg)) {@@ -443,12 +441,12 @@
if (cv_len(cv) == sz)
memcpy(dest, cv_data(cv), sz);
else
- lerror(ArgError, "array: size mismatch");
+ lerrorf(ArgError, "array: size mismatch");
return 0;
}
else {// TODO: initialize array from different type elements
- lerror(ArgError, "array: element type mismatch");
+ lerrorf(ArgError, "array: element type mismatch");
}
}
}
@@ -533,42 +531,23 @@
// *palign is an output argument giving the alignment required by type
size_t ctype_sizeof(value_t type, int *palign)
{- if (type == int8sym || type == uint8sym || type == bytesym) {- *palign = 1;
- return 1;
+ symbol_t *s;
+
+ if (issymbol(type) && (s = ptr(type)) != NULL && valid_numtype(s->numtype)) {+ *palign = s->align;
+ return s->size;
}
- if (type == int16sym || type == uint16sym) {- *palign = ALIGN2;
- return 2;
- }
- if (type == int32sym || type == uint32sym || type == wcharsym ||
- type == floatsym) {- *palign = ALIGN4;
- return 4;
- }
- if (type == int64sym || type == uint64sym || type == doublesym) {- *palign = ALIGN8;
- return 8;
- }
- if (type == longsym || type == ulongsym) {-#if defined(ULONG64)
- *palign = ALIGN8;
- return 8;
-#else
- *palign = ALIGN4;
- return 4;
-#endif
- }
+
if (iscons(type)) {value_t hed = car_(type);
if (hed == pointersym || hed == cfunctionsym) {- *palign = ALIGNPTR;
+ *palign = sizeof(struct { char a; void *i; }) - sizeof(void*);return sizeof(void*);
}
if (hed == arraysym) {value_t t = car(cdr_(type));
if (!iscons(cdr_(cdr_(type))))
- lerror(ArgError, "sizeof: incomplete type");
+ lerrorf(ArgError, "sizeof: incomplete type");
value_t n = car_(cdr_(cdr_(type)));
size_t sz = toulong(n, "sizeof");
return sz * ctype_sizeof(t, palign);
@@ -580,11 +559,12 @@
return cvalue_union_size(type, palign);
}
else if (hed == enumsym) {- *palign = ALIGN4;
- return 4;
+ *palign = sizeof(struct { char c; numerictype_t e; }) - sizeof(numerictype_t);+ return sizeof(numerictype_t);
}
}
- lerror(ArgError, "sizeof: invalid c type");
+
+ lerrorf(ArgError, "sizeof: invalid c type");
return 0;
}
@@ -702,11 +682,11 @@
{ argcount("copy", nargs, 1);if (iscons(args[0]) || isvector(args[0]))
- lerror(ArgError, "copy: argument must be a leaf atom");
+ lerrorf(ArgError, "copy: argument must be a leaf atom");
if (!iscvalue(args[0]))
return args[0];
if (!cv_isPOD((cvalue_t*)ptr(args[0])))
- lerror(ArgError, "copy: argument must be a plain-old-data type");
+ lerrorf(ArgError, "copy: argument must be a plain-old-data type");
return cvalue_copy(args[0]);
}
@@ -723,52 +703,11 @@
cvinitfunc_t f=type->init;
if (f == NULL)
- lerror(ArgError, "c-value: invalid c type");
+ lerrorf(ArgError, "c-value: invalid c type");
f(type, v, dest);
}
-static numerictype_t sym_to_numtype(value_t type)
-{- if (type == int8sym)
- return T_INT8;
- else if (type == uint8sym || type == bytesym)
- return T_UINT8;
- else if (type == int16sym)
- return T_INT16;
- else if (type == uint16sym)
- return T_UINT16;
-#if defined(ULONG64)
- else if (type == int32sym || type == wcharsym)
-#else
- else if (type == int32sym || type == wcharsym || type == longsym)
-#endif
- return T_INT32;
-#if defined(ULONG64)
- else if (type == uint32sym)
-#else
- else if (type == uint32sym || type == ulongsym)
-#endif
- return T_UINT32;
-#if defined(ULONG64)
- else if (type == int64sym || type == longsym)
-#else
- else if (type == int64sym)
-#endif
- return T_INT64;
-#if defined(ULONG64)
- else if (type == uint64sym || type == ulongsym)
-#else
- else if (type == uint64sym)
-#endif
- return T_UINT64;
- else if (type == floatsym)
- return T_FLOAT;
- else if (type == doublesym)
- return T_DOUBLE;
- return N_NUMTYPES;
-}
-
// (new type . args)
// this provides (1) a way to allocate values with a shared type for
// efficiency, (2) a uniform interface for allocating cvalues of any
@@ -928,43 +867,58 @@
{ NULL, NULL }};
-#define cv_intern(tok) tok##sym = symbol(#tok)
-#define ctor_cv_intern(tok) \
- cv_intern(tok);set(tok##sym, cbuiltin(#tok, cvalue_##tok))
-
-#define mk_primtype(name,ctype) \
- name##type=get_type(name##sym);name##type->init = cvalue_##ctype##_init
+#define cv_intern(tok) \
+ do{ \+ tok##sym = symbol(#tok); \
+ }while(0)
+#define ctor_cv_intern(tok, nt, ctype) \
+ do{ \+ symbol_t *s; \
+ cv_intern(tok); \
+ set(tok##sym, cbuiltin(#tok, cvalue_##tok)); \
+ if (valid_numtype(nt)) { \+ s = ptr(tok##sym); \
+ s->numtype = nt; \
+ s->size = sizeof(ctype); \
+ s->align = sizeof(struct{char c; ctype x;}) - sizeof(ctype); \+ } \
+ }while(0)
+#define mk_primtype(name, ctype) \
+ do{ \+ name##type=get_type(name##sym); \
+ name##type->init = cvalue_##ctype##_init; \
+ }while(0)
+
static void cvalues_init(void)
{htable_new(&TypeTable, 256);
htable_new(&reverse_dlsym_lookup_table, 256);
- // compute struct field alignment required for primitives
- ALIGN2 = sizeof(struct { char a; int16_t i; }) - 2;- ALIGN4 = sizeof(struct { char a; int32_t i; }) - 4;- ALIGN8 = sizeof(struct { char a; int64_t i; }) - 8;- ALIGNPTR = sizeof(struct { char a; void *i; }) - sizeof(void*);-
builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
- ctor_cv_intern(int8);
- ctor_cv_intern(uint8);
- ctor_cv_intern(int16);
- ctor_cv_intern(uint16);
- ctor_cv_intern(int32);
- ctor_cv_intern(uint32);
- ctor_cv_intern(int64);
- ctor_cv_intern(uint64);
- ctor_cv_intern(byte);
- ctor_cv_intern(wchar);
- ctor_cv_intern(long);
- ctor_cv_intern(ulong);
- ctor_cv_intern(float);
- ctor_cv_intern(double);
+ ctor_cv_intern(int8, T_INT8, int8_t);
+ ctor_cv_intern(uint8, T_UINT8, uint8_t);
+ ctor_cv_intern(int16, T_INT16, int16_t);
+ ctor_cv_intern(uint16, T_UINT16, uint16_t);
+ ctor_cv_intern(int32, T_INT32, int32_t);
+ ctor_cv_intern(uint32, T_UINT32, uint32_t);
+ ctor_cv_intern(int64, T_INT64, int64_t);
+ ctor_cv_intern(uint64, T_UINT64, uint64_t);
+ ctor_cv_intern(byte, T_UINT8, uint8_t);
+ ctor_cv_intern(wchar, T_INT32, int32_t);
+#if defined(ULONG64)
+ ctor_cv_intern(long, T_INT64, int64_t);
+ ctor_cv_intern(ulong, T_UINT64, uint64_t);
+#else
+ ctor_cv_intern(long, T_INT32, int32_t);
+ ctor_cv_intern(ulong, T_UINT32, uint32_t);
+#endif
+ ctor_cv_intern(float, T_FLOAT, float);
+ ctor_cv_intern(double, T_DOUBLE, double);
- ctor_cv_intern(array);
- ctor_cv_intern(enum);
+ ctor_cv_intern(array, NONNUMERIC, int);
+ ctor_cv_intern(enum, NONNUMERIC, int);
cv_intern(pointer);
cv_intern(struct);
cv_intern(union);
@@ -1270,10 +1224,10 @@
return 1;
}
-static void DivideByZeroError() __attribute__ ((__noreturn__));
+static void DivideByZeroError(void) __attribute__ ((__noreturn__));
static void DivideByZeroError(void)
{- lerror(DivideError, "/: division by zero");
+ lerrorf(DivideError, "/: division by zero");
}
static value_t fl_div2(value_t a, value_t b)
--- a/flisp.c
+++ b/flisp.c
@@ -189,14 +189,6 @@
fl_raise(fl_list2(e, msg));
}
-void lerror(value_t e, const char *msg)
-{- PUSH(e);
- value_t m = cvalue_static_cstring(msg);
- e = POP();
- fl_raise(fl_list2(e, m));
-}
-
void type_error(char *fname, char *expected, value_t got)
{fl_raise(fl_listn(4, TypeError, symbol(fname), symbol(expected), got));
@@ -239,19 +231,17 @@
symbol_t *sym;
size_t len = strlen(str);
- sym = malloc(sizeof(*sym)-sizeof(void*) + len + 1);
+ sym = calloc(1, sizeof(*sym)-sizeof(void*) + len + 1);
assert(((uintptr_t)sym & 0x7) == 0); // make sure malloc aligns 8
- sym->left = sym->right = NULL;
- sym->flags = 0;
+ sym->numtype = NONNUMERIC;
if (fl_is_keyword_name(str, len)) {value_t s = tagptr(sym, TAG_SYM);
setc(s, s);
- sym->flags |= 0x2;
+ sym->flags |= FLAG_KEYWORD;
}
else {sym->binding = UNBOUND;
}
- sym->type = sym->dlcache = NULL;
sym->hash = memhash32(str, len)^0xAAAAAAAA;
memcpy(sym->name, str, len+1);
return sym;
@@ -396,7 +386,7 @@
void fl_gc_handle(value_t *pv)
{if (N_GCHND >= N_GC_HANDLES)
- lerror(MemoryError, "out of gc handles");
+ lerrorf(MemoryError, "out of gc handles");
GCHandleStack[N_GCHND++] = pv;
}
@@ -603,7 +593,7 @@
size_t newsz = N_STACK + (N_STACK>>1);
value_t *ns = realloc(Stack, newsz*sizeof(value_t));
if (ns == NULL)
- lerror(MemoryError, "stack overflow");
+ lerrorf(MemoryError, "stack overflow");
Stack = ns;
N_STACK = newsz;
}
@@ -624,6 +614,8 @@
}
else if (isbuiltin(f)) {value_t tab = symbol_value(builtins_table_sym);
+ if (ptr(tab) == NULL)
+ lerrorf(UnboundError, "builtins table");
Stack[SP-n-1] = vector_elt(tab, uintval(f));
v = apply_cl(n);
}
@@ -828,9 +820,9 @@
value_t s4 = Stack[SP-4];
value_t s5 = Stack[SP-5];
if (nargs < nreq)
- lerror(ArgError, "apply: too few arguments");
+ lerrorf(ArgError, "apply: too few arguments");
if (extr > sizeof(args)/sizeof(args[0]))
- lerror(ArgError, "apply: too many arguments");
+ lerrorf(ArgError, "apply: too many arguments");
for (i=0; i < extr; i++) args[i] = UNBOUND;
for (i=nreq; i < nargs; i++) {v = Stack[bp+i];
@@ -870,7 +862,7 @@
no_kw:
nrestargs = nargs - i;
if (!va && nrestargs > 0)
- lerror(ArgError, "apply: too many arguments");
+ lerrorf(ArgError, "apply: too many arguments");
nargs = ntot + nrestargs;
if (nrestargs)
memmove(&Stack[bp+ntot], &Stack[bp+i], nrestargs*sizeof(value_t));
@@ -969,9 +961,9 @@
do_argc:
if (nargs != n) {if (nargs > n)
- lerror(ArgError, "apply: too many arguments");
+ lerrorf(ArgError, "apply: too many arguments");
else
- lerror(ArgError, "apply: too few arguments");
+ lerrorf(ArgError, "apply: too few arguments");
}
NEXT_OP;
OP(OP_VARGC)
@@ -992,7 +984,7 @@
}
}
else if (s < 0) {- lerror(ArgError, "apply: too few arguments");
+ lerrorf(ArgError, "apply: too few arguments");
}
else {PUSH(0);
@@ -1729,10 +1721,10 @@
i = GET_INT32(ip); ip+=4;
n = GET_INT32(ip); ip+=4;
if (nargs < i)
- lerror(ArgError, "apply: too few arguments");
+ lerrorf(ArgError, "apply: too few arguments");
if ((int32_t)n > 0) {if (nargs > n)
- lerror(ArgError, "apply: too many arguments");
+ lerrorf(ArgError, "apply: too many arguments");
}
else n = -n;
if (n > nargs) {@@ -2030,7 +2022,7 @@
}
}
if (isgensym(fn->name))
- lerror(ArgError, "function: name should not be a gensym");
+ lerrorf(ArgError, "function: name should not be a gensym");
}
return fv;
}
@@ -2118,7 +2110,7 @@
value_t fl_map1(value_t *args, uint32_t nargs)
{if (nargs < 2)
- lerror(ArgError, "map: too few arguments");
+ lerrorf(ArgError, "map: too few arguments");
if (!iscons(args[1])) return NIL;
value_t first, last, v;
int64_t argSP = args-Stack;
--- a/flisp.h
+++ b/flisp.h
@@ -1,12 +1,30 @@
#ifndef FLISP_H
#define FLISP_H
+/* functions needed to implement the value interface (cvtable_t) */
+typedef enum {+ T_INT8, T_UINT8,
+ T_INT16, T_UINT16,
+ T_INT32, T_UINT32,
+ T_INT64, T_UINT64,
+ T_FLOAT,
+ T_DOUBLE,
+} numerictype_t;
+
+#define NONNUMERIC (0xff)
+#define valid_numtype(v) ((v) <= T_DOUBLE)
+
typedef uintptr_t value_t;
typedef lltint_t fixnum_t;
+
#ifdef BITS64
#define T_FIXNUM T_INT64
+#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
+#define mk_xlong mk_int64
#else
#define T_FIXNUM T_INT32
+#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
+#define mk_xlong mk_long
#endif
typedef struct {@@ -15,10 +33,13 @@
} cons_t;
typedef struct _symbol_t {- uintptr_t flags;
value_t binding; // global value binding
- struct _fltype_t *type;
uint32_t hash;
+ uint8_t numtype;
+ uint8_t size;
+ uint8_t align;
+ uint8_t flags;
+ struct _fltype_t *type;
void *dlcache; // dlsym address
// below fields are private
struct _symbol_t *left;
@@ -36,14 +57,22 @@
uint32_t id;
} gensym_t;
-#define TAG_NUM 0x0
-#define TAG_CPRIM 0x1
-#define TAG_FUNCTION 0x2
-#define TAG_VECTOR 0x3
-#define TAG_NUM1 0x4
-#define TAG_CVALUE 0x5
-#define TAG_SYM 0x6
-#define TAG_CONS 0x7
+enum {+ TAG_NUM,
+ TAG_CPRIM,
+ TAG_FUNCTION,
+ TAG_VECTOR,
+ TAG_NUM1,
+ TAG_CVALUE,
+ TAG_SYM,
+ TAG_CONS,
+};
+
+enum {+ FLAG_CONST = 1<<0,
+ FLAG_KEYWORD = 1<<1,
+};
+
#define UNBOUND ((value_t)0x1) // an invalid value
#define TAG_FWD UNBOUND
#define tag(x) ((x)&0x7)
@@ -51,11 +80,6 @@
#define tagptr(p,t) (((value_t)(p)) | (t))
#define fixnum(x) ((value_t)((fixnum_t)(x))<<2)
#define numval(x) (((fixnum_t)(x))>>2)
-#if defined(BITS64)
-#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
-#else
-#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
-#endif
#define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
#define uintval(x) (((unsigned int)(x))>>3)
#define builtin(n) tagptr((((int)n)<<3), TAG_FUNCTION)
@@ -94,11 +118,12 @@
#define fn_name(f) (((value_t*)ptr(f))[3])
#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) do { ((symbol_t*)ptr(s))->flags |= 1; \+#define setc(s, v) do { ((symbol_t*)ptr(s))->flags |= FLAG_CONST; \((symbol_t*)ptr(s))->binding = (v); } while (0)
-#define isconstant(s) ((s)->flags&0x1)
-#define iskeyword(s) ((s)->flags&0x2)
+#define isconstant(s) ((s)->flags&FLAG_CONST)
+#define iskeyword(s) ((s)->flags&FLAG_KEYWORD)
#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
+#define sym_to_numtype(s) (((symbol_t*)ptr(s))->numtype)
#define ismanaged(v) ((((uint8_t*)ptr(v)) >= fromspace) && \
(((uint8_t*)ptr(v)) < fromspace+heapsize))
#define isgensym(x) (issymbol(x) && ismanaged(x))
@@ -188,7 +213,6 @@
for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
void lerrorf(value_t e, char *format, ...) __attribute__ ((__noreturn__));
-void lerror(value_t e, const char *msg) __attribute__ ((__noreturn__));
void fl_savestate(fl_exception_context_t *_ctx);
void fl_restorestate(fl_exception_context_t *_ctx);
void fl_raise(value_t e) __attribute__ ((__noreturn__));
@@ -209,12 +233,6 @@
void (*print_traverse)(value_t self);
} cvtable_t;
-/* functions needed to implement the value interface (cvtable_t) */
-typedef enum { T_INT8, T_UINT8, T_INT16, T_UINT16, T_INT32, T_UINT32,- T_INT64, T_UINT64, T_FLOAT, T_DOUBLE } numerictype_t;
-
-#define N_NUMTYPES ((int)T_DOUBLE+1)
-
value_t relocate_lispvalue(value_t v);
void print_traverse(value_t v);
void fl_print_chr(char c, ios_t *f);
@@ -225,14 +243,14 @@
typedef struct _fltype_t {value_t type;
- numerictype_t numtype;
- size_t size;
- size_t elsz;
cvtable_t *vtable;
struct _fltype_t *eltype; // for arrays
struct _fltype_t *artype; // (array this)
- int marked;
cvinitfunc_t init;
+ size_t size;
+ size_t elsz;
+ int marked;
+ numerictype_t numtype;
} fltype_t;
typedef struct {@@ -278,7 +296,6 @@
#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
#define value2c(type, v) ((type)cv_data((cvalue_t*)ptr(v)))
-#define valid_numtype(v) ((v) < N_NUMTYPES)
#define cp_class(cp) ((cp)->type)
#define cp_type(cp) (cp_class(cp)->type)
#define cp_numtype(cp) (cp_class(cp)->numtype)
@@ -339,12 +356,6 @@
value_t mk_wchar(int32_t n);
value_t return_from_uint64(uint64_t Uaccum);
value_t return_from_int64(int64_t Saccum);
-
-#ifdef BITS64
-#define mk_xlong mk_int64
-#else
-#define mk_xlong mk_long
-#endif
numerictype_t effective_numerictype(double r);
double conv_to_double(void *data, numerictype_t tag);
--- a/flmain.c
+++ b/flmain.c
@@ -32,15 +32,11 @@
fl_init(512*1024);
-#if defined(INITFILE)
- snprintf(fname_buf, sizeof(fname_buf), "%s", INITFILE);
-#else
value_t str = symbol_value(symbol("*install-dir*"));char *exedir = (str == UNBOUND ? NULL : cvalue_data(str));
snprintf(fname_buf, sizeof(fname_buf), "%s%sflisp.boot",
exedir ? exedir : "",
exedir ? PATHSEPSTRING : "");
-#endif
fl_gc_handle(&args[0]);
fl_gc_handle(&args[1]);
--- a/iostream.c
+++ b/iostream.c
@@ -94,7 +94,7 @@
value_t f = cvalue(iostreamtype, sizeof(ios_t));
ios_t *s = value2c(ios_t*, f);
if (ios_mem(s, 0) == NULL)
- lerror(MemoryError, "buffer: could not allocate stream");
+ lerrorf(MemoryError, "buffer: could not allocate stream");
return f;
}
@@ -125,7 +125,7 @@
ios_t *s = toiostream(args[0], "io.getc");
uint32_t wc;
if (ios_getutf8(s, &wc) == IOS_EOF)
- //lerror(IOError, "io.getc: end of file reached");
+ //lerrorf(IOError, "io.getc: end of file reached");
return FL_EOF;
return mk_wchar(wc);
}
@@ -158,7 +158,7 @@
type_error("io.ungetc", "wchar", args[1]);uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
if (wc >= 0x80) {- lerror(ArgError, "io_ungetc: unicode not yet supported");
+ lerrorf(ArgError, "io_ungetc: unicode not yet supported");
}
return fixnum(ios_ungetc((int)wc,s));
}
@@ -244,7 +244,7 @@
else {ft = get_type(args[1]);
if (ft->eltype != NULL && !iscons(cdr_(cdr_(args[1]))))
- lerror(ArgError, "io.read: incomplete type");
+ lerrorf(ArgError, "io.read: incomplete type");
n = ft->size;
}
value_t cv = cvalue(ft, n);
@@ -253,7 +253,7 @@
else data = cp_data((cprim_t*)ptr(cv));
size_t got = ios_read(value2c(ios_t*,args[0]), data, n);
if (got < n)
- //lerror(IOError, "io.read: end of input reached");
+ //lerrorf(IOError, "io.read: end of input reached");
return FL_EOF;
return cv;
}
@@ -280,7 +280,7 @@
ios_t *s = toiostream(args[0], "io.write");
if (iscprim(args[1]) && ((cprim_t*)ptr(args[1]))->type == wchartype) {if (nargs > 2)
- lerror(ArgError,
+ lerrorf(ArgError,
"io.write: offset argument not supported for characters");
uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
return fixnum(ios_pututf8(s, wc));
@@ -400,7 +400,7 @@
argcount("io.tostring!", nargs, 1);ios_t *src = toiostream(args[0], "io.tostring!");
if (src->bm != bm_mem)
- lerror(ArgError, "io.tostring!: requires memory stream");
+ lerrorf(ArgError, "io.tostring!: requires memory stream");
return stream_to_string(&args[0]);
}
--- a/print.c
+++ b/print.c
@@ -207,7 +207,7 @@
// get the width of an expression if we can do so cheaply
if (issymbol(v))
return u8_strwidth(symbol_name(v));
- if (iscprim(v) && cp_class((cprim_t*)ptr(v)) == wchartype)
+ if (iscprim(v) && ptr(v) != NULL && cp_class((cprim_t*)ptr(v)) == wchartype)
return 4;
return -1;
}
@@ -611,8 +611,6 @@
// get rid of all those zeros.
}
-static numerictype_t sym_to_numtype(value_t type);
-
// 'weak' means we don't need to accurately reproduce the type, so
// for example #int32(0) can be printed as just 0. this is used
// printing in a context where a type is already implied, e.g. inside
@@ -708,15 +706,15 @@
// handle other integer prims. we know it's smaller than uint64
// at this point, so int64 is big enough to capture everything.
numerictype_t nt = sym_to_numtype(type);
- if (nt == N_NUMTYPES) {- HPOS += ios_printf(f, "#<%s>", symbol_name(type));
- }
- else {+ if (valid_numtype(nt)) {int64_t i64 = conv_to_int64(data, nt);
if (weak || print_princ)
HPOS += ios_printf(f, "%"PRId64, i64);
else
HPOS += ios_printf(f, "#%s(%"PRId64")", symbol_name(type), i64);
+ }
+ else {+ HPOS += ios_printf(f, "#<%s>", symbol_name(type));
}
}
else if (iscons(type)) {--- a/read.c
+++ b/read.c
@@ -182,7 +182,7 @@
{buf[(*pi)++] = c;
if (*pi >= (int)(sizeof(buf)-1))
- lerror(ParseError, "read: token too long");
+ lerrorf(ParseError, "read: token too long");
}
// return: 1 if escaped (forced to be symbol)
@@ -258,7 +258,7 @@
else if (c == '#') {ch = ios_getc(F); c = (char)ch;
if (ch == IOS_EOF)
- lerror(ParseError, "read: invalid read macro");
+ lerrorf(ParseError, "read: invalid read macro");
if (c == '.') {toktype = TOK_SHARPDOT;
}
@@ -268,13 +268,13 @@
else if (c == '\\') {uint32_t cval;
if (ios_getutf8(F, &cval) == IOS_EOF)
- lerror(ParseError, "read: end of input in character constant");
+ lerrorf(ParseError, "read: end of input in character constant");
if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
cval == (uint32_t)'x') { read_token('u', 0); if (buf[1] != '\0') { // not a solitary 'u','U','x'if (!read_numtok(&buf[1], &tokval, 16))
- lerror(ParseError,
+ lerrorf(ParseError,
"read: invalid hex character constant");
cval = numval(tokval);
}
@@ -305,7 +305,7 @@
toktype = TOK_SHARPOPEN;
}
else if (c == '<') {- lerror(ParseError, "read: unreadable object");
+ lerrorf(ParseError, "read: unreadable object");
}
else if (isdigit(c)) {read_token(c, 1);
@@ -315,11 +315,11 @@
else if (c == '=')
toktype = TOK_LABEL;
else
- lerror(ParseError, "read: invalid label");
+ lerrorf(ParseError, "read: invalid label");
errno = 0;
x = strtoll(buf, &end, 10);
if (*end != '\0' || errno)
- lerror(ParseError, "read: invalid label");
+ lerrorf(ParseError, "read: invalid label");
tokval = fixnum(x);
}
else if (c == '!') {@@ -336,7 +336,7 @@
ch = ios_getc(F);
hashpipe_gotc:
if (ch == IOS_EOF)
- lerror(ParseError, "read: eof within comment");
+ lerrorf(ParseError, "read: eof within comment");
if ((char)ch == '|') {ch = ios_getc(F);
if ((char)ch == '#') {@@ -373,7 +373,7 @@
errno = 0;
x = strtol(buf, &end, 10);
if (*end != '\0' || buf[0] == '\0' || errno)
- lerror(ParseError, "read: invalid gensym label");
+ lerrorf(ParseError, "read: invalid gensym label");
toktype = TOK_GENSYM;
tokval = fixnum(x);
}
@@ -395,7 +395,7 @@
tokval = symbol(buf);
}
else {- lerror(ParseError, "read: unknown read macro");
+ lerrorf(ParseError, "read: unknown read macro");
}
}
else if (c == ',') {@@ -460,7 +460,7 @@
ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
while (peek() != closer) {if (ios_eof(F))
- lerror(ParseError, "read: unexpected end of input");
+ lerrorf(ParseError, "read: unexpected end of input");
if (i >= vector_size(v)) {v = Stack[SP-1] = vector_grow(v);
if (label != UNBOUND)
@@ -494,7 +494,7 @@
temp = realloc(buf, sz);
if (temp == NULL) {free(buf);
- lerror(ParseError, "read: out of memory reading string");
+ lerrorf(ParseError, "read: out of memory reading string");
}
buf = temp;
}
@@ -501,7 +501,7 @@
c = ios_getc(F);
if (c == IOS_EOF) {free(buf);
- lerror(ParseError, "read: unexpected end of input in string");
+ lerrorf(ParseError, "read: unexpected end of input in string");
}
if (c == '"')
break;
@@ -509,7 +509,7 @@
c = ios_getc(F);
if (c == IOS_EOF) {free(buf);
- lerror(ParseError, "read: end of input in escape sequence");
+ lerrorf(ParseError, "read: end of input in escape sequence");
}
j=0;
if (octal_digit(c)) {@@ -536,7 +536,7 @@
if (j) wc = strtol(eseq, NULL, 16);
if (!j || wc > 0x10ffff) {free(buf);
- lerror(ParseError, "read: invalid escape sequence");
+ lerrorf(ParseError, "read: invalid escape sequence");
}
if (ndig == 2)
buf[i++] = ((char)wc);
@@ -570,7 +570,7 @@
t = peek();
while (t != closer) {if (ios_eof(F))
- lerror(ParseError, "read: unexpected end of input");
+ lerrorf(ParseError, "read: unexpected end of input");
c = mk_cons(); car_(c) = cdr_(c) = NIL;
if (iscons(*pc)) {cdr_(*pc) = c;
@@ -591,7 +591,7 @@
cdr_(*pc) = c;
t = peek();
if (ios_eof(F))
- lerror(ParseError, "read: unexpected end of input");
+ lerrorf(ParseError, "read: unexpected end of input");
if (t != closer) {take();
lerrorf(ParseError, "read: expected '%c'", closer==TOK_CLOSEB ? ']' : ')');
@@ -615,11 +615,11 @@
take();
switch (t) {case TOK_CLOSE:
- lerror(ParseError, "read: unexpected ')'");
+ lerrorf(ParseError, "read: unexpected ')'");
case TOK_CLOSEB:
- lerror(ParseError, "read: unexpected ']'");
+ lerrorf(ParseError, "read: unexpected ']'");
case TOK_DOT:
- lerror(ParseError, "read: unexpected '.'");
+ lerrorf(ParseError, "read: unexpected '.'");
case TOK_SYM:
case TOK_NUM:
return tokval;
--- a/table.c
+++ b/table.c
@@ -79,7 +79,7 @@
{size_t cnt = (size_t)nargs;
if (cnt & 1)
- lerror(ArgError, "table: arguments must come in pairs");
+ lerrorf(ArgError, "table: arguments must come in pairs");
value_t nt;
// prevent small tables from being added to finalizer list
if (cnt <= HT_N_INLINE) {@@ -176,7 +176,7 @@
// reload pointer
h = (htable_t*)cv_data((cvalue_t*)ptr(t));
if (h->size != n)
- lerror(EnumerationError, "table.foldl: table modified");
+ lerrorf(EnumerationError, "table.foldl: table modified");
table = h->table;
}
}
--- a/types.c
+++ b/types.c
@@ -22,28 +22,22 @@
sz = ctype_sizeof(t, &align);
}
- ft = (fltype_t*)malloc(sizeof(fltype_t));
+ ft = calloc(1, sizeof(fltype_t));
ft->type = t;
+ ft->numtype = NONNUMERIC;
if (issymbol(t)) {ft->numtype = sym_to_numtype(t);
+ assert(valid_numtype(ft->numtype));
((symbol_t*)ptr(t))->type = ft;
}
- else {- ft->numtype = N_NUMTYPES;
- }
ft->size = sz;
- ft->vtable = NULL;
- ft->artype = NULL;
ft->marked = 1;
- ft->elsz = 0;
- ft->eltype = NULL;
- ft->init = NULL;
if (iscons(t)) { if (isarray) {fltype_t *eltype = get_type(car_(cdr_(t)));
if (eltype->size == 0) {free(ft);
- lerror(ArgError, "invalid array element type");
+ lerrorf(ArgError, "invalid array element type");
}
ft->elsz = eltype->size;
ft->eltype = eltype;
@@ -70,14 +64,11 @@
fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
cvinitfunc_t init)
{- fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t));
+ fltype_t *ft = calloc(1, sizeof(fltype_t));
ft->type = sym;
+ ft->numtype = NONNUMERIC;
ft->size = sz;
- ft->numtype = N_NUMTYPES;
ft->vtable = vtab;
- ft->artype = NULL;
- ft->eltype = NULL;
- ft->elsz = 0;
ft->marked = 1;
ft->init = init;
return ft;