parent
17d81eb4e6
commit
2c1bb59486
|
@ -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 },
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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 }
|
||||
};
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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;
|
||||
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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);
|
||||
|
||||
|
|
Loading…
Reference in New Issue