shithub: femtolisp

--- a/femtolisp/builtins.c

+++ b/femtolisp/builtins.c

@@ -182,6 +182,35 @@

     return FL_T;

+value_t fl_integerp(value_t *args, u_int32_t nargs)

+{

+    argcount("integer?", nargs, 1);

+    value_t v = args[0];

+    if (isfixnum(v)) {

+        return FL_T;

+    }

+    else if (iscprim(v)) {

+        numerictype_t nt = cp_numtype((cprim_t*)ptr(v));

+        if (nt < T_FLOAT)

+            return FL_T;

+        void *data = cp_data((cprim_t*)ptr(v));

+        if (nt == T_FLOAT) {

+            float f = *(float*)data;

+            if (f < 0) f = -f;

+            if (f <= FLT_MAXINT && (float)(int32_t)f == f)

+                return FL_T;

+        }

+        else {

+            assert(nt == T_DOUBLE);

+            double d = *(double*)data;

+            if (d < 0) d = -d;

+            if (d <= DBL_MAXINT && (double)(int64_t)d == d)

+                return FL_T;

+        }

+    }

+    return FL_F;

+}

 value_t fl_fixnum(value_t *args, u_int32_t nargs)

     argcount("fixnum", nargs, 1);

@@ -377,6 +406,7 @@

     { "intern", fl_intern },

     { "fixnum", fl_fixnum },

     { "truncate", fl_truncate },

+    { "integer?", fl_integerp },

     { "vector.alloc", fl_vector_alloc },

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -59,7 +59,7 @@

       "cons", "list", "car", "cdr", "set-car!", "set-cdr!",

       "eval", "eval*", "apply", "prog1", "raise",

-      "+", "-", "*", "/", "<", "~", "&", "!", "$",

+      "+", "-", "*", "/", "<", "lognot", "logand", "logior", "logxor",

       "vector", "aref", "aset!", "length", "assq", "compare", "for",

       "", "", "" };

@@ -1139,7 +1139,7 @@

             break;

         case F_BNOT:

-            argcount("~", nargs, 1);

+            argcount("lognot", nargs, 1);

             if (isfixnum(Stack[SP-1]))

                 v = fixnum(~numval(Stack[SP-1]));

             else

@@ -1146,7 +1146,7 @@

                 v = fl_bitwise_not(Stack[SP-1]);

             break;

         case F_BAND:

-            argcount("&", nargs, 2);

+            argcount("logand", nargs, 2);

             if (bothfixnums(Stack[SP-1], Stack[SP-2]))

                 v = Stack[SP-1] & Stack[SP-2];

             else

@@ -1153,7 +1153,7 @@

                 v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&");

             break;

         case F_BOR:

-            argcount("!", nargs, 2);

+            argcount("logior", nargs, 2);

             if (bothfixnums(Stack[SP-1], Stack[SP-2]))

                 v = Stack[SP-1] | Stack[SP-2];

             else

@@ -1160,7 +1160,7 @@

                 v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!");

             break;

         case F_BXOR:

-            argcount("$", nargs, 2);

+            argcount("logxor", nargs, 2);

             if (bothfixnums(Stack[SP-1], Stack[SP-2]))

                 v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2]));

             else

--- a/femtolisp/read.c

+++ b/femtolisp/read.c

@@ -16,15 +16,6 @@

     return (!isspace(c) && !strchr(special, c));

-static int isdigit_base(char c, int base)

-{

-    if (base < 11)

-        return (c >= '0' && c < '0'+base);

-    return ((c >= '0' && c <= '9') ||

-            (c >= 'a' && c < 'a'+base-10) ||

-            (c >= 'A' && c < 'A'+base-10));

-}

 static int isnumtok_base(char *tok, value_t *pval, int base)

     char *end;

--- a/femtolisp/string.c

+++ b/femtolisp/string.c

@@ -347,6 +347,27 @@

     return size_wrap(i);

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

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

+                             cp_numtype((cprim_t*)ptr(n)));

