diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index f1172dd..44dc8dc 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -182,6 +182,35 @@ value_t fl_constantp(value_t *args, u_int32_t nargs) 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 @@ static builtinspec_t builtin_info[] = { { "intern", fl_intern }, { "fixnum", fl_fixnum }, { "truncate", fl_truncate }, + { "integer?", fl_integerp }, { "vector.alloc", fl_vector_alloc }, diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 34bf6ee..d12436f 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -59,7 +59,7 @@ static char *builtin_names[] = "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,28 +1139,28 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } break; case F_BNOT: - argcount("~", nargs, 1); + argcount("lognot", nargs, 1); if (isfixnum(Stack[SP-1])) v = fixnum(~numval(Stack[SP-1])); else 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 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 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 diff --git a/femtolisp/read.c b/femtolisp/read.c index 55730cc..163c5cd 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -16,15 +16,6 @@ static int symchar(char c) 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; diff --git a/femtolisp/string.c b/femtolisp/string.c index 13e9ab2..39f09eb 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -347,6 +347,27 @@ value_t fl_string_dec(value_t *args, u_int32_t nargs) 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 @@ static builtinspec_t stringfunc_info[] = { { "string.reverse", fl_string_reverse }, { "string.encode", fl_string_encode }, { "string.decode", fl_string_decode }, + + { "number->string", fl_numbertostring }, + { NULL, NULL } }; diff --git a/femtolisp/todo b/femtolisp/todo index 611fa0a..92df3d7 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -600,13 +600,10 @@ cvalues todo: * 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 @@ cvalues todo: - 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) diff --git a/llt/int2str.c b/llt/int2str.c index 255754c..a288ccc 100644 --- a/llt/int2str.c +++ b/llt/int2str.c @@ -1,10 +1,10 @@ #include #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; @@ -26,3 +26,37 @@ char *int2str(char *dest, size_t n, long num, uint32_t base) 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; +} diff --git a/llt/utils.h b/llt/utils.h index 1a532a4..b707211 100644 --- a/llt/utils.h +++ b/llt/utils.h @@ -45,7 +45,9 @@ 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 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);