ref: a805e16b52d1fe06d6ce7ca865be3153473fdb28
parent: 4c0aa8a8b86164bbe9ff9c5876fbf158e8481b45
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Sun Feb 2 15:58:09 EST 2025
more tests and minor fixes; separate math funcs into math.c
--- a/meson.build
+++ b/meson.build
@@ -55,6 +55,7 @@
'src/htable.c',
'src/ios.c',
'src/iostream.c',
+ 'src/math.c',
'src/opcodes.c',
'src/operators.c',
'src/print.c',
--- a/mkfile
+++ b/mkfile
@@ -35,6 +35,7 @@
src/htable.$O\
src/ios.$O\
src/iostream.$O\
+ src/math.$O\
src/nan.$O\
src/opcodes.$O\
src/operators.$O\
@@ -63,8 +64,10 @@
{attr=""}' \ `{ls `{echo $OFILES | sed 's/\.'$O'/.c/g'} >[2]/dev/null} | sort >$target-cvalues.$O: src/fl_arith_any.inc
-flisp.$O: src/maxstack.inc src/vm.inc
+src/cvalues.$O: src/fl_arith_any.inc
+src/flisp.$O: src/maxstack.inc src/vm.inc
+src/equalhash.$O: src/htable.inc
+src/ptrhash.$O: src/htable.inc
src/plan9/flisp.boot.s:D: boot/flisp.boot.builtin
aux/data2s boot <$prereq >$target
--- a/src/builtins.c
+++ b/src/builtins.c
@@ -7,7 +7,6 @@
#include "cvalues.h"
#include "timefuncs.h"
#include "table.h"
-#include "random.h"
#include "nan.h"
#define DBL_MAXINT (1LL<<53)
@@ -225,7 +224,7 @@
{argcount(nargs, 1);
value_t v = args[0];
- if(isfixnum(v))
+ if(isfixnum(v) || ismpint(v))
return FL_t;
if(iscprim(v)){numerictype_t nt = cp_numtype(ptr(v));
@@ -255,7 +254,7 @@
{argcount(nargs, 1);
value_t v = args[0];
- return (isfixnum(v) ||
+ return (isfixnum(v) || ismpint(v) ||
(iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ?
FL_t : FL_f;
}
@@ -289,10 +288,11 @@
BUILTIN("truncate", truncate) {argcount(nargs, 1);
- if(isfixnum(args[0]))
- return args[0];
- if(iscprim(args[0])){- cprim_t *cp = ptr(args[0]);
+ value_t v = args[0];
+ if(isfixnum(v) || ismpint(v))
+ return v;
+ if(iscprim(v)){+ cprim_t *cp = ptr(v);
void *data = cp_data(cp);
numerictype_t nt = cp_numtype(cp);
double d;
@@ -301,11 +301,11 @@
else if(nt == T_DOUBLE)
d = *(double*)data;
else
- return args[0];
+ return v;
if(d > 0){if(d > (double)INT64_MAX)
- return args[0];
+ return v;
return return_from_uint64((uint64_t)d);
}
if(d > (double)INT64_MAX || d < (double)INT64_MIN)
@@ -312,7 +312,7 @@
return args[0];
return return_from_int64((int64_t)d);
}
- type_error("number", args[0]);+ type_error("number", v);}
BUILTIN("vector-alloc", vector_alloc)@@ -357,6 +357,8 @@
numerictype_t nt = cp_numtype(cp);
return conv_to_double(cp_data(cp), nt);
}
+ if(ismpint(a))
+ return conv_to_double(cv_data(ptr(a)), T_MPINT);
type_error("number", a);}
@@ -437,71 +439,3 @@
lerrorf(FL_ArgError, "invalid environment variable");
return FL_t;
}
-
-BUILTIN("rand", rand)-{- USED(args); USED(nargs);
-#ifdef BITS64
- uint64_t x = genrand_uint64();
-#else
- uint32_t x = genrand_uint32();
-#endif
- return fixnum(x >> 3);
-}
-
-BUILTIN("rand-uint32", rand_uint32)-{- USED(args); USED(nargs);
- return mk_uint32(genrand_uint32());
-}
-
-BUILTIN("rand-uint64", rand_uint64)-{- USED(args); USED(nargs);
- return mk_uint64(genrand_uint64());
-}
-
-BUILTIN("rand-double", rand_double)-{- USED(args); USED(nargs);
- return mk_double(genrand_double());
-}
-
-BUILTIN("rand-float", rand_float)-{- USED(args); USED(nargs);
- return mk_float(genrand_double());
-}
-
-#define BUILTIN_(lname, cname) \
- BUILTIN(lname, cname) \
- { \- argcount(nargs, 1); \
- return mk_double(cname(todouble(args[0]))); \
- }
-
-BUILTIN_("sqrt", sqrt)-BUILTIN_("exp", exp)-BUILTIN_("log", log)-BUILTIN_("log10", log10)-BUILTIN_("sin", sin)-BUILTIN_("cos", cos)-BUILTIN_("tan", tan)-BUILTIN_("asin", asin)-BUILTIN_("acos", acos)-BUILTIN_("atan", atan)-BUILTIN_("floor", floor)-BUILTIN_("ceiling", ceil)-BUILTIN_("sinh", sinh)-BUILTIN_("cosh", cosh)-BUILTIN_("tanh", tanh)-
-#undef BUILTIN_
-#define BUILTIN_(lname, cname) \
- BUILTIN(lname, cname) \
- { \- argcount(nargs, 2); \
- return mk_double(cname(todouble(args[0]), todouble(args[1]))); \
- }
-
-BUILTIN_("expt", pow)--- a/src/htable.inc
+++ b/src/htable.inc
@@ -71,14 +71,14 @@
void
HTNAME(_put)(htable_t *h, void *key, void *val)
{- void **bp = HTNAME(_lookup_bp)(h, key);
- *bp = val;
+ void **bp = HTNAME(_lookup_bp)(h, key);
+ *bp = val;
}
void **
HTNAME(_bp)(htable_t *h, void *key)
{- return HTNAME(_lookup_bp)(h, key);
+ return HTNAME(_lookup_bp)(h, key);
}
/* returns bp if key is in hash, otherwise nil */
@@ -86,51 +86,51 @@
static void **
HTNAME(_peek_bp)(htable_t *h, void *key)
{- size_t sz = hash_size(h);
- size_t maxprobe = max_probe(sz);
- void **tab = h->table;
- size_t index = (HFUNC(key) & (sz-1)) * 2;
- sz *= 2;
- size_t orig = index;
- size_t iter = 0;
+ size_t sz = hash_size(h);
+ size_t maxprobe = max_probe(sz);
+ void **tab = h->table;
+ size_t index = (HFUNC(key) & (sz-1)) * 2;
+ sz *= 2;
+ size_t orig = index;
+ size_t iter = 0;
- do {- if(tab[index] == HT_NOTFOUND)
- return nil;
- if(EQFUNC(key, tab[index]))
- return &tab[index+1];
+ do {+ if(tab[index] == HT_NOTFOUND)
+ return nil;
+ if(EQFUNC(key, tab[index]))
+ return &tab[index+1];
- index = (index+2) & (sz-1);
- iter++;
- if(iter > maxprobe)
- break;
- }while(index != orig);
+ index = (index+2) & (sz-1);
+ iter++;
+ if(iter > maxprobe)
+ break;
+ }while(index != orig);
- return nil;
+ return nil;
}
void *
HTNAME(_get)(htable_t *h, void *key)
{- void **bp = HTNAME(_peek_bp)(h, key);
- if(bp == nil)
- return HT_NOTFOUND;
- return *bp;
+ void **bp = HTNAME(_peek_bp)(h, key);
+ if(bp == nil)
+ return HT_NOTFOUND;
+ return *bp;
}
-int
+bool
HTNAME(_has)(htable_t *h, void *key)
{- return HTNAME(_get)(h, key) != HT_NOTFOUND;
+ return HTNAME(_get)(h, key) != HT_NOTFOUND;
}
-int
+bool
HTNAME(_remove)(htable_t *h, void *key)
{- void **bp = HTNAME(_peek_bp)(h, key);
- if(bp != nil){- *bp = HT_NOTFOUND;
- return 1;
- }
- return 0;
+ void **bp = HTNAME(_peek_bp)(h, key);
+ if(bp != nil && *bp != HT_NOTFOUND){+ *bp = HT_NOTFOUND;
+ return true;
+ }
+ return false;
}
--- a/src/htableh.inc
+++ b/src/htableh.inc
@@ -5,8 +5,8 @@
#define HTPROT(HTNAME) \
void *HTNAME##_get(htable_t *h, void *key) fl_purefn; \
void HTNAME##_put(htable_t *h, void *key, void *val); \
-int HTNAME##_has(htable_t *h, void *key) fl_purefn; \
-int HTNAME##_remove(htable_t *h, void *key); \
+bool HTNAME##_has(htable_t *h, void *key) fl_purefn; \
+bool HTNAME##_remove(htable_t *h, void *key); \
void **HTNAME##_bp(htable_t *h, void *key);
// return value, or HT_NOTFOUND if key not found
--- /dev/null
+++ b/src/math.c
@@ -1,0 +1,35 @@
+#include "flisp.h"
+#include "cvalues.h"
+
+#define BUILTIN_(lname, cname) \
+ BUILTIN(lname, cname) \
+ { \+ argcount(nargs, 1); \
+ return mk_double(cname(todouble(args[0]))); \
+ }
+
+BUILTIN_("sqrt", sqrt)+BUILTIN_("exp", exp)+BUILTIN_("log", log)+BUILTIN_("log10", log10)+BUILTIN_("sin", sin)+BUILTIN_("cos", cos)+BUILTIN_("tan", tan)+BUILTIN_("asin", asin)+BUILTIN_("acos", acos)+BUILTIN_("atan", atan)+BUILTIN_("floor", floor)+BUILTIN_("ceiling", ceil)+BUILTIN_("sinh", sinh)+BUILTIN_("cosh", cosh)+BUILTIN_("tanh", tanh)+
+#undef BUILTIN_
+#define BUILTIN_(lname, cname) \
+ BUILTIN(lname, cname) \
+ { \+ argcount(nargs, 2); \
+ return mk_double(cname(todouble(args[0]), todouble(args[1]))); \
+ }
+
+BUILTIN_("expt", pow)--- a/src/random.c
+++ b/src/random.c
@@ -1,4 +1,5 @@
#include "flisp.h"
+#include "cvalues.h"
#include "mt19937-64.h"
#include "timefuncs.h"
#include "random.h"
@@ -5,27 +6,43 @@
static mt19937_64 ctx;
-uint64_t
-genrand_uint64(void)
+void
+randomize(void)
{- return genrand64_int64(&ctx);
+ unsigned long long tm = sec_realtime() * 1000.0;
+ init_by_array64(&ctx, &tm, 1);
}
-uint32_t
-genrand_uint32(void)
+BUILTIN("rand", rand) {- return genrand64_int64(&ctx) >> 32;
+ USED(args); USED(nargs);
+#ifdef BITS64
+ return fixnum(genrand64_int64(&ctx) >> 3);
+#else
+ return fixnum(genrand64_int64(&ctx) >> (32+3));
+#endif
}
-double
-genrand_double(void)
+BUILTIN("rand-uint32", rand_uint32) {- return genrand64_real1(&ctx);
+ USED(args); USED(nargs);
+ return mk_uint32(genrand64_int64(&ctx) >> 32);
}
-void
-randomize(void)
+BUILTIN("rand-uint64", rand_uint64) {- unsigned long long tm = sec_realtime() * 1000.0;
- init_by_array64(&ctx, &tm, 1);
+ USED(args); USED(nargs);
+ return mk_uint64(genrand64_int64(&ctx));
+}
+
+BUILTIN("rand-double", rand_double)+{+ USED(args); USED(nargs);
+ return mk_double(genrand64_real1(&ctx));
+}
+
+BUILTIN("rand-float", rand_float)+{+ USED(args); USED(nargs);
+ return mk_float(genrand64_real1(&ctx));
}
--- a/src/random.h
+++ b/src/random.h
@@ -1,6 +1,4 @@
#pragma once
void randomize(void);
-double genrand_double(void);
-uint64_t genrand_uint64(void);
-uint32_t genrand_uint32(void);
+
--- a/test/number-boundaries.lsp
+++ b/test/number-boundaries.lsp
@@ -63,6 +63,12 @@
`(let* ((h (high-border ,smaller))
(L (low-border ,bigger))
(l (if (= L 0) 0 (low-border ,smaller))))
+ (assert (and (integer? h) (integer? l)))
+ (assert (and (integer? (,smaller h)) (integer? (,smaller l))))
+ (assert (and (integer? (,bigger h)) (integer? (,bigger l))))
+ (assert (and (integer-valued? h) (integer-valued? l)))
+ (assert (and (integer-valued? (,smaller h)) (integer-valued? (,smaller l))))
+ (assert (and (integer-valued? (,bigger h)) (integer-valued? (,bigger l))))
(assert (= h
(,smaller h) (,bigger h)
(,smaller (,bigger h)) (,bigger (,smaller h))))
--- a/test/unittest.lsp
+++ b/test/unittest.lsp
@@ -570,5 +570,75 @@
(assert (equal? "111111111111111111111111111111111" (number->string 111111111111111111111111111111111)))
(assert (equal? "fffffffffffffffffffffffffffffffff" (number->string 0xfffffffffffffffffffffffffffffffff 16)))
+(assert (= (length (byte #\f)) 1))
+(assert (= (length #\я) 2))
+(assert (= (length #\⁹) 3))
+(assert-fail (= (length (uint8 0)) 1))
+(assert-fail (= (length (uint16 0)) 2))
+(assert-fail (= (length (uint32 0)) 4))
+(assert-fail (= (length (uint64 0)) 4))
+(assert-fail (= (length (bignum 0)) 0))
+
+(assert-fail (symbol 1))
+(assert-fail (symbol 'blah))
+(assert-fail (exit 1 2))
+
+(assert (integer-valued? 1.0))
+(assert (integer-valued? -1.0))
+(assert (integer-valued? 1.0f))
+(assert (integer-valued? -1.0f))
+(assert (integer-valued? (bignum 0)))
+
+(assert (integer? 0))
+(assert (integer? (bignum 0)))
+
+(assert (= 12345 (fixnum (bignum 12345))))
+(assert (= -12345 (fixnum (bignum -12345))))
+
+(assert (= 1.0 (truncate 1.3)))
+(assert (= -1.0 (truncate -1.3)))
+(assert (= 1.0 (truncate 1.3)))
+(assert (= -1.0 (truncate -1.3)))
+(assert (= 1.0 (truncate 1.3f)))
+(assert (= -1.0 (truncate -1.3f)))
+(assert (= 1.0 (truncate 1.3f)))
+(assert (= -1.0 (truncate -1.3f)))
+(assert (= 1 (truncate (bignum 1))))
+(assert (= -1 (truncate (bignum -1))))
+(assert (= 123 (truncate (int64 123))))
+(assert (= -123 (truncate (int8 -123))))
+(assert-fail (truncate "blah"))
+(assert-fail (truncate 'blah))
+(assert-fail (truncate truncate))
+
+(assert (= 0 (sin 0)))
+(assert (= 0 (sin 0.0)))
+(assert (= 0 (sin 0.0f)))
+(assert (= 0 (sin (int64 0))))
+(assert (= 0 (sin (bignum 0))))
+(assert-fail (sin "blah"))
+(assert-fail (sin 'blah))
+(assert-fail (sin sin))
+
+(assert (= (length (table "hello" "goodbye" 123 456)) 2))
+(assert-fail (table 1))
+(assert-fail (table 1 2 3))
+(define t (table 1 2 "3" 4 'foo 'bar))
+(assert (table? t))
+(assert (not (table? "nope")))
+(assert-fail (get t 3))
+(assert-fail (get t "foo"))
+(assert-fail (get t 1+))
+(assert (= 2 (get t 1)))
+(assert (= 4 (get t "3")))
+
+(assert (has? t 'foo))
+(assert (equal? 'bar (get t 'foo)))
+(assert (equal? t (del! t 'foo)))
+(assert (not (has? t 'foo)))
+(assert-fail (get t 'foo))
+(assert-fail (del! t 'foo))
+
+
(princ "all tests pass")
(newline)