+    ulong radix = 10;

+    if (nargs == 2) {

+        radix = toulong(args[1], "number->string");

+        if (radix < 2 || radix > 36)

+            lerror(ArgError, "number->string: invalid radix");

+    }

+    char buf[128];

+    char *str = int2str(buf, sizeof(buf), num, radix);

+    return string_from_cstr(str);

+}

 static builtinspec_t stringfunc_info[] = {

     { "string", fl_string },

     { "string?", fl_stringp },

@@ -360,6 +381,9 @@

     { "string.reverse", fl_string_reverse },

     { "string.encode", fl_string_encode },

     { "string.decode", fl_string_decode },

+    { "number->string", fl_numbertostring },

     { NULL, NULL }

};

--- a/femtolisp/todo

+++ b/femtolisp/todo

@@ -600,13 +600,10 @@

 * allow int constructors to accept other int cvalues

 * array constructor should accept any cvalue of the right size

 * make sure cvalues participate well in circular printing

-- lispvalue type

-  . keep track of whether a cvalue leads to any lispvalues, so they can

-    be automatically relocated (?)

 * float, double

 - struct, union (may want to start with more general layout type)

 - pointer type, function type

-- finalizers and lifetime dependency tracking

+* finalizers

 - functions autorelease, guestfunction

 - cref/cset/byteref/byteset

 * wchar type, wide character strings as (array wchar)

@@ -614,13 +611,13 @@

 - ccall

 - anonymous unions

 * fix princ for cvalues

-- make header size for primitives 8 bytes, even on 64-bit arch

+* make header size for primitives <= 8 bytes, even on 64-bit arch

 - more efficient read for #array(), so it doesn't need to build a pairlist

-- make sure shared pieces of types, like lists of enum values, can be

-  printed as shared structure to avoid duplication.

-- share more types, allocate less

+? lispvalue type

+  . keep track of whether a cvalue leads to any lispvalues, so they can

+    be automatically relocated (?)

-- string constructor/concatenator:

+* string constructor/concatenator:

 (string 'sym #char(65) #wchar(945) "blah" 23)

    ; gives "symA\u03B1blah23"

 "ccc"  reads to (array char)

--- a/llt/int2str.c

+++ b/llt/int2str.c

@@ -1,10 +1,10 @@

 #include <stdlib.h>

 #include "dtypes.h"

-char *int2str(char *dest, size_t n, long num, uint32_t base)

+char *int2str(char *dest, size_t len, int64_t num, uint32_t base)

-    int i = n-1;

-    int b = (int)base, neg = 0;

+    int i = len-1, neg = 0;

+    int64_t b = (int64_t)base;

     char ch;

     if (num < 0) {

         num = -num;

@@ -25,4 +25,38 @@

     if (i >= 0 && neg)

         dest[i--] = '-';

     return &dest[i+1];

+}

+int isdigit_base(char c, int base)

+{

+    if (base < 11)

+        return (c >= '0' && c < '0'+base);

+    return ((c >= '0' && c <= '9') ||

+            (c >= 'a' && c < 'a'+base-10) ||

+            (c >= 'A' && c < 'A'+base-10));

+}

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

+    char digit;

+    int i;

+    place = 1; result = 0;

+    for(i=len-1; i>=0; i--) {

+        digit = str[i];

+        if (!isdigit_base(digit, base))

+            return 1;

+        if (digit <= '9')

+            digit -= '0';

+        else if (digit >= 'a')

+            digit = digit-'a'+10;

+        else if (digit >= 'A')

+            digit = digit-'A'+10;

+        result += digit * place;

+        place *= base;

+    }

+    *res = result;

+    return 0;

--- a/llt/utils.h

+++ b/llt/utils.h

@@ -45,7 +45,9 @@

                   // print spaces around sign in a+bi

                   int spflag);

-char *int2str(char *dest, size_t n, long num, uint32_t base);

+char *int2str(char *dest, size_t len, int64_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);

 extern double trunc(double x);