ref: fe72c101e29f4f99f42547d3c8b5673e851bb5ef
parent: b63a23eb1af229f30e2e73810123347fbf9fac46
author: JeffBezanson <[email protected]>
date: Tue Mar 24 22:28:21 EDT 2009
avoiding sprintf for error messages where possible moving raise, logand, logior, logxor, and ash out of core changing prog1 to a special form
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -78,6 +78,12 @@
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 @@
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 @@
}
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 @@
{ "symbol-syntax", fl_symbolsyntax }, { "environment", fl_global_env }, { "constant?", fl_constantp },+ { "raise", fl_raise }, { "exit", fl_exit }, { "intern", fl_intern },--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -200,9 +200,9 @@
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,6 +899,11 @@
*/
}
+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 },@@ -905,6 +910,10 @@
{ "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 @@
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;
@@ -1423,5 +1398,110 @@
}
}
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;
}
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -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 @@
"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 @@
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 @@
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 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 @@
}
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 @@
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 @@
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");
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -102,7 +102,7 @@
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,
@@ -109,9 +109,9 @@
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 @@
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 @@
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 @@
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);
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -74,7 +74,7 @@
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 @@
// 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;
}
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -305,7 +305,7 @@
(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 @@
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 @@
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 @@
// 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);
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -312,7 +312,7 @@
{ulong radix = toulong(arg, fname);
if (radix < 2 || radix > 36)
- lerror(ArgError, "%s: invalid radix", fname);
+ lerrorf(ArgError, "%s: invalid radix", fname);
return radix;
}
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -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)))
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -121,7 +121,7 @@
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])
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -962,6 +962,7 @@
- remaining c types
- remaining cvalues functions
- finish ios
+
- special efficient reader for #array
- reimplement vectors as (array lispvalue)
- implement fast subvectors and subarrays
--- a/llt/int2str.c
+++ b/llt/int2str.c
@@ -31,6 +31,7 @@
}
/* 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 @@
*res = result;
return 0;
}
+*/