conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

avoiding sprintf for error messages where possible 

moving raise, logand, logior, logxor, and ash out of core
changing prog1 to a special form
This commit is contained in:
JeffBezanson 2009-03-25 02:28:21 +00:00
parent b63a23eb1a
commit fe72c101e2
12 changed files with 178 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
femtolisp/builtins.c
View File

@ -78,6 +78,12 @@ static value_t fl_memq(value_t *args, u_int32_t nargs)
return FL_F;
}
static value_t fl_raise(value_t *args, u_int32_t nargs)
{
argcount("raise", nargs, 1);
raise(args[0]);
}
static value_t fl_exit(value_t *args, u_int32_t nargs)
{
if (nargs > 0)
@ -101,8 +107,8 @@ static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
argcount("set-syntax!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-syntax!");
if (sym->syntax && (sym->syntax == TAG_CONST || isspecial(sym->syntax)))
lerror(ArgError, "set-syntax!: cannot define syntax for %s",
symbol_name(args[0]));
lerrorf(ArgError, "set-syntax!: cannot define syntax for %s",
symbol_name(args[0]));
if (args[1] == FL_F) {
sym->syntax = 0;
}
@ -292,7 +298,7 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs)
}
char *ptr = tostring(args[0], "path.cwd");
if (set_cwd(ptr))
lerror(IOError, "path.cwd: could not cd to %s", ptr);
lerrorf(IOError, "path.cwd: could not cd to %s", ptr);
return FL_T;
}
@ -371,6 +377,7 @@ static builtinspec_t builtin_info[] = {
{ "symbol-syntax", fl_symbolsyntax },
{ "environment", fl_global_env },
{ "constant?", fl_constantp },
{ "raise", fl_raise },
{ "exit", fl_exit },
{ "intern", fl_intern },

7
femtolisp/cps.lsp
View File

@ -1,4 +1,9 @@
; -*- scheme -*-
(define (cond-body e)
(cond ((atom? e) #f)
((null? (cdr e)) (car e))
(#t (cons 'begin e))))
(define (cond->if form)
(cond-clauses->if (cdr form)))
(define (cond-clauses->if lst)
@ -6,7 +11,7 @@
lst
(let ((clause (car lst)))
`(if ,(car clause)
,(f-body (cdr clause))
,(cond-body (cdr clause))
,(cond-clauses->if (cdr lst))))))
(define (begin->cps forms k)

152
femtolisp/cvalues.c
View File

@ -200,9 +200,9 @@ value_t cvalue_string(size_t sz)
return cvalue(stringtype, sz);
}
value_t cvalue_static_cstring(char *str)
value_t cvalue_static_cstring(const char *str)
{
return cvalue_from_ref(stringtype, str, strlen(str), NIL);
return cvalue_from_ref(stringtype, (char*)str, strlen(str), NIL);
}
value_t string_from_cstrn(char *str, size_t n)
@ -899,12 +899,21 @@ value_t cbuiltin(char *name, builtin_t f)
*/
}
static value_t fl_logand(value_t *args, u_int32_t nargs);
static value_t fl_logior(value_t *args, u_int32_t nargs);
static value_t fl_logxor(value_t *args, u_int32_t nargs);
static value_t fl_ash(value_t *args, u_int32_t nargs);
static builtinspec_t cvalues_builtin_info[] = {
{ "c-value", cvalue_new },
{ "typeof", cvalue_typeof },
{ "sizeof", cvalue_sizeof },
{ "builtin", fl_builtin },
{ "copy", fl_copy },
{ "logand", fl_logand },
{ "logior", fl_logior },
{ "logxor", fl_logxor },
{ "ash", fl_ash },
// todo: autorelease
{ NULL, NULL }
};
@ -1321,40 +1330,6 @@ static value_t fl_bitwise_not(value_t a)
return NIL;
}
static value_t fl_ash(value_t a, int n)
{
cprim_t *cp;
int ta;
void *aptr;
if (iscprim(a)) {
if (n == 0) return a;
cp = (cprim_t*)ptr(a);
ta = cp_numtype(cp);
aptr = cp_data(cp);
if (n < 0) {
n = -n;
switch (ta) {
case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
}
}
else {
if (ta == T_UINT64)
return return_from_uint64((*(uint64_t*)aptr)<<n);
int64_t i64 = conv_to_int64(aptr, ta);
return return_from_int64(i64<<n);
}
}
type_error("ash", "integer", a);
return NIL;
}
static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
{
int_t ai, bi;
@ -1425,3 +1400,108 @@ static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
assert(0);
return NIL;
}
static value_t fl_logand(value_t *args, u_int32_t nargs)
{
value_t v, e;
int i;
if (nargs == 0)
return fixnum(-1);
v = args[0];
i = 1;
while (i < (int)nargs) {
e = args[i];
if (bothfixnums(v, e))
v = v & e;
else
v = fl_bitwise_op(v, e, 0, "logand");
i++;
}
return v;
}
static value_t fl_logior(value_t *args, u_int32_t nargs)
{
value_t v, e;
int i;
if (nargs == 0)
return fixnum(0);
v = args[0];
i = 1;
while (i < (int)nargs) {
e = args[i];
if (bothfixnums(v, e))
v = v | e;
else
v = fl_bitwise_op(v, e, 1, "logior");
i++;
}
return v;
}
static value_t fl_logxor(value_t *args, u_int32_t nargs)
{
value_t v, e;
int i;
if (nargs == 0)
return fixnum(0);
v = args[0];
i = 1;
while (i < (int)nargs) {
e = args[i];
if (bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
v = fl_bitwise_op(v, e, 2, "logxor");
i++;
}
return v;
}
static value_t fl_ash(value_t *args, u_int32_t nargs)
{
fixnum_t n;
int64_t accum;
argcount("ash", nargs, 2);
value_t a = args[0];
n = tofixnum(args[1], "ash");
if (isfixnum(a)) {
if (n <= 0)
return fixnum(numval(a)>>(-n));
accum = ((int64_t)numval(a))<<n;
if (fits_fixnum(accum))
return fixnum(accum);
else
return return_from_int64(accum);
}
cprim_t *cp;
int ta;
void *aptr;
if (iscprim(a)) {
if (n == 0) return a;
cp = (cprim_t*)ptr(a);
ta = cp_numtype(cp);
aptr = cp_data(cp);
if (n < 0) {
n = -n;
switch (ta) {
case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
}
}
else {
if (ta == T_UINT64)
return return_from_uint64((*(uint64_t*)aptr)<<n);
int64_t i64 = conv_to_int64(aptr, ta);
return return_from_int64(i64<<n);
}
}
type_error("ash", "integer", a);
return NIL;
}

107
femtolisp/flisp.c
View File

@ -54,7 +54,7 @@
static char *builtin_names[] =
{ // special forms
"quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "%apply", "set!", "begin",
"trycatch", "%apply", "set!", "prog1", "begin",
// predicates
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
@ -64,11 +64,10 @@ static char *builtin_names[] =
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
// execution
"eval", "eval*", "apply", "prog1", "raise",
"eval", "eval*", "apply",
// arithmetic
"+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor", "ash",
"compare",
"+", "-", "*", "/", "<", "lognot", "compare",
// sequences
"vector", "aref", "aset!", "length", "for",
@ -157,7 +156,7 @@ static value_t make_error_msg(char *format, va_list args)
return string_from_cstr(msgbuf);
}
void lerror(value_t e, char *format, ...)
void lerrorf(value_t e, char *format, ...)
{
va_list args;
PUSH(e);
@ -169,6 +168,14 @@ void lerror(value_t e, char *format, ...)
raise(list2(e, msg));
}
void lerror(value_t e, const char *msg)
{
PUSH(e);
value_t m = cvalue_static_cstring(msg);
e = POP();
raise(list2(e, m));
}
void type_error(char *fname, char *expected, value_t got)
{
raise(listn(4, TypeError, symbol(fname), symbol(expected), got));
@ -176,7 +183,7 @@ void type_error(char *fname, char *expected, value_t got)
void bounds_error(char *fname, value_t arr, value_t ind)
{
lerror(listn(3, BoundsError, arr, ind), "%s: index out of bounds", fname);
lerrorf(listn(3, BoundsError, arr, ind), "%s: index out of bounds", fname);
}
// safe cast operators --------------------------------------------------------
@ -899,6 +906,19 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
}
v = FL_F;
break;
case F_PROG1:
// return first arg
pv = &Stack[saveSP];
if (__unlikely(!iscons(*pv)))
lerror(ArgError, "prog1: too few arguments");
PUSH(eval(car_(*pv)));
*pv = cdr_(*pv);
while (iscons(*pv)) {
(void)eval(car_(*pv));
*pv = cdr_(*pv);
}
v = POP();
break;
case F_TRYCATCH:
v = do_trycatch(car(Stack[saveSP]), penv);
break;
@ -1145,71 +1165,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
else
v = fl_bitwise_not(Stack[SP-1]);
break;
case F_BAND:
if (nargs == 0)
v = fixnum(-1);
else {
v = Stack[SP-nargs];
while (nargs > 1) {
e = Stack[SP-nargs+1];
if (bothfixnums(v, e))
v = v & e;
else
v = fl_bitwise_op(v, e, 0, "&");
nargs--;
Stack[SP-nargs] = v;
}
}
break;
case F_BOR:
if (nargs == 0)
v = fixnum(0);
else {
v = Stack[SP-nargs];
while (nargs > 1) {
e = Stack[SP-nargs+1];
if (bothfixnums(v, e))
v = v | e;
else
v = fl_bitwise_op(v, e, 1, "!");
nargs--;
Stack[SP-nargs] = v;
}
}
break;
case F_BXOR:
if (nargs == 0)
v = fixnum(0);
else {
v = Stack[SP-nargs];
while (nargs > 1) {
e = Stack[SP-nargs+1];
if (bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
v = fl_bitwise_op(v, e, 2, "$");
nargs--;
Stack[SP-nargs] = v;
}
}
break;
case F_ASH:
argcount("ash", nargs, 2);
i = tofixnum(Stack[SP-1], "ash");
if (isfixnum(Stack[SP-2])) {
if (i <= 0)
v = fixnum(numval(Stack[SP-2])>>(-i));
else {
accum = ((int64_t)numval(Stack[SP-2]))<<i;
if (fits_fixnum(accum))
v = fixnum(accum);
else
v = return_from_int64(accum);
}
}
else
v = fl_ash(Stack[SP-2], i);
break;
case F_COMPARE:
argcount("compare", nargs, 2);
v = compare(Stack[SP-2], Stack[SP-1]);
@ -1275,16 +1230,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
if (selfevaluating(e)) { SP=saveSP; return e; }
SP = penv+2;
goto eval_top;
case F_RAISE:
argcount("raise", nargs, 1);
raise(Stack[SP-1]);
break;
case F_PROG1:
// return first arg
if (__unlikely(nargs < 1))
lerror(ArgError, "prog1: too few arguments");
v = Stack[saveSP+1];
break;
case F_FOR:
argcount("for", nargs, 3);
lo = tofixnum(Stack[SP-3], "for");

15
femtolisp/flisp.h
View File

@ -102,16 +102,16 @@ extern uint32_t SP;
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_BEGIN,
F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROG1, F_BEGIN,
// functions
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP,
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE,
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ASH,
F_COMPARE,
F_EVAL, F_EVALSTAR, F_APPLY,
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR,
F_TRUE, F_FALSE, F_NIL,
N_BUILTINS,
@ -150,7 +150,8 @@ fixnum_t tofixnum(value_t v, char *fname);
char *tostring(value_t v, char *fname);
/* error handling */
void lerror(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 raise(value_t e) __attribute__ ((__noreturn__));
void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));
void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));
@ -158,7 +159,7 @@ extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
static inline void argcount(char *fname, uint32_t nargs, uint32_t c)
{
if (__unlikely(nargs != c))
lerror(ArgError,"%s: too %s arguments", fname, nargs<c ? "few":"many");
lerrorf(ArgError,"%s: too %s arguments", fname, nargs<c ? "few":"many");
}
typedef struct {
@ -267,7 +268,7 @@ size_t cvalue_arraylen(value_t v);
value_t size_wrap(size_t sz);
size_t toulong(value_t n, char *fname);
value_t cvalue_string(size_t sz);
value_t cvalue_static_cstring(char *str);
value_t cvalue_static_cstring(const char *str);
value_t string_from_cstr(char *str);
value_t string_from_cstrn(char *str, size_t n);
int isstring(value_t v);

4
femtolisp/iostream.c
View File

@ -74,7 +74,7 @@ value_t fl_file(value_t *args, uint32_t nargs)
char *fname = tostring(args[0], "file");
ios_t *s = value2c(ios_t*, f);
if (ios_file(s, fname, r, w, c, t) == NULL)
lerror(IOError, "file: could not open \"%s\"", fname);
lerrorf(IOError, "file: could not open \"%s\"", fname);
if (a) ios_seek_end(s);
return f;
}
@ -245,7 +245,7 @@ static char get_delim_arg(value_t arg, char *fname)
// wchars > 0x7f, or anything else > 0xff, are out of range
if ((iscprim(arg) && cp_class((cprim_t*)ptr(arg))==wchartype) ||
uldelim > 0xff)
lerror(ArgError, "%s: delimiter out of range", fname);
lerrorf(ArgError, "%s: delimiter out of range", fname);
}
return (char)uldelim;
}

10
femtolisp/read.c
View File

@ -305,7 +305,7 @@ static u_int32_t peek()
(isdigit_base(buf[1],base) ||
buf[1]=='-')) {
if (!read_numtok(&buf[1], &tokval, base))
lerror(ParseError, "read: invalid base %d constant", base);
lerrorf(ParseError, "read: invalid base %d constant", base);
return (toktype=TOK_NUM);
}
@ -546,8 +546,8 @@ static value_t do_read_sexpr(value_t label)
c = nextchar();
if (c != '(') {
take();
lerror(ParseError, "read: expected argument list for %s",
symbol_name(tokval));
lerrorf(ParseError, "read: expected argument list for %s",
symbol_name(tokval));
}
PUSH(NIL);
read_list(&Stack[SP-1], UNBOUND);
@ -568,7 +568,7 @@ static value_t do_read_sexpr(value_t label)
case TOK_LABEL:
// create backreference label
if (ptrhash_has(&readstate->backrefs, (void*)tokval))
lerror(ParseError, "read: label %ld redefined", numval(tokval));
lerrorf(ParseError, "read: label %ld redefined", numval(tokval));
oldtokval = tokval;
v = do_read_sexpr(tokval);
ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v);
@ -577,7 +577,7 @@ static value_t do_read_sexpr(value_t label)
// look up backreference
v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval);
if (v == (value_t)HT_NOTFOUND)
lerror(ParseError, "read: undefined label %ld", numval(tokval));
lerrorf(ParseError, "read: undefined label %ld", numval(tokval));
return v;
case TOK_GENSYM:
pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);

2
femtolisp/string.c
View File

@ -312,7 +312,7 @@ static ulong get_radix_arg(value_t arg, char *fname)
{
ulong radix = toulong(arg, fname);
if (radix < 2 || radix > 36)
lerror(ArgError, "%s: invalid radix", fname);
lerrorf(ArgError, "%s: invalid radix", fname);
return radix;
}

2
femtolisp/system.lsp
View File

@ -184,8 +184,6 @@
(define (abs x) (if (< x 0) (- x) x))
(define (identity x) x)
(define (char? x) (eq? (typeof x) 'wchar))
(define K prog1) ; K combinator ;)
(define begin0 prog1)
(define (caar x) (car (car x)))
(define (cdar x) (cdr (car x)))

2
femtolisp/table.c
View File

@ -121,7 +121,7 @@ value_t fl_table_put(value_t *args, uint32_t nargs)
static void key_error(char *fname, value_t key)
{
lerror(list2(KeyError, key), "%s: key not found", fname);
lerrorf(list2(KeyError, key), "%s: key not found", fname);
}
// (get table key [default])

1
femtolisp/todo
View File

@ -962,6 +962,7 @@ consolidated todo list as of 8/30:
- remaining c types
- remaining cvalues functions
- finish ios
- special efficient reader for #array
- reimplement vectors as (array lispvalue)
- implement fast subvectors and subarrays

2
llt/int2str.c
View File

@ -31,6 +31,7 @@ int isdigit_base(char c, int base)
}
/* assumes valid base, returns 1 on error, 0 if OK */
/*
int str2int(char *str, size_t len, int64_t *res, uint32_t base)
{
int64_t result, place;
@ -54,3 +55,4 @@ int str2int(char *str, size_t len, int64_t *res, uint32_t base)
*res = result;
return 0;
}
*/