avoiding sprintf for error messages where possible

moving raise, logand, logior, logxor, and ash out of core
changing prog1 to a special form

femtolisp/builtins.c

@@ -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,7 +107,7 @@ 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",
+        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 },

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)

femtolisp/cvalues.c

@@ -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;
+}

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 @@ 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",
+      "+", "-", "*", "/", "<", "lognot", "compare",
-      "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");

femtolisp/flisp.h

@@ -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_EVAL, F_EVALSTAR, F_APPLY,
-    F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ASH,
+    F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_COMPARE,
-    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);

femtolisp/iostream.c

@@ -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;
 }

femtolisp/read.c

@@ -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,7 +546,7 @@ static value_t do_read_sexpr(value_t label)
         c = nextchar();
         if (c != '(') {
             take();
-            lerror(ParseError, "read: expected argument list for %s",
+            lerrorf(ParseError, "read: expected argument list for %s",
                     symbol_name(tokval));
         }
         PUSH(NIL);
@@ -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);

femtolisp/string.c

@@ -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;
 }
 

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)))

femtolisp/table.c

@@ -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])

femtolisp/todo

@@ -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

llt/int2str.c

@@ -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;
 }
+*/