adding apply1, using it in trycatch (avoids consing)

allowing left bit shift to overflow to larger types
fixing bug in number->string on uint64
fixing bug in rand.uint64

femtolisp/builtins.c

@@ -334,7 +334,7 @@ value_t fl_rand32(value_t *args, u_int32_t nargs)
 value_t fl_rand64(value_t *args, u_int32_t nargs)
 {
     (void)args; (void)nargs;
-    ulong r = (((uint64_t)random())<<32) | random();
+    uint64_t r = (((uint64_t)random())<<32) | random();
     return mk_uint64(r);
 }
 value_t fl_randd(value_t *args, u_int32_t nargs)

femtolisp/cvalues.c

@@ -1303,32 +1303,39 @@ static value_t fl_bitwise_not(value_t a)
     return NIL;
 }
 
-#define BITSHIFT_OP(name, op)                                       \
+static value_t fl_ash(value_t a, int n)
-static value_t fl_##name(value_t a, int n)                          \
+{
-{                                                                   \
+    cprim_t *cp;
-    cprim_t *cp;                                                    \
+    int ta;
-    int ta;                                                         \
+    void *aptr;
-    void *aptr;                                                     \
+    if (iscprim(a)) {
-    if (iscprim(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);
-        switch (ta) {                                               \
+        if (n < 0) {
-        case T_INT8:   return fixnum((*(int8_t *)aptr) op n);       \
+            n = -n;
-        case T_UINT8:  return fixnum((*(uint8_t *)aptr) op n);      \
+            switch (ta) {
-        case T_INT16:  return fixnum((*(int16_t *)aptr) op n);      \
+            case T_INT8:   return fixnum((*(int8_t *)aptr) >> n);
-        case T_UINT16: return fixnum((*(uint16_t*)aptr) op n);      \
+            case T_UINT8:  return fixnum((*(uint8_t *)aptr) >> n);
-        case T_INT32:  return mk_int32((*(int32_t *)aptr) op n);    \
+            case T_INT16:  return fixnum((*(int16_t *)aptr) >> n);
-        case T_UINT32: return mk_uint32((*(uint32_t*)aptr) op n);   \
+            case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
-        case T_INT64:  return mk_int64((*(int64_t *)aptr) op n);    \
+            case T_INT32:  return mk_int32((*(int32_t *)aptr) >> n);
-        case T_UINT64: return mk_uint64((*(uint64_t*)aptr) op 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);
-    type_error("ash", "integer", a);                                \
+            }
-    return NIL;                                                     \
+        }
+        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;
 }
-BITSHIFT_OP(shl,<<)
-BITSHIFT_OP(shr,>>)
 
 static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
 {

femtolisp/flisp.c

@@ -280,7 +280,7 @@ char *symbol_name(value_t v)
     if (ismanaged(v)) {
         gensym_t *gs = (gensym_t*)ptr(v);
         gsnameno = 1-gsnameno;
-        char *n = int2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10);
+        char *n = uint2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10);
         *(--n) = 'g';
         return n;
     }
@@ -449,6 +449,7 @@ static void trace_globals(symbol_t *root)
 }
 
 static value_t special_apply_form;
+static value_t apply1_args;
 static value_t memory_exception_value;
 
 void gc(int mustgrow)
@@ -476,6 +477,7 @@ void gc(int mustgrow)
     }
     lasterror = relocate(lasterror);
     special_apply_form = relocate(special_apply_form);
+    apply1_args = relocate(apply1_args);
     memory_exception_value = relocate(memory_exception_value);
 
     sweep_finalizers();
@@ -522,6 +524,12 @@ value_t apply(value_t f, value_t l)
     return v;
 }
 
+value_t apply1(value_t f, value_t a0)
+{
+    car_(apply1_args) = a0;
+    return apply(f, apply1_args);
+}
+
 value_t listn(size_t n, ...)
 {
     va_list ap;
@@ -658,10 +666,8 @@ static value_t do_trycatch(value_t expr, uint32_t penv)
             v = FL_F;   // 1-argument form
         }
         else {
-            Stack[SP-1] = car_(v);
+            Stack[SP-1] = eval(car_(v));
-            value_t quoted = list2(QUOTE, lasterror);
+            v = apply1(Stack[SP-1], lasterror);
-            expr = list2(Stack[SP-1], quoted);
-            v = eval(expr);
         }
     }
     return v;
@@ -1202,19 +1208,22 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
             }
             break;
         case F_ASH:
-          argcount("ash", nargs, 2);
+            argcount("ash", nargs, 2);
-          i = tofixnum(Stack[SP-1], "ash");
+            i = tofixnum(Stack[SP-1], "ash");
-          if (isfixnum(Stack[SP-2])) {
+            if (isfixnum(Stack[SP-2])) {
-            if (i < 0)
+                if (i <= 0)
-              v = fixnum(numval(Stack[SP-2])>>(-i));
+                    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 = fixnum(numval(Stack[SP-2])<<i);
+                v = fl_ash(Stack[SP-2], i);
-          }
+            break;
-          else if (i < 0)
-            v = fl_shr(Stack[SP-2], -i);
-          else
-            v = fl_shl(Stack[SP-2],  i);
-          break;
         case F_COMPARE:
             argcount("compare", nargs, 2);
             v = compare(Stack[SP-2], Stack[SP-1]);
@@ -1520,6 +1529,7 @@ static void lisp_init(void)
     set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
     lasterror = NIL;
     special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);
+    apply1_args = fl_cons(NIL, NIL);
     i = 0;
     while (isspecial(builtin(i))) {
         if (i != F_SPECIAL_APPLY)

femtolisp/flisp.h

@@ -125,6 +125,7 @@ value_t read_sexpr(value_t f);
 void print(ios_t *f, value_t v, int princ);
 value_t toplevel_eval(value_t expr);
 value_t apply(value_t f, value_t l);
+value_t apply1(value_t f, value_t a0);
 value_t load_file(char *fname);
 
 /* object model manipulation */

femtolisp/string.c

@@ -295,11 +295,16 @@ value_t fl_numbertostring(value_t *args, u_int32_t nargs)
     if (nargs < 1 || nargs > 2)
         argcount("number->string", nargs, 2);
     value_t n = args[0];
-    int64_t num;
+    int neg = 0;
+    uint64_t num;
     if (isfixnum(n))      num = numval(n);
     else if (!iscprim(n)) type_error("number->string", "integer", n);
-    else num = conv_to_int64(cp_data((cprim_t*)ptr(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(compare(args[0],fixnum(0))) < 0) {
+        num = -num;
+        neg = 1;
+    }
     ulong radix = 10;
     if (nargs == 2) {
         radix = toulong(args[1], "number->string");
@@ -307,7 +312,9 @@ value_t fl_numbertostring(value_t *args, u_int32_t nargs)
             lerror(ArgError, "number->string: invalid radix");
     }
     char buf[128];
-    char *str = int2str(buf, sizeof(buf), num, radix);
+    char *str = uint2str(buf, sizeof(buf), num, radix);
+    if (neg && str > &buf[0])
+        *(--str) = '-';
     return string_from_cstr(str);
 }
 

llt/int2str.c

@@ -1,15 +1,11 @@
 #include <stdlib.h>
 #include "dtypes.h"
 
-char *int2str(char *dest, size_t len, int64_t num, uint32_t base)
+char *uint2str(char *dest, size_t len, uint64_t num, uint32_t base)
 {
-    int i = len-1, neg = 0;
+    int i = len-1;
-    int64_t b = (int64_t)base;
+    uint64_t b = (uint64_t)base;
     char ch;
-    if (num < 0) {
-        num = -num;
-        neg = 1;
-    }
     dest[i--] = '\0';
     while (i >= 0) {
         ch = (char)(num % b);
@@ -22,8 +18,6 @@ char *int2str(char *dest, size_t len, int64_t num, uint32_t base)
         if (num == 0)
             break;
     }
-    if (i >= 0 && neg)
-        dest[i--] = '-';
     return &dest[i+1];
 }
 

llt/utils.h

@@ -45,7 +45,7 @@ void snprint_cplx(char *s, size_t cnt, double re, double im,
                   // print spaces around sign in a+bi
                   int spflag);
 
-char *int2str(char *dest, size_t len, int64_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 isdigit_base(char c, int base);