ref: 52677147a7a0e4a4c0db4743dd9de3f7f24de8eb
parent: e9e65bff7f2881102adc9b48e3e47a17b6e2094d
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Fri Feb 28 13:54:34 EST 2025
rename to StreetLISP
--- a/.build.yml
+++ b/.build.yml
@@ -10,18 +10,18 @@
- rsync
- samurai
sources:
- - https://git.sr.ht/~ft/femtolisp
+ - https://git.sr.ht/~ft/sl
tasks:
- setup: |
- cd femtolisp
+ cd sl
meson setup build . -Dbuildtype=release -Db_coverage=true
- build: |
- cd femtolisp
+ cd sl
ninja -C build test
- coverage: |
- cd femtolisp
+ cd sl
ninja -C build coverage-html
- coverage-upload: |
test $GIT_REF = refs/heads/main || exit 0
set +x
- rsync -Pavq femtolisp/build/meson-logs/coveragereport -e "ssh -p 8886 -i .ssh/05bf4496-881e-4741-b17f-5cc8640334bf" secretsauce@ftrv.se:incoming/femtolisp-coverage 2>/dev/null
+ rsync -Pavq sl/build/meson-logs/coveragereport -e "ssh -p 8886 -i .ssh/05bf4496-881e-4741-b17f-5cc8640334bf" secretsauce@ftrv.se:incoming/sl-coverage 2>/dev/null
--- a/.gitignore
+++ b/.gitignore
@@ -1,10 +1,10 @@
*.[05678qvtoa]
*.out
*.bak
-flisp.boot
+sl.boot
instructions.lsp
builtins.lsp
docs_ops.lsp
builtin_fns.h
*.core
-flisp.boot.s
+sl.boot.s
--- a/.lcovrc
+++ b/.lcovrc
@@ -1,3 +1,3 @@
exclude = */3rd/*
ignore_errors = unused
-genhtml_header = Coverage report for FemtoLisp
+genhtml_header = Coverage report for StreetLISP
--- a/3rd/brieflz/brieflz.c
+++ b/3rd/brieflz/brieflz.c
@@ -209,7 +209,7 @@
};
#endif
-fl_constfn
+sl_constfn
static int
blz_log2(unsigned long n)
{@@ -232,7 +232,7 @@
#endif
}
-fl_constfn
+sl_constfn
static unsigned long
blz_gamma_cost(unsigned long n)
{@@ -241,7 +241,7 @@
return 2 * (unsigned long) blz_log2(n);
}
-fl_constfn
+sl_constfn
static unsigned long
blz_match_cost(unsigned long pos, unsigned long len)
{@@ -412,7 +412,7 @@
// This is Fibonacci hashing, also known as Knuth's multiplicative hash. The
// constant is a prime close to 2^32/phi.
//
-fl_purefn
+sl_purefn
static unsigned long
blz_hash4_bits(const unsigned char *p, int bits)
{@@ -426,7 +426,7 @@
return (val * 2654435761U) >> (32 - bits);
}
-fl_purefn
+sl_purefn
static unsigned long
blz_hash4(const unsigned char *p)
{--- a/3rd/brieflz/brieflz.h
+++ b/3rd/brieflz/brieflz.h
@@ -79,7 +79,7 @@
* @return maximum size of compressed data
*/
BLZ_API size_t
-blz_max_packed_size(size_t src_size) fl_constfn;
+blz_max_packed_size(size_t src_size) sl_constfn;
/**
* Get required size of `workmem` buffer.
@@ -90,7 +90,7 @@
* @return required size in bytes of `workmem` buffer
*/
BLZ_API size_t
-blz_workmem_size(size_t src_size) fl_constfn;
+blz_workmem_size(size_t src_size) sl_constfn;
/**
* Compress `src_size` bytes of data from `src` to `dst`.
@@ -114,7 +114,7 @@
* @return required size in bytes of `workmem` buffer
*/
BLZ_API size_t
-blz_workmem_size_level(size_t src_size, int level) fl_constfn;
+blz_workmem_size_level(size_t src_size, int level) sl_constfn;
/**
* Compress `src_size` bytes of data from `src` to `dst`.
--- a/3rd/brieflz/brieflz_hashbucket.h
+++ b/3rd/brieflz/brieflz_hashbucket.h
@@ -28,7 +28,7 @@
#ifndef BRIEFLZ_HASHBUCKET_H_INCLUDED
#define BRIEFLZ_HASHBUCKET_H_INCLUDED
-fl_constfn
+sl_constfn
static size_t
blz_hashbucket_workmem_size(size_t src_size, unsigned int bucket_size)
{--- a/3rd/dlmalloc.inc
+++ b/3rd/dlmalloc.inc
@@ -2707,7 +2707,7 @@
((char*)(A) >= S->base && (char*)(A) < S->base + S->size)
/* Return segment holding given address */
-fl_purefn
+sl_purefn
static msegmentptr segment_holding(mstate m, char* addr) {msegmentptr sp = &m->seg;
for (;;) {@@ -2719,7 +2719,7 @@
}
/* Return true if segment contains a segment link */
-fl_purefn
+sl_purefn
static int has_segment_link(mstate m, msegmentptr ss) {msegmentptr sp = &m->seg;
for (;;) {@@ -5352,17 +5352,17 @@
return result;
}
-fl_purefn
+sl_purefn
size_t dlmalloc_footprint(void) {return gm->footprint;
}
-fl_purefn
+sl_purefn
size_t dlmalloc_max_footprint(void) {return gm->max_footprint;
}
-fl_purefn
+sl_purefn
size_t dlmalloc_footprint_limit(void) {size_t maf = gm->footprint_limit;
return maf == 0 ? MAX_SIZE_T : maf;
@@ -5395,7 +5395,7 @@
return change_mparam(param_number, value);
}
-fl_purefn
+sl_purefn
size_t dlmalloc_usable_size(void* mem) { if (mem != 0) {mchunkptr p = mem2chunk(mem);
--- a/3rd/fn.c
+++ b/3rd/fn.c
@@ -14,7 +14,7 @@
if(t == nil)
return false;
while(isbranch(t)){- fl_prefetch(t->ptr);
+ sl_prefetch(t->ptr);
Tindex i = t->index;
Tbitmap b = twigbit(i, key, len);
if(!hastwig(i, b))
@@ -80,7 +80,7 @@
Tindex i = 0;
Tbitmap b = 0;
while(isbranch(t)){- fl_prefetch(t->ptr);
+ sl_prefetch(t->ptr);
i = t->index;
b = twigbit(i, key, len);
if(!hastwig(i, b))
@@ -96,7 +96,7 @@
return nil;
}
Trie *twigs = Tbranch_twigs(p);
- uint32_t m = fl_popcount(Tindex_bitmap(i));
+ uint32_t m = sl_popcount(Tindex_bitmap(i));
assert(twigs <= t && t < twigs+m);
if(m == 2){// Move the other twig to the parent branch.
@@ -136,7 +136,7 @@
// which can be at a lower index than the point at which we
// detect a difference.
while(isbranch(t)){- fl_prefetch(t->ptr);
+ sl_prefetch(t->ptr);
Tindex i = t->index;
Tbitmap b = twigbit(i, key, len);
// Even if our key is missing from this branch we need to
@@ -158,7 +158,7 @@
Tset_val(t, val);
return tbl;
newkey:; // We have the branch's byte index; what is its chunk index?
- uint32_t bit = off * 8 + fl_clz(xor) + 8 - sizeof(uint32_t) * 8;
+ uint32_t bit = off * 8 + sl_clz(xor) + 8 - sizeof(uint32_t) * 8;
uint32_t qo = bit / 5;
off = qo * 5 / 8;
shf = qo * 5 % 8;
@@ -173,7 +173,7 @@
t = tbl;
Tindex i;
while(isbranch(t)){- fl_prefetch(t->ptr);
+ sl_prefetch(t->ptr);
i = t->index;
if(off == Tindex_offset(i) && shf == Tindex_shift(i))
goto growbranch;
--- a/3rd/fn.h
+++ b/3rd/fn.h
@@ -25,7 +25,7 @@
typedef struct Tbl {Tindex index;
void *ptr;
-}fl_aligned(8) Trie;
+}sl_aligned(8) Trie;
// accessor functions, except for the index word
@@ -61,11 +61,11 @@
} \
struct dummy
-fl_purefn
+sl_purefn
Tcheck_get(Trie *, Tbranch, twigs, t->ptr);
-fl_purefn
+sl_purefn
Tcheck_get(const char *, Tleaf, key, t->ptr);
-fl_purefn
+sl_purefn
Tcheck_get(void *, Tleaf, val, (void*)(uintptr_t)t->index);
// index word layout
@@ -181,10 +181,10 @@
static inline uint32_t
twigoff(Tindex i, Tbitmap bit)
{- return fl_popcount(Tindex_bitmap(i) & (bit-1));
+ return sl_popcount(Tindex_bitmap(i) & (bit-1));
}
#define TWIGOFFMAX(off, max, i, b) do{ \off = twigoff(i, b); \
- max = fl_popcount(Tindex_bitmap(i)); \
+ max = sl_popcount(Tindex_bitmap(i)); \
}while(0)
--- a/3rd/iswprint.c
+++ b/3rd/iswprint.c
@@ -21,11 +21,11 @@
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*/
-#include "flisp.h"
+#include "sl.h"
// straight from musl
int
-fl_iswprint(Rune c)
+sl_iswprint(Rune c)
{if(c < 0xff)
return ((c+1) & 0x7f) >= 0x21;
--- a/3rd/mp/mp.h
+++ b/3rd/mp/mp.h
@@ -24,8 +24,8 @@
#define mpdighi (((mpdigit)1)<<(Dbits-1))
#define DIGITS(x) ((int)(x) >= -(Dbits-1) ? ((Dbits - 1 + (x))/Dbits) : 0)
-extern mpdigit dec16chr(int) fl_constfn;
-extern int enc16chr(int) fl_constfn;
+extern mpdigit dec16chr(int) sl_constfn;
+extern int enc16chr(int) sl_constfn;
/*
* the code assumes mpdigit to be at least an int
@@ -76,15 +76,15 @@
mpint* betomp(uint8_t*, uint32_t, mpint*); /* byte array, big-endian */
int mptobe(mpint*, uint8_t*, uint32_t, uint8_t**);
void mptober(mpint *b, uint8_t *p, int n);
-uint32_t mptoui(mpint*) fl_purefn; /* unsigned int */
+uint32_t mptoui(mpint*) sl_purefn; /* unsigned int */
mpint* uitomp(uint32_t, mpint*);
-int mptoi(mpint*) fl_purefn; /* int */
+int mptoi(mpint*) sl_purefn; /* int */
mpint* itomp(int, mpint*);
-uint64_t mptouv(mpint*) fl_purefn; /* unsigned int64_t */
+uint64_t mptouv(mpint*) sl_purefn; /* unsigned int64_t */
mpint* uvtomp(uint64_t, mpint*);
-int64_t mptov(mpint*) fl_purefn; /* int64_t */
+int64_t mptov(mpint*) sl_purefn; /* int64_t */
mpint* vtomp(int64_t, mpint*);
-double mptod(mpint*) fl_purefn; /* double */
+double mptod(mpint*) sl_purefn; /* double */
mpint* dtomp(double, mpint*);
/* divide the 2 digit dividend by the one digit divisor and stick in quotient */
@@ -118,7 +118,7 @@
void mpdiv(mpint *dividend, mpint *divisor, mpint *quotient, mpint *remainder);
/* return neg, 0, pos as b1-b2 is neg, 0, pos */
-int mpcmp(mpint *b1, mpint *b2) fl_purefn;
+int mpcmp(mpint *b1, mpint *b2) sl_purefn;
/* res = s != 0 ? b1 : b2 */
void mpsel(int s, mpint *b1, mpint *b2, mpint *res);
@@ -130,7 +130,7 @@
void mpinvert(mpint *b, mpint *m, mpint *res);
/* bit counting */
-uint32_t mpsignif(mpint*) fl_purefn; /* number of sigificant bits in mantissa */
+uint32_t mpsignif(mpint*) sl_purefn; /* number of sigificant bits in mantissa */
uint32_t mplowbits0(mpint*); /* k, where n = 2**k * q for odd q */
/* well known constants */
@@ -158,11 +158,11 @@
void mpvectsmul(mpdigit *a, int alen, mpdigit *b, int blen, mpdigit *p);
/* sign of a - b or zero if the same */
-int mpveccmp(mpdigit *a, int alen, mpdigit *b, int blen) fl_purefn;
-int mpvectscmp(mpdigit *a, int alen, mpdigit *b, int blen) fl_purefn;
+int mpveccmp(mpdigit *a, int alen, mpdigit *b, int blen) sl_purefn;
+int mpvectscmp(mpdigit *a, int alen, mpdigit *b, int blen) sl_purefn;
/* playing with magnitudes */
-int mpmagcmp(mpint *b1, mpint *b2) fl_purefn;
+int mpmagcmp(mpint *b1, mpint *b2) sl_purefn;
void mpmagadd(mpint *b1, mpint *b2, mpint *sum); /* sum = b1+b2 */
void mpmagsub(mpint *b1, mpint *b2, mpint *sum); /* sum = b1+b2 */
--- a/3rd/mp/test/fns.h
+++ b/3rd/mp/test/fns.h
@@ -1,5 +1,5 @@
ldint* ldnew(int);
-int ldcmp(ldint *, ldint *) fl_purefn;
+int ldcmp(ldint *, ldint *) sl_purefn;
int ldmagcmp(ldint *, ldint *);
void ldadd(ldint *, ldint *, ldint *);
void ldsub(ldint *, ldint *, ldint *);
@@ -16,7 +16,7 @@
void lddiv_(ldint *, ldint *, ldint *, ldint *);
void ldfree(ldint *);
void testgen(int, ldint *);
-int ldmpeq(ldint *, mpint *) fl_purefn;
+int ldmpeq(ldint *, mpint *) sl_purefn;
mpint* ldtomp(ldint *, mpint *);
void mptarget(mpint *);
void tests(void);
--- a/3rd/spooky.c
+++ b/3rd/spooky.c
@@ -53,7 +53,7 @@
//
// Read uint64_t in little-endian order.
//
-fl_purefn
+sl_purefn
static inline uint64_t
spooky_read_le64(const uint64_t *s)
{--- a/3rd/utf/utf.h
+++ b/3rd/utf/utf.h
@@ -11,17 +11,17 @@
int chartorune(Rune *rune, const char *str);
int runetochar(char *str, const Rune *rune);
-int runenlen(const Rune *r, int nrune) fl_purefn;
-int fullrune(const char *str, int n) fl_purefn;
-int runelen(Rune c) fl_constfn;
-Rune tolowerrune(Rune c) fl_constfn;
-Rune toupperrune(Rune c) fl_constfn;
-Rune totitlerune(Rune c) fl_constfn;
-int islowerrune(Rune c) fl_constfn;
-int isupperrune(Rune c) fl_constfn;
-int isalpharune(Rune c) fl_constfn;
-int istitlerune(Rune c) fl_constfn;
-int isspacerune(Rune c) fl_constfn;
-int isdigitrune(Rune c) fl_constfn;
+int runenlen(const Rune *r, int nrune) sl_purefn;
+int fullrune(const char *str, int n) sl_purefn;
+int runelen(Rune c) sl_constfn;
+Rune tolowerrune(Rune c) sl_constfn;
+Rune toupperrune(Rune c) sl_constfn;
+Rune totitlerune(Rune c) sl_constfn;
+int islowerrune(Rune c) sl_constfn;
+int isupperrune(Rune c) sl_constfn;
+int isalpharune(Rune c) sl_constfn;
+int istitlerune(Rune c) sl_constfn;
+int isspacerune(Rune c) sl_constfn;
+int isdigitrune(Rune c) sl_constfn;
int utfnlen(const char *s, long m);
--- a/3rd/wcwidth.c
+++ b/3rd/wcwidth.c
@@ -15,7 +15,7 @@
* https://github.com/termux/termux-packages/tree/master/packages/libandroid-support
*/
-#include "flisp.h"
+#include "sl.h"
struct width_interval {int start;
@@ -498,7 +498,7 @@
{0x30000, 0x3fffd}, // Cjk Unified Ideograph-30..(nil)};
-fl_constfn
+sl_constfn
static bool
intable(const struct width_interval* table, int table_length, int c)
{@@ -523,7 +523,7 @@
}
int
-fl_wcwidth(Rune ucs)
+sl_wcwidth(Rune ucs)
{// NOTE: created by hand, there isn't anything identifiable other than
// general Cf category code to identify these, and some characters in Cf
--- a/README.md
+++ b/README.md
@@ -1,11 +1,15 @@
-# femtolisp
+# StreetLISP
-[](https://builds.sr.ht/~ft/femtolisp/commits/main/.build.yml?)
+ < cinap_lenrek> maybe thats all you need
+ < cinap_lenrek> a street lisp
+ < cinap_lenrek> sl(1)
-[Coverage report](https://ftrv.se/_/femtolisp/index.html)
+[](https://builds.sr.ht/~ft/sl/commits/main/.build.yml?)
-A compact interpreter for a minimal lisp/scheme dialect.
+[Coverage report](https://ftrv.se/_/sl/index.html)
+A compact interpreter for a minimal lisp/scheme dialect. A street lisp.
+
This is a reanimation of
https://github.com/lambdaconservatory/femtolisp with bigger plans.
@@ -38,8 +42,8 @@
Two ways to learn about more changes:
- * https://todo.sr.ht/~ft/femtolisp?search=status:closed
- * https://git.sr.ht/~ft/femtolisp/log
+ * https://todo.sr.ht/~ft/sl?search=status:closed
+ * https://git.sr.ht/~ft/sl/log
## Building
@@ -63,9 +67,9 @@
../retro68/build-toolchain.bash --ninja
# wait until everything builds, make sure it did not error out
-Now build femtolisp:
+Now build `sl`:
- cd femtolisp
+ cd sl
export PATH="$PATH:$(pwd)/../retro68-build/toolchain/bin"
# for PowerPC:
meson setup build . -Dbuildtype=minsize --cross-file cross/powerpc-apple.txt
@@ -73,7 +77,7 @@
meson setup build . -Dbuildtype=minsize --cross-file cross/m68k-apple.txt
ninja -C build
-Either `build/flisp.dsk` or `build/flisp.bin` is the file to get on your Mac.
+Either `build/sl.dsk` or `build/sl.bin` is the file to get on your Mac.
NOTE: this isn't a full-fledged port and is going to stay low priority unless somebody
wants to spend time polishing it.
@@ -86,7 +90,7 @@
meson setup build . -Dbuildtype=minsize --cross-file cross/djgpp.txt
ninja -C build
-Result is `build/flisp.exe`.
+Result is `build/sl.exe`.
## Characteristics
binary files a/boot/flisp.boot.builtin /dev/null differ
binary files /dev/null b/boot/sl.boot.builtin differ
--- a/meson.build
+++ b/meson.build
@@ -1,5 +1,5 @@
project(
- 'femtolisp',
+ 'sl',
'c',
version: '0.999',
meson_version: '>=1.1.0',
@@ -39,7 +39,7 @@
language: 'c',
)
-src_flisp = [
+src_sl = [
'3rd/fn.c',
'3rd/iswprint.c',
'3rd/mt19937-64.c',
@@ -52,8 +52,8 @@
'src/cvalues.c',
'src/equal.c',
'src/equalhash.c',
- 'src/flisp.c',
- 'src/flmain.c',
+ 'src/sl.c',
+ 'src/slmain.c',
'src/hashing.c',
'src/htable.c',
'src/ios.c',
@@ -104,7 +104,7 @@
if sys == 'macos'
platform = sys
- flisp_exe_name = 'flisp.code.bin'
+ sl_exe_name = 'sl.code.bin'
add_languages(
'cpp',
native: false,
@@ -128,14 +128,14 @@
]
elif sys == 'dos'
platform = sys
- flisp_exe_name = 'flisp.exe'
+ sl_exe_name = 'sl.exe'
else
platform = 'posix'
- flisp_exe_name = 'flisp'
+ sl_exe_name = 'sl'
endif
inc += [include_directories('src'/platform)]-src_flisp += ['src'/platform/'sys.c']
+src_sl += ['src'/platform/'sys.c']
common = static_library(
'common',
@@ -151,10 +151,10 @@
'boot',
capture: true,
input: [
- 'boot/flisp.boot.builtin',
+ 'boot/sl.boot.builtin',
],
output: [
- 'flisp.boot.h',
+ 'sl.boot.h',
],
command: [
'tools/boot2h.sh', '@INPUT@',
@@ -165,7 +165,7 @@
'builtins',
capture: true,
input: [
- src_flisp,
+ src_sl,
],
output: [
'builtin_fns.h',
@@ -253,10 +253,10 @@
prelink: false,
)
-flisp = executable(
- flisp_exe_name,
+sl = executable(
+ sl_exe_name,
sources: [
- src_flisp,
+ src_sl,
boot,
builtins,
ops,
@@ -289,22 +289,22 @@
rincludes = fs.parent(fs.parent(rez.full_path()))/'RIncludes'
if cpu == 'm68k'
- template = 'femtolispm68k.r'
+ template = 'm68k.r'
rez_data = '--copy'
rezflags = []
- flisp_code = flisp
+ sl_code = sl
else
assert(cpu == 'ppc', 'unexpected cpu setting')
- template = 'femtolispppc.r'
+ template = 'ppc.r'
rez_data = '--data'
rezflags = ['-DTARGET_API_MAC_CARBON=0']
- flisp_code = custom_target(
- 'flisp.pef',
+ sl_code = custom_target(
+ 'sl.pef',
input: [
- flisp
+ sl
],
output: [
- 'flisp.pef',
+ 'sl.pef',
],
command: [
makepef,
@@ -315,15 +315,15 @@
endif
template = meson.global_source_root()/'src/macos'/template
- flisp_bin = custom_target(
- 'flisp.bin',
+ sl_bin = custom_target(
+ 'sl.bin',
input: [
- flisp_code,
+ sl_code,
template,
],
output: [
- 'flisp.bin',
- 'flisp.dsk',
+ 'sl.bin',
+ 'sl.dsk',
],
command: [
rez,
@@ -330,12 +330,12 @@
'-I' + rincludes,
] + rezflags + [
template,
- '-DCFRAG_NAME="flisp"',
- '-o', 'flisp.bin',
+ '-DCFRAG_NAME="sl"',
+ '-o', 'sl.bin',
'-t', 'APPL',
'-c', '????',
- rez_data, flisp_code,
- '--cc', 'flisp.dsk',
+ rez_data, sl_code,
+ '--cc', 'sl.dsk',
],
build_by_default: true,
)
@@ -375,18 +375,18 @@
src_dir = meson.current_source_dir()
tests_dir = join_paths(src_dir, 'test')
-test('100x100.lsp', flisp, args: ['100x100.lsp'], workdir: tests_dir)-test('argv.lsp', flisp, args: ['argv.lsp'], workdir: tests_dir)-test('exit0.lsp', flisp, args: ['exit0.lsp'], workdir: tests_dir)-test('exit1.lsp', flisp, args: ['exit1.lsp'], workdir: tests_dir, should_fail: true)-test('bench.lsp', flisp, args: ['bench.lsp'], workdir: tests_dir)-test('hashtest.lsp', flisp, args: ['hashtest.lsp'], workdir: tests_dir)-test('mp.lsp', flisp, args: ['mp.lsp'], workdir: tests_dir)-test('perf.lsp', flisp, args: ['perf.lsp'], workdir: tests_dir, timeout: -1)-test('tme.lsp', flisp, args: ['tme.lsp'], workdir: tests_dir)-test('torture.lsp', flisp, args: ['-S', '8m', 'torture.lsp'], workdir: tests_dir, timeout: -1)-test('torus.lsp', flisp, args: ['torus.lsp'], workdir: tests_dir)-test('unit.lsp', flisp, args: ['-S', '1m', 'unittest.lsp'], workdir: tests_dir)+test('100x100.lsp', sl, args: ['100x100.lsp'], workdir: tests_dir)+test('argv.lsp', sl, args: ['argv.lsp'], workdir: tests_dir)+test('exit0.lsp', sl, args: ['exit0.lsp'], workdir: tests_dir)+test('exit1.lsp', sl, args: ['exit1.lsp'], workdir: tests_dir, should_fail: true)+test('bench.lsp', sl, args: ['bench.lsp'], workdir: tests_dir)+test('hashtest.lsp', sl, args: ['hashtest.lsp'], workdir: tests_dir)+test('mp.lsp', sl, args: ['mp.lsp'], workdir: tests_dir)+test('perf.lsp', sl, args: ['perf.lsp'], workdir: tests_dir, timeout: -1)+test('tme.lsp', sl, args: ['tme.lsp'], workdir: tests_dir)+test('torture.lsp', sl, args: ['-S', '8m', 'torture.lsp'], workdir: tests_dir, timeout: -1)+test('torus.lsp', sl, args: ['torus.lsp'], workdir: tests_dir)+test('unit.lsp', sl, args: ['-S', '1m', 'unittest.lsp'], workdir: tests_dir)bootstrap = find_program(
'bootstrap.sh',
--- a/mkfile
+++ b/mkfile
@@ -1,16 +1,16 @@
</$objtype/mkfile
BIN=/$objtype/bin
-TARG=flisp
+TARG=sl
CFLAGS=$CFLAGS -p -Isrc -I3rd -I3rd/brieflz -Isrc/plan9 \
-D__plan9__ -D__${objtype}__ \-DNDEBUG \
-CLEANFILES=src/plan9/flisp.boot.s src/plan9/builtin_fns.h
+CLEANFILES=src/plan9/sl.boot.s src/plan9/builtin_fns.h
HFILES=\
src/equalhash.h\
- src/flisp.h\
+ src/sl.h\
src/opcodes.h\
src/plan9/platform.h\
@@ -29,8 +29,8 @@
src/cvalues.$O\
src/equal.$O\
src/equalhash.$O\
- src/flisp.$O\
- src/flmain.$O\
+ src/sl.$O\
+ src/slmain.$O\
src/hashing.$O\
src/htable.$O\
src/ios.$O\
@@ -40,7 +40,7 @@
src/opcodes.$O\
src/operators.$O\
src/plan9/clz`{test -f src/plan9/clz_$objtype.s && echo -n _$objtype}.$O\- src/plan9/flisp.boot.$O\
+ src/plan9/sl.boot.$O\
src/plan9/popcount`{test -f src/plan9/popcount_$objtype.s && echo -n _$objtype}.$O\src/plan9/sys.$O\
src/print.$O\
@@ -58,18 +58,18 @@
src/plan9/builtin_fns.h:D:
awk -F '[()]' '\
- /^fl_.*fn/ {attr=$1; next} \+ /^sl_.*fn/ {attr=$1; next} \ /^_Noreturn/ {attr=$1; next} \ /^BUILTIN[_]?/ {printf "BUILTIN_FN(%s, %s)\n", $2, attr} \ {attr=""}' \ `{ls `{echo $OFILES | sed 's/\.'$O'/.c/g'} >[2]/dev/null} | sort >$target-src/cvalues.$O: src/fl_arith_any.inc
-src/flisp.$O: src/vm.inc
+src/cvalues.$O: src/sl_arith_any.inc
+src/sl.$O: 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
+src/plan9/sl.boot.s:D: boot/sl.boot.builtin
aux/data2s boot <$prereq >$target
%.$O: %.c
@@ -83,10 +83,10 @@
bootstrap:V: $O.out
cd src && \
../$O.out ../tools/gen.lsp && \
- cp ../boot/flisp.boot ../boot/flisp.boot.bak && \
- ../$O.out ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/flisp.boot.new && \
- mv ../boot/flisp.boot.new ../boot/flisp.boot && \
- cp ../boot/flisp.boot ../boot/flisp.boot.builtin && \
+ cp ../boot/sl.boot ../boot/sl.boot.bak && \
+ ../$O.out ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/sl.boot.new && \
+ mv ../boot/sl.boot.new ../boot/sl.boot && \
+ cp ../boot/sl.boot ../boot/sl.boot.builtin && \
cd .. && \
mk && \
cd boot && \
--- a/src/bitvector.c
+++ b/src/bitvector.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
uint32_t *
bitvector_resize(uint32_t *b, uint64_t oldsz, uint64_t newsz, bool zero)
--- a/src/builtins.c
+++ b/src/builtins.c
@@ -1,8 +1,4 @@
-/*
- Extra femtoLisp builtin functions
-*/
-
-#include "flisp.h"
+#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "timefuncs.h"
@@ -26,9 +22,9 @@
BUILTIN("nconc", nconc) {if(nargs == 0)
- return FL_nil;
+ return SL_nil;
- value_t lst, first = FL_nil;
+ value_t lst, first = SL_nil;
value_t *pcdr = &first;
cons_t *c;
int i = 0;
@@ -43,7 +39,7 @@
while(iscons(c->cdr))
c = ptr(c->cdr);
pcdr = &c->cdr;
- }else if(lst != FL_nil)
+ }else if(lst != SL_nil)
type_error("cons", lst);}
*pcdr = lst;
@@ -50,7 +46,7 @@
return first;
}
-fl_purefn
+sl_purefn
BUILTIN("assq", assq) {argcount(nargs, 2);
@@ -65,10 +61,10 @@
return bind;
v = cdr_(v);
}
- return FL_nil;
+ return SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("memq", memq) {argcount(nargs, 2);
@@ -79,7 +75,7 @@
if((c = ptr(v))->car == args[0])
return v;
}
- return FL_nil;
+ return SL_nil;
}
BUILTIN("length", length)@@ -106,9 +102,9 @@
}
if(iscprim(a)){cv = ptr(a);
- if(cp_class(cv) == FL(bytetype))
+ if(cp_class(cv) == SL(bytetype))
return fixnum(1);
- if(cp_class(cv) == FL(runetype))
+ if(cp_class(cv) == SL(runetype))
return fixnum(runelen(*(Rune*)cp_data(cv)));
}
if(iscvalue(a) && cv_class(ptr(a))->eltype != nil)
@@ -126,7 +122,7 @@
}
return size_wrap(n);
}
- if(a == FL_nil)
+ if(a == SL_nil)
return fixnum(0);
type_error("sequence", a);}
@@ -135,7 +131,7 @@
BUILTIN("raise", raise) {argcount(nargs, 1);
- fl_raise(args[0]);
+ sl_raise(args[0]);
}
_Noreturn
@@ -143,25 +139,25 @@
{if(nargs > 1)
argcount(nargs, 1);
- fl_exit(nargs > 0 ? tofixnum(args[0]) : 0);
+ sl_exit(nargs > 0 ? tofixnum(args[0]) : 0);
}
BUILTIN("symbol", symbol) {argcount(nargs, 1);
- if(fl_unlikely(!fl_isstring(args[0])))
+ if(sl_unlikely(!sl_isstring(args[0])))
type_error("string", args[0]);return symbol(cvalue_data(args[0]), true);
}
-fl_purefn
+sl_purefn
BUILTIN("keyword?", keywordp) {argcount(nargs, 1);
- return (issymbol(args[0]) && iskeyword((symbol_t*)ptr(args[0]))) ? FL_t : FL_nil;
+ return (issymbol(args[0]) && iskeyword((symbol_t*)ptr(args[0]))) ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("top-level-value", top_level_value) {argcount(nargs, 1);
@@ -186,7 +182,7 @@
symbol_t *sym = tosymbol(args[0]);
if(!isconstant(sym))
sym->binding = UNBOUND;
- return FL_void;
+ return SL_void;
}
BUILTIN("environment", environment)@@ -193,43 +189,43 @@
{USED(args);
argcount(nargs, 0);
- value_t lst = FL_nil;
- fl_gc_handle(&lst);
+ value_t lst = SL_nil;
+ sl_gc_handle(&lst);
const char *k = nil;
symbol_t *v;
- while(Tnext(FL(symtab), &k, (void**)&v)){+ while(Tnext(SL(symtab), &k, (void**)&v)){if(v->binding != UNBOUND && (v->flags & FLAG_KEYWORD) == 0)
- lst = fl_cons(tagptr(v, TAG_SYM), lst);
+ lst = sl_cons(tagptr(v, TAG_SYM), lst);
}
- fl_free_gc_handles(1);
+ sl_free_gc_handles(1);
return lst;
}
-fl_purefn
+sl_purefn
BUILTIN("constant?", constantp) {argcount(nargs, 1);
if(issymbol(args[0]))
- return isconstant((symbol_t*)ptr(args[0])) ? FL_t : FL_nil;
+ return isconstant((symbol_t*)ptr(args[0])) ? SL_t : SL_nil;
if(iscons(args[0])){- if(car_(args[0]) == FL_quote)
- return FL_t;
- return FL_nil;
+ if(car_(args[0]) == SL_quote)
+ return SL_t;
+ return SL_nil;
}
- return FL_t;
+ return SL_t;
}
-fl_purefn
+sl_purefn
BUILTIN("integer-valued?", integer_valuedp) {argcount(nargs, 1);
value_t v = args[0];
if(isfixnum(v) || ismpint(v))
- return FL_t;
+ return SL_t;
if(iscprim(v)){numerictype_t nt = cp_numtype(ptr(v));
if(nt < T_FLOAT)
- return FL_t;
+ return SL_t;
void *data = cp_data(ptr(v));
if(nt == T_FLOAT){float f = *(float*)data;
@@ -236,7 +232,7 @@
if(f < 0)
f = -f;
if(f <= FLT_MAXINT && (float)(int32_t)f == f)
- return FL_t;
+ return SL_t;
}else{assert(nt == T_DOUBLE);
double d = *(double*)data;
@@ -243,13 +239,13 @@
if(d < 0)
d = -d;
if(d <= DBL_MAXINT && (double)(int64_t)d == d)
- return FL_t;
+ return SL_t;
}
}
- return FL_nil;
+ return SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("integer?", integerp) {argcount(nargs, 1);
@@ -256,14 +252,14 @@
value_t v = args[0];
return (isfixnum(v) || ismpint(v) ||
(iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ?
- FL_t : FL_nil;
+ SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("bignum?", bignump) {argcount(nargs, 1);
- return ismpint(args[0]) ? FL_t : FL_nil;
+ return ismpint(args[0]) ? SL_t : SL_nil;
}
BUILTIN("fixnum", fixnum)@@ -323,7 +319,7 @@
value_t v = alloc_vector(i, 0);
int a = 1;
for(size_t k = 0; k < i; k++){- value_t f = a < nargs ? args[a] : FL_void;
+ value_t f = a < nargs ? args[a] : SL_void;
vector_elt(v, k) = f;
if((a = (a + 1) % nargs) < 1)
a = 1;
@@ -387,13 +383,13 @@
if(nargs == 0){char buf[4096];
if(getcwd(buf, sizeof(buf)) == nil)
- lerrorf(FL_IOError, "could not get current dir");
+ lerrorf(SL_IOError, "could not get current dir");
return string_from_cstr(buf);
}
char *ptr = tostring(args[0]);
if(chdir(ptr) != 0)
- lerrorf(FL_IOError, "could not cd to %s", ptr);
- return FL_void;
+ lerrorf(SL_IOError, "could not cd to %s", ptr);
+ return SL_void;
}
BUILTIN("path-exists?", path_existsp)@@ -400,7 +396,7 @@
{argcount(nargs, 1);
const char *path = tostring(args[0]);
- return access(path, F_OK) == 0 ? FL_t : FL_nil;
+ return access(path, F_OK) == 0 ? SL_t : SL_nil;
}
BUILTIN("delete-file", delete_file)@@ -408,8 +404,8 @@
argcount(nargs, 1);
const char *path = tostring(args[0]);
if(remove(path) != 0)
- lerrorf(FL_IOError, "could not remove %s", path);
- return FL_void;
+ lerrorf(SL_IOError, "could not remove %s", path);
+ return SL_void;
}
BUILTIN("os-getenv", os_getenv)@@ -418,7 +414,7 @@
char *name = tostring(args[0]);
char *val = getenv(name);
if(val == nil)
- return FL_nil;
+ return SL_nil;
return cvalue_static_cstring(val);
}
@@ -427,7 +423,7 @@
argcount(nargs, 2);
char *name = tostring(args[0]);
int result;
- if(args[1] == FL_nil)
+ if(args[1] == SL_nil)
result = unsetenv(name);
else{char *val = tostring(args[1]);
@@ -434,6 +430,6 @@
result = setenv(name, val, 1);
}
if(result != 0)
- lerrorf(FL_ArgError, "invalid environment variable");
- return FL_t;
+ lerrorf(SL_ArgError, "invalid environment variable");
+ return SL_t;
}
--- a/src/cc.h
+++ b/src/cc.h
@@ -2,21 +2,21 @@
#ifdef __GNUC__
-#define fl_unlikely(x) __builtin_expect(!!(x), 0)
-#define fl_likely(x) __builtin_expect(!!(x), 1)
-#define fl_printfmt(x, y) __attribute__((format(printf, x, y)))
+#define sl_unlikely(x) __builtin_expect(!!(x), 0)
+#define sl_likely(x) __builtin_expect(!!(x), 1)
+#define sl_printfmt(x, y) __attribute__((format(printf, x, y)))
#if defined(NDEBUG) && !defined(__macos__) && !defined(__dos__)
-#define fl_thread(x) __thread x
+#define sl_thread(x) __thread x
#else
-#define fl_thread(x) x
+#define sl_thread(x) x
#endif
-#define fl_prefetch(x) __builtin_prefetch(x)
-#define fl_constfn __attribute__((const))
-#define fl_purefn __attribute__((pure))
-#define fl_hotfn __attribute__((hot))
-#define fl_aligned(x) __attribute__((aligned(x)))
-#define fl_popcount(x) __builtin_popcount(x)
-#define fl_clz(x) __builtin_clz(x)
+#define sl_prefetch(x) __builtin_prefetch(x)
+#define sl_constfn __attribute__((const))
+#define sl_purefn __attribute__((pure))
+#define sl_hotfn __attribute__((hot))
+#define sl_aligned(x) __attribute__((aligned(x)))
+#define sl_popcount(x) __builtin_popcount(x)
+#define sl_clz(x) __builtin_clz(x)
#define sadd_overflow __builtin_add_overflow
#define sadd_overflow_64 __builtin_add_overflow
#define smul_overflow_64 __builtin_mul_overflow
@@ -23,15 +23,15 @@
#else
-#define fl_unlikely(x) (x)
-#define fl_likely(x) (x)
-#define fl_printfmt(x, y)
-#define fl_thread(x) x
-#define fl_prefetch(x)
-#define fl_constfn
-#define fl_purefn
-#define fl_hotfn
-#define fl_aligned(x)
+#define sl_unlikely(x) (x)
+#define sl_likely(x) (x)
+#define sl_printfmt(x, y)
+#define sl_thread(x) x
+#define sl_prefetch(x)
+#define sl_constfn
+#define sl_purefn
+#define sl_hotfn
+#define sl_aligned(x)
/* FIXME(sigrid): s*_overflow_* can be more optimal */
#define sadd_overflow_64(a, b, c) ( \
--- a/src/compress.c
+++ b/src/compress.c
@@ -1,10 +1,10 @@
-#include "flisp.h"
+#include "sl.h"
#include "compress.h"
#include "cvalues.h"
#include "types.h"
#include "brieflz.h"
-static value_t FL_sizesym, FL_tosym;
+static value_t SL_sizesym, SL_tosym;
BUILTIN("lz-pack", lz_pack) {@@ -36,7 +36,7 @@
: blz_pack(in, out, insz, work);
MEM_FREE(work);
if(n == BLZ_ERROR)
- lerrorf(FL_ArgError, "blz error");
+ lerrorf(SL_ArgError, "blz error");
cvalue_len(v) = n;
return v;
}
@@ -53,19 +53,19 @@
size_t outsz;
uint8_t *out;
value_t v;
- if(args[1] == FL_sizesym){+ if(args[1] == SL_sizesym){outsz = tosize(args[2]);
v = cvalue(cv_class(ptr(args[0])), outsz);
out = cvalue_data(v);
- }else if(args[1] == FL_tosym){+ }else if(args[1] == SL_tosym){v = args[2];
to_sized_ptr(v, &out, &outsz);
}else{- lerrorf(FL_ArgError, "either :size or :to must be specified");
+ lerrorf(SL_ArgError, "either :size or :to must be specified");
}
unsigned long n = blz_depack_safe(in, insz, out, outsz);
if(n == BLZ_ERROR)
- lerrorf(FL_ArgError, "blz error");
+ lerrorf(SL_ArgError, "blz error");
cvalue_len(v) = n;
return v;
}
@@ -73,6 +73,6 @@
void
compress_init(void)
{- FL_sizesym = csymbol(":size");- FL_tosym = csymbol(":to");+ SL_sizesym = csymbol(":size");+ SL_tosym = csymbol(":to");}
--- a/src/cvalues.c
+++ b/src/cvalues.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "types.h"
@@ -15,17 +15,17 @@
#define owned(cv) ((uintptr_t)(cv)->type & CV_OWNED)
#define isinlined(cv) ((cv)->data == (cv)->_space)
-static void cvalue_init(fltype_t *type, value_t v, void *dest);
+static void cvalue_init(sltype_t *type, value_t v, void *dest);
void
add_finalizer(cvalue_t *cv)
{- if(FL(nfinalizers) == FL(maxfinalizers)){- FL(maxfinalizers) *= 2;
- FL(finalizers) = MEM_REALLOC(FL(finalizers), FL(maxfinalizers)*sizeof(FL(finalizers)));
- assert(FL(finalizers) != nil);
+ if(SL(nfinalizers) == SL(maxfinalizers)){+ SL(maxfinalizers) *= 2;
+ SL(finalizers) = MEM_REALLOC(SL(finalizers), SL(maxfinalizers)*sizeof(SL(finalizers)));
+ assert(SL(finalizers) != nil);
}
- FL(finalizers)[FL(nfinalizers)++] = cv;
+ SL(finalizers)[SL(nfinalizers)++] = cv;
}
// remove dead objects from finalization list in-place
@@ -32,13 +32,13 @@
void
sweep_finalizers(void)
{- cvalue_t **lst = FL(finalizers);
- size_t n = 0, ndel = 0, l = FL(nfinalizers);
+ cvalue_t **lst = SL(finalizers);
+ size_t n = 0, ndel = 0, l = SL(nfinalizers);
cvalue_t *tmp;
#define SWAP_sf(a, b) (tmp = a, a = b, b = tmp, 1)
if(l == 0)
return;
- bool exiting = FL(exiting);
+ bool exiting = SL(exiting);
do{tmp = lst[n];
if(isforwarded((value_t)tmp)){@@ -46,7 +46,7 @@
lst[n] = ptr(forwardloc((value_t)tmp));
n++;
}else{- fltype_t *t = cv_class(tmp);
+ sltype_t *t = cv_class(tmp);
if(t->vtable != nil && t->vtable->finalize != nil)
t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
if(!isinlined(tmp) && owned(tmp) && !exiting)
@@ -55,9 +55,9 @@
}
}while((n < l-ndel) && SWAP_sf(lst[n], lst[n+ndel]));
- FL(nfinalizers) -= ndel;
+ SL(nfinalizers) -= ndel;
- FL(malloc_pressure) = 0;
+ SL(malloc_pressure) = 0;
}
// compute the size of the metadata object for a cvalue
@@ -75,12 +75,12 @@
void
cv_autorelease(cvalue_t *cv)
{- cv->type = (fltype_t*)(((uintptr_t)cv->type) | CV_OWNED);
+ cv->type = (sltype_t*)(((uintptr_t)cv->type) | CV_OWNED);
add_finalizer(cv);
}
static value_t
-cprim(fltype_t *type, size_t sz)
+cprim(sltype_t *type, size_t sz)
{assert(!ismanaged((uintptr_t)type));
assert(sz == type->size);
@@ -90,7 +90,7 @@
}
value_t
-cvalue_(fltype_t *type, size_t sz, bool nofinalize)
+cvalue_(sltype_t *type, size_t sz, bool nofinalize)
{assert(type != nil);
if(valid_numtype(type->numtype) && type->numtype != T_MPINT)
@@ -97,9 +97,9 @@
return cprim(type, sz);
bool str = false;
- if(type->eltype == FL(bytetype)){+ if(type->eltype == SL(bytetype)){if(sz == 0)
- return FL(the_empty_string);
+ return SL(the_empty_string);
sz++;
str = true;
}
@@ -112,13 +112,13 @@
if(!nofinalize && type->vtable != nil && type->vtable->finalize != nil)
add_finalizer(pcv);
}else{- if(FL(malloc_pressure) > ALLOC_LIMIT_TRIGGER)
- fl_gc(false);
+ if(SL(malloc_pressure) > ALLOC_LIMIT_TRIGGER)
+ sl_gc(false);
pcv = alloc_words(CVALUE_NWORDS);
pcv->type = type;
pcv->data = MEM_ALLOC(sz);
cv_autorelease(pcv);
- FL(malloc_pressure) += sz;
+ SL(malloc_pressure) += sz;
}
if(str)
((char*)pcv->data)[--sz] = '\0';
@@ -135,7 +135,7 @@
// 'parent' is an optional cvalue that this pointer is known to point
// into; NIL if none.
value_t
-cvalue_from_ref(fltype_t *type, void *ptr, size_t sz)
+cvalue_from_ref(sltype_t *type, void *ptr, size_t sz)
{cvalue_t *pcv;
@@ -152,8 +152,8 @@
cvalue_string(size_t sz)
{if(sz == 0)
- return FL(the_empty_string);
- return cvalue(FL(stringtype), sz);
+ return SL(the_empty_string);
+ return cvalue(SL(stringtype), sz);
}
value_t
@@ -160,8 +160,8 @@
cvalue_static_cstring(const char *str)
{if(*str == 0)
- return FL(the_empty_string);
- return cvalue_from_ref(FL(stringtype), (char*)str, strlen(str));
+ return SL(the_empty_string);
+ return cvalue_from_ref(SL(stringtype), (char*)str, strlen(str));
}
value_t
@@ -179,7 +179,7 @@
}
bool
-fl_isstring(value_t v)
+sl_isstring(value_t v)
{return iscvalue(v) && cv_isstr(ptr(v));
}
@@ -201,7 +201,7 @@
#define num_init(ctype, cnvt, tag) \
static void \
- cvalue_##ctype##_init(fltype_t *type, value_t arg, void *dest) \
+ cvalue_##ctype##_init(sltype_t *type, value_t arg, void *dest) \
{ \ctype n; \
USED(type); \
@@ -236,10 +236,10 @@
{ \ if(nargs == 0){ \PUSH(fixnum(0)); \
- args = FL(sp)-1; \
+ args = SL(sp)-1; \
} \
- value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
- cvalue_##ctype##_init(FL(typenam##type), args[0], cp_data(ptr(cp))); \
+ value_t cp = cprim(SL(typenam##type), sizeof(ctype)); \
+ cvalue_##ctype##_init(SL(typenam##type), args[0], cp_data(ptr(cp))); \
return cp; \
}
@@ -246,7 +246,7 @@
#define num_ctor_ctor(typenam, ctype, tag) \
value_t mk_##typenam(ctype n) \
{ \- value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
+ value_t cp = cprim(SL(typenam##type), sizeof(ctype)); \
*(ctype*)cp_data(ptr(cp)) = n; \
return cp; \
}
@@ -269,7 +269,7 @@
num_ctor(rune, uint32_t, T_UINT32)
static void
-cvalue_mpint_init(fltype_t *type, value_t arg, void *dest)
+cvalue_mpint_init(sltype_t *type, value_t arg, void *dest)
{mpint *n;
USED(type);
@@ -292,10 +292,10 @@
{ if(nargs == 0){PUSH(fixnum(0));
- args = FL(sp)-1;
+ args = SL(sp)-1;
}
- value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
- cvalue_mpint_init(FL(mpinttype), args[0], cvalue_data(cv));
+ value_t cv = cvalue(SL(mpinttype), sizeof(mpint*));
+ cvalue_mpint_init(SL(mpinttype), args[0], cvalue_data(cv));
return cv;
}
@@ -303,7 +303,7 @@
value_t
mk_mpint(mpint *n)
{- value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
+ value_t cv = cvalue(SL(mpinttype), sizeof(mpint*));
*(mpint**)cvalue_data(cv) = n;
return cv;
}
@@ -366,7 +366,7 @@
return vector_size(arg);
if(iscons(arg))
return llength(arg);
- if(arg == FL_nil)
+ if(arg == SL_nil)
return 0;
if(isarray(arg))
return cvalue_arraylen(arg);
@@ -374,11 +374,11 @@
}
void
-cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
+cvalue_array_init(sltype_t *ft, value_t arg, void *dest)
{value_t type = ft->type;
size_t elsize, i, cnt, sz;
- fltype_t *eltype = ft->eltype;
+ sltype_t *eltype = ft->eltype;
elsize = ft->elsz;
cnt = predict_arraylen(arg);
@@ -386,7 +386,7 @@
if(iscons(cdr_(cdr_(type)))){size_t tc = tosize(car_(cdr_(cdr_(type))));
if(tc != cnt)
- lerrorf(FL_ArgError, "size mismatch");
+ lerrorf(SL_ArgError, "size mismatch");
}
sz = elsize * cnt;
@@ -399,7 +399,7 @@
}
return;
}
- if(iscons(arg) || arg == FL_nil){+ if(iscons(arg) || arg == SL_nil){i = 0;
while(iscons(arg)){ if(i == cnt){@@ -412,22 +412,22 @@
arg = cdr_(arg);
}
if(i != cnt)
- lerrorf(FL_ArgError, "size mismatch");
+ lerrorf(SL_ArgError, "size mismatch");
return;
}
if(iscvalue(arg)){cvalue_t *cv = ptr(arg);
if(isarray(arg)){- fltype_t *aet = cv_class(cv)->eltype;
+ sltype_t *aet = cv_class(cv)->eltype;
if(aet == eltype){if(cv_len(cv) == sz)
memcpy(dest, cv_data(cv), sz);
else
- lerrorf(FL_ArgError, "size mismatch");
+ lerrorf(SL_ArgError, "size mismatch");
return;
}else{// TODO: initialize array from different type elements
- lerrorf(FL_ArgError, "element type mismatch");
+ lerrorf(SL_ArgError, "element type mismatch");
}
}
}
@@ -445,7 +445,7 @@
argcount(nargs, 1);
cnt = nargs - 1;
- fltype_t *type = get_array_type(args[0]);
+ sltype_t *type = get_array_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;
@@ -453,7 +453,7 @@
char *dest = cvalue_data(cv);
int i;
FOR_ARGS(i, 1, arg, args){- if(!fl_isnumber(arg))
+ if(!sl_isnumber(arg))
type_error("number", arg);cvalue_init(type->eltype, arg, dest);
dest += elsize;
@@ -470,9 +470,9 @@
argcount(nargs, 3);
cnt = tosize(args[1]);
if(cnt < 0)
- lerrorf(FL_ArgError, "invalid size: %"PRIu64, (uint64_t)cnt);
+ lerrorf(SL_ArgError, "invalid size: %"PRIu64, (uint64_t)cnt);
- fltype_t *type = get_array_type(args[0]);
+ sltype_t *type = get_array_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;
@@ -481,7 +481,7 @@
a = 2;
for(i = 0; i < cnt; i++){value_t arg = args[a];
- if(!fl_isnumber(arg))
+ if(!sl_isnumber(arg))
type_error("number", arg);cvalue_init(type->eltype, arg, dest);
dest += elsize;
@@ -509,10 +509,10 @@
if(iscons(type)){value_t hed = car_(type);
- if(hed == FL_arraysym){+ if(hed == SL_arraysym){value_t t = car(cdr_(type));
if(!iscons(cdr_(cdr_(type))))
- lerrorf(FL_ArgError, "incomplete type");
+ lerrorf(SL_ArgError, "incomplete type");
value_t n = car_(cdr_(cdr_(type)));
size_t sz = tosize(n);
return sz * ctype_sizeof(t);
@@ -519,7 +519,7 @@
}
}
- lerrorf(FL_ArgError, "invalid c type");
+ lerrorf(SL_ArgError, "invalid c type");
}
// get pointer and size for any plain-old-data value
@@ -529,7 +529,7 @@
if(iscvalue(v)){cvalue_t *pcv = ptr(v);
ios_t *x = value2c(ios_t*, v);
- if(cv_class(pcv) == FL(iostreamtype) && x->bm == bm_mem){+ if(cv_class(pcv) == SL(iostreamtype) && x->bm == bm_mem){*pdata = x->buf;
*psz = x->size;
return;
@@ -560,27 +560,27 @@
return size_wrap(n);
}
-fl_purefn
+sl_purefn
BUILTIN("typeof", typeof) {argcount(nargs, 1);
switch(tag(args[0])){- case TAG_CONS: return FL_conssym;
- case TAG_NUM1: case TAG_NUM: return FL_fixnumsym;
- case TAG_SYM: return FL_symbolsym;
- case TAG_VECTOR: return FL_vectorsym;
+ case TAG_CONS: return SL_conssym;
+ case TAG_NUM1: case TAG_NUM: return SL_fixnumsym;
+ case TAG_SYM: return SL_symbolsym;
+ case TAG_VECTOR: return SL_vectorsym;
case TAG_FUNCTION:
- if(args[0] == FL_t)
- return FL_booleansym;
- if(args[0] == FL_nil)
- return FL_nullsym;
- if(args[0] == FL_eof)
- return FL_eof;
- if(args[0] == FL_void)
- return FL_void;
+ if(args[0] == SL_t)
+ return SL_booleansym;
+ if(args[0] == SL_nil)
+ return SL_nullsym;
+ if(args[0] == SL_eof)
+ return SL_eof;
+ if(args[0] == SL_void)
+ return SL_void;
if(isbuiltin(args[0]))
- return FL_builtinsym;
- return FL_function;
+ return SL_builtinsym;
+ return SL_function;
}
return cv_type(ptr(args[0]));
}
@@ -599,11 +599,11 @@
if(isinlined(cv))
nv->data = nv->_space;
ncv = tagptr(nv, TAG_CVALUE);
- fltype_t *t = cv_class(cv);
+ sltype_t *t = cv_class(cv);
if(t->vtable != nil && t->vtable->relocate != nil)
t->vtable->relocate(v, ncv);
forward(v, ncv);
- if(FL(exiting))
+ if(SL(exiting))
cv_autorelease(ptr(ncv));
return ncv;
}
@@ -637,29 +637,29 @@
{argcount(nargs, 1);
if(iscons(args[0]) || isvector(args[0]))
- lerrorf(FL_ArgError, "argument must be a leaf atom");
+ lerrorf(SL_ArgError, "argument must be a leaf atom");
if(!iscvalue(args[0]))
return args[0];
if(!cv_isPOD(ptr(args[0])))
- lerrorf(FL_ArgError, "argument must be a plain-old-data type");
+ lerrorf(SL_ArgError, "argument must be a plain-old-data type");
return cvalue_copy(args[0]);
}
-fl_purefn
+sl_purefn
BUILTIN("plain-old-data?", plain_old_datap) {argcount(nargs, 1);
return (iscprim(args[0]) ||
(iscvalue(args[0]) && cv_isPOD(ptr(args[0])))) ?
- FL_t : FL_nil;
+ SL_t : SL_nil;
}
static void
-cvalue_init(fltype_t *type, value_t v, void *dest)
+cvalue_init(sltype_t *type, value_t v, void *dest)
{cvinitfunc_t f = type->init;
if(f == nil)
- lerrorf(FL_ArgError, "invalid c type");
+ lerrorf(SL_ArgError, "invalid c type");
f(type, v, dest);
}
@@ -672,7 +672,7 @@
if(nargs < 1 || nargs > 2)
argcount(nargs, 2);
value_t type = args[0];
- fltype_t *ft = get_type(type);
+ sltype_t *ft = get_type(type);
value_t cv;
if(ft->eltype != nil){// special case to handle incomplete array types bla[]
@@ -734,7 +734,7 @@
{uint8_t *data;
int index;
- fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
+ sltype_t *eltype = cv_class(ptr(args[0]))->eltype;
value_t el = 0;
numerictype_t nt = eltype->numtype;
if(nt >= T_INT32)
@@ -768,7 +768,7 @@
cvalue_array_aset(value_t *args)
{uint8_t *data; int index;
- fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
+ sltype_t *eltype = cv_class(ptr(args[0]))->eltype;
check_addr_args(args[0], args[1], &data, &index);
uint8_t *dest = data + index*eltype->size;
cvalue_init(eltype, args[2], dest);
@@ -775,13 +775,13 @@
return args[2];
}
-fl_purefn
+sl_purefn
BUILTIN("builtin", builtin) {argcount(nargs, 1);
symbol_t *s = tosymbol(args[0]);
if(!iscbuiltin(s->binding))
- lerrorf(FL_ArgError, "function \"%s\" not found", s->name);
+ lerrorf(SL_ArgError, "function \"%s\" not found", s->name);
return s->binding;
}
@@ -791,13 +791,13 @@
cvalue_t *cv;
cv = MEM_CALLOC(CVALUE_NWORDS-1, sizeof(*cv));
assert(cv != nil);
- cv->type = FL(builtintype);
+ cv->type = SL(builtintype);
cv->cbuiltin = f;
value_t sym = symbol(name, false);
symbol_t *s = ptr(sym);
s->binding = tagptr(cv, TAG_CVALUE);
- ptrhash_put(&FL(reverse_dlsym_lookup_table), cv, (void*)sym);
+ ptrhash_put(&SL(reverse_dlsym_lookup_table), cv, (void*)sym);
return s->binding;
}
@@ -804,7 +804,7 @@
#define cv_intern(tok) \
do{ \- FL_##tok##sym = csymbol(#tok); \
+ SL_##tok##sym = csymbol(#tok); \
}while(0)
#define ctor_cv_intern(tok, nt, ctype) \
@@ -811,9 +811,9 @@
do{ \symbol_t *s; \
cv_intern(tok); \
- set(FL_##tok##sym, cbuiltin(#tok, fn_builtin_##tok)); \
+ set(SL_##tok##sym, cbuiltin(#tok, fn_builtin_##tok)); \
if(valid_numtype(nt)){ \- s = ptr(FL_##tok##sym); \
+ s = ptr(SL_##tok##sym); \
s->numtype = nt; \
s->size = sizeof(ctype); \
} \
@@ -821,8 +821,8 @@
#define mk_primtype(name, ctype) \
do{ \- FL(name##type) = get_type(FL_##name##sym); \
- FL(name##type)->init = cvalue_##ctype##_init; \
+ SL(name##type) = get_type(SL_##name##sym); \
+ SL(name##type)->init = cvalue_##ctype##_init; \
}while(0)
#define RETURN_NUM_AS(var, type) return(mk_##type(var))
@@ -854,9 +854,9 @@
#define MP_OP mpadd
#define ARITH_OVERFLOW sadd_overflow_64
value_t
-fl_add_any(value_t *args, uint32_t nargs)
+sl_add_any(value_t *args, uint32_t nargs)
{-#include "fl_arith_any.inc"
+#include "sl_arith_any.inc"
}
#define ACCUM_DEFAULT 1
@@ -864,13 +864,13 @@
#define MP_OP mpmul
#define ARITH_OVERFLOW smul_overflow_64
value_t
-fl_mul_any(value_t *args, uint32_t nargs)
+sl_mul_any(value_t *args, uint32_t nargs)
{-#include "fl_arith_any.inc"
+#include "sl_arith_any.inc"
}
value_t
-fl_neg(value_t n)
+sl_neg(value_t n)
{int64_t i64;
uint64_t ui64;
@@ -989,11 +989,11 @@
_Noreturn void
divide_by_0_error(void)
{- lerrorf(FL_DivideError, "/: division by zero");
+ lerrorf(SL_DivideError, "/: division by zero");
}
value_t
-fl_div2(value_t a, value_t b)
+sl_div2(value_t a, value_t b)
{double da, db;
fixnum_t ai, bi;
@@ -1019,7 +1019,7 @@
}
value_t
-fl_idiv2(value_t a, value_t b)
+sl_idiv2(value_t a, value_t b)
{fixnum_t ai, bi;
numerictype_t ta, tb;
@@ -1080,7 +1080,7 @@
}
static value_t
-fl_bitwise_op(value_t a, value_t b, int opcode)
+sl_bitwise_op(value_t a, value_t b, int opcode)
{fixnum_t ai, bi;
numerictype_t ta, tb, itmp;
@@ -1156,7 +1156,7 @@
}
}
assert(0);
- return FL_nil;
+ return SL_nil;
}
BUILTIN("logand", logand)@@ -1170,7 +1170,7 @@
if(bothfixnums(v, e))
v = v & e;
else
- v = fl_bitwise_op(v, e, 0);
+ v = sl_bitwise_op(v, e, 0);
}
return v;
}
@@ -1186,7 +1186,7 @@
if(bothfixnums(v, e))
v = v | e;
else
- v = fl_bitwise_op(v, e, 1);
+ v = sl_bitwise_op(v, e, 1);
}
return v;
}
@@ -1202,7 +1202,7 @@
if(bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
- v = fl_bitwise_op(v, e, 2);
+ v = sl_bitwise_op(v, e, 2);
}
return v;
}
@@ -1304,10 +1304,10 @@
void
cvalues_init(void)
{- htable_new(&FL(TypeTable), 256);
- htable_new(&FL(reverse_dlsym_lookup_table), 256);
+ htable_new(&SL(TypeTable), 256);
+ htable_new(&SL(reverse_dlsym_lookup_table), 256);
- FL(builtintype) = define_opaque_type(FL_builtinsym, sizeof(builtin_t), nil, nil);
+ SL(builtintype) = define_opaque_type(SL_builtinsym, sizeof(builtin_t), nil, nil);
ctor_cv_intern(int8, T_INT8, int8_t);
ctor_cv_intern(uint8, T_UINT8, uint8_t);
@@ -1324,11 +1324,11 @@
ctor_cv_intern(array, NONNUMERIC, int);
- FL_stringtypesym = csymbol("*string-type*");- setc(FL_stringtypesym, fl_list2(FL_arraysym, FL_bytesym));
+ SL_stringtypesym = csymbol("*string-type*");+ setc(SL_stringtypesym, sl_list2(SL_arraysym, SL_bytesym));
- FL_runestringtypesym = csymbol("*runestring-type*");- setc(FL_runestringtypesym, fl_list2(FL_arraysym, FL_runesym));
+ SL_runestringtypesym = csymbol("*runestring-type*");+ setc(SL_runestringtypesym, sl_list2(SL_arraysym, SL_runesym));
mk_primtype(int8, int8_t);
mk_primtype(uint8, uint8_t);
@@ -1344,11 +1344,11 @@
mk_primtype(double, double);
ctor_cv_intern(bignum, T_MPINT, mpint*);
- FL(mpinttype) = get_type(FL_bignumsym);
- FL(mpinttype)->init = cvalue_mpint_init;
- FL(mpinttype)->vtable = &mpint_vtable;
+ SL(mpinttype) = get_type(SL_bignumsym);
+ SL(mpinttype)->init = cvalue_mpint_init;
+ SL(mpinttype)->vtable = &mpint_vtable;
- FL(stringtype) = get_type(symbol_value(FL_stringtypesym));
- FL(the_empty_string) = cvalue_from_ref(FL(stringtype), (char*)"", 0);
- FL(runestringtype) = get_type(symbol_value(FL_runestringtypesym));
+ SL(stringtype) = get_type(symbol_value(SL_stringtypesym));
+ SL(the_empty_string) = cvalue_from_ref(SL(stringtype), (char*)"", 0);
+ SL(runestringtype) = get_type(symbol_value(SL_runestringtypesym));
}
--- a/src/cvalues.h
+++ b/src/cvalues.h
@@ -9,39 +9,39 @@
void add_finalizer(cvalue_t *cv);
void sweep_finalizers(void);
void cv_autorelease(cvalue_t *cv);
-value_t cvalue_(fltype_t *type, size_t sz, bool nofinalizer);
+value_t cvalue_(sltype_t *type, size_t sz, bool nofinalizer);
#define cvalue(type, sz) cvalue_(type, sz, false)
#define cvalue_nofinalizer(type, sz) cvalue_(type, sz, true)
-value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz);
+value_t cvalue_from_ref(sltype_t *type, void *ptr, size_t sz);
value_t cvalue_string(size_t sz);
value_t cvalue_static_cstring(const char *str);
value_t string_from_cstrn(char *str, size_t n);
value_t string_from_cstr(char *str);
-bool fl_isstring(value_t v) fl_purefn;
+bool sl_isstring(value_t v) sl_purefn;
void cv_pin(cvalue_t *cv);
value_t size_wrap(size_t sz);
size_t tosize(value_t n);
off_t tooffset(value_t n);
-bool isarray(value_t v) fl_purefn;
-void cvalue_array_init(fltype_t *ft, value_t arg, void *dest);
-size_t cvalue_arraylen(value_t v) fl_purefn;
+bool isarray(value_t v) sl_purefn;
+void cvalue_array_init(sltype_t *ft, value_t arg, void *dest);
+size_t cvalue_arraylen(value_t v) sl_purefn;
size_t ctype_sizeof(value_t type);
void to_sized_ptr(value_t v, uint8_t **pdata, size_t *psz);
value_t cvalue_relocate(value_t v);
value_t cvalue_copy(value_t v);
-value_t cvalue_compare(value_t a, value_t b) fl_purefn;
+value_t cvalue_compare(value_t a, value_t b) sl_purefn;
value_t cvalue_array_aref(value_t *args);
value_t cvalue_array_aset(value_t *args);
value_t cbuiltin(const char *name, builtin_t f);
value_t return_from_uint64(uint64_t Uaccum);
value_t return_from_int64(int64_t Saccum);
-value_t fl_add_any(value_t *args, uint32_t nargs);
-value_t fl_neg(value_t n);
-value_t fl_mul_any(value_t *args, uint32_t nargs);
+value_t sl_add_any(value_t *args, uint32_t nargs);
+value_t sl_neg(value_t n);
+value_t sl_mul_any(value_t *args, uint32_t nargs);
bool num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp);
_Noreturn void divide_by_0_error(void);
-value_t fl_div2(value_t a, value_t b);
-value_t fl_idiv2(value_t a, value_t b);
+value_t sl_div2(value_t a, value_t b);
+value_t sl_idiv2(value_t a, value_t b);
void cvalues_init(void);
value_t mk_double(double n);
@@ -53,4 +53,4 @@
value_t mk_rune(Rune n);
value_t mk_mpint(mpint *n);
-size_t llength(value_t v) fl_purefn;
+size_t llength(value_t v) sl_purefn;
--- a/src/dos/platform.h
+++ b/src/dos/platform.h
@@ -32,8 +32,8 @@
#define USED(x) ((void)(x))
#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
-#define fl_setjmp(e) setjmp((e))
-#define fl_longjmp(e, v) longjmp((e), (v))
+#define sl_setjmp(e) setjmp((e))
+#define sl_longjmp(e, v) longjmp((e), (v))
#define PATHSEP '\\'
#define PATHSEPSTRING "\\"
--- a/src/dos/sys.c
+++ b/src/dos/sys.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "timefuncs.h"
double
@@ -42,7 +42,7 @@
}
static const uint8_t boot[] = {-#include "flisp.boot.h"
+#include "sl.boot.h"
};
int
@@ -50,5 +50,5 @@
{setlocale(LC_NUMERIC, "C");
setlocale(LC_CTYPE, "");
- flmain(boot, sizeof(boot), argc, argv);
+ slmain(boot, sizeof(boot), argc, argv);
}
--- a/src/equal.c
+++ b/src/equal.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "equal.h"
@@ -23,7 +23,7 @@
{value_t c = (value_t)ptrhash_get(table, (void*)key);
if(c == (value_t)HT_NOTFOUND)
- return FL_nil;
+ return SL_nil;
if(c == key)
return c;
return eq_class(table, c);
@@ -32,8 +32,8 @@
static void
eq_union(htable_t *table, value_t a, value_t b, value_t c, value_t cb)
{- value_t ca = c == FL_nil ? a : c;
- if(cb != FL_nil)
+ value_t ca = c == SL_nil ? a : c;
+ if(cb != SL_nil)
ptrhash_put(table, (void*)cb, (void*)ca);
ptrhash_put(table, (void*)a, (void*)ca);
ptrhash_put(table, (void*)b, (void*)ca);
@@ -53,7 +53,7 @@
m = la < lb ? la : lb;
for(i = 0; i < m; i++){value_t d = bounded_compare(vector_elt(a, i), vector_elt(b, i), bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
+ if(d == SL_nil || numval(d) != 0)
return d;
}
if(la < lb)
@@ -75,7 +75,7 @@
if(a == b)
return fixnum(0);
if(bound <= 0)
- return FL_nil;
+ return SL_nil;
int taga = tag(a);
int tagb = cmptag(b);
int c;
@@ -85,7 +85,7 @@
if(isfixnum(b))
return (fixnum_t)a < (fixnum_t)b ? fixnum(-1) : fixnum(1);
if(iscprim(b)){- if(cp_class(ptr(b)) == FL(runetype))
+ if(cp_class(ptr(b)) == SL(runetype))
return fixnum(1);
return fixnum(numeric_compare(a, b, eq, true, false));
}
@@ -106,10 +106,10 @@
return bounded_vector_compare(a, b, bound, eq);
break;
case TAG_CPRIM:
- if(cp_class(ptr(a)) == FL(runetype)){- if(!iscprim(b) || cp_class(ptr(b)) != FL(runetype))
+ if(cp_class(ptr(a)) == SL(runetype)){+ if(!iscprim(b) || cp_class(ptr(b)) != SL(runetype))
return fixnum(-1);
- }else if(iscprim(b) && cp_class(ptr(b)) == FL(runetype))
+ }else if(iscprim(b) && cp_class(ptr(b)) == SL(runetype))
return fixnum(1);
c = numeric_compare(a, b, eq, true, false);
if(c != 2)
@@ -133,13 +133,13 @@
function_t *fa = ptr(a);
function_t *fb = ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
+ if(d == SL_nil || numval(d) != 0)
return d;
d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
+ if(d == SL_nil || numval(d) != 0)
return d;
d = bounded_compare(fa->env, fb->env, bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
+ if(d == SL_nil || numval(d) != 0)
return d;
return fixnum(0);
}
@@ -150,7 +150,7 @@
if(tagb < TAG_CONS)
return fixnum(1);
d = bounded_compare(car_(a), car_(b), bound-1, eq);
- if(d == FL_nil || numval(d) != 0)
+ if(d == SL_nil || numval(d) != 0)
return d;
a = cdr_(a); b = cdr_(b);
bound--;
@@ -176,7 +176,7 @@
xb = vector_elt(b, i);
if(leafp(xa) || leafp(xb)){d = bounded_compare(xa, xb, 1, eq);
- if(d != FL_nil && numval(d) != 0)
+ if(d != SL_nil && numval(d) != 0)
return d;
}else if(tag(xa) < tag(xb))
return fixnum(-1);
@@ -186,7 +186,7 @@
ca = eq_class(table, a);
cb = eq_class(table, b);
- if(ca != FL_nil && ca == cb)
+ if(ca != SL_nil && ca == cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
@@ -227,7 +227,7 @@
int tagdb = tag(db);
if(leafp(aa) || leafp(ab)){d = bounded_compare(aa, ab, 1, eq);
- if(d != FL_nil && numval(d) != 0)
+ if(d != SL_nil && numval(d) != 0)
return d;
}
if(tagaa < tagab)
@@ -236,7 +236,7 @@
return fixnum(1);
if(leafp(da) || leafp(db)){d = bounded_compare(da, db, 1, eq);
- if(d != FL_nil && numval(d) != 0)
+ if(d != SL_nil && numval(d) != 0)
return d;
}
if(tagda < tagdb)
@@ -246,7 +246,7 @@
ca = eq_class(table, a);
cb = eq_class(table, b);
- if(ca != FL_nil && ca == cb)
+ if(ca != SL_nil && ca == cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
@@ -271,7 +271,7 @@
ca = eq_class(table, a);
cb = eq_class(table, b);
- if(ca != FL_nil && ca == cb)
+ if(ca != SL_nil && ca == cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
@@ -295,10 +295,10 @@
// 'eq' means unordered comparison is sufficient
value_t
-fl_compare(value_t a, value_t b, bool eq)
+sl_compare(value_t a, value_t b, bool eq)
{value_t guess = bounded_compare(a, b, BOUNDED_COMPARE_BOUND, eq);
- if(guess == FL_nil){+ if(guess == SL_nil){guess = cyc_compare(a, b, &equal_eq_hashtable, eq);
htable_reset(&equal_eq_hashtable, 512);
}
@@ -345,7 +345,7 @@
case TAG_CPRIM:
cp = ptr(a);
data = cp_data(cp);
- if(cp_class(cp) == FL(runetype))
+ if(cp_class(cp) == SL(runetype))
return inthash(*(Rune*)data);
nt = cp_numtype(cp);
u.d = conv_to_double(data, nt);
@@ -353,7 +353,7 @@
case TAG_CVALUE:
cv = ptr(a);
data = cv_data(cv);
- if(cv->type == FL(mpinttype)){+ if(cv->type == SL(mpinttype)){len = mptobe(*(mpint**)data, nil, 0, (uint8_t**)&data);
h = memhash(data, len);
MEM_FREE(data);
@@ -406,7 +406,7 @@
{if(eq_comparable(a, b))
return a == b;
- return numval(fl_compare(a, b, true)) == 0;
+ return numval(sl_compare(a, b, true)) == 0;
}
uintptr_t
--- a/src/equal.h
+++ b/src/equal.h
@@ -6,6 +6,6 @@
int equal_lispvalue(value_t a, value_t b);
uintptr_t hash_lispvalue(value_t a);
-value_t fl_compare(value_t a, value_t b, bool eq);
+value_t sl_compare(value_t a, value_t b, bool eq);
int numeric_compare(value_t a, value_t b, bool eq, bool eqnans, bool typeerr);
void comparehash_init(void);
--- a/src/equalhash.c
+++ b/src/equalhash.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "equalhash.h"
#include "equal.h"
--- a/src/fl_arith_any.inc
+++ /dev/null
@@ -1,158 +1,0 @@
-//value_t
-//fl_*_any(value_t *args, uint32_t nargs)
-// input: ACCUM_DEFAULT ARITH_OP(a,b) MP_OP ARITH_OVERFLOW
-// add: 0 a+b mpadd sadd_overflow_64
-// mul: 1 a*b mpmul smul_overflow_64
-
- mpint *Maccum = nil, *m = nil;
- int64_t Saccum = ACCUM_DEFAULT, x;
- uint64_t u64;
- double Faccum = ACCUM_DEFAULT;
- bool inexact = false;
- value_t arg;
- numerictype_t pt;
- void *a;
- cprim_t *cp;
- cvalue_t *cv;
-
- uint32_t i, j;
- FOR_ARGS(i, 0, arg, args){- if(isfixnum(arg))
- x = numval(arg);
- else{- if(iscprim(arg)){- cp = ptr(arg);
- a = cp_data(cp);
- pt = cp_numtype(cp);
- }else if(iscvalue(arg)){- cv = ptr(arg);
- a = cv_data(cv);
- pt = cv_class(cv)->numtype;
- }else{-typeerr:
- mpfree(Maccum);
- mpfree(m);
- type_error("number", arg);- }
- switch(pt){- case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
- case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
- case T_INT8: x = *(int8_t*)a; break;
- case T_UINT8: x = *(uint8_t*)a; break;
- case T_INT16: x = *(int16_t*)a; break;
- case T_UINT16: x = *(uint16_t*)a; break;
- case T_INT32: x = *(int32_t*)a; break;
- case T_UINT32: x = *(uint32_t*)a; break;
- case T_INT64: x = *(int64_t*)a; break;
- case T_UINT64:
- u64 = *(uint64_t*)a;
- if(u64 > INT64_MAX){- x = ACCUM_DEFAULT;
- goto overflow;
- }
- x = u64;
- break;
- case T_MPINT:
- x = ACCUM_DEFAULT;
- u64 = ACCUM_DEFAULT;
- m = mpcopy(*(mpint**)a);
- goto overflow;
- default:
- goto typeerr;
- }
- }
-
- int64_t accu;
- if(ARITH_OVERFLOW(Saccum, x, &accu)){- u64 = ACCUM_DEFAULT;
- goto overflow;
- }
- Saccum = accu;
- }
-
- if(inexact)
- return mk_double(ARITH_OP(Faccum, Saccum));
- if(fits_fixnum(Saccum))
- return fixnum((fixnum_t)Saccum);
- u64 = ACCUM_DEFAULT;
- x = ACCUM_DEFAULT;
-
-overflow:
- i++;
- if(Maccum == nil)
- Maccum = vtomp(Saccum, nil);
- if(m == nil)
- m = u64 != ACCUM_DEFAULT ? uvtomp(u64, nil) : vtomp(x, nil);
-
- MP_OP(Maccum, m, Maccum);
-
- FOR_ARGS(j, i, arg, args){- if(isfixnum(arg)){- vtomp(numval(arg), m);
- MP_OP(Maccum, m, Maccum);
- continue;
- }
-
- if(iscprim(arg)){- cp = ptr(arg);
- a = cp_data(cp);
- pt = cp_numtype(cp);
- }else if(iscvalue(arg)){- cv = ptr(arg);
- a = cv_data(cv);
- pt = cv_class(cv)->numtype;
- }else{- goto typeerr;
- }
- switch(pt){- case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
- case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
- case T_INT8: x = *(int8_t*)a; break;
- case T_UINT8: x = *(uint8_t*)a; break;
- case T_INT16: x = *(int16_t*)a; break;
- case T_UINT16: x = *(uint16_t*)a; break;
- case T_INT32: x = *(int32_t*)a; break;
- case T_UINT32: x = *(uint32_t*)a; break;
- case T_INT64: x = *(int64_t*)a; break;
- case T_UINT64:
- uvtomp(*(uint64_t*)a, m);
- MP_OP(Maccum, m, Maccum);
- continue;
- case T_MPINT:
- MP_OP(Maccum, *(mpint**)a, Maccum);
- continue;
- default:
- goto typeerr;
- }
- vtomp(x, m);
- MP_OP(Maccum, m, Maccum);
- }
-
- int n = mpsignif(Maccum);
- if(n >= FIXNUM_BITS){- if(inexact){- dtomp(Faccum, m);
- MP_OP(Maccum, m, Maccum);
- n = mpsignif(Maccum);
- if(n < FIXNUM_BITS){- inexact = false;
- goto down;
- }
- }
- mpfree(m);
- return mk_mpint(Maccum);
- }
-
-down:
- mpfree(m);
- Saccum = mptov(Maccum);
- mpfree(Maccum);
- if(inexact)
- return mk_double(ARITH_OP(Faccum, Saccum));
- assert(fits_fixnum(Saccum));
- return fixnum((fixnum_t)Saccum);
-
-#undef ACCUM_DEFAULT
-#undef ARITH_OP
-#undef MP_OP
-#undef ARITH_OVERFLOW
--- a/src/flisp.c
+++ /dev/null
@@ -1,1355 +1,0 @@
-/*
- femtoLisp
-
- by Jeff Bezanson (C) 2009
- Distributed under the BSD License
-*/
-
-#include "flisp.h"
-#include "operators.h"
-#include "cvalues.h"
-#include "types.h"
-#include "print.h"
-#include "read.h"
-#include "timefuncs.h"
-#include "equal.h"
-#include "hashing.h"
-#include "table.h"
-#include "iostream.h"
-#include "compress.h"
-
-value_t FL_builtins_table_sym, FL_quote, FL_lambda, FL_function, FL_comma, FL_commaat;
-value_t FL_commadot, FL_trycatch, FL_backquote;
-value_t FL_conssym, FL_symbolsym, FL_fixnumsym, FL_vectorsym, FL_builtinsym, FL_vu8sym;
-value_t FL_defsym, FL_defmacrosym, FL_forsym, FL_setqsym;
-value_t FL_booleansym, FL_nullsym, FL_evalsym, FL_fnsym;
-value_t FL_nulsym, FL_alarmsym, FL_backspacesym, FL_tabsym, FL_linefeedsym, FL_newlinesym;
-value_t FL_vtabsym, FL_pagesym, FL_returnsym, FL_escsym, FL_spacesym, FL_deletesym;
-value_t FL_IOError, FL_ParseError, FL_TypeError, FL_ArgError, FL_MemoryError;
-value_t FL_DivideError, FL_BoundsError, FL_Error, FL_KeyError, FL_UnboundError;
-
-value_t FL_printwidthsym, FL_printreadablysym, FL_printprettysym, FL_printlengthsym;
-value_t FL_printlevelsym;
-value_t FL_tablesym, FL_arraysym;
-value_t FL_iostreamsym, FL_rdsym, FL_wrsym, FL_apsym, FL_crsym, FL_truncsym;
-value_t FL_instrsym, FL_outstrsym;
-value_t FL_int8sym, FL_uint8sym, FL_int16sym, FL_uint16sym, FL_int32sym, FL_uint32sym;
-value_t FL_int64sym, FL_uint64sym, FL_bignumsym;
-value_t FL_bytesym, FL_runesym, FL_floatsym, FL_doublesym;
-value_t FL_stringtypesym, FL_runestringtypesym;
-
-fl_thread(Fl *fl);
-
-typedef struct {- const char *name;
- builtin_t fptr;
-}builtinspec_t;
-
-bool
-isbuiltin(value_t x)
-{- int i;
- return tag(x) == TAG_FUNCTION && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil;
-}
-
-static value_t apply_cl(int nargs) fl_hotfn;
-
-// error utilities ------------------------------------------------------------
-
-void
-free_readstate(fl_readstate_t *rs)
-{- htable_free(&rs->backrefs);
- htable_free(&rs->gensyms);
-}
-
-_Noreturn void
-fl_exit(int status)
-{- FL(exiting) = true;
- fl_gc(false);
- exit(status);
-}
-
-#define FL_TRY \
- fl_exception_context_t _ctx; int l__tr, l__ca; \
- _ctx.sp = FL(sp); _ctx.frame = FL(curr_frame); _ctx.rdst = FL(readstate); _ctx.prev = FL(exctx); \
- _ctx.ngchnd = FL(ngchandles); FL(exctx) = &_ctx; \
- if(!fl_setjmp(_ctx.buf)) \
- for(l__tr = 1; l__tr; l__tr = 0, (void)(FL(exctx) = FL(exctx)->prev))
-
-#define FL_CATCH_INC \
- l__ca = 0, FL(lasterror) = FL_nil, FL(throwing_frame) = 0, FL(sp) = _ctx.sp, FL(curr_frame) = _ctx.frame
-
-#define FL_CATCH \
- else \
- for(l__ca = 1; l__ca; FL_CATCH_INC)
-
-#define FL_CATCH_NO_INC \
- else \
- for(l__ca = 1; l__ca;)
-
-void
-fl_savestate(fl_exception_context_t *_ctx)
-{- _ctx->sp = FL(sp);
- _ctx->frame = FL(curr_frame);
- _ctx->rdst = FL(readstate);
- _ctx->prev = FL(exctx);
- _ctx->ngchnd = FL(ngchandles);
-}
-
-void
-fl_restorestate(fl_exception_context_t *_ctx)
-{- FL(lasterror) = FL_nil;
- FL(throwing_frame) = 0;
- FL(sp) = _ctx->sp;
- FL(curr_frame) = _ctx->frame;
-}
-
-_Noreturn void
-fl_raise(value_t e)
-{- ios_flush(ios_stdout);
- ios_flush(ios_stderr);
-
- FL(lasterror) = e;
- // unwind read state
- while(FL(readstate) != FL(exctx)->rdst){- free_readstate(FL(readstate));
- FL(readstate) = FL(readstate)->prev;
- }
- if(FL(throwing_frame) == 0)
- FL(throwing_frame) = FL(curr_frame);
- FL(ngchandles) = FL(exctx)->ngchnd;
- fl_exception_context_t *thisctx = FL(exctx);
- if(FL(exctx)->prev) // don't throw past toplevel
- FL(exctx) = FL(exctx)->prev;
- fl_longjmp(thisctx->buf, 1);
-}
-
-_Noreturn void
-lerrorf(value_t e, const char *format, ...)
-{- char msgbuf[256];
- va_list args;
-
- PUSH(e);
- va_start(args, format);
- vsnprintf(msgbuf, sizeof(msgbuf), format, args);
- value_t msg = string_from_cstr(msgbuf);
- va_end(args);
-
- e = POP();
- fl_raise(fl_list2(e, msg));
-}
-
-_Noreturn void
-type_error(const char *expected, value_t got)
-{- fl_raise(fl_listn(3, FL_TypeError, symbol(expected, false), got));
-}
-
-_Noreturn void
-bounds_error(value_t arr, value_t ind)
-{- fl_raise(fl_listn(3, FL_BoundsError, arr, ind));
-}
-
-_Noreturn void
-unbound_error(value_t sym)
-{- fl_raise(fl_listn(2, FL_UnboundError, sym));
-}
-
-_Noreturn void
-arity_error(int nargs, int c)
-{- lerrorf(FL_ArgError, "arity mismatch: wanted %"PRId32", got %"PRId32, c, nargs);
-}
-
-// safe cast operators --------------------------------------------------------
-
-#define isstring fl_isstring
-#define SAFECAST_OP(type, ctype, cnvt) \
- ctype to##type(value_t v) \
- { \- if(fl_likely(is##type(v))) \
- return (ctype)cnvt(v); \
- type_error(#type, v); \
- }
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol, symbol_t*, ptr)
-SAFECAST_OP(fixnum, fixnum_t, numval)
-//SAFECAST_OP(cvalue, cvalue_t*, ptr)
-SAFECAST_OP(string, char*, cvalue_data)
-#undef isstring
-
-// symbol table ---------------------------------------------------------------
-
-static symbol_t *
-mk_symbol(const char *str, int len, bool copy)
-{- symbol_t *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));
- sym->numtype = NONNUMERIC;
- if(str[0] == ':' && str[1] != 0){- value_t s = tagptr(sym, TAG_SYM);
- sym->flags = FLAG_KEYWORD;
- setc(s, s);
- }else{- sym->binding = UNBOUND;
- sym->flags = 0;
- }
- sym->type = nil;
- sym->hash = memhash(str, len)^0xAAAAAAAAAAAAAAAAULL;
- if(copy){- memcpy((char*)(sym+1), str, len+1);
- sym->name = (const char*)(sym+1);
- }else{- sym->name = str;
- }
- sym->size = 0;
- return sym;
-}
-
-value_t
-symbol(const char *str, bool copy)
-{- int len = strlen(str);
- symbol_t *v;
- const char *k;
- if(!Tgetkv(FL(symtab), str, len, &k, (void**)&v)){- v = mk_symbol(str, len, copy);
- FL(symtab) = Tsetl(FL(symtab), v->name, len, v);
- }
- return tagptr(v, TAG_SYM);
-}
-
-value_t
-csymbol_(const char *str, int len)
-{- symbol_t *v = mk_symbol(str, len, false);
- FL(symtab) = Tsetl(FL(symtab), str, len, v);
- return tagptr(v, TAG_SYM);
-}
-
-BUILTIN("gensym", gensym)-{- argcount(nargs, 0);
- USED(args);
- gensym_t *gs = alloc_words(sizeof(gensym_t)/sizeof(value_t));
- gs->id = FL(gensym_ctr)++;
- gs->binding = UNBOUND;
- gs->type = nil;
- return tagptr(gs, TAG_SYM);
-}
-
-value_t
-gensym(void)
-{- return fn_builtin_gensym(nil, 0);
-}
-
-fl_purefn
-BUILTIN("gensym?", gensymp)-{- argcount(nargs, 1);
- return isgensym(args[0]) ? FL_t : FL_nil;
-}
-
-char *
-uint2str(char *dest, size_t len, uint64_t num, int base)
-{- int i = len-1;
- uint64_t b = (uint64_t)base;
- char ch;
- dest[i--] = '\0';
- while(i >= 0){- ch = (char)(num % b);
- if(ch < 10)
- ch += '0';
- else
- ch = ch-10+'a';
- dest[i--] = ch;
- num /= b;
- if(num == 0)
- break;
- }
- return &dest[i+1];
-}
-
-const char *
-symbol_name(value_t v)
-{- if(ismanaged(v)){- gensym_t *gs = ptr(v);
- FL(gsnameno) = 1-FL(gsnameno);
- char *n = uint2str(FL(gsname)[FL(gsnameno)]+1, sizeof(FL(gsname)[0])-1, gs->id, 10);
- *(--n) = 'g';
- return n;
- }
- return ((symbol_t*)ptr(v))->name;
-}
-
-// conses ---------------------------------------------------------------------
-
-value_t
-mk_cons(void)
-{- cons_t *c;
-
- if(fl_unlikely(FL(curheap) > FL(lim)))
- fl_gc(false);
- c = (cons_t*)FL(curheap);
- FL(curheap) += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-void *
-alloc_words(int n)
-{- value_t *first;
-
-#if !defined(BITS64)
- // force 8-byte alignment
- if(n & 1)
- n++;
-#endif
- if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)+2-n)){- fl_gc(false);
- while(fl_unlikely((value_t*)FL(curheap) > ((value_t*)FL(lim))+2-n))
- fl_gc(true);
- }
- first = (value_t*)FL(curheap);
- FL(curheap) += n*sizeof(value_t);
- return first;
-}
-
-value_t
-alloc_vector(size_t n, bool init)
-{- if(n == 0)
- return FL(the_empty_vector);
- value_t *c = alloc_words(n+1);
- value_t v = tagptr(c, TAG_VECTOR);
- vector_setsize(v, n);
- if(init){- for(size_t i = 0; i < n; i++)
- vector_elt(v, i) = FL_void;
- }
- return v;
-}
-
-// collector ------------------------------------------------------------------
-
-void
-fl_gc_handle(value_t *pv)
-{- if(fl_unlikely(FL(ngchandles) >= N_GC_HANDLES))
- lerrorf(FL_MemoryError, "out of gc handles");
- FL(gchandles)[FL(ngchandles)++] = pv;
-}
-
-void
-fl_free_gc_handles(int n)
-{- assert(FL(ngchandles) >= n);
- FL(ngchandles) -= n;
-}
-
-value_t
-relocate(value_t v)
-{- value_t a, d, nc, first, *pcdr;
-
- if(isfixnum(v))
- return v;
-
- uintptr_t t = tag(v);
- if(t == TAG_CONS){- // iterative implementation allows arbitrarily long cons chains
- pcdr = &first;
- do{- a = car_(v);
- if(isforwarded(v)){- *pcdr = forwardloc(v);
- return first;
- }
- d = cdr_(v);
- *pcdr = nc = tagptr((cons_t*)FL(curheap), TAG_CONS);
- FL(curheap) += sizeof(cons_t);
- forward(v, nc);
- car_(nc) = ismanaged(a) ? relocate(a) : a;
- pcdr = &cdr_(nc);
- v = d;
- }while(iscons(v));
- *pcdr = d == FL_nil ? FL_nil : relocate(d);
- return first;
- }
-
- if(!ismanaged(v))
- return v;
- if(isforwarded(v))
- return forwardloc(v);
-
- if(t == TAG_CVALUE)
- return cvalue_relocate(v);
- if(t == TAG_VECTOR){- // N.B.: 0-length vectors secretly have space for a first element
- size_t i, sz = vector_size(v);
- if(vector_elt(v, -1) & 0x1){- // grown vector
- nc = relocate(vector_elt(v, 0));
- forward(v, nc);
- }else{- nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
- vector_setsize(nc, sz);
- a = vector_elt(v, 0);
- forward(v, nc);
- if(sz > 0){- vector_elt(nc, 0) = relocate(a);
- for(i = 1; i < sz; i++)
- vector_elt(nc, i) = relocate(vector_elt(v, i));
- }
- }
- return nc;
- }
- if(t == TAG_FUNCTION){- function_t *fn = ptr(v);
- function_t *nfn = alloc_words(sizeof(function_t)/sizeof(value_t));
- nfn->bcode = fn->bcode;
- nfn->vals = fn->vals;
- nc = tagptr(nfn, TAG_FUNCTION);
- forward(v, nc);
- nfn->env = relocate(fn->env);
- nfn->vals = relocate(nfn->vals);
- nfn->bcode = relocate(nfn->bcode);
- assert(!ismanaged(fn->name));
- nfn->name = fn->name;
- return nc;
- }
- if(t == TAG_SYM){- gensym_t *gs = ptr(v);
- gensym_t *ng = alloc_words(sizeof(gensym_t)/sizeof(value_t));
- ng->id = gs->id;
- ng->binding = gs->binding;
- ng->type = gs->type;
- nc = tagptr(ng, TAG_SYM);
- forward(v, nc);
- if(fl_likely(ng->binding != UNBOUND))
- ng->binding = relocate(ng->binding);
- return nc;
- }
- if(t == TAG_CPRIM){- cprim_t *pcp = ptr(v);
- size_t nw = CPRIM_NWORDS+NWORDS(cp_class(pcp)->size);
- cprim_t *ncp = alloc_words(nw);
- while(nw--)
- ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
- nc = tagptr(ncp, TAG_CPRIM);
- forward(v, nc);
- return nc;
- }
- return v;
-}
-
-static void
-trace_globals(void)
-{- const char *k = nil;
- symbol_t *v;
- while(Tnext(FL(symtab), &k, (void**)&v)){- if(v->binding != UNBOUND)
- v->binding = relocate(v->binding);
- }
-}
-
-void
-fl_gc(bool mustgrow)
-{- FL(gccalls)++;
- FL(curheap) = FL(tospace);
- if(FL(grew))
- FL(lim) = FL(curheap)+FL(heapsize)*2-sizeof(cons_t);
- else
- FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t);
-
- value_t *top, *f;
- if(FL(throwing_frame) > FL(curr_frame)){- top = FL(throwing_frame) - 3;
- f = (value_t*)*top;
- }else{- top = FL(sp);
- f = FL(curr_frame);
- }
- for(;;){- for(value_t *p = f; p < top; p++)
- *p = relocate(*p);
- if(f == FL(stack))
- break;
- top = f - 3;
- f = (value_t*)*top;
- }
- for(int i = 0; i < FL(ngchandles); i++)
- *FL(gchandles)[i] = relocate(*FL(gchandles)[i]);
- trace_globals();
- relocate_typetable();
- fl_readstate_t *rs = FL(readstate);
- while(rs){- value_t ent;
- for(int i = 0; i < rs->backrefs.size; i++){- ent = (value_t)rs->backrefs.table[i];
- if(ent != (value_t)HT_NOTFOUND)
- rs->backrefs.table[i] = (void*)relocate(ent);
- }
- for(int i = 0; i < rs->gensyms.size; i++){- ent = (value_t)rs->gensyms.table[i];
- if(ent != (value_t)HT_NOTFOUND)
- rs->gensyms.table[i] = (void*)relocate(ent);
- }
- rs->source = relocate(rs->source);
- rs = rs->prev;
- }
- FL(lasterror) = relocate(FL(lasterror));
- FL(memory_exception_value) = relocate(FL(memory_exception_value));
- FL(the_empty_vector) = relocate(FL(the_empty_vector));
- FL(the_empty_string) = relocate(FL(the_empty_string));
-
- sweep_finalizers();
-
- void *temp = FL(tospace);
- FL(tospace) = FL(fromspace);
- FL(fromspace) = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if(FL(grew) || ((intptr_t)(FL(lim)-FL(curheap)) < (intptr_t)FL(heapsize)/5) || mustgrow){- temp = MEM_REALLOC(FL(tospace), FL(heapsize)*2);
- if(fl_unlikely(temp == nil))
- fl_raise(FL(memory_exception_value));
- FL(tospace) = temp;
- if(FL(grew)){- FL(heapsize) *= 2;
- temp = bitvector_resize(FL(consflags), 0, FL(heapsize)/sizeof(cons_t), 1);
- if(fl_unlikely(temp == nil))
- fl_raise(FL(memory_exception_value));
- FL(consflags) = (uint32_t*)temp;
- }
- FL(grew) = !FL(grew);
- }
- if(fl_unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2)){- // all data was live; gc again and grow heap.
- // but also always leave at least 4 words available, so a closure
- // can be allocated without an extra check.
- fl_gc(false);
- }
-}
-
-// utils ----------------------------------------------------------------------
-
-// apply function with n args on the stack
-fl_hotfn
-static value_t
-_applyn(int n)
-{- value_t *saveSP = FL(sp);
- value_t f = saveSP[-n-1];
- value_t v;
- if(iscbuiltin(f))
- v = ((cvalue_t*)ptr(f))->cbuiltin(saveSP-n, n);
- else if(isfunction(f))
- v = apply_cl(n);
- else if(fl_likely(isbuiltin(f))){- value_t tab = symbol_value(FL_builtins_table_sym);
- if(fl_unlikely(ptr(tab) == nil))
- unbound_error(tab);
- saveSP[-n-1] = vector_elt(tab, uintval(f));
- v = apply_cl(n);
- }else{- type_error("function", f);- }
- FL(sp) = saveSP;
- return v;
-}
-
-value_t
-fl_apply(value_t f, value_t v)
-{- value_t *saveSP = FL(sp);
-
- PUSH(f);
- int n;
- for(n = 0; iscons(v); n++){- PUSH(car_(v));
- v = cdr_(v);
- }
- if(v != FL_nil)
- lerrorf(FL_ArgError, "apply: last argument: not a list");
- v = _applyn(n);
- FL(sp) = saveSP;
- return v;
-}
-
-value_t
-fl_applyn(int n, value_t f, ...)
-{- va_list ap;
- va_start(ap, f);
-
- PUSH(f);
- for(int i = 0; i < n; i++){- value_t a = va_arg(ap, value_t);
- PUSH(a);
- }
- value_t v = _applyn(n);
- POPN(n+1);
- va_end(ap);
- return v;
-}
-
-value_t
-fl_listn(int n, ...)
-{- va_list ap;
- va_start(ap, n);
- value_t *si = FL(sp);
-
- for(int i = 0; i < n; i++){- value_t a = va_arg(ap, value_t);
- PUSH(a);
- }
- cons_t *c = alloc_words(n*2);
- cons_t *l = c;
- for(int i = 0; i < n; i++){- c->car = *si++;
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- c[-1].cdr = FL_nil;
-
- POPN(n);
- va_end(ap);
- return tagptr(l, TAG_CONS);
-}
-
-value_t
-fl_list2(value_t a, value_t b)
-{- PUSH(a);
- PUSH(b);
- cons_t *c = alloc_words(4);
- b = POP();
- a = POP();
- c[0].car = a;
- c[0].cdr = tagptr(c+1, TAG_CONS);
- c[1].car = b;
- c[1].cdr = FL_nil;
- return tagptr(c, TAG_CONS);
-}
-
-value_t
-fl_cons(value_t a, value_t b)
-{- PUSH(a);
- PUSH(b);
- value_t c = mk_cons();
- cdr_(c) = POP();
- car_(c) = POP();
- return c;
-}
-
-bool
-fl_isnumber(value_t v)
-{- if(isfixnum(v) || ismpint(v))
- return true;
- if(iscprim(v)){- cprim_t *c = ptr(v);
- return c->type != FL(runetype) && valid_numtype(c->type->numtype);
- }
- return false;
-}
-
-// eval -----------------------------------------------------------------------
-
-fl_hotfn
-static value_t
-list(value_t *args, int nargs, bool star)
-{- if(fl_unlikely(nargs == 0))
- return FL_nil;
- value_t v = cons_reserve(nargs);
- cons_t *c = ptr(v);
- for(int i = 0; i < nargs; i++){- c->car = args[i];
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- if(star)
- c[-2].cdr = c[-1].car;
- else
- c[-1].cdr = FL_nil;
- return v;
-}
-
-static value_t
-copy_list(value_t L)
-{- if(!iscons(L))
- return FL_nil;
- value_t *plcons = FL(sp);
- value_t *pL = plcons+1;
- PUSH(FL_nil);
- PUSH(L);
- value_t c;
- c = mk_cons(); PUSH(c); // save first cons
- car_(c) = car_(*pL);
- cdr_(c) = FL_nil;
- *plcons = c;
- *pL = cdr_(*pL);
- while(iscons(*pL)){- c = mk_cons();
- car_(c) = car_(*pL);
- cdr_(c) = FL_nil;
- cdr_(*plcons) = c;
- *plcons = c;
- *pL = cdr_(*pL);
- }
- c = POP(); // first cons
- POPN(2);
- return c;
-}
-
-static value_t
-do_trycatch(void)
-{- value_t *saveSP = FL(sp);
- value_t v = FL_nil;
- value_t thunk = saveSP[-2];
- FL(sp)[-2] = saveSP[-1];
- FL(sp)[-1] = thunk;
-
- FL_TRY{- v = apply_cl(0);
- }
- FL_CATCH{- v = saveSP[-2];
- PUSH(v);
- PUSH(FL(lasterror));
- v = apply_cl(1);
- }
- FL(sp) = saveSP;
- return v;
-}
-
-/*
- argument layout on stack is
- |--required args--|--opt args--|--kw args--|--rest args...
-*/
-static int
-process_keys(value_t kwtable, int nreq, int nkw, int nopt, value_t *bp, int nargs, int va)
-{- int extr = nopt+nkw;
- int ntot = nreq+extr;
- value_t args[64], v = FL_nil;
- int i, a = 0, nrestargs;
- value_t s1 = FL(sp)[-1];
- value_t s3 = FL(sp)[-3];
- value_t s4 = FL(sp)[-4];
- if(fl_unlikely(nargs < nreq))
- lerrorf(FL_ArgError, "too few arguments");
- if(fl_unlikely(extr > nelem(args)))
- lerrorf(FL_ArgError, "too many arguments");
- for(i = 0; i < extr; i++)
- args[i] = UNBOUND;
- for(i = nreq; i < nargs; i++){- v = bp[i];
- if(issymbol(v) && iskeyword((symbol_t*)ptr(v)))
- break;
- if(a >= nopt)
- goto no_kw;
- args[a++] = v;
- }
- if(i >= nargs)
- goto no_kw;
- // now process keywords
- uintptr_t n = vector_size(kwtable)/2;
- do{- i++;
- if(fl_unlikely(i >= nargs))
- lerrorf(FL_ArgError, "keyword %s requires an argument", symbol_name(v));
- value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
- fixnum_t lx = numval(hv);
- uintptr_t x = 2*((lx < 0 ? -lx : lx) % n);
- if(fl_likely(vector_elt(kwtable, x) == v)){- intptr_t idx = numval(vector_elt(kwtable, x+1));
- assert(idx < nkw);
- idx += nopt;
- if(args[idx] == UNBOUND){- // if duplicate key, keep first value
- args[idx] = bp[i];
- }
- }else{- lerrorf(FL_ArgError, "unsupported keyword %s", symbol_name(v));
- }
- i++;
- if(i >= nargs)
- break;
- v = bp[i];
- }while(issymbol(v) && iskeyword((symbol_t*)ptr(v)));
-no_kw:
- nrestargs = nargs - i;
- if(fl_unlikely(!va && nrestargs > 0))
- lerrorf(FL_ArgError, "too many arguments");
- nargs = ntot + nrestargs;
- if(nrestargs)
- memmove(bp+ntot, bp+i, nrestargs*sizeof(value_t));
- memmove(bp+nreq, args, extr*sizeof(value_t));
- FL(sp) = bp + nargs;
- assert((intptr_t)(FL(sp)-FL(stack)) < (intptr_t)FL(nstack)-4);
- PUSH(s4);
- PUSH(s3);
- PUSH(nargs);
- PUSH(s1);
- FL(curr_frame) = FL(sp);
- return nargs;
-}
-
-#if BYTE_ORDER == LITTLE_ENDIAN && defined(MEM_UNALIGNED_ACCESS)
-#define GET_INT32(a) *(const int32_t*)(a)
-#define GET_INT16(a) *(const int16_t*)(a)
-#else
-#define GET_INT32(a) (int32_t)((a)[0]<<0 | (a)[1]<<8 | (a)[2]<<16 | (uint32_t)(a)[3]<<24)
-#define GET_INT16(a) (int16_t)((a)[0]<<0 | (a)[1]<<8)
-#endif
-
-/*
- stack on entry: <func> <nargs args...>
- caller's responsibility:
- - put the stack in this state
- - provide arg count
- - respect tail position
- - restore SP
-
- callee's responsibility:
- - check arg counts
- - allocate vararg array
- - push closed env, set up new environment
-*/
-static value_t
-apply_cl(int nargs)
-{- value_t *top_frame = FL(curr_frame), *bp, *ipd;
- register value_t *sp = FL(sp);
- const uint8_t *ip;
- bool tail;
- int n;
-
- goto apply_func;
-
-#if defined(COMPUTED_GOTO)
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wpedantic"
- static const void * const ops[] = {-#define GOTO_OP_OFFSET(op) [op] = &&op_##op
-#include "vm_goto.inc"
-#undef GOTO_OP_OFFSET
- };
-#define NEXT_OP goto *ops[*ip++]
-#define LABEL(x) x
-#define OP(x) op_##x:
-#include "vm.inc"
-#undef OP
-#undef LABEL
-#undef NEXT_OP
-#pragma GCC diagnostic pop
-#else /* just a usual (portable) switch/case */
- uint8_t op;
- while(1){- switch(op){-#define NEXT_OP break
-#define LABEL(x) x
-#define OP(x) case x:
-#include "vm.inc"
-#undef OP
-#undef LABEL
-#undef NEXT_OP
- }
- op = *ip++;
- }
-#endif
-}
-
-// top = top frame pointer to start at
-static value_t
-_stacktrace(value_t *top)
-{- value_t lst = FL_nil;
- value_t *stack = FL(stack);
-
- fl_gc_handle(&lst);
- while(top > stack){- const uint8_t *ip1 = (void*)top[-1];
- int sz = top[-2]+1;
- value_t *bp = top-4-sz;
- value_t func = bp[0];
- const uint8_t *ip0 = cvalue_data(fn_bcode(func));
- intptr_t ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */
- value_t v = alloc_vector(sz+1, 0);
- vector_elt(v, 0) = fixnum(ip);
- vector_elt(v, 1) = func;
- for(int i = 1; i < sz; i++){- value_t si = bp[i];
- // if there's an error evaluating argument defaults some slots
- // might be left set to UNBOUND
- vector_elt(v, i+1) = si == UNBOUND ? FL_void : si;
- }
- lst = fl_cons(v, lst);
- top = (value_t*)top[-3];
- }
- fl_free_gc_handles(1);
- return lst;
-}
-
-// builtins -------------------------------------------------------------------
-
-BUILTIN("gc", gc)-{- USED(args);
- argcount(nargs, 0);
- fl_gc(false);
- return FL_void;
-}
-
-BUILTIN("function", function)-{- if(nargs == 1 && issymbol(args[0]))
- return fn_builtin_builtin(args, nargs);
- if(nargs < 2 || nargs > 4)
- argcount(nargs, 2);
- if(fl_unlikely(!fl_isstring(args[0])))
- type_error("string", args[0]);- if(fl_unlikely(!isvector(args[1])))
- type_error("vector", args[1]);- cvalue_t *arr = ptr(args[0]);
- cv_pin(arr);
- uint8_t *data = cv_data(arr);
- if(FL(loading)){- // read syntax, shifted 48 for compact text representation
- size_t i, sz = cv_len(arr);
- for(i = 0; i < sz; i++)
- data[i] -= 48;
- }
- function_t *fn = alloc_words(sizeof(function_t)/sizeof(value_t));
- value_t fv = tagptr(fn, TAG_FUNCTION);
- fn->bcode = args[0];
- fn->vals = args[1];
- fn->env = FL_nil;
- fn->name = FL_lambda;
- if(nargs > 2){- if(issymbol(args[2])){- fn->name = args[2];
- if(nargs > 3)
- fn->env = args[3];
- }else{- fn->env = args[2];
- if(nargs > 3){- if(fl_unlikely(!issymbol(args[3])))
- type_error("symbol", args[3]);- fn->name = args[3];
- }
- }
- if(fl_unlikely(isgensym(fn->name)))
- lerrorf(FL_ArgError, "name should not be a gensym");
- }
- return fv;
-}
-
-fl_purefn
-BUILTIN("function:code", function_code)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(fl_unlikely(!isfunction(v)))
- type_error("function", v);- return fn_bcode(v);
-}
-
-fl_purefn
-BUILTIN("function:vals", function_vals)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(fl_unlikely(!isfunction(v)))
- type_error("function", v);- return fn_vals(v);
-}
-
-fl_purefn
-BUILTIN("function:env", function_env)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(fl_unlikely(!isfunction(v)))
- type_error("function", v);- return fn_env(v);
-}
-
-BUILTIN("function:name", function_name)-{- argcount(nargs, 1);
- value_t v = args[0];
- if(isfunction(v))
- return fn_name(v);
- if(isbuiltin(v))
- return symbol(builtins[uintval(v)].name, false);
- if(iscbuiltin(v)){- v = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), ptr(v));
- if(v == (value_t)HT_NOTFOUND)
- return FL_nil;
- return v;
- }
- type_error("function", v);-}
-
-BUILTIN("copy-list", copy_list)-{- argcount(nargs, 1);
- return copy_list(args[0]);
-}
-
-BUILTIN("append", append)-{- value_t first = FL_nil, lst, lastcons = FL_nil;
- int i;
- if(nargs == 0)
- return FL_nil;
- fl_gc_handle(&first);
- fl_gc_handle(&lastcons);
- for(i = 0; i < nargs; i++){- lst = args[i];
- if(iscons(lst)){- lst = copy_list(lst);
- if(first == FL_nil)
- first = lst;
- else
- cdr_(lastcons) = lst;
- lastcons = tagptr((((cons_t*)FL(curheap))-1), TAG_CONS);
- }else if(lst != FL_nil){- type_error("cons", lst);- }
- }
- fl_free_gc_handles(2);
- return first;
-}
-
-BUILTIN("list*", liststar)-{- if(nargs == 1)
- return args[0];
- if(nargs == 0)
- argcount(nargs, 1);
- return list(args, nargs, true);
-}
-
-BUILTIN("stacktrace", stacktrace)-{- USED(args);
- argcount(nargs, 0);
- return _stacktrace(FL(throwing_frame) ? FL(throwing_frame) : FL(curr_frame));
-}
-
-BUILTIN("map", map)-{- if(fl_unlikely(nargs < 2))
- lerrorf(FL_ArgError, "too few arguments");
- value_t *k = FL(sp);
- PUSH(FL_nil);
- PUSH(FL_nil);
- for(bool first = true;;){- PUSH(args[0]);
- for(int i = 1; i < nargs; i++){- if(!iscons(args[i])){- POPN(2+i);
- return k[1];
- }
- PUSH(car(args[i]));
- args[i] = cdr_(args[i]);
- }
- value_t v = _applyn(nargs-1);
- POPN(nargs);
- PUSH(v);
- value_t c = mk_cons();
- car_(c) = POP(); cdr_(c) = FL_nil;
- if(first)
- k[1] = c;
- else
- cdr_(k[0]) = c;
- k[0] = c;
- first = false;
- }
-}
-
-BUILTIN("for-each", for_each)-{- if(fl_unlikely(nargs < 2))
- lerrorf(FL_ArgError, "too few arguments");
- for(size_t n = 0;; n++){- PUSH(args[0]);
- int pargs = 0;
- for(int i = 1; i < nargs; i++, pargs++){- value_t v = args[i];
- if(iscons(v)){- PUSH(car_(v));
- args[i] = cdr_(v);
- continue;
- }
- if(isvector(v)){- size_t sz = vector_size(v);
- if(n < sz){- PUSH(vector_elt(v, n));
- continue;
- }
- }
- if(isarray(v)){- size_t sz = cvalue_arraylen(v);
- if(n < sz){- value_t a[2];
- a[0] = v;
- a[1] = fixnum(n);
- PUSH(cvalue_array_aref(a));
- continue;
- }
- }
- if(ishashtable(v)){- htable_t *h = totable(v);
- assert(n != 0 || h->i == 0);
- void **table = h->table;
- for(; h->i < h->size; h->i += 2){- if(table[h->i+1] != HT_NOTFOUND)
- break;
- }
- if(h->i < h->size){- PUSH((value_t)table[h->i]);
- pargs++;
- PUSH((value_t)table[h->i+1]);
- h->i += 2;
- continue;
- }
- h->i = 0;
- }
- POPN(pargs+1);
- return FL_void;
- }
- _applyn(pargs);
- POPN(pargs+1);
- }
-}
-
-BUILTIN("sleep", fl_sleep)-{- if(nargs > 1)
- argcount(nargs, 1);
- double s = nargs > 0 ? todouble(args[0]) : 0;
- sleep_ms(s * 1000.0);
- return FL_void;
-}
-
-BUILTIN("vm-stats", vm_stats)-{- USED(args);
- argcount(nargs, 0);
- ios_printf(ios_stderr, "heap total %10"PRIuPTR" bytes\n", FL(heapsize));
- ios_printf(ios_stderr, "heap free %10"PRIuPTR" bytes\n", (uintptr_t)(FL(lim)-FL(curheap)));
- ios_printf(ios_stderr, "heap used %10"PRIuPTR" bytes\n", (uintptr_t)(FL(curheap)-FL(fromspace)));
- ios_printf(ios_stderr, "stack %10"PRIu64" bytes\n", (uint64_t)FL(nstack)*sizeof(value_t));
- ios_printf(ios_stderr, "finalizers %10"PRIu32"\n", (uint32_t)FL(nfinalizers));
- ios_printf(ios_stderr, "max finalizers %10"PRIu32"\n", (uint32_t)FL(maxfinalizers));
- ios_printf(ios_stderr, "gc handles %10"PRIu32"\n", (uint32_t)FL(ngchandles));
- ios_printf(ios_stderr, "gc calls %10"PRIu64"\n", (uint64_t)FL(gccalls));
- ios_printf(ios_stderr, "opcodes %10d\n", N_OPCODES);
- return FL_void;
-}
-
-static const builtinspec_t builtin_fns[] = {-#define BUILTIN_FN(l, c, attr){l, (builtin_t)fn_builtin_##c},-#include "builtin_fns.h"
-#undef BUILTIN_FN
-};
-
-// initialization -------------------------------------------------------------
-
-int
-fl_init(size_t heapsize, size_t stacksize)
-{- int i;
-
- if((fl = MEM_CALLOC(1, sizeof(*fl))) == nil)
- return -1;
- FL(scr_width) = 100;
-
- FL(heapsize) = heapsize*sizeof(value_t);
-
- if((FL(fromspace) = MEM_ALLOC(FL(heapsize))) == nil){-failed:
- MEM_FREE(FL(fromspace));
- MEM_FREE(FL(tospace));
- MEM_FREE(FL(consflags));
- MEM_FREE(FL(finalizers));
- fl_segfree(FL(stack), stacksize*sizeof(value_t));
- htable_free(&FL(printconses));
- MEM_FREE(fl);
- return -1;
- }
-
- if((FL(tospace) = MEM_ALLOC(FL(heapsize))) == nil)
- goto failed;
- FL(curheap) = FL(fromspace);
- FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t);
-
- if((FL(stack) = fl_segalloc(stacksize*sizeof(value_t))) == nil)
- goto failed;
- FL(curr_frame) = FL(sp) = FL(stack);
- FL(nstack) = stacksize;
-
- FL(maxfinalizers) = 512;
- if((FL(finalizers) = MEM_ALLOC(FL(maxfinalizers) * sizeof(*FL(finalizers)))) == nil)
- goto failed;
-
- if((FL(consflags) = bitvector_new(FL(heapsize)/sizeof(cons_t), 1)) == nil)
- goto failed;
- if((htable_new(&FL(printconses), 32)) == nil)
- goto failed;
-
- comparehash_init();
-
- FL_lambda = csymbol("λ");- FL_function = csymbol("function");- FL_quote = csymbol("quote");- FL_trycatch = csymbol("trycatch");- FL_backquote = csymbol("quasiquote");- FL_comma = csymbol("unquote");- FL_commaat = csymbol("unquote-splicing");- FL_commadot = csymbol("unquote-nsplicing");- FL_IOError = csymbol("io-error");- FL_ParseError = csymbol("parse-error");- FL_TypeError = csymbol("type-error");- FL_ArgError = csymbol("arg-error");- FL_UnboundError = csymbol("unbound-error");- FL_KeyError = csymbol("key-error");- FL_MemoryError = csymbol("memory-error");- FL_BoundsError = csymbol("bounds-error");- FL_DivideError = csymbol("divide-error");- FL_Error = csymbol("error");- FL_conssym = csymbol("cons");- FL_symbolsym = csymbol("symbol");- FL_fixnumsym = csymbol("fixnum");- FL_vectorsym = csymbol("vector");- FL_builtinsym = csymbol("builtin");- FL_booleansym = csymbol("boolean");- FL_nullsym = csymbol("null");- FL_defsym = csymbol("def");- FL_defmacrosym = csymbol("defmacro");- FL_forsym = csymbol("for");- FL_setqsym = csymbol("set!");- FL_evalsym = csymbol("eval");- FL_vu8sym = csymbol("vu8");- FL_fnsym = csymbol("fn");- FL_nulsym = csymbol("nul");- FL_alarmsym = csymbol("alarm");- FL_backspacesym = csymbol("backspace");- FL_tabsym = csymbol("tab");- FL_linefeedsym = csymbol("linefeed");- FL_vtabsym = csymbol("vtab");- FL_pagesym = csymbol("page");- FL_returnsym = csymbol("return");- FL_escsym = csymbol("esc");- FL_spacesym = csymbol("space");- FL_deletesym = csymbol("delete");- FL_newlinesym = csymbol("newline");- FL_builtins_table_sym = csymbol("*builtins*");-
- set(FL_printprettysym = csymbol("*print-pretty*"), FL_t);- set(FL_printreadablysym = csymbol("*print-readably*"), FL_t);- set(FL_printwidthsym = csymbol("*print-width*"), fixnum(FL(scr_width)));- set(FL_printlengthsym = csymbol("*print-length*"), FL_nil);- set(FL_printlevelsym = csymbol("*print-level*"), FL_nil);- FL(lasterror) = FL_nil;
-
- for(i = 0; i < nelem(builtins); i++){- if(builtins[i].name)
- set(symbol(builtins[i].name, false), builtin(i));
- }
- setc(csymbol("procedure?"), builtin(OP_FUNCTIONP));- setc(csymbol("top-level-bound?"), builtin(OP_BOUNDP));-
- FL(the_empty_vector) = tagptr(alloc_words(1), TAG_VECTOR);
- vector_setsize(FL(the_empty_vector), 0);
-
- cvalues_init();
-
- set(csymbol("*os-name*"), cvalue_static_cstring(__os_name__));-#if defined(__os_version__)
- set(csymbol("*os-version*"), cvalue_static_cstring(__os_version__));-#endif
- FL(memory_exception_value) = fl_list2(FL_MemoryError, cvalue_static_cstring("out of memory"));-
- const builtinspec_t *b;
- for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++)
- cbuiltin(b->name, b->fptr);
- table_init();
- iostream_init();
- compress_init();
- return 0;
-}
-
-// top level ------------------------------------------------------------------
-
-value_t
-fl_toplevel_eval(value_t expr)
-{- return fl_applyn(1, symbol_value(FL_evalsym), expr);
-}
-
-int
-fl_load_system_image(value_t sys_image_iostream)
-{- FL(loading) = true;
- PUSH(sys_image_iostream);
- value_t *saveSP = FL(sp);
- FL_TRY{- while(1){- FL(sp) = saveSP;
- value_t e = fl_read_sexpr(FL(sp)[-1]);
- if(ios_eof(value2c(ios_t*, FL(sp)[-1])))
- break;
- if(isfunction(e)){- // stage 0 format: series of thunks
- PUSH(e);
- (void)_applyn(0);
- }else{- // stage 1 format: list alternating symbol/value
- while(iscons(e)){- symbol_t *sym = tosymbol(car_(e));
- e = cdr_(e);
- if(sym->binding != UNBOUND)
- ios_printf(ios_stderr, "%s redefined on boot\n", sym->name);
- sym->binding = car_(e);
- e = cdr_(e);
- }
- break;
- }
- }
- }
- FL_CATCH_NO_INC{- ios_puts(ios_stderr, "fatal error during bootstrap: ");
- fl_print(ios_stderr, FL(lasterror));
- ios_putc(ios_stderr, '\n');
- return -1;
- }
- FL(sp) = saveSP-1;
- FL(loading) = false;
- return 0;
-}
--- a/src/flisp.h
+++ /dev/null
@@ -1,452 +1,0 @@
-#pragma once
-
-#include "platform.h"
-#include "utf8.h"
-#include "ios.h"
-#include "tbl.h"
-#include "bitvector.h"
-#include "htableh.inc"
-HTPROT(ptrhash)
-
-typedef struct fltype_t fltype_t;
-
-enum {- TAG_NUM,
- TAG_CPRIM,
- TAG_FUNCTION,
- TAG_VECTOR,
- TAG_NUM1,
- TAG_CVALUE,
- TAG_SYM,
- TAG_CONS,
-
- /* those were set to 7 and 3 strategically on purpose */
- TAG_NONLEAF_MASK = TAG_CONS & TAG_VECTOR,
-};
-
-enum {- FLAG_CONST = 1<<0,
- FLAG_KEYWORD = 1<<1,
-};
-
-typedef enum {- T_INT8, T_UINT8,
- T_INT16, T_UINT16,
- T_INT32, T_UINT32,
- T_INT64, T_UINT64,
- T_MPINT,
- T_FLOAT,
- T_DOUBLE,
-}numerictype_t;
-
-typedef uintptr_t value_t;
-
-#if defined(BITS64)
-typedef int64_t fixnum_t;
-#define FIXNUM_BITS 62
-#define TOP_BIT (1ULL<<63)
-#define T_FIXNUM T_INT64
-#define PRIdFIXNUM PRId64
-#else
-typedef int32_t fixnum_t;
-#define FIXNUM_BITS 30
-#define TOP_BIT (1U<<31)
-#define T_FIXNUM T_INT32
-#define PRIdFIXNUM PRId32
-#endif
-
-#if !defined(FWD_BIT)
-#define FWD_BIT TOP_BIT
-#endif
-
-typedef struct {- value_t car;
- value_t cdr;
-}fl_aligned(8) cons_t;
-
-// NOTE: symbol_t MUST have the same fields as gensym_t first
-// there are places where gensyms are treated as normal symbols
-typedef struct {- uint64_t hash;
- fltype_t *type;
- value_t binding; // global value binding
- uint8_t numtype;
- uint8_t size;
- uint8_t flags;
- uint8_t _dummy;
- const char *name;
-}fl_aligned(8) symbol_t;
-
-typedef struct {- uint64_t id;
- fltype_t *type;
- value_t binding;
-}fl_aligned(8) gensym_t;
-
-typedef struct Builtin Builtin;
-
-struct Builtin {- const char *name;
- int nargs;
-};
-
-typedef value_t (*builtin_t)(value_t*, int);
-
-#define fits_bits(x, b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
-#define fits_fixnum(x) fits_bits(x, FIXNUM_BITS)
-
-#define ANYARGS -10000
-#define NONNUMERIC (0xff)
-#define valid_numtype(v) ((v) <= T_DOUBLE)
-#define UNBOUND ((value_t)1) // an invalid value
-#define tag(x) ((x) & 7)
-#define ptr(x) ((void*)((uintptr_t)(x) & (~(uintptr_t)7)))
-#define tagptr(p, t) ((value_t)(p) | (t))
-#define fixnum(x) ((value_t)(x)<<2)
-#define numval(x) ((fixnum_t)(x)>>2)
-#define uintval(x) (((unsigned int)(x))>>3)
-#define builtin(n) tagptr(((value_t)n<<3), TAG_FUNCTION)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isfixnum(x) (((x)&3) == TAG_NUM)
-#define bothfixnums(x, y) (isfixnum(x) && isfixnum(y))
-#define isvector(x) (tag(x) == TAG_VECTOR)
-#define iscvalue(x) (tag(x) == TAG_CVALUE)
-#define iscprim(x) (tag(x) == TAG_CPRIM)
-// doesn't lead to other values
-#define leafp(a) (((a)&TAG_NONLEAF_MASK) != TAG_NONLEAF_MASK)
-
-// allocate n consecutive conses
-#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
-#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)FL(fromspace)))
-#define ismarked(c) bitvector_get(FL(consflags), cons_index(c))
-#define mark_cons(c) bitvector_set(FL(consflags), cons_index(c))
-#define unmark_cons(c) bitvector_reset(FL(consflags), cons_index(c))
-
-#define isforwarded(v) (*(value_t*)ptr(v) & FWD_BIT)
-#define forwardloc(v) (*(value_t*)ptr(v) ^ FWD_BIT)
-#define forward(v, to) \
- do{ \- *(value_t*)ptr(v) = (value_t)(to) | FWD_BIT; \
- }while(0)
-
-#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
-#define vector_setsize(v, n) (((size_t*)ptr(v))[0] = ((n)<<2))
-#define vector_elt(v, i) (((value_t*)ptr(v))[1+(i)])
-#define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons(v)->car)
-#define cdr(v) (tocons(v)->cdr)
-#define fn_bcode(f) (((function_t*)ptr(f))->bcode)
-#define fn_vals(f) (((function_t*)ptr(f))->vals)
-#define fn_env(f) (((function_t*)ptr(f))->env)
-#define fn_name(f) (((function_t*)ptr(f))->name)
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) \
- do{ \- symbol_t *sy = (symbol_t*)ptr(s); \
- sy->flags |= FLAG_CONST; \
- sy->binding = (v); \
- }while(0)
-#define isconstant(s) ((s)->flags & FLAG_CONST)
-#define iskeyword(s) ((s)->flags & FLAG_KEYWORD)
-#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
-#define sym_to_numtype(s) (((symbol_t*)ptr(s))->numtype)
-#define ismanaged(v) ((((uint8_t*)ptr(v)) >= FL(fromspace)) && (((uint8_t*)ptr(v)) < FL(fromspace)+FL(heapsize)))
-#define isgensym(x) (issymbol(x) && ismanaged(x))
-#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
-#define iscbuiltin(x) (iscvalue(x) && cv_class(ptr(x)) == FL(builtintype))
-// utility for iterating over all arguments in a builtin
-// i=index, i0=start index, arg = var for each arg, args = arg array
-// assumes "nargs" is the argument count
-#define FOR_ARGS(i, i0, arg, args) for(i=i0; i<nargs && ((arg=args[i]) || 1); i++)
-#define N_BUILTINS ((int)N_OPCODES)
-
-#define PUSH(v) \
- do{ \- *FL(sp)++ = (v); \
- }while(0)
-#define POPN(n) \
- do{ \- FL(sp) -= (n); \
- }while(0)
-#define POP() *(--FL(sp))
-
-bool isbuiltin(value_t x) fl_constfn fl_hotfn;
-int fl_init(size_t heapsize, size_t stacksize);
-int fl_load_system_image(value_t ios);
-
-_Noreturn void fl_exit(int status);
-
-/* collector */
-value_t relocate(value_t v) fl_hotfn;
-void fl_gc(bool mustgrow);
-void fl_gc_handle(value_t *pv);
-void fl_free_gc_handles(int n);
-
-/* symbol table */
-value_t gensym(void);
-value_t symbol(const char *str, bool copy) fl_hotfn;
-value_t csymbol_(const char *str, int len);
-#define csymbol(str) csymbol_(str, sizeof(str)-1)
-const char *symbol_name(value_t v);
-
-/* read, eval, print main entry points */
-value_t fl_toplevel_eval(value_t expr);
-value_t fl_apply(value_t f, value_t l);
-value_t fl_applyn(int n, value_t f, ...);
-
-/* object model manipulation */
-value_t fl_cons(value_t a, value_t b);
-value_t fl_list2(value_t a, value_t b);
-value_t fl_listn(int n, ...);
-bool fl_isnumber(value_t v) fl_purefn;
-value_t alloc_vector(size_t n, bool init);
-
-/* consistent iswprint and wcwidth */
-int fl_iswprint(Rune c) fl_constfn;
-int fl_wcwidth(Rune c) fl_constfn;
-
-/* safe casts */
-cons_t *tocons(value_t v) fl_purefn;
-symbol_t *tosymbol(value_t v) fl_purefn;
-fixnum_t tofixnum(value_t v) fl_purefn;
-char *tostring(value_t v) fl_purefn;
-double todouble(value_t a) fl_purefn;
-
-/* conses */
-value_t mk_cons(void) fl_hotfn;
-void *alloc_words(int n) fl_hotfn;
-
-char *uint2str(char *dest, size_t len, uint64_t num, int base);
-
-/* error handling */
-typedef struct _fl_readstate_t {- htable_t backrefs;
- htable_t gensyms;
- value_t source;
- struct _fl_readstate_t *prev;
-}fl_readstate_t;
-
-typedef struct _ectx_t {- fl_readstate_t *rdst;
- struct _ectx_t *prev;
- jmp_buf buf;
- value_t *sp;
- value_t *frame;
- int ngchnd;
-}fl_exception_context_t;
-
-void free_readstate(fl_readstate_t *rs);
-
-#define FL_TRY_EXTERN \
- fl_exception_context_t _ctx; int l__tr, l__ca; \
- fl_savestate(&_ctx); FL(exctx) = &_ctx; \
- if(!fl_setjmp(_ctx.buf)) \
- for(l__tr = 1; l__tr; l__tr = 0, (void)(FL(exctx) = FL(exctx)->prev))
-
-#define FL_CATCH_EXTERN_NO_RESTORE \
- else \
- for(l__ca=1; l__ca;)
-
-#define FL_CATCH_EXTERN \
- else \
- for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
-
-_Noreturn void lerrorf(value_t e, const char *format, ...) fl_printfmt(2, 3);
-void fl_savestate(fl_exception_context_t *_ctx);
-void fl_restorestate(fl_exception_context_t *_ctx);
-_Noreturn void fl_raise(value_t e);
-_Noreturn void type_error(const char *expected, value_t got);
-_Noreturn void bounds_error(value_t arr, value_t ind);
-_Noreturn void unbound_error(value_t sym);
-_Noreturn void arity_error(int nargs, int c);
-
-#define argcount(nargs, c) \
- do{ \- if(fl_unlikely(nargs != c)) \
- arity_error(nargs, c); \
- }while(0)
-
-typedef struct {- void (*print)(value_t self, ios_t *f);
- void (*relocate)(value_t oldv, value_t newv);
- void (*finalize)(value_t self);
- void (*print_traverse)(value_t self);
-} cvtable_t;
-
-typedef void (*cvinitfunc_t)(fltype_t*, value_t, void*);
-
-struct fltype_t {- value_t type;
- cvtable_t *vtable;
- fltype_t *eltype; // for arrays
- fltype_t *artype; // (array this)
- cvinitfunc_t init;
- size_t size;
- size_t elsz;
- numerictype_t numtype;
-};
-
-typedef struct {- fltype_t *type;
- union {- void *data;
- builtin_t cbuiltin;
- };
- size_t len; // length of *data in bytes
- uint8_t _space[]; // variable size
-}fl_aligned(8) cvalue_t;
-
-typedef struct {- fltype_t *type;
- uint8_t _space[];
-}fl_aligned(8) cprim_t;
-
-typedef struct {- value_t bcode;
- value_t vals;
- value_t env;
- value_t name;
-}fl_aligned(8) function_t;
-
-#define CPRIM_NWORDS sizeof(cprim_t)/sizeof(value_t)
-#define cv_class(cv) ((fltype_t*)(((uintptr_t)((cvalue_t*)cv)->type)&~(uintptr_t)3))
-#define cv_len(cv) (((cvalue_t*)(cv))->len)
-#define cv_type(cv) (cv_class(cv)->type)
-#define cv_data(cv) (((cvalue_t*)(cv))->data)
-#define cv_isstr(cv) (cv_class(cv)->eltype == FL(bytetype))
-#define cv_isPOD(cv) (cv_class(cv)->init != nil)
-#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
-#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
-#define value2c(type, v) ((type)cvalue_data(v))
-#define cp_class(cp) (((cprim_t*)(cp))->type)
-#define cp_type(cp) (cp_class(cp)->type)
-#define cp_numtype(cp) (cp_class(cp)->numtype)
-#define cp_data(cp) (((cprim_t*)(cp))->_space)
-// WARNING: multiple evaluation!
-#define cptr(v) (iscprim(v) ? cp_data(ptr(v)) : cvalue_data(v))
-
-#define ismpint(v) (iscvalue(v) && cp_numtype(ptr(v)) == T_MPINT)
-#define tompint(v) (*(mpint**)cv_data(ptr(v)))
-
-#define BUILTIN(lname, cname) \
- value_t fn_builtin_##cname(value_t *args, int nargs)
-
-#define BUILTIN_FN(l, c, attr) attr BUILTIN(l, c);
-#include "builtin_fns.h"
-#undef BUILTIN_FN
-
-#include "opcodes.h"
-
-enum {- FL_nil = builtin(OP_LOADNIL),
- FL_t = builtin(OP_LOADT),
- FL_void = builtin(OP_LOADVOID),
- FL_eof = builtin(OP_EOF_OBJECT),
-};
-
-#define N_GC_HANDLES 1024
-
-typedef struct Fl Fl;
-
-struct Fl {- value_t *sp;
- uint8_t *curheap;
- value_t *curr_frame;
-
- uint8_t *fromspace;
- uint8_t *tospace;
- uint8_t *lim;
-
- value_t *stack;
-
- uintptr_t heapsize;//bytes
- size_t malloc_pressure;
- uint32_t nstack;
-
- cvalue_t **finalizers;
- size_t nfinalizers;
- size_t maxfinalizers;
-
- fl_readstate_t *readstate;
- Tbl *symtab;
-
- // saved execution state for an unwind target
- fl_exception_context_t *exctx;
- value_t *throwing_frame; // active frame when exception was thrown
- value_t lasterror;
-
- fltype_t *tabletype;
-
- fltype_t *iostreamtype;
-
- value_t the_empty_vector;
- value_t the_empty_string;
- value_t memory_exception_value;
-
- fltype_t *mpinttype;
- fltype_t *int8type, *uint8type;
- fltype_t *int16type, *uint16type;
- fltype_t *int32type, *uint32type;
- fltype_t *int64type, *uint64type;
- fltype_t *floattype, *doubletype;
- fltype_t *bytetype, *runetype;
- fltype_t *stringtype, *runestringtype;
- fltype_t *builtintype;
-
- uint32_t gensym_ctr;
- // two static buffers for gensym printing so there can be two
- // gensym names available at a time, mostly for compare()
- char gsname[2][16];
- int gsnameno;
-
- bool loading;
- bool exiting;
- bool grew;
-
- uint32_t *consflags;
- size_t gccalls;
-
- htable_t printconses;
- uint32_t printlabel;
- int print_pretty;
- int print_princ;
- fixnum_t print_length;
- fixnum_t print_level;
- fixnum_t p_level;
- int scr_width;
- ssize_t hpos, vpos;
-
- htable_t reverse_dlsym_lookup_table;
- htable_t TypeTable;
- int ngchandles;
- value_t *gchandles[N_GC_HANDLES];
-};
-
-extern fl_thread(Fl *fl);
-#define FL(f) fl->f
-
-extern value_t FL_builtins_table_sym, FL_quote, FL_lambda, FL_function, FL_comma, FL_commaat;
-extern value_t FL_commadot, FL_trycatch, FL_backquote;
-extern value_t FL_conssym, FL_symbolsym, FL_fixnumsym, FL_vectorsym, FL_builtinsym, FL_vu8sym;
-extern value_t FL_defsym, FL_defmacrosym, FL_forsym, FL_setqsym;
-extern value_t FL_booleansym, FL_nullsym, FL_evalsym, FL_fnsym;
-extern value_t FL_nulsym, FL_alarmsym, FL_backspacesym, FL_tabsym, FL_linefeedsym, FL_newlinesym;
-extern value_t FL_vtabsym, FL_pagesym, FL_returnsym, FL_escsym, FL_spacesym, FL_deletesym;
-extern value_t FL_IOError, FL_ParseError, FL_TypeError, FL_ArgError, FL_MemoryError;
-extern value_t FL_DivideError, FL_BoundsError, FL_Error, FL_KeyError, FL_UnboundError;
-
-extern value_t FL_printwidthsym, FL_printreadablysym, FL_printprettysym, FL_printlengthsym;
-extern value_t FL_printlevelsym;
-extern value_t FL_arraysym;
-extern value_t FL_iostreamsym, FL_rdsym, FL_wrsym, FL_apsym, FL_crsym, FL_truncsym;
-extern value_t FL_instrsym, FL_outstrsym;
-extern value_t FL_int8sym, FL_uint8sym, FL_int16sym, FL_uint16sym, FL_int32sym, FL_uint32sym;
-extern value_t FL_int64sym, FL_uint64sym, FL_bignumsym;
-extern value_t FL_bytesym, FL_runesym, FL_floatsym, FL_doublesym;
-extern value_t FL_stringtypesym, FL_runestringtypesym;
-
-_Noreturn void flmain(const uint8_t *boot, int bootsz, int argc, char **argv);
--- a/src/flmain.c
+++ /dev/null
@@ -1,145 +1,0 @@
-#include "flisp.h"
-#include "cvalues.h"
-#include "print.h"
-#include "iostream.h"
-#include "random.h"
-#include "brieflz.h"
-#include "nan.h"
-
-#if !defined(ARGBEGIN)
-/* straight from 9front */
-static char *argv0 = nil;
-#define ARGBEGIN \
- for((argv0 ? 0 : (argv0=*argv)), argv++, argc--; argv[0] && argv[0][0]=='-' && argv[0][1]; argc--, argv++){ \- const char *_args, *_argt; \
- Rune _argc; \
- _args = &argv[0][1]; \
- if(_args[0]=='-' && _args[1]==0){ \- argc--; \
- argv++; \
- break; \
- }\
- _argc = 0; \
- while(*_args && (_args += chartorune(&_argc, _args))) \
- switch(_argc)
-#define ARGEND USED(_argt); USED(_argc); USED(_args);}USED(argv); USED(argc);
-#define ARGF() (_argt=_args, _args="", (*_argt? _argt: argv[1]? (argc--, *++argv): 0))
-#define ARGC() _argc
-#define EARGF(x) (_argt=_args, _args="", (*_argt? _argt: argv[1]? (argc--, *++argv): (x, (char*)0)))
-#endif
-
-static value_t
-argv_list(int argc, char **argv)
-{- int i;
- value_t lst = FL_nil, temp;
- fl_gc_handle(&lst);
- fl_gc_handle(&temp);
- for(i = argc-1; i >= 0; i--){- temp = cvalue_static_cstring(argv[i]);
- lst = fl_cons(temp, lst);
- }
- lst = fl_cons(cvalue_static_cstring(argv0), lst);
- fl_free_gc_handles(2);
- return lst;
-}
-
-static void
-sizesuffix(size_t *sz, char su)
-{- switch(tolower(su)){- case 'k':
- *sz *= 1024;
- break;
- case 'm':
- *sz *= 1024*1024;
- break;
- case 0:
- break;
- default:
- ios_printf(ios_stderr, "invalid size suffix '%c'\n", su);
- exit(1);
- }
-}
-
-_Noreturn static void
-usage(void)
-{- ios_printf(ios_stderr, "%s: [-H heapsize] [-S stacksize] ...\n", argv0);
- exit(0);
-}
-
-
-_Noreturn void
-flmain(const uint8_t *boot, int bootsz, int argc, char **argv)
-{- size_t heapsize = HEAP_SIZE0, stacksize = STACK_SIZE0;
- char *e;
-
- nan_init();
- randomize();
- ios_init_stdstreams();
- mpsetminbits(sizeof(fixnum_t)*8);
-
- ARGBEGIN{- case 'H':
- heapsize = strtoull(EARGF(usage()), &e, 0);
- sizesuffix(&heapsize, *e);
- break;
- case 'S':
- stacksize = strtoull(EARGF(usage()), &e, 0);
- sizesuffix(&stacksize, *e);
- break;
- case 'h':
- usage();
- default:
- break;
- }ARGEND
-
- if(fl_init(heapsize, stacksize) != 0){- ios_puts(ios_stderr, "init failed\n");
- exit(1);
- }
-
- value_t f = cvalue(FL(iostreamtype), (int)sizeof(ios_t));
- fl_gc_handle(&f);
- value_t args = argv_list(argc, argv);
- fl_gc_handle(&args);
- ios_t *s = value2c(ios_t*, f);
- uint8_t *unpacked = nil;
- if(boot[0] == 0){- uint32_t unpackedsz =
- boot[1]<<0 |
- boot[2]<<8 |
- boot[3]<<16|
- boot[4]<<24;
- unpacked = MEM_ALLOC(unpackedsz);
- unsigned long n = blz_depack_safe(boot+5, bootsz-5, unpacked, unpackedsz);
- if(n == BLZ_ERROR){- ios_puts(ios_stderr, "failed to unpack boot image\n");
- fl_exit(1);
- }
- boot = unpacked;
- bootsz = n;
- }
- ios_static_buffer(s, boot, bootsz);
-
- int r = 1;
- FL_TRY_EXTERN{- if(fl_load_system_image(f) == 0){- MEM_FREE(unpacked);
- s = value2c(ios_t*, f);
- fl_free_gc_handles(2);
- ios_close(s);
- fl_applyn(1, symbol_value(symbol("__start", false)), args);- r = 0;
- }
- }
- FL_CATCH_EXTERN_NO_RESTORE{- ios_puts(ios_stderr, "fatal error:\n");
- fl_print(ios_stderr, FL(lasterror));
- ios_putc(ios_stderr, '\n');
- break;
- }
- fl_exit(r);
-}
--- a/src/hashing.c
+++ b/src/hashing.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "hashing.h"
#include "spooky.h"
--- a/src/hashing.h
+++ b/src/hashing.h
@@ -1,5 +1,5 @@
#pragma once
-value_t inthash(value_t a) fl_constfn;
-uint32_t int64to32hash(uint64_t key) fl_constfn;
+value_t inthash(value_t a) sl_constfn;
+uint32_t int64to32hash(uint64_t key) sl_constfn;
uint64_t memhash(const char* buf, size_t n);
--- a/src/htable.c
+++ b/src/htable.c
@@ -2,11 +2,11 @@
functions common to all hash table instantiations
*/
-#include "flisp.h"
+#include "sl.h"
#include "htable.h"
#include "hashing.h"
-static fl_constfn value_t
+static sl_constfn value_t
nextipow2(value_t i)
{if(i == 0)
--- a/src/htable.h
+++ b/src/htable.h
@@ -9,7 +9,7 @@
// FIXME(sigrid): in a multithreaded environment this isn't enough
int i;
void *_space[HT_N_INLINE];
-}fl_aligned(8) htable_t;
+}sl_aligned(8) htable_t;
// define this to be an invalid key/value
#define HT_NOTFOUND ((void*)1)
--- a/src/htableh.inc
+++ b/src/htableh.inc
@@ -3,9 +3,9 @@
#include "htable.h"
#define HTPROT(HTNAME) \
-void *HTNAME##_get(htable_t *h, void *key) fl_purefn; \
+void *HTNAME##_get(htable_t *h, void *key) sl_purefn; \
void HTNAME##_put(htable_t *h, void *key, void *val); \
-bool HTNAME##_has(htable_t *h, void *key) fl_purefn; \
+bool HTNAME##_has(htable_t *h, void *key) sl_purefn; \
bool HTNAME##_remove(htable_t *h, void *key); \
void **HTNAME##_bp(htable_t *h, void *key);
--- a/src/ios.c
+++ b/src/ios.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "timefuncs.h"
#define MOST_OF(x) ((x) - ((x)>>4))
--- a/src/ios.h
+++ b/src/ios.h
@@ -54,7 +54,7 @@
uint8_t local[IOS_INLSIZE];
}ios_t;
-void *llt_memrchr(const void *s, int c, size_t n) fl_purefn;
+void *llt_memrchr(const void *s, int c, size_t n) sl_purefn;
/* low-level interface functions */
size_t ios_read(ios_t *s, void *dest, size_t n);
@@ -64,7 +64,7 @@
off_t ios_skip(ios_t *s, off_t offs); // relative seek
off_t ios_pos(ios_t *s); // get current position
int ios_trunc(ios_t *s, off_t size);
-bool ios_eof(ios_t *s) fl_purefn;
+bool ios_eof(ios_t *s) sl_purefn;
int ios_flush(ios_t *s);
void ios_close(ios_t *s);
void ios_free(ios_t *s);
@@ -92,8 +92,8 @@
/* high-level functions - output */
int ios_pututf8(ios_t *s, Rune r);
-int ios_printf(ios_t *s, const char *format, ...) fl_printfmt(2, 3);
-int ios_vprintf(ios_t *s, const char *format, va_list args) fl_printfmt(2, 0);
+int ios_printf(ios_t *s, const char *format, ...) sl_printfmt(2, 3);
+int ios_vprintf(ios_t *s, const char *format, va_list args) sl_printfmt(2, 0);
void hexdump(ios_t *dest, const uint8_t *buffer, size_t len, size_t startoffs);
--- a/src/iostream.c
+++ b/src/iostream.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "cvalues.h"
#include "types.h"
#include "print.h"
@@ -9,12 +9,12 @@
print_iostream(value_t v, ios_t *f)
{ios_t *s = value2c(ios_t*, v);
- fl_print_str(f, "#<io stream");
+ sl_print_str(f, "#<io stream");
if(*s->loc.filename){- fl_print_chr(f, ' ');
- fl_print_str(f, s->loc.filename);
+ sl_print_chr(f, ' ');
+ sl_print_str(f, s->loc.filename);
}
- fl_print_chr(f, '>');
+ sl_print_chr(f, '>');
}
static void
@@ -44,28 +44,28 @@
static int
isiostream(value_t v)
{- return iscvalue(v) && cv_class(ptr(v)) == FL(iostreamtype);
+ return iscvalue(v) && cv_class(ptr(v)) == SL(iostreamtype);
}
-fl_purefn
+sl_purefn
BUILTIN("iostream?", iostreamp) {argcount(nargs, 1);
- return isiostream(args[0]) ? FL_t : FL_nil;
+ return isiostream(args[0]) ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("eof-object?", eof_objectp) {argcount(nargs, 1);
- return args[0] == FL_eof ? FL_t : FL_nil;
+ return args[0] == SL_eof ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
ios_t *
toiostream(value_t v)
{- if(fl_unlikely(!isiostream(v)))
+ if(sl_unlikely(!isiostream(v)))
type_error("iostream", v);return value2c(ios_t*, v);
}
@@ -76,24 +76,24 @@
argcount(nargs, 1);
bool r = false, w = false, c = false, t = false, a = false;
for(int i = 1; i < nargs; i++){- if(args[i] == FL_rdsym)
+ if(args[i] == SL_rdsym)
r = 1;
- else if(args[i] == FL_wrsym)
+ else if(args[i] == SL_wrsym)
w = 1;
- else if(args[i] == FL_apsym)
+ else if(args[i] == SL_apsym)
a = w = 1;
- else if(args[i] == FL_crsym)
+ else if(args[i] == SL_crsym)
c = w = 1;
- else if(args[i] == FL_truncsym)
+ else if(args[i] == SL_truncsym)
t = w = 1;
}
if(!r && !w && !c && !t && !a)
r = true; // default to reading
- value_t f = cvalue(FL(iostreamtype), sizeof(ios_t));
+ value_t f = cvalue(SL(iostreamtype), sizeof(ios_t));
char *fname = tostring(args[0]);
ios_t *s = value2c(ios_t*, f);
if(ios_file(s, fname, r, w, c, t) == nil)
- lerrorf(FL_IOError, "could not open \"%s\"", fname);
+ lerrorf(SL_IOError, "could not open \"%s\"", fname);
if(a)
ios_seek_end(s);
return f;
@@ -103,10 +103,10 @@
{argcount(nargs, 0);
USED(args);
- value_t f = cvalue(FL(iostreamtype), sizeof(ios_t));
+ value_t f = cvalue(SL(iostreamtype), sizeof(ios_t));
ios_t *s = value2c(ios_t*, f);
if(ios_mem(s, 0) == nil)
- lerrorf(FL_MemoryError, "could not allocate stream");
+ lerrorf(SL_MemoryError, "could not allocate stream");
return f;
}
@@ -114,11 +114,11 @@
{if(nargs > 1)
argcount(nargs, 1);
- value_t a = nargs == 0 ? symbol_value(FL_instrsym) : args[0];
- fl_gc_handle(&a);
- value_t v = fl_read_sexpr(a);
- fl_free_gc_handles(1);
- return ios_eof(toiostream(a)) ? FL_eof : v;
+ value_t a = nargs == 0 ? symbol_value(SL_instrsym) : args[0];
+ sl_gc_handle(&a);
+ value_t v = sl_read_sexpr(a);
+ sl_free_gc_handles(1);
+ return ios_eof(toiostream(a)) ? SL_eof : v;
}
BUILTIN("io-getc", io_getc)@@ -128,10 +128,10 @@
Rune r;
int res;
if((res = ios_getutf8(s, &r)) == IOS_EOF)
- //lerrorf(FL_IOError, "end of file reached");
- return FL_eof;
+ //lerrorf(SL_IOError, "end of file reached");
+ return SL_eof;
if(res == 0)
- lerrorf(FL_IOError, "invalid UTF-8 sequence");
+ lerrorf(SL_IOError, "invalid UTF-8 sequence");
return mk_rune(r);
}
@@ -142,10 +142,10 @@
ios_t *s = toiostream(args[0]);
int r = ios_wait(s, nargs > 1 ? todouble(args[1]) : -1);
if(r >= 0)
- return r ? FL_t : FL_nil;
+ return r ? SL_t : SL_nil;
if(r == IOS_EOF)
- return FL_eof;
- lerrorf(FL_IOError, "i/o error");
+ return SL_eof;
+ lerrorf(SL_IOError, "i/o error");
}
BUILTIN("io-putc", io_putc)@@ -153,7 +153,7 @@
argcount(nargs, 2);
ios_t *s = toiostream(args[0]);
cprim_t *cp = ptr(args[1]);
- if(!iscprim(args[1]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[1]) || cp_class(cp) != SL(runetype))
type_error("rune", args[1]);Rune r = *(Rune*)cp_data(cp);
return fixnum(ios_pututf8(s, r));
@@ -166,7 +166,7 @@
off_t off = tooffset(args[1]);
off_t res = ios_skip(s, off);
if(res < 0)
- return FL_nil;
+ return SL_nil;
return sizeof(res) == sizeof(int64_t) ? mk_int64(res) : mk_int32(res);
}
@@ -173,7 +173,7 @@
BUILTIN("io-flush", io_flush) {argcount(nargs, 1);
- return ios_flush(toiostream(args[0])) == 0 ? FL_t : FL_nil;
+ return ios_flush(toiostream(args[0])) == 0 ? SL_t : SL_nil;
}
BUILTIN("io-close", io_close)@@ -180,7 +180,7 @@
{argcount(nargs, 1);
ios_close(toiostream(args[0]));
- return FL_void;
+ return SL_void;
}
BUILTIN("io-truncate", io_truncate)@@ -188,8 +188,8 @@
argcount(nargs, 2);
ios_t *s = toiostream(args[0]);
if(ios_trunc(s, tooffset(args[1])) < 0)
- lerrorf(FL_IOError, "truncation failed");
- return FL_void;
+ lerrorf(SL_IOError, "truncation failed");
+ return SL_void;
}
BUILTIN("io-discardbuffer", io_discardbuffer)@@ -196,14 +196,14 @@
{argcount(nargs, 1);
ios_purge(toiostream(args[0]));
- return FL_void;
+ return SL_void;
}
-fl_purefn
+sl_purefn
BUILTIN("io-eof?", io_eofp) {argcount(nargs, 1);
- return ios_eof(toiostream(args[0])) ? FL_t : FL_nil;
+ return ios_eof(toiostream(args[0])) ? SL_t : SL_nil;
}
BUILTIN("io-seek", io_seek)@@ -213,8 +213,8 @@
size_t pos = tosize(args[1]);
off_t res = ios_seek(s, (off_t)pos);
if(res < 0)
- return FL_nil;
- return FL_t;
+ return SL_nil;
+ return SL_t;
}
BUILTIN("io-pos", io_pos)@@ -223,7 +223,7 @@
ios_t *s = toiostream(args[0]);
off_t res = ios_pos(s);
if(res < 0)
- return FL_nil;
+ return SL_nil;
return size_wrap((size_t)res);
}
@@ -232,8 +232,8 @@
if(nargs < 1 || nargs > 2)
argcount(nargs, 1);
ios_t *s;
- s = nargs == 2 ? toiostream(args[1]) : toiostream(symbol_value(FL_outstrsym));
- fl_print(s, args[0]);
+ s = nargs == 2 ? toiostream(args[1]) : toiostream(symbol_value(SL_outstrsym));
+ sl_print(s, args[0]);
return args[0];
}
@@ -243,7 +243,7 @@
argcount(nargs, 2);
ios_t *s = toiostream(args[0]);
size_t n;
- fltype_t *ft;
+ sltype_t *ft;
if(nargs == 3){// form (io.read s type count)
ft = get_array_type(args[1]);
@@ -251,7 +251,7 @@
}else{ft = get_type(args[1]);
if(ft->eltype != nil && !iscons(cdr_(cdr_(args[1]))))
- lerrorf(FL_ArgError, "incomplete type");
+ lerrorf(SL_ArgError, "incomplete type");
n = ft->size;
}
value_t cv = cvalue(ft, n);
@@ -258,8 +258,8 @@
uint8_t *data = cptr(cv);
size_t got = ios_read(s, data, n);
if(got < n)
- //lerrorf(FL_IOError, "end of input reached");
- return FL_eof;
+ //lerrorf(SL_IOError, "end of input reached");
+ return SL_eof;
return cv;
}
@@ -282,9 +282,9 @@
ios_t *s = toiostream(args[0]);
value_t v = args[1];
cprim_t *cp = ptr(v);
- if(iscprim(args[1]) && cp_class(cp) == FL(runetype)){+ if(iscprim(args[1]) && cp_class(cp) == SL(runetype)){if(nargs > 2)
- lerrorf(FL_ArgError, "offset argument not supported for characters");
+ lerrorf(SL_ArgError, "offset argument not supported for characters");
Rune r = *(Rune*)cp_data(ptr(args[1]));
return fixnum(ios_pututf8(s, r));
}
@@ -305,8 +305,8 @@
size_t uldelim = tosize(arg);
if(uldelim > 0x7f){// runes > 0x7f, or anything else > 0xff, are out of range
- if((iscprim(arg) && cp_class(ptr(arg)) == FL(runetype)) || uldelim > 0xff)
- lerrorf(FL_ArgError, "delimiter out of range");
+ if((iscprim(arg) && cp_class(ptr(arg)) == SL(runetype)) || uldelim > 0xff)
+ lerrorf(SL_ArgError, "delimiter out of range");
}
return (uint8_t)uldelim;
}
@@ -333,7 +333,7 @@
((uint8_t*)cv->data)[n] = 0;
}
if(n == 0 && ios_eof(src))
- return FL_eof;
+ return SL_eof;
return str;
}
@@ -413,9 +413,9 @@
}else{uint8_t *b = ios_takebuf(st, &n); n--;
if(n == 0)
- return FL(the_empty_string);
+ return SL(the_empty_string);
b[n] = '\0';
- str = cvalue_from_ref(FL(stringtype), b, n);
+ str = cvalue_from_ref(SL(stringtype), b, n);
cv_autorelease(ptr(str));
}
return str;
@@ -426,11 +426,11 @@
argcount(nargs, 1);
ios_t *src = toiostream(args[0]);
if(src->bm != bm_mem)
- lerrorf(FL_ArgError, "requires memory stream");
+ lerrorf(SL_ArgError, "requires memory stream");
bool eof = ios_eof(src);
value_t v = stream_to_string(&args[0]);
- if(eof && v == FL(the_empty_string))
- v = FL_eof;
+ if(eof && v == SL(the_empty_string))
+ v = SL_eof;
return v;
}
@@ -437,16 +437,16 @@
void
iostream_init(void)
{- FL_iostreamsym = csymbol("iostream");- FL_rdsym = csymbol(":read");- FL_wrsym = csymbol(":write");- FL_apsym = csymbol(":append");- FL_crsym = csymbol(":create");- FL_truncsym = csymbol(":truncate");- FL_instrsym = csymbol("*input-stream*");- FL_outstrsym = csymbol("*output-stream*");- FL(iostreamtype) = define_opaque_type(FL_iostreamsym, sizeof(ios_t), &iostream_vtable, nil);
- set(csymbol("*stdout*"), cvalue_from_ref(FL(iostreamtype), ios_stdout, sizeof(ios_t)));- set(csymbol("*stderr*"), cvalue_from_ref(FL(iostreamtype), ios_stderr, sizeof(ios_t)));- set(csymbol("*stdin*"), cvalue_from_ref(FL(iostreamtype), ios_stdin, sizeof(ios_t)));+ SL_iostreamsym = csymbol("iostream");+ SL_rdsym = csymbol(":read");+ SL_wrsym = csymbol(":write");+ SL_apsym = csymbol(":append");+ SL_crsym = csymbol(":create");+ SL_truncsym = csymbol(":truncate");+ SL_instrsym = csymbol("*input-stream*");+ SL_outstrsym = csymbol("*output-stream*");+ SL(iostreamtype) = define_opaque_type(SL_iostreamsym, sizeof(ios_t), &iostream_vtable, nil);
+ set(csymbol("*stdout*"), cvalue_from_ref(SL(iostreamtype), ios_stdout, sizeof(ios_t)));+ set(csymbol("*stderr*"), cvalue_from_ref(SL(iostreamtype), ios_stderr, sizeof(ios_t)));+ set(csymbol("*stdin*"), cvalue_from_ref(SL(iostreamtype), ios_stdin, sizeof(ios_t)));}
--- a/src/macos/femtolispm68k.r
+++ /dev/null
@@ -1,22 +1,0 @@
-#include "Retro68APPL.r"
-
-resource 'SIZE' (-1) {- reserved,
- ignoreSuspendResumeEvents,
- reserved,
- cannotBackground,
- needsActivateOnFGSwitch,
- backgroundAndForeground,
- dontGetFrontClicks,
- ignoreChildDiedEvents,
- is32BitCompatible,
- notHighLevelEventAware,
- onlyLocalHLEvents,
- notStationeryAware,
- dontUseTextEditServices,
- reserved,
- reserved,
- reserved,
- 4 * 1024 * 1024,
- 1 * 1024 * 1024
-};
--- a/src/macos/femtolispppc.r
+++ /dev/null
@@ -1,22 +1,0 @@
-#include "RetroPPCAPPL.r"
-
-resource 'SIZE' (-1) {- reserved,
- ignoreSuspendResumeEvents,
- reserved,
- cannotBackground,
- needsActivateOnFGSwitch,
- backgroundAndForeground,
- dontGetFrontClicks,
- ignoreChildDiedEvents,
- is32BitCompatible,
- notHighLevelEventAware,
- onlyLocalHLEvents,
- notStationeryAware,
- dontUseTextEditServices,
- reserved,
- reserved,
- reserved,
- 16 * 1024 * 1024,
- 8 * 1024 * 1024
-};
--- /dev/null
+++ b/src/macos/m68k.r
@@ -1,0 +1,22 @@
+#include "Retro68APPL.r"
+
+resource 'SIZE' (-1) {+ reserved,
+ ignoreSuspendResumeEvents,
+ reserved,
+ cannotBackground,
+ needsActivateOnFGSwitch,
+ backgroundAndForeground,
+ dontGetFrontClicks,
+ ignoreChildDiedEvents,
+ is32BitCompatible,
+ notHighLevelEventAware,
+ onlyLocalHLEvents,
+ notStationeryAware,
+ dontUseTextEditServices,
+ reserved,
+ reserved,
+ reserved,
+ 4 * 1024 * 1024,
+ 1 * 1024 * 1024
+};
--- a/src/macos/platform.h
+++ b/src/macos/platform.h
@@ -34,8 +34,8 @@
#define USED(x) ((void)(x))
#define nelem(x) (int)(sizeof(x)/sizeof((x)[0]))
-#define fl_setjmp(e) setjmp((e))
-#define fl_longjmp(e, v) longjmp((e), (v))
+#define sl_setjmp(e) setjmp((e))
+#define sl_longjmp(e, v) longjmp((e), (v))
#define PATHSEP '/'
#define PATHSEPSTRING "/"
--- /dev/null
+++ b/src/macos/ppc.r
@@ -1,0 +1,22 @@
+#include "RetroPPCAPPL.r"
+
+resource 'SIZE' (-1) {+ reserved,
+ ignoreSuspendResumeEvents,
+ reserved,
+ cannotBackground,
+ needsActivateOnFGSwitch,
+ backgroundAndForeground,
+ dontGetFrontClicks,
+ ignoreChildDiedEvents,
+ is32BitCompatible,
+ notHighLevelEventAware,
+ onlyLocalHLEvents,
+ notStationeryAware,
+ dontUseTextEditServices,
+ reserved,
+ reserved,
+ reserved,
+ 16 * 1024 * 1024,
+ 8 * 1024 * 1024
+};
--- a/src/macos/sys.c
+++ b/src/macos/sys.c
@@ -1,5 +1,5 @@
#include <OSUtils.h>
-#include "flisp.h"
+#include "sl.h"
#include "timefuncs.h"
double
@@ -74,7 +74,7 @@
char os_version[10];
static const uint8_t boot[] = {-#include "flisp.boot.h"
+#include "sl.boot.h"
};
int
@@ -90,5 +90,5 @@
(r.systemVersion>>4)&0xf,
(r.systemVersion>>0)&0xf
);
- flmain(boot, sizeof(boot), argc, argv);
+ slmain(boot, sizeof(boot), argc, argv);
}
--- a/src/math.c
+++ b/src/math.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "cvalues.h"
#define BUILTIN_(lname, cname) \
--- a/src/mem.c
+++ b/src/mem.c
@@ -4,8 +4,8 @@
#include "platform.h"
#define HAVE_MORECORE 1
-#define MORECORE fl_sbrk
-static void *fl_sbrk(intptr_t increment);
+#define MORECORE sl_sbrk
+static void *sl_sbrk(intptr_t increment);
#define MORECORE_CONTIGUOUS 0
#define MORECORE_CANNOT_TRIM 1
#define NO_SEGMENT_TRAVERSAL 1
@@ -26,31 +26,31 @@
#include "dlmalloc.inc"
void *
-fl_malloc(size_t size)
+sl_malloc(size_t size)
{return dlmalloc(size);
}
void
-fl_free(void *p)
+sl_free(void *p)
{dlfree(p);
}
void *
-fl_calloc(size_t n, size_t size)
+sl_calloc(size_t n, size_t size)
{return dlcalloc(n, size);
}
void *
-fl_realloc(void *p, size_t size)
+sl_realloc(void *p, size_t size)
{return dlrealloc(p, size);
}
char *
-fl_strdup(const char *s)
+sl_strdup(const char *s)
{size_t sz = strlen(s)+1;
char *p = dlmalloc(sz);
@@ -60,7 +60,7 @@
#if defined(__macos__)
static void *
-fl_sbrk(intptr_t increment)
+sl_sbrk(intptr_t increment)
{static char *e = nil;
if(increment == 0)
@@ -74,7 +74,7 @@
}
#else
static void *
-fl_sbrk(intptr_t increment)
+sl_sbrk(intptr_t increment)
{return sbrk(increment);
}
--- a/src/mem.h
+++ b/src/mem.h
@@ -11,18 +11,18 @@
#endif
#if defined(USE_DLMALLOC)
-void *fl_malloc(size_t);
-void fl_free(void *);
-void *fl_calloc(size_t, size_t);
-void *fl_realloc(void *, size_t);
-char *fl_strdup(const char *s);
-#define MEM_CALLOC(n, sz) fl_calloc((size_t)(n), (size_t)(sz))
-#define MEM_ALLOC(n) fl_malloc((size_t)(n))
-#define MEM_REALLOC(p, n) fl_realloc((p), (size_t)(n))
-#define MEM_FREE(x) fl_free(x)
-#define MEM_STRDUP(s) fl_strdup(s)
-#define fl_segalloc(sz) MEM_ALLOC((size_t)sz)
-#define fl_segfree(s, sz) MEM_FREE(s)
+void *sl_malloc(size_t);
+void sl_free(void *);
+void *sl_calloc(size_t, size_t);
+void *sl_realloc(void *, size_t);
+char *sl_strdup(const char *s);
+#define MEM_CALLOC(n, sz) sl_calloc((size_t)(n), (size_t)(sz))
+#define MEM_ALLOC(n) sl_malloc((size_t)(n))
+#define MEM_REALLOC(p, n) sl_realloc((p), (size_t)(n))
+#define MEM_FREE(x) sl_free(x)
+#define MEM_STRDUP(s) sl_strdup(s)
+#define sl_segalloc(sz) MEM_ALLOC((size_t)sz)
+#define sl_segfree(s, sz) MEM_FREE(s)
#else
#define MEM_CALLOC(n, sz) calloc((size_t)(n), (size_t)(sz))
#define MEM_ALLOC(n) malloc((size_t)(n))
@@ -29,6 +29,6 @@
#define MEM_REALLOC(p, n) realloc((p), (size_t)(n))
#define MEM_FREE(x) free(x)
#define MEM_STRDUP(s) strdup(s)
-void *fl_segalloc(size_t sz);
-void fl_segfree(void *s, size_t sz);
+void *sl_segalloc(size_t sz);
+void sl_segfree(void *s, size_t sz);
#endif
--- a/src/opcodes.c
+++ b/src/opcodes.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
const Builtin builtins[N_OPCODES] = { [OP_NANP] = {"nan?", 1},--- a/src/operators.c
+++ b/src/operators.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "operators.h"
mpint *
@@ -20,7 +20,7 @@
return mpzero;
}
-fl_purefn
+sl_purefn
double
conv_to_double(void *data, numerictype_t tag)
{@@ -47,7 +47,7 @@
// FIXME sign with mpint
#define CONV_TO_INTTYPE(name, ctype) \
-fl_purefn \
+sl_purefn \
ctype \
conv_to_##name(void *data, numerictype_t tag) \
{ \@@ -74,7 +74,7 @@
// this is needed to work around an UB casting negative
// floats and doubles to uint64. you need to cast to int64
// first.
-fl_purefn
+sl_purefn
uint64_t
conv_to_uint64(void *data, numerictype_t tag)
{@@ -103,7 +103,7 @@
return 0;
}
-fl_purefn
+sl_purefn
bool
cmp_same_lt(void *a, void *b, numerictype_t tag)
{@@ -123,7 +123,7 @@
return false;
}
-fl_purefn
+sl_purefn
bool
cmp_same_eq(void *a, void *b, numerictype_t tag)
{--- a/src/plan9/clz.c
+++ b/src/plan9/clz.c
@@ -1,7 +1,7 @@
#include "platform.h"
int
-fl_clz(uint32_t x)
+sl_clz(uint32_t x)
{uint32_t r;
if(x == 0)
--- a/src/plan9/clz_amd64.s
+++ b/src/plan9/clz_amd64.s
@@ -1,4 +1,4 @@
-TEXT fl_clz(SB),1,$0
+TEXT sl_clz(SB),1,$0
BYTE $0x0F; BYTE $0xBD; BYTE $0xC5 /* BSRL RARG, AX */
XORL $31, AX
RET
--- a/src/plan9/clz_arm64.s
+++ b/src/plan9/clz_arm64.s
@@ -1,3 +1,3 @@
-TEXT fl_clz(SB),1,$0
+TEXT sl_clz(SB),1,$0
CLZW R0, R0
RETURN
--- a/src/plan9/platform.h
+++ b/src/plan9/platform.h
@@ -22,11 +22,11 @@
#define __os_name__ "plan9"
-int fl_popcount(unsigned int w);
-int fl_clz(unsigned int x);
+int sl_popcount(unsigned int w);
+int sl_clz(unsigned int x);
-#define fl_setjmp(e) setjmp((e))
-#define fl_longjmp(e, v) longjmp((e), (v))
+#define sl_setjmp(e) setjmp((e))
+#define sl_longjmp(e, v) longjmp((e), (v))
extern double D_PNAN, D_PINF;
--- a/src/plan9/popcount.c
+++ b/src/plan9/popcount.c
@@ -1,7 +1,7 @@
#include "platform.h"
int
-fl_popcount(unsigned int w)
+sl_popcount(unsigned int w)
{w -= (w >> 1) & 0x55555555U;
w = (w & 0x33333333U) + ((w >> 2) & 0x33333333U);
--- a/src/plan9/sys.c
+++ b/src/plan9/sys.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "timefuncs.h"
#include <tos.h>
@@ -16,13 +16,13 @@
}
void *
-fl_segalloc(size_t sz)
+sl_segalloc(size_t sz)
{return segattach(SG_CEXEC, "memory", nil, sz);
}
void
-fl_segfree(void *s, size_t sz)
+sl_segfree(void *s, size_t sz)
{USED(sz);
segdetach(s);
@@ -105,5 +105,5 @@
tmfmtinstall();
D_PNAN = strtod("+NaN", nil); D_PINF = strtod("+Inf", nil);- flmain(bootcode, bootlen, argc, argv);
+ slmain(bootcode, bootlen, argc, argv);
}
--- a/src/posix/platform.h
+++ b/src/posix/platform.h
@@ -61,8 +61,8 @@
#endif
#endif
-#define fl_setjmp(e) sigsetjmp((e), 0)
-#define fl_longjmp(e, v) siglongjmp((e), (v))
+#define sl_setjmp(e) sigsetjmp((e), 0)
+#define sl_longjmp(e, v) siglongjmp((e), (v))
#define nil NULL
#define USED(x) ((void)(x))
--- a/src/posix/sys.c
+++ b/src/posix/sys.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "timefuncs.h"
#include <sys/mman.h>
@@ -6,7 +6,7 @@
#define PAGEALIGNED(x) (((x) + pagesize-1) & ~(pagesize-1))
void *
-fl_segalloc(size_t sz)
+sl_segalloc(size_t sz)
{sz = PAGEALIGNED(sz);
void *s = mmap(nil, sz, PROT_READ|PROT_WRITE, MAP_ANONYMOUS|MAP_PRIVATE, -1, 0);
@@ -16,7 +16,7 @@
}
void
-fl_segfree(void *s, size_t sz)
+sl_segfree(void *s, size_t sz)
{sz = PAGEALIGNED(sz);
if(munmap(s, sz) != 0)
@@ -91,7 +91,7 @@
}
static const uint8_t boot[] = {-#include "flisp.boot.h"
+#include "sl.boot.h"
};
char *os_version;
@@ -106,5 +106,5 @@
long p = sysconf(_SC_PAGE_SIZE);
if(p > 0)
pagesize = p;
- flmain(boot, sizeof(boot), argc, argv);
+ slmain(boot, sizeof(boot), argc, argv);
}
--- a/src/print.c
+++ b/src/print.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "ieee754.h"
@@ -12,9 +12,9 @@
{ios_putc(f, c);
if(c == '\n')
- FL(hpos) = 0;
+ SL(hpos) = 0;
else
- FL(hpos)++;
+ SL(hpos)++;
}
static inline void
@@ -23,7 +23,7 @@
ios_write(f, s, n);
ssize_t w = u8_strwidth(s, n);
if(w > 0)
- FL(hpos) += w;
+ SL(hpos) += w;
}
static inline void
@@ -36,12 +36,12 @@
outindent(ios_t *f, int n)
{// move back to left margin if we get too indented
- if(n > FL(scr_width)-12)
+ if(n > SL(scr_width)-12)
n = 2;
int n0 = n;
ios_putc(f, '\n');
- FL(vpos)++;
- FL(hpos) = n;
+ SL(vpos)++;
+ SL(hpos) = n;
while(n >= 8){ios_putc(f, '\t');
n -= 8;
@@ -54,13 +54,13 @@
}
void
-fl_print_chr(ios_t *f, char c)
+sl_print_chr(ios_t *f, char c)
{outc(f, c);
}
void
-fl_print_str(ios_t *f, const char *s)
+sl_print_str(ios_t *f, const char *s)
{outs(f, s);
}
@@ -71,9 +71,9 @@
value_t *bp;
while(iscons(v)){ if(ismarked(v)){- bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
+ bp = (value_t*)ptrhash_bp(&SL(printconses), (void*)v);
if(*bp == (value_t)HT_NOTFOUND)
- *bp = fixnum(FL(printlabel)++);
+ *bp = fixnum(SL(printlabel)++);
return;
}
mark_cons(v);
@@ -83,9 +83,9 @@
if(!ismanaged(v) || issymbol(v))
return;
if(ismarked(v)){- bp = (value_t*)ptrhash_bp(&FL(printconses), (void*)v);
+ bp = (value_t*)ptrhash_bp(&SL(printconses), (void*)v);
if(*bp == (value_t)HT_NOTFOUND)
- *bp = fixnum(FL(printlabel)++);
+ *bp = fixnum(SL(printlabel)++);
return;
}
if(isvector(v)){@@ -107,7 +107,7 @@
// don't consider shared references to ""
if(!cv_isstr(cv) || cv_len(cv) != 0)
mark_cons(v);
- fltype_t *t = cv_class(cv);
+ sltype_t *t = cv_class(cv);
if(t->vtable != nil && t->vtable->print_traverse != nil)
t->vtable->print_traverse(v);
}
@@ -122,7 +122,7 @@
if((name[0] == '\0') ||
(name[0] == '.' && name[1] == '\0') ||
(name[0] == '#') ||
- fl_read_numtok(name, nil, 0))
+ sl_read_numtok(name, nil, 0))
escape = true;
i = 0;
while(name[i]){@@ -173,11 +173,11 @@
const char *s = symbol_name(v);
return u8_strwidth(s, strlen(s)) < SMALL_STR_LEN;
}
- if(fl_isstring(v))
+ if(sl_isstring(v))
return cv_len(ptr(v)) < SMALL_STR_LEN;
return (
isfixnum(v) || isbuiltin(v) || iscprim(v) ||
- v == FL_t || v == FL_nil || v == FL_eof || v == FL_void
+ v == SL_t || v == SL_nil || v == SL_eof || v == SL_void
);
}
@@ -186,11 +186,11 @@
{if(tinyp(v))
return true;
- if(fl_isnumber(v))
+ if(sl_isnumber(v))
return true;
if(iscons(v)){if(tinyp(car_(v)) &&
- (tinyp(cdr_(v)) || (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) && cdr_(cdr_(v)) == FL_nil)))
+ (tinyp(cdr_(v)) || (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) && cdr_(cdr_(v)) == SL_nil)))
return true;
return false;
}
@@ -208,8 +208,8 @@
specialindent(value_t head)
{// indent these forms 2 spaces, not lined up with the first argument
- if(head == FL_lambda || head == FL_trycatch || head == FL_defsym ||
- head == FL_defmacrosym || head == FL_forsym)
+ if(head == SL_lambda || head == SL_trycatch || head == SL_defsym ||
+ head == SL_defmacrosym || head == SL_forsym)
return 2;
return -1;
}
@@ -222,7 +222,7 @@
const char *s = symbol_name(v);
return u8_strwidth(s, strlen(s));
}
- if(iscprim(v) && ptr(v) != nil && cp_class(ptr(v)) == FL(runetype))
+ if(iscprim(v) && ptr(v) != nil && cp_class(ptr(v)) == SL(runetype))
return 4;
return -1;
}
@@ -246,7 +246,7 @@
indentafter3(value_t head, value_t v)
{// for certain X always indent (X a b c) after b
- return head == FL_forsym && !allsmallp(cdr_(v));
+ return head == SL_forsym && !allsmallp(cdr_(v));
}
static int
@@ -253,7 +253,7 @@
indentafter2(value_t head, value_t v)
{// for certain X always indent (X a b) after a
- return (head == FL_defsym || head == FL_defmacrosym) && !allsmallp(cdr_(v));
+ return (head == SL_defsym || head == SL_defmacrosym) && !allsmallp(cdr_(v));
}
static bool
@@ -262,9 +262,9 @@
// indent before every subform of a special form, unless every
// subform is "small"
value_t c = car_(v);
- if(c == FL_lambda || c == FL_setqsym)
+ if(c == SL_lambda || c == SL_setqsym)
return false;
- //if(c == FL(IF)) // TODO: others
+ //if(c == SL(IF)) // TODO: others
// return !allsmallp(cdr_(v));
return false;
}
@@ -284,23 +284,23 @@
{value_t cd;
const char *op;
- if(iscons(cdr_(v)) && cdr_(cdr_(v)) == FL_nil &&
- !ptrhash_has(&FL(printconses), (void*)cdr_(v)) &&
- ((car_(v) == FL_quote && (op = "'")) ||
- (car_(v) == FL_backquote && (op = "`")) ||
- (car_(v) == FL_comma && (op = ",")) ||
- (car_(v) == FL_commaat && (op = ",@")) ||
- (car_(v) == FL_commadot && (op = ",.")))){+ if(iscons(cdr_(v)) && cdr_(cdr_(v)) == SL_nil &&
+ !ptrhash_has(&SL(printconses), (void*)cdr_(v)) &&
+ ((car_(v) == SL_quote && (op = "'")) ||
+ (car_(v) == SL_backquote && (op = "`")) ||
+ (car_(v) == SL_comma && (op = ",")) ||
+ (car_(v) == SL_commaat && (op = ",@")) ||
+ (car_(v) == SL_commadot && (op = ",.")))){// special prefix syntax
unmark_cons(v);
unmark_cons(cdr_(v));
outs(f, op);
- fl_print_child(f, car_(cdr_(v)));
+ sl_print_child(f, car_(cdr_(v)));
return;
}
- int startpos = FL(hpos);
+ int startpos = SL(hpos);
outc(f, '(');- int newindent = FL(hpos);
+ int newindent = SL(hpos);
int lastv, n = 0, si, ind, est, nextsmall, thistiny;
bool always = false, blk = blockindent(v);
if(!blk)
@@ -311,24 +311,24 @@
int n_unindented = 1;
while(1){cd = cdr_(v);
- if(FL(print_length) >= 0 && n >= FL(print_length) && cd != FL_nil){+ if(SL(print_length) >= 0 && n >= SL(print_length) && cd != SL_nil){outsn(f, "...)", 4);
break;
}
- lastv = FL(vpos);
+ lastv = SL(vpos);
unmark_cons(v);
- fl_print_child(f, car_(v));
- if(!iscons(cd) || ptrhash_has(&FL(printconses), (void*)cd)){- if(cd != FL_nil){+ sl_print_child(f, car_(v));
+ if(!iscons(cd) || ptrhash_has(&SL(printconses), (void*)cd)){+ if(cd != SL_nil){outsn(f, " . ", 3);
- fl_print_child(f, cd);
+ sl_print_child(f, cd);
}
outc(f, ')');
break;
}
- if(!FL(print_pretty) ||
- (head == FL_lambda && n == 0)){+ if(!SL(print_pretty) ||
+ (head == SL_lambda && n == 0)){// never break line before lambda-list
ind = 0;
}else{@@ -335,14 +335,14 @@
est = lengthestimate(car_(cd));
nextsmall = smallp(car_(cd));
thistiny = tinyp(car_(v));
- ind = ((FL(vpos) > lastv ||
- (FL(hpos)>FL(scr_width)/2 && !nextsmall && !thistiny && n>0)) ||
+ ind = ((SL(vpos) > lastv ||
+ (SL(hpos)>SL(scr_width)/2 && !nextsmall && !thistiny && n>0)) ||
- (FL(hpos) > FL(scr_width)-4) ||
+ (SL(hpos) > SL(scr_width)-4) ||
- (est != -1 && FL(hpos)+est > FL(scr_width)-2) ||
+ (est != -1 && SL(hpos)+est > SL(scr_width)-2) ||
- (head == FL_lambda && !nextsmall) ||
+ (head == SL_lambda && !nextsmall) ||
(n > 0 && always) ||
@@ -366,7 +366,7 @@
if(si != -1)
newindent = startpos + si;
else if(!blk)
- newindent = FL(hpos);
+ newindent = SL(hpos);
}
}
n++;
@@ -380,12 +380,12 @@
print_circle_prefix(ios_t *f, value_t v)
{value_t label;
- if((label = (value_t)ptrhash_get(&FL(printconses), (void*)v)) != (value_t)HT_NOTFOUND){+ if((label = (value_t)ptrhash_get(&SL(printconses), (void*)v)) != (value_t)HT_NOTFOUND){ if(!ismarked(v)){- FL(hpos) += ios_printf(f, "#%"PRIdPTR"#", (intptr_t)numval(label));
+ SL(hpos) += ios_printf(f, "#%"PRIdPTR"#", (intptr_t)numval(label));
return true;
}
- FL(hpos) += ios_printf(f, "#%"PRIdPTR"=", (intptr_t)numval(label));
+ SL(hpos) += ios_printf(f, "#%"PRIdPTR"=", (intptr_t)numval(label));
}
if(ismanaged(v))
unmark_cons(v);
@@ -393,22 +393,22 @@
}
void
-fl_print_child(ios_t *f, value_t v)
+sl_print_child(ios_t *f, value_t v)
{const char *name;
- if(FL(print_level) >= 0 && FL(p_level) >= FL(print_level) && (iscons(v) || isvector(v) || isfunction(v))){+ if(SL(print_level) >= 0 && SL(p_level) >= SL(print_level) && (iscons(v) || isvector(v) || isfunction(v))){outc(f, '#');
return;
}
- FL(p_level)++;
+ SL(p_level)++;
switch(tag(v)){case TAG_NUM: case TAG_NUM1:
- FL(hpos) += ios_printf(f, "%"PRIdFIXNUM, numval(v));
+ SL(hpos) += ios_printf(f, "%"PRIdFIXNUM, numval(v));
break;
case TAG_SYM:
name = symbol_name(v);
- if(FL(print_princ))
+ if(SL(print_princ))
outs(f, name);
else if(ismanaged(v)){outsn(f, "#:", 2);
@@ -417,21 +417,21 @@
print_symbol_name(f, name);
break;
case TAG_FUNCTION:
- if(v == FL_t)
+ if(v == SL_t)
outc(f, 'T');
- else if(v == FL_nil)
+ else if(v == SL_nil)
outsn(f, "NIL", 3);
- else if(v == FL_eof)
+ else if(v == SL_eof)
outsn(f, "#<eof>", 6);
- else if(v == FL_void){+ else if(v == SL_void){outsn(f, "#<void>", 7);
}else if(isbuiltin(v)){- if(!FL(print_princ))
+ if(!SL(print_princ))
outsn(f, "#.", 2);
outs(f, builtins[uintval(v)].name);
}else{assert(isfunction(v));
- if(!FL(print_princ)){+ if(!SL(print_princ)){if(print_circle_prefix(f, v))
break;
function_t *fn = ptr(v);
@@ -440,18 +440,18 @@
size_t i, sz = cvalue_len(fn->bcode);
for(i = 0; i < sz; i++)
data[i] += 48;
- fl_print_child(f, fn->bcode);
+ sl_print_child(f, fn->bcode);
for(i = 0; i < sz; i++)
data[i] -= 48;
outc(f, ' ');
- fl_print_child(f, fn->vals);
- if(fn->env != FL_nil){+ sl_print_child(f, fn->vals);
+ if(fn->env != SL_nil){outc(f, ' ');
- fl_print_child(f, fn->env);
+ sl_print_child(f, fn->env);
}
- if(fn->name != FL_lambda){+ if(fn->name != SL_lambda){outc(f, ' ');
- fl_print_child(f, fn->name);
+ sl_print_child(f, fn->name);
}
outc(f, ')');
}else{@@ -468,26 +468,26 @@
case TAG_CVALUE:
case TAG_VECTOR:
case TAG_CONS:
- if(!FL(print_princ) && print_circle_prefix(f, v))
+ if(!SL(print_princ) && print_circle_prefix(f, v))
break;
if(isvector(v)){ outs(f, "#(");- int newindent = FL(hpos), est;
+ int newindent = SL(hpos), est;
int i, sz = vector_size(v);
for(i = 0; i < sz; i++){- if(FL(print_length) >= 0 && i >= FL(print_length) && i < sz-1){+ if(SL(print_length) >= 0 && i >= SL(print_length) && i < sz-1){outsn(f, "...", 3);
break;
}
- fl_print_child(f, vector_elt(v, i));
+ sl_print_child(f, vector_elt(v, i));
if(i < sz-1){- if(!FL(print_pretty))
+ if(!SL(print_pretty))
outc(f, ' ');
else{est = lengthestimate(vector_elt(v, i+1));
- if(FL(hpos) > FL(scr_width)-4 ||
- (est != -1 && (FL(hpos)+est > FL(scr_width)-2)) ||
- (FL(hpos) > FL(scr_width)/2 && !smallp(vector_elt(v, i+1)) && !tinyp(vector_elt(v, i))))
+ if(SL(hpos) > SL(scr_width)-4 ||
+ (est != -1 && (SL(hpos)+est > SL(scr_width)-2)) ||
+ (SL(hpos) > SL(scr_width)/2 && !smallp(vector_elt(v, i+1)) && !tinyp(vector_elt(v, i))))
newindent = outindent(f, newindent);
else
outc(f, ' ');
@@ -503,7 +503,7 @@
print_cons(f, v);
break;
}
- FL(p_level)--;
+ SL(p_level)--;
}
static void
@@ -641,20 +641,20 @@
static void
cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, int weak)
{- if(type == FL_bytesym){+ if(type == SL_bytesym){uint8_t ch = *(uint8_t*)data;
- if(FL(print_princ))
+ if(SL(print_princ))
outc(f, ch);
else if(weak)
- FL(hpos) += ios_printf(f, "0x%hhx", ch);
+ SL(hpos) += ios_printf(f, "0x%hhx", ch);
else
- FL(hpos) += ios_printf(f, "#byte(0x%hhx)", ch);
- }else if(type == FL_runesym){+ SL(hpos) += ios_printf(f, "#byte(0x%hhx)", ch);
+ }else if(type == SL_runesym){Rune r = *(Rune*)data;
char seq[UTFmax+1];
int nb = runetochar(seq, &r);
seq[nb] = '\0';
- if(FL(print_princ)){+ if(SL(print_princ)){outsn(f, seq, nb);
}else{outsn(f, "#\\", 2);
@@ -671,18 +671,18 @@
case ' ': outsn(f, "space", 5); break;
case 0x7f: outsn(f, "delete", 6); break;
default:
- if(fl_iswprint(r))
+ if(sl_iswprint(r))
outs(f, seq);
else
- FL(hpos) += ios_printf(f, "x%04"PRIx32, r);
+ SL(hpos) += ios_printf(f, "x%04"PRIx32, r);
break;
}
}
- }else if(type == FL_floatsym || type == FL_doublesym){+ }else if(type == SL_floatsym || type == SL_doublesym){char buf[64];
double d;
int ndec;
- if(type == FL_floatsym){+ if(type == SL_floatsym){d = (double)*(float*)data;
ndec = 8;
}else{@@ -697,8 +697,8 @@
rep = signbit(d) ? "-nan.0" : "+nan.0";
else
rep = signbit(d) ? "-wtf.0" : "+wtf.0";
- if(type == FL_floatsym && !FL(print_princ) && !weak)
- FL(hpos) += ios_printf(f, "#%s(%s)", symbol_name(type), rep);
+ if(type == SL_floatsym && !SL(print_princ) && !weak)
+ SL(hpos) += ios_printf(f, "#%s(%s)", symbol_name(type), rep);
else
outs(f, rep);
}else if(d == 0){@@ -706,7 +706,7 @@
outsn(f, "-0.0", 4);
else
outsn(f, "0.0", 3);
- if(type == FL_floatsym && !FL(print_princ) && !weak)
+ if(type == SL_floatsym && !SL(print_princ) && !weak)
outc(f, 'f');
}else{snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
@@ -714,19 +714,19 @@
outs(f, buf);
if(!hasdec)
outsn(f, ".0", 2);
- if(type == FL_floatsym && !FL(print_princ) && !weak)
+ if(type == SL_floatsym && !SL(print_princ) && !weak)
outc(f, 'f');
}
- }else if(type == FL_uint64sym){+ }else if(type == SL_uint64sym){uint64_t ui64 = *(uint64_t*)data;
- if(weak || FL(print_princ))
- FL(hpos) += ios_printf(f, "%"PRIu64, ui64);
+ if(weak || SL(print_princ))
+ SL(hpos) += ios_printf(f, "%"PRIu64, ui64);
else
- FL(hpos) += ios_printf(f, "#%s(%"PRIu64")", symbol_name(type), ui64);
- }else if(type == FL_bignumsym){+ SL(hpos) += ios_printf(f, "#%s(%"PRIu64")", symbol_name(type), ui64);
+ }else if(type == SL_bignumsym){mpint *i = *(mpint**)data;
char *s = mptoa(i, 10, nil, 0);
- FL(hpos) += ios_printf(f, "%s", s);
+ SL(hpos) += ios_printf(f, "%s", s);
MEM_FREE(s);
}else if(issymbol(type)){// handle other integer prims. we know it's smaller than uint64
@@ -734,15 +734,15 @@
numerictype_t nt = sym_to_numtype(type);
if(valid_numtype(nt)){int64_t i64 = conv_to_int64(data, nt);
- if(weak || FL(print_princ))
- FL(hpos) += ios_printf(f, "%"PRId64, i64);
+ if(weak || SL(print_princ))
+ SL(hpos) += ios_printf(f, "%"PRId64, i64);
else
- FL(hpos) += ios_printf(f, "#%s(%"PRId64")", symbol_name(type), i64);
+ SL(hpos) += ios_printf(f, "#%s(%"PRId64")", symbol_name(type), i64);
}else{- FL(hpos) += ios_printf(f, "#<%s>", symbol_name(type));
+ SL(hpos) += ios_printf(f, "#<%s>", symbol_name(type));
}
}else if(iscons(type)){- if(car_(type) == FL_arraysym){+ if(car_(type) == SL_arraysym){size_t i;
value_t eltype = car(cdr_(type));
size_t cnt, elsize;
@@ -754,15 +754,15 @@
elsize = ctype_sizeof(eltype);
cnt = elsize ? len/elsize : 0;
}
- if(eltype == FL_bytesym){- if(FL(print_princ)){+ if(eltype == SL_bytesym){+ if(SL(print_princ)){ios_write(f, data, len);
/*
char *nl = llt_memrchr(data, '\n', len);
if(nl)
- FL(hpos) = u8_strwidth(nl+1);
+ SL(hpos) = u8_strwidth(nl+1);
else
- FL(hpos) += u8_strwidth(data);
+ SL(hpos) += u8_strwidth(data);
*/
}else{outc(f, '"');
@@ -770,28 +770,28 @@
outc(f, '"');
}
return;
- }else if(eltype == FL_runesym){+ }else if(eltype == SL_runesym){char buf[UTFmax+1];
- if(!FL(print_princ))
+ if(!SL(print_princ))
outc(f, '"');
for(i = 0; i < cnt; i++, data = (char*)data + elsize){int n = runetochar(buf, (Rune*)data);
buf[n] = 0;
- if(FL(print_princ))
+ if(SL(print_princ))
ios_write(f, buf, n);
else
print_string(f, buf, n);
}
- if(!FL(print_princ))
+ if(!SL(print_princ))
outc(f, '"');
return;
}
if(!weak){- if(eltype == FL_uint8sym){+ if(eltype == SL_uint8sym){ outsn(f, "#vu8(", 5); }else{ outsn(f, "#array(", 7);- fl_print_child(f, eltype);
+ sl_print_child(f, eltype);
if(cnt > 0)
outc(f, ' ');
}
@@ -816,10 +816,10 @@
void *data = cptr(v);
value_t label;
- if(cv_class(cv) == FL(builtintype)){- label = (value_t)ptrhash_get(&FL(reverse_dlsym_lookup_table), cv);
+ if(cv_class(cv) == SL(builtintype)){+ label = (value_t)ptrhash_get(&SL(reverse_dlsym_lookup_table), cv);
assert(label != (value_t)HT_NOTFOUND);
- if(FL(print_princ)){+ if(SL(print_princ)){outs(f, symbol_name(label));
}else{ outsn(f, "#fn(", 4);@@ -838,36 +838,36 @@
static void
set_print_width(void)
{- value_t pw = symbol_value(FL_printwidthsym);
+ value_t pw = symbol_value(SL_printwidthsym);
if(!isfixnum(pw))
return;
- FL(scr_width) = numval(pw);
+ SL(scr_width) = numval(pw);
}
void
-fl_print(ios_t *f, value_t v)
+sl_print(ios_t *f, value_t v)
{- FL(print_pretty) = symbol_value(FL_printprettysym) != FL_nil;
- if(FL(print_pretty))
+ SL(print_pretty) = symbol_value(SL_printprettysym) != SL_nil;
+ if(SL(print_pretty))
set_print_width();
- FL(print_princ) = symbol_value(FL_printreadablysym) == FL_nil;
- value_t pl = symbol_value(FL_printlengthsym);
- FL(print_length) = isfixnum(pl) ? numval(pl) : -1;
- pl = symbol_value(FL_printlevelsym);
- FL(print_level) = isfixnum(pl) ? numval(pl) : -1;
- FL(p_level) = 0;
+ SL(print_princ) = symbol_value(SL_printreadablysym) == SL_nil;
+ value_t pl = symbol_value(SL_printlengthsym);
+ SL(print_length) = isfixnum(pl) ? numval(pl) : -1;
+ pl = symbol_value(SL_printlevelsym);
+ SL(print_level) = isfixnum(pl) ? numval(pl) : -1;
+ SL(p_level) = 0;
- FL(printlabel) = 0;
- if(!FL(print_princ))
+ SL(printlabel) = 0;
+ if(!SL(print_princ))
print_traverse(v);
- FL(hpos) = FL(vpos) = 0;
+ SL(hpos) = SL(vpos) = 0;
- fl_print_child(f, v);
+ sl_print_child(f, v);
- if(FL(print_level) >= 0 || FL(print_length) >= 0)
- memset(FL(consflags), 0, 4*bitvector_nwords(FL(heapsize)/sizeof(cons_t)));
+ if(SL(print_level) >= 0 || SL(print_length) >= 0)
+ memset(SL(consflags), 0, 4*bitvector_nwords(SL(heapsize)/sizeof(cons_t)));
if((iscons(v) || isvector(v) || isfunction(v) || iscvalue(v)) &&
- !fl_isstring(v) && v != FL_t && v != FL_nil && v != FL_void)
- htable_reset(&FL(printconses), 32);
+ !sl_isstring(v) && v != SL_t && v != SL_nil && v != SL_void)
+ htable_reset(&SL(printconses), 32);
}
--- a/src/print.h
+++ b/src/print.h
@@ -1,7 +1,7 @@
#pragma once
-void fl_print(ios_t *f, value_t v);
+void sl_print(ios_t *f, value_t v);
void print_traverse(value_t v);
-void fl_print_chr(ios_t *f, char c);
-void fl_print_str(ios_t *f, const char *s);
-void fl_print_child(ios_t *f, value_t v);
+void sl_print_chr(ios_t *f, char c);
+void sl_print_str(ios_t *f, const char *s);
+void sl_print_child(ios_t *f, value_t v);
--- a/src/ptrhash.c
+++ b/src/ptrhash.c
@@ -3,7 +3,7 @@
optimized for storing info about particular values
*/
-#include "flisp.h"
+#include "sl.h"
#if defined(BITS64)
static uint64_t
--- a/src/random.c
+++ b/src/random.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "cvalues.h"
#include "mt19937-64.h"
#include "timefuncs.h"
--- a/src/read.c
+++ b/src/read.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "cvalues.h"
#include "read.h"
#include "nan.h"
@@ -24,10 +24,10 @@
static value_t do_read_sexpr(Rctx *ctx, value_t label);
-#define RS value2c(ios_t*, FL(readstate)->source)
+#define RS value2c(ios_t*, SL(readstate)->source)
bool
-fl_read_numtok(const char *tok, value_t *pval, int base)
+sl_read_numtok(const char *tok, value_t *pval, int base)
{char *end;
int64_t i64;
@@ -121,7 +121,7 @@
ctx->toktype = TOK_NONE;
}
-static _Noreturn void fl_printfmt(2, 3)
+static _Noreturn void sl_printfmt(2, 3)
parse_error(ios_loc_t *loc, const char *format, ...)
{char msgbuf[512];
@@ -137,7 +137,7 @@
value_t msg = string_from_cstr(msgbuf);
va_end(args);
- fl_raise(fl_list2(FL_ParseError, msg));
+ sl_raise(sl_list2(SL_ParseError, msg));
}
static void
@@ -242,7 +242,7 @@
if(cval == 'u' || cval == 'U' || cval == 'x'){read_token(ctx, 'u', 0);
if(ctx->buf[1] != '\0'){ // not a solitary 'u','U','x'- if(!fl_read_numtok(&ctx->buf[1], &ctx->tokval, 16))
+ if(!sl_read_numtok(&ctx->buf[1], &ctx->tokval, 16))
parse_error(&ctx->loc, "invalid hex character constant");
cval = numval(ctx->tokval);
}
@@ -250,18 +250,18 @@
read_token(ctx, (char)cval, 0);
ctx->tokval = symbol(ctx->buf, true);
if(ctx->buf[1] == '\0') USED(cval); /* one character */
- else if(ctx->tokval == FL_nulsym) cval = 0x00;
- else if(ctx->tokval == FL_alarmsym) cval = 0x07;
- else if(ctx->tokval == FL_backspacesym) cval = 0x08;
- else if(ctx->tokval == FL_tabsym) cval = 0x09;
- else if(ctx->tokval == FL_linefeedsym) cval = 0x0A;
- else if(ctx->tokval == FL_newlinesym) cval = 0x0A;
- else if(ctx->tokval == FL_vtabsym) cval = 0x0B;
- else if(ctx->tokval == FL_pagesym) cval = 0x0C;
- else if(ctx->tokval == FL_returnsym) cval = 0x0D;
- else if(ctx->tokval == FL_escsym) cval = 0x1B;
- else if(ctx->tokval == FL_spacesym) cval = 0x20;
- else if(ctx->tokval == FL_deletesym) cval = 0x7F;
+ else if(ctx->tokval == SL_nulsym) cval = 0x00;
+ else if(ctx->tokval == SL_alarmsym) cval = 0x07;
+ else if(ctx->tokval == SL_backspacesym) cval = 0x08;
+ else if(ctx->tokval == SL_tabsym) cval = 0x09;
+ else if(ctx->tokval == SL_linefeedsym) cval = 0x0A;
+ else if(ctx->tokval == SL_newlinesym) cval = 0x0A;
+ else if(ctx->tokval == SL_vtabsym) cval = 0x0B;
+ else if(ctx->tokval == SL_pagesym) cval = 0x0C;
+ else if(ctx->tokval == SL_returnsym) cval = 0x0D;
+ else if(ctx->tokval == SL_escsym) cval = 0x1B;
+ else if(ctx->tokval == SL_spacesym) cval = 0x20;
+ else if(ctx->tokval == SL_deletesym) cval = 0x7F;
else
parse_error(&ctx->loc, "unknown character #\\%s", ctx->buf);
}
@@ -340,7 +340,7 @@
(c == 'o' && (base = 8)) ||
(c == 'd' && (base = 10)) ||
(c == 'x' && (base = 16))) && (isdigit_base(ctx->buf[1], base) || ctx->buf[1] == '-')){- if(!fl_read_numtok(&ctx->buf[1], &ctx->tokval, base))
+ if(!sl_read_numtok(&ctx->buf[1], &ctx->tokval, base))
parse_error(&ctx->loc, "invalid base %d constant", base);
return (ctx->toktype = TOK_NUM);
}
@@ -368,16 +368,16 @@
if(!ok){if(s[0] == '.' && s[1] == '\0')
return (ctx->toktype = TOK_DOT);
- if(fl_read_numtok(s, &ctx->tokval, 0))
+ if(sl_read_numtok(s, &ctx->tokval, 0))
return (ctx->toktype = TOK_NUM);
}
ctx->toktype = TOK_SYM;
if(strcasecmp(s, "nil") == 0)
- ctx->tokval = FL_nil;
+ ctx->tokval = SL_nil;
else if(s[1] == 0 && (s[0] == 't' || s[0] == 'T'))
- ctx->tokval = FL_t;
+ ctx->tokval = SL_t;
else if(strcmp(s, "λ") == 0 || strcmp(s, "lambda") == 0)
- ctx->tokval = FL_lambda;
+ ctx->tokval = SL_lambda;
else{ctx->tokval = symbol(s, true);
if(s[strlen(s)-1] == '#')
@@ -397,15 +397,15 @@
PUSH(v);
assert(s+d > s);
value_t newv = alloc_vector(s+d, 1);
- v = FL(sp)[-1];
+ v = SL(sp)[-1];
for(i = 0; i < s; i++)
vector_elt(newv, i) = vector_elt(v, i);
// use gc to rewrite references from the old vector to the new
- FL(sp)[-1] = newv;
+ SL(sp)[-1] = newv;
if(s > 0 && rewrite_refs){((size_t*)ptr(v))[0] |= 0x1;
vector_elt(v, 0) = newv;
- fl_gc(false);
+ sl_gc(false);
}
return POP();
}
@@ -413,22 +413,22 @@
static value_t
read_vector(Rctx *ctx, value_t label, uint32_t closer)
{- value_t v = FL(the_empty_vector), elt;
+ value_t v = SL(the_empty_vector), elt;
uint32_t i = 0;
PUSH(v);
if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
+ ptrhash_put(&SL(readstate)->backrefs, (void*)label, (void*)v);
while(peek(ctx) != closer){if(ios_eof(RS))
parse_error(&ctx->loc, "unexpected end of input");
- v = FL(sp)[-1]; // reload after possible alloc in peek()
+ v = SL(sp)[-1]; // reload after possible alloc in peek()
if(i >= vector_size(v)){- v = FL(sp)[-1] = vector_grow(v, label != UNBOUND);
+ v = SL(sp)[-1] = vector_grow(v, label != UNBOUND);
if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
+ ptrhash_put(&SL(readstate)->backrefs, (void*)label, (void*)v);
}
elt = do_read_sexpr(ctx, UNBOUND);
- v = FL(sp)[-1];
+ v = SL(sp)[-1];
assert(i < vector_size(v));
vector_elt(v, i) = elt;
i++;
@@ -555,14 +555,14 @@
loc0 = RS->loc;
loc0.colno--;
- ipval = FL(sp)-1;
- PUSH(FL_nil);
- ipc = FL(sp)-1; // to keep track of current cons cell
+ ipval = SL(sp)-1;
+ PUSH(SL_nil);
+ ipc = SL(sp)-1; // to keep track of current cons cell
t = peek(ctx);
while(t != closer){if(ios_eof(RS))
parse_error(&loc0, "not closed: unexpected EOI "PAtLoc, ctx->loc.lineno, ctx->loc.colno);
- c = mk_cons(); car_(c) = cdr_(c) = FL_nil;
+ c = mk_cons(); car_(c) = cdr_(c) = SL_nil;
pc = ipc;
if(iscons(*pc))
cdr_(*pc) = c;
@@ -570,7 +570,7 @@
pval = ipval;
*pval = c;
if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)c);
+ ptrhash_put(&SL(readstate)->backrefs, (void*)label, (void*)c);
}
*pc = c;
c = do_read_sexpr(ctx, UNBOUND);
@@ -614,7 +614,7 @@
take(ctx);
switch(t){case TOK_OPEN:
- PUSH(FL_nil);
+ PUSH(SL_nil);
read_list(ctx, label, TOK_CLOSE);
return POP();
case TOK_SYM:
@@ -621,36 +621,36 @@
case TOK_NUM:
return ctx->tokval;
case TOK_OPENB:
- PUSH(FL_nil);
+ PUSH(SL_nil);
read_list(ctx, label, TOK_CLOSEB);
return POP();
case TOK_OPENC:
- PUSH(FL_nil);
+ PUSH(SL_nil);
read_list(ctx, label, TOK_CLOSEC);
return POP();
case TOK_COMMA:
- head = &FL_comma; goto listwith;
+ head = &SL_comma; goto listwith;
case TOK_COMMAAT:
- head = &FL_commaat; goto listwith;
+ head = &SL_commaat; goto listwith;
case TOK_COMMADOT:
- head = &FL_commadot; goto listwith;
+ head = &SL_commadot; goto listwith;
case TOK_BQ:
- head = &FL_backquote; goto listwith;
+ head = &SL_backquote; goto listwith;
case TOK_QUOTE:
- head = &FL_quote;
+ head = &SL_quote;
listwith:
v = cons_reserve(2);
car_(v) = *head;
cdr_(v) = tagptr((cons_t*)ptr(v)+1, TAG_CONS);
- car_(cdr_(v)) = cdr_(cdr_(v)) = FL_nil;
+ car_(cdr_(v)) = cdr_(cdr_(v)) = SL_nil;
PUSH(v);
if(label != UNBOUND)
- ptrhash_put(&FL(readstate)->backrefs, (void*)label, (void*)v);
+ ptrhash_put(&SL(readstate)->backrefs, (void*)label, (void*)v);
v = do_read_sexpr(ctx, UNBOUND);
- car_(cdr_(FL(sp)[-1])) = v;
+ car_(cdr_(SL(sp)[-1])) = v;
return POP();
case TOK_SHARPQUOTE:
- // femtoLisp doesn't need symbol-function, so #' does nothing
+ // StreetLISP doesn't need symbol-function, so #' does nothing
return do_read_sexpr(ctx, label);
case TOK_SHARPSYM:
sym = ctx->tokval;
@@ -661,18 +661,18 @@
take(ctx);
parse_error(&ctx->loc, "expected argument list for %s", symbol_name(ctx->tokval));
}
- PUSH(FL_nil);
+ PUSH(SL_nil);
read_list(ctx, UNBOUND, TOK_CLOSE);
- if(sym == FL_vu8sym){- sym = FL_arraysym;
- FL(sp)[-1] = fl_cons(FL_uint8sym, FL(sp)[-1]);
- }else if(sym == FL_fnsym){- sym = FL_function;
+ if(sym == SL_vu8sym){+ sym = SL_arraysym;
+ SL(sp)[-1] = sl_cons(SL_uint8sym, SL(sp)[-1]);
+ }else if(sym == SL_fnsym){+ sym = SL_function;
}
v = symbol_value(sym);
if(v == UNBOUND)
unbound_error(sym);
- return fl_apply(v, POP());
+ return sl_apply(v, POP());
case TOK_SHARPOPEN:
return read_vector(ctx, label, TOK_CLOSE);
case TOK_SHARPDOT:
@@ -688,23 +688,23 @@
unbound_error(sym);
return v;
}
- return fl_toplevel_eval(sym);
+ return sl_toplevel_eval(sym);
case TOK_LABEL:
// create backreference label
- if(ptrhash_has(&FL(readstate)->backrefs, (void*)ctx->tokval))
+ if(ptrhash_has(&SL(readstate)->backrefs, (void*)ctx->tokval))
parse_error(&ctx->loc, "label %"PRIdPTR" redefined", (intptr_t)numval(ctx->tokval));
oldtokval = ctx->tokval;
v = do_read_sexpr(ctx, ctx->tokval);
- ptrhash_put(&FL(readstate)->backrefs, (void*)oldtokval, (void*)v);
+ ptrhash_put(&SL(readstate)->backrefs, (void*)oldtokval, (void*)v);
return v;
case TOK_BACKREF:
// look up backreference
- v = (value_t)ptrhash_get(&FL(readstate)->backrefs, (void*)ctx->tokval);
+ v = (value_t)ptrhash_get(&SL(readstate)->backrefs, (void*)ctx->tokval);
if(v == (value_t)HT_NOTFOUND)
parse_error(&ctx->loc, "undefined label %"PRIdPTR, (intptr_t)numval(ctx->tokval));
return v;
case TOK_GENSYM:
- pv = (value_t*)ptrhash_bp(&FL(readstate)->gensyms, (void*)ctx->tokval);
+ pv = (value_t*)ptrhash_bp(&SL(readstate)->gensyms, (void*)ctx->tokval);
if(*pv == (value_t)HT_NOTFOUND)
*pv = gensym();
return *pv;
@@ -719,26 +719,26 @@
case TOK_DOT:
parse_error(&ctx->loc, "unexpected '.'");
}
- return FL_void;
+ return SL_void;
}
value_t
-fl_read_sexpr(value_t f)
+sl_read_sexpr(value_t f)
{- fl_readstate_t state;
- state.prev = FL(readstate);
+ sl_readstate_t state;
+ state.prev = SL(readstate);
htable_new(&state.backrefs, 8);
htable_new(&state.gensyms, 8);
state.source = f;
- FL(readstate) = &state;
+ SL(readstate) = &state;
Rctx ctx;
ctx.toktype = TOK_NONE;
- fl_gc_handle(&ctx.tokval);
+ sl_gc_handle(&ctx.tokval);
value_t v = do_read_sexpr(&ctx, UNBOUND);
- fl_free_gc_handles(1);
- FL(readstate) = state.prev;
+ sl_free_gc_handles(1);
+ SL(readstate) = state.prev;
free_readstate(&state);
return v;
}
--- a/src/read.h
+++ b/src/read.h
@@ -1,7 +1,7 @@
#pragma once
-value_t fl_read_sexpr(value_t f);
-bool fl_read_numtok(const char *tok, value_t *pval, int base);
+value_t sl_read_sexpr(value_t f);
+bool sl_read_numtok(const char *tok, value_t *pval, int base);
// defines which characters are ordinary symbol characters.
// exceptions are '.', which is an ordinary symbol character
--- /dev/null
+++ b/src/sl.c
@@ -1,0 +1,1348 @@
+#include "sl.h"
+#include "operators.h"
+#include "cvalues.h"
+#include "types.h"
+#include "print.h"
+#include "read.h"
+#include "timefuncs.h"
+#include "equal.h"
+#include "hashing.h"
+#include "table.h"
+#include "iostream.h"
+#include "compress.h"
+
+value_t SL_builtins_table_sym, SL_quote, SL_lambda, SL_function, SL_comma, SL_commaat;
+value_t SL_commadot, SL_trycatch, SL_backquote;
+value_t SL_conssym, SL_symbolsym, SL_fixnumsym, SL_vectorsym, SL_builtinsym, SL_vu8sym;
+value_t SL_defsym, SL_defmacrosym, SL_forsym, SL_setqsym;
+value_t SL_booleansym, SL_nullsym, SL_evalsym, SL_fnsym;
+value_t SL_nulsym, SL_alarmsym, SL_backspacesym, SL_tabsym, SL_linefeedsym, SL_newlinesym;
+value_t SL_vtabsym, SL_pagesym, SL_returnsym, SL_escsym, SL_spacesym, SL_deletesym;
+value_t SL_IOError, SL_ParseError, SL_TypeError, SL_ArgError, SL_MemoryError;
+value_t SL_DivideError, SL_BoundsError, SL_Error, SL_KeyError, SL_UnboundError;
+
+value_t SL_printwidthsym, SL_printreadablysym, SL_printprettysym, SL_printlengthsym;
+value_t SL_printlevelsym;
+value_t SL_tablesym, SL_arraysym;
+value_t SL_iostreamsym, SL_rdsym, SL_wrsym, SL_apsym, SL_crsym, SL_truncsym;
+value_t SL_instrsym, SL_outstrsym;
+value_t SL_int8sym, SL_uint8sym, SL_int16sym, SL_uint16sym, SL_int32sym, SL_uint32sym;
+value_t SL_int64sym, SL_uint64sym, SL_bignumsym;
+value_t SL_bytesym, SL_runesym, SL_floatsym, SL_doublesym;
+value_t SL_stringtypesym, SL_runestringtypesym;
+
+sl_thread(Sl *sl);
+
+typedef struct {+ const char *name;
+ builtin_t fptr;
+}builtinspec_t;
+
+bool
+isbuiltin(value_t x)
+{+ int i;
+ return tag(x) == TAG_FUNCTION && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil;
+}
+
+static value_t apply_cl(int nargs) sl_hotfn;
+
+// error utilities ------------------------------------------------------------
+
+void
+free_readstate(sl_readstate_t *rs)
+{+ htable_free(&rs->backrefs);
+ htable_free(&rs->gensyms);
+}
+
+_Noreturn void
+sl_exit(int status)
+{+ SL(exiting) = true;
+ sl_gc(false);
+ exit(status);
+}
+
+#define SL_TRY \
+ sl_exception_context_t _ctx; int l__tr, l__ca; \
+ _ctx.sp = SL(sp); _ctx.frame = SL(curr_frame); _ctx.rdst = SL(readstate); _ctx.prev = SL(exctx); \
+ _ctx.ngchnd = SL(ngchandles); SL(exctx) = &_ctx; \
+ if(!sl_setjmp(_ctx.buf)) \
+ for(l__tr = 1; l__tr; l__tr = 0, (void)(SL(exctx) = SL(exctx)->prev))
+
+#define SL_CATCH_INC \
+ l__ca = 0, SL(lasterror) = SL_nil, SL(throwing_frame) = 0, SL(sp) = _ctx.sp, SL(curr_frame) = _ctx.frame
+
+#define SL_CATCH \
+ else \
+ for(l__ca = 1; l__ca; SL_CATCH_INC)
+
+#define SL_CATCH_NO_INC \
+ else \
+ for(l__ca = 1; l__ca;)
+
+void
+sl_savestate(sl_exception_context_t *_ctx)
+{+ _ctx->sp = SL(sp);
+ _ctx->frame = SL(curr_frame);
+ _ctx->rdst = SL(readstate);
+ _ctx->prev = SL(exctx);
+ _ctx->ngchnd = SL(ngchandles);
+}
+
+void
+sl_restorestate(sl_exception_context_t *_ctx)
+{+ SL(lasterror) = SL_nil;
+ SL(throwing_frame) = 0;
+ SL(sp) = _ctx->sp;
+ SL(curr_frame) = _ctx->frame;
+}
+
+_Noreturn void
+sl_raise(value_t e)
+{+ ios_flush(ios_stdout);
+ ios_flush(ios_stderr);
+
+ SL(lasterror) = e;
+ // unwind read state
+ while(SL(readstate) != SL(exctx)->rdst){+ free_readstate(SL(readstate));
+ SL(readstate) = SL(readstate)->prev;
+ }
+ if(SL(throwing_frame) == 0)
+ SL(throwing_frame) = SL(curr_frame);
+ SL(ngchandles) = SL(exctx)->ngchnd;
+ sl_exception_context_t *thisctx = SL(exctx);
+ if(SL(exctx)->prev) // don't throw past toplevel
+ SL(exctx) = SL(exctx)->prev;
+ sl_longjmp(thisctx->buf, 1);
+}
+
+_Noreturn void
+lerrorf(value_t e, const char *format, ...)
+{+ char msgbuf[256];
+ va_list args;
+
+ PUSH(e);
+ va_start(args, format);
+ vsnprintf(msgbuf, sizeof(msgbuf), format, args);
+ value_t msg = string_from_cstr(msgbuf);
+ va_end(args);
+
+ e = POP();
+ sl_raise(sl_list2(e, msg));
+}
+
+_Noreturn void
+type_error(const char *expected, value_t got)
+{+ sl_raise(sl_listn(3, SL_TypeError, symbol(expected, false), got));
+}
+
+_Noreturn void
+bounds_error(value_t arr, value_t ind)
+{+ sl_raise(sl_listn(3, SL_BoundsError, arr, ind));
+}
+
+_Noreturn void
+unbound_error(value_t sym)
+{+ sl_raise(sl_listn(2, SL_UnboundError, sym));
+}
+
+_Noreturn void
+arity_error(int nargs, int c)
+{+ lerrorf(SL_ArgError, "arity mismatch: wanted %"PRId32", got %"PRId32, c, nargs);
+}
+
+// safe cast operators --------------------------------------------------------
+
+#define isstring sl_isstring
+#define SAFECAST_OP(type, ctype, cnvt) \
+ ctype to##type(value_t v) \
+ { \+ if(sl_likely(is##type(v))) \
+ return (ctype)cnvt(v); \
+ type_error(#type, v); \
+ }
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol, symbol_t*, ptr)
+SAFECAST_OP(fixnum, fixnum_t, numval)
+//SAFECAST_OP(cvalue, cvalue_t*, ptr)
+SAFECAST_OP(string, char*, cvalue_data)
+#undef isstring
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *
+mk_symbol(const char *str, int len, bool copy)
+{+ symbol_t *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));
+ sym->numtype = NONNUMERIC;
+ if(str[0] == ':' && str[1] != 0){+ value_t s = tagptr(sym, TAG_SYM);
+ sym->flags = FLAG_KEYWORD;
+ setc(s, s);
+ }else{+ sym->binding = UNBOUND;
+ sym->flags = 0;
+ }
+ sym->type = nil;
+ sym->hash = memhash(str, len)^0xAAAAAAAAAAAAAAAAULL;
+ if(copy){+ memcpy((char*)(sym+1), str, len+1);
+ sym->name = (const char*)(sym+1);
+ }else{+ sym->name = str;
+ }
+ sym->size = 0;
+ return sym;
+}
+
+value_t
+symbol(const char *str, bool copy)
+{+ int len = strlen(str);
+ symbol_t *v;
+ const char *k;
+ if(!Tgetkv(SL(symtab), str, len, &k, (void**)&v)){+ v = mk_symbol(str, len, copy);
+ SL(symtab) = Tsetl(SL(symtab), v->name, len, v);
+ }
+ return tagptr(v, TAG_SYM);
+}
+
+value_t
+csymbol_(const char *str, int len)
+{+ symbol_t *v = mk_symbol(str, len, false);
+ SL(symtab) = Tsetl(SL(symtab), str, len, v);
+ return tagptr(v, TAG_SYM);
+}
+
+BUILTIN("gensym", gensym)+{+ argcount(nargs, 0);
+ USED(args);
+ gensym_t *gs = alloc_words(sizeof(gensym_t)/sizeof(value_t));
+ gs->id = SL(gensym_ctr)++;
+ gs->binding = UNBOUND;
+ gs->type = nil;
+ return tagptr(gs, TAG_SYM);
+}
+
+value_t
+gensym(void)
+{+ return fn_builtin_gensym(nil, 0);
+}
+
+sl_purefn
+BUILTIN("gensym?", gensymp)+{+ argcount(nargs, 1);
+ return isgensym(args[0]) ? SL_t : SL_nil;
+}
+
+char *
+uint2str(char *dest, size_t len, uint64_t num, int base)
+{+ int i = len-1;
+ uint64_t b = (uint64_t)base;
+ char ch;
+ dest[i--] = '\0';
+ while(i >= 0){+ ch = (char)(num % b);
+ if(ch < 10)
+ ch += '0';
+ else
+ ch = ch-10+'a';
+ dest[i--] = ch;
+ num /= b;
+ if(num == 0)
+ break;
+ }
+ return &dest[i+1];
+}
+
+const char *
+symbol_name(value_t v)
+{+ if(ismanaged(v)){+ gensym_t *gs = ptr(v);
+ SL(gsnameno) = 1-SL(gsnameno);
+ char *n = uint2str(SL(gsname)[SL(gsnameno)]+1, sizeof(SL(gsname)[0])-1, gs->id, 10);
+ *(--n) = 'g';
+ return n;
+ }
+ return ((symbol_t*)ptr(v))->name;
+}
+
+// conses ---------------------------------------------------------------------
+
+value_t
+mk_cons(void)
+{+ cons_t *c;
+
+ if(sl_unlikely(SL(curheap) > SL(lim)))
+ sl_gc(false);
+ c = (cons_t*)SL(curheap);
+ SL(curheap) += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+void *
+alloc_words(int n)
+{+ value_t *first;
+
+#if !defined(BITS64)
+ // force 8-byte alignment
+ if(n & 1)
+ n++;
+#endif
+ if(sl_unlikely((value_t*)SL(curheap) > (value_t*)SL(lim)+2-n)){+ sl_gc(false);
+ while(sl_unlikely((value_t*)SL(curheap) > ((value_t*)SL(lim))+2-n))
+ sl_gc(true);
+ }
+ first = (value_t*)SL(curheap);
+ SL(curheap) += n*sizeof(value_t);
+ return first;
+}
+
+value_t
+alloc_vector(size_t n, bool init)
+{+ if(n == 0)
+ return SL(the_empty_vector);
+ value_t *c = alloc_words(n+1);
+ value_t v = tagptr(c, TAG_VECTOR);
+ vector_setsize(v, n);
+ if(init){+ for(size_t i = 0; i < n; i++)
+ vector_elt(v, i) = SL_void;
+ }
+ return v;
+}
+
+// collector ------------------------------------------------------------------
+
+void
+sl_gc_handle(value_t *pv)
+{+ if(sl_unlikely(SL(ngchandles) >= N_GC_HANDLES))
+ lerrorf(SL_MemoryError, "out of gc handles");
+ SL(gchandles)[SL(ngchandles)++] = pv;
+}
+
+void
+sl_free_gc_handles(int n)
+{+ assert(SL(ngchandles) >= n);
+ SL(ngchandles) -= n;
+}
+
+value_t
+relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+
+ if(isfixnum(v))
+ return v;
+
+ uintptr_t t = tag(v);
+ if(t == TAG_CONS){+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do{+ a = car_(v);
+ if(isforwarded(v)){+ *pcdr = forwardloc(v);
+ return first;
+ }
+ d = cdr_(v);
+ *pcdr = nc = tagptr((cons_t*)SL(curheap), TAG_CONS);
+ SL(curheap) += sizeof(cons_t);
+ forward(v, nc);
+ car_(nc) = ismanaged(a) ? relocate(a) : a;
+ pcdr = &cdr_(nc);
+ v = d;
+ }while(iscons(v));
+ *pcdr = d == SL_nil ? SL_nil : relocate(d);
+ return first;
+ }
+
+ if(!ismanaged(v))
+ return v;
+ if(isforwarded(v))
+ return forwardloc(v);
+
+ if(t == TAG_CVALUE)
+ return cvalue_relocate(v);
+ if(t == TAG_VECTOR){+ // N.B.: 0-length vectors secretly have space for a first element
+ size_t i, sz = vector_size(v);
+ if(vector_elt(v, -1) & 0x1){+ // grown vector
+ nc = relocate(vector_elt(v, 0));
+ forward(v, nc);
+ }else{+ nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
+ vector_setsize(nc, sz);
+ a = vector_elt(v, 0);
+ forward(v, nc);
+ if(sz > 0){+ vector_elt(nc, 0) = relocate(a);
+ for(i = 1; i < sz; i++)
+ vector_elt(nc, i) = relocate(vector_elt(v, i));
+ }
+ }
+ return nc;
+ }
+ if(t == TAG_FUNCTION){+ function_t *fn = ptr(v);
+ function_t *nfn = alloc_words(sizeof(function_t)/sizeof(value_t));
+ nfn->bcode = fn->bcode;
+ nfn->vals = fn->vals;
+ nc = tagptr(nfn, TAG_FUNCTION);
+ forward(v, nc);
+ nfn->env = relocate(fn->env);
+ nfn->vals = relocate(nfn->vals);
+ nfn->bcode = relocate(nfn->bcode);
+ assert(!ismanaged(fn->name));
+ nfn->name = fn->name;
+ return nc;
+ }
+ if(t == TAG_SYM){+ gensym_t *gs = ptr(v);
+ gensym_t *ng = alloc_words(sizeof(gensym_t)/sizeof(value_t));
+ ng->id = gs->id;
+ ng->binding = gs->binding;
+ ng->type = gs->type;
+ nc = tagptr(ng, TAG_SYM);
+ forward(v, nc);
+ if(sl_likely(ng->binding != UNBOUND))
+ ng->binding = relocate(ng->binding);
+ return nc;
+ }
+ if(t == TAG_CPRIM){+ cprim_t *pcp = ptr(v);
+ size_t nw = CPRIM_NWORDS+NWORDS(cp_class(pcp)->size);
+ cprim_t *ncp = alloc_words(nw);
+ while(nw--)
+ ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
+ nc = tagptr(ncp, TAG_CPRIM);
+ forward(v, nc);
+ return nc;
+ }
+ return v;
+}
+
+static void
+trace_globals(void)
+{+ const char *k = nil;
+ symbol_t *v;
+ while(Tnext(SL(symtab), &k, (void**)&v)){+ if(v->binding != UNBOUND)
+ v->binding = relocate(v->binding);
+ }
+}
+
+void
+sl_gc(bool mustgrow)
+{+ SL(gccalls)++;
+ SL(curheap) = SL(tospace);
+ if(SL(grew))
+ SL(lim) = SL(curheap)+SL(heapsize)*2-sizeof(cons_t);
+ else
+ SL(lim) = SL(curheap)+SL(heapsize)-sizeof(cons_t);
+
+ value_t *top, *f;
+ if(SL(throwing_frame) > SL(curr_frame)){+ top = SL(throwing_frame) - 3;
+ f = (value_t*)*top;
+ }else{+ top = SL(sp);
+ f = SL(curr_frame);
+ }
+ for(;;){+ for(value_t *p = f; p < top; p++)
+ *p = relocate(*p);
+ if(f == SL(stack))
+ break;
+ top = f - 3;
+ f = (value_t*)*top;
+ }
+ for(int i = 0; i < SL(ngchandles); i++)
+ *SL(gchandles)[i] = relocate(*SL(gchandles)[i]);
+ trace_globals();
+ relocate_typetable();
+ sl_readstate_t *rs = SL(readstate);
+ while(rs){+ value_t ent;
+ for(int i = 0; i < rs->backrefs.size; i++){+ ent = (value_t)rs->backrefs.table[i];
+ if(ent != (value_t)HT_NOTFOUND)
+ rs->backrefs.table[i] = (void*)relocate(ent);
+ }
+ for(int i = 0; i < rs->gensyms.size; i++){+ ent = (value_t)rs->gensyms.table[i];
+ if(ent != (value_t)HT_NOTFOUND)
+ rs->gensyms.table[i] = (void*)relocate(ent);
+ }
+ rs->source = relocate(rs->source);
+ rs = rs->prev;
+ }
+ SL(lasterror) = relocate(SL(lasterror));
+ SL(memory_exception_value) = relocate(SL(memory_exception_value));
+ SL(the_empty_vector) = relocate(SL(the_empty_vector));
+ SL(the_empty_string) = relocate(SL(the_empty_string));
+
+ sweep_finalizers();
+
+ void *temp = SL(tospace);
+ SL(tospace) = SL(fromspace);
+ SL(fromspace) = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if(SL(grew) || ((intptr_t)(SL(lim)-SL(curheap)) < (intptr_t)SL(heapsize)/5) || mustgrow){+ temp = MEM_REALLOC(SL(tospace), SL(heapsize)*2);
+ if(sl_unlikely(temp == nil))
+ sl_raise(SL(memory_exception_value));
+ SL(tospace) = temp;
+ if(SL(grew)){+ SL(heapsize) *= 2;
+ temp = bitvector_resize(SL(consflags), 0, SL(heapsize)/sizeof(cons_t), 1);
+ if(sl_unlikely(temp == nil))
+ sl_raise(SL(memory_exception_value));
+ SL(consflags) = (uint32_t*)temp;
+ }
+ SL(grew) = !SL(grew);
+ }
+ if(sl_unlikely((value_t*)SL(curheap) > (value_t*)SL(lim)-2)){+ // all data was live; gc again and grow heap.
+ // but also always leave at least 4 words available, so a closure
+ // can be allocated without an extra check.
+ sl_gc(false);
+ }
+}
+
+// utils ----------------------------------------------------------------------
+
+// apply function with n args on the stack
+sl_hotfn
+static value_t
+_applyn(int n)
+{+ value_t *saveSP = SL(sp);
+ value_t f = saveSP[-n-1];
+ value_t v;
+ if(iscbuiltin(f))
+ v = ((cvalue_t*)ptr(f))->cbuiltin(saveSP-n, n);
+ else if(isfunction(f))
+ v = apply_cl(n);
+ else if(sl_likely(isbuiltin(f))){+ value_t tab = symbol_value(SL_builtins_table_sym);
+ if(sl_unlikely(ptr(tab) == nil))
+ unbound_error(tab);
+ saveSP[-n-1] = vector_elt(tab, uintval(f));
+ v = apply_cl(n);
+ }else{+ type_error("function", f);+ }
+ SL(sp) = saveSP;
+ return v;
+}
+
+value_t
+sl_apply(value_t f, value_t v)
+{+ value_t *saveSP = SL(sp);
+
+ PUSH(f);
+ int n;
+ for(n = 0; iscons(v); n++){+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ if(v != SL_nil)
+ lerrorf(SL_ArgError, "apply: last argument: not a list");
+ v = _applyn(n);
+ SL(sp) = saveSP;
+ return v;
+}
+
+value_t
+sl_applyn(int n, value_t f, ...)
+{+ va_list ap;
+ va_start(ap, f);
+
+ PUSH(f);
+ for(int i = 0; i < n; i++){+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ value_t v = _applyn(n);
+ POPN(n+1);
+ va_end(ap);
+ return v;
+}
+
+value_t
+sl_listn(int n, ...)
+{+ va_list ap;
+ va_start(ap, n);
+ value_t *si = SL(sp);
+
+ for(int i = 0; i < n; i++){+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ cons_t *c = alloc_words(n*2);
+ cons_t *l = c;
+ for(int i = 0; i < n; i++){+ c->car = *si++;
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ c[-1].cdr = SL_nil;
+
+ POPN(n);
+ va_end(ap);
+ return tagptr(l, TAG_CONS);
+}
+
+value_t
+sl_list2(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ cons_t *c = alloc_words(4);
+ b = POP();
+ a = POP();
+ c[0].car = a;
+ c[0].cdr = tagptr(c+1, TAG_CONS);
+ c[1].car = b;
+ c[1].cdr = SL_nil;
+ return tagptr(c, TAG_CONS);
+}
+
+value_t
+sl_cons(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ value_t c = mk_cons();
+ cdr_(c) = POP();
+ car_(c) = POP();
+ return c;
+}
+
+bool
+sl_isnumber(value_t v)
+{+ if(isfixnum(v) || ismpint(v))
+ return true;
+ if(iscprim(v)){+ cprim_t *c = ptr(v);
+ return c->type != SL(runetype) && valid_numtype(c->type->numtype);
+ }
+ return false;
+}
+
+// eval -----------------------------------------------------------------------
+
+sl_hotfn
+static value_t
+list(value_t *args, int nargs, bool star)
+{+ if(sl_unlikely(nargs == 0))
+ return SL_nil;
+ value_t v = cons_reserve(nargs);
+ cons_t *c = ptr(v);
+ for(int i = 0; i < nargs; i++){+ c->car = args[i];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ if(star)
+ c[-2].cdr = c[-1].car;
+ else
+ c[-1].cdr = SL_nil;
+ return v;
+}
+
+static value_t
+copy_list(value_t L)
+{+ if(!iscons(L))
+ return SL_nil;
+ value_t *plcons = SL(sp);
+ value_t *pL = plcons+1;
+ PUSH(SL_nil);
+ PUSH(L);
+ value_t c;
+ c = mk_cons(); PUSH(c); // save first cons
+ car_(c) = car_(*pL);
+ cdr_(c) = SL_nil;
+ *plcons = c;
+ *pL = cdr_(*pL);
+ while(iscons(*pL)){+ c = mk_cons();
+ car_(c) = car_(*pL);
+ cdr_(c) = SL_nil;
+ cdr_(*plcons) = c;
+ *plcons = c;
+ *pL = cdr_(*pL);
+ }
+ c = POP(); // first cons
+ POPN(2);
+ return c;
+}
+
+static value_t
+do_trycatch(void)
+{+ value_t *saveSP = SL(sp);
+ value_t v = SL_nil;
+ value_t thunk = saveSP[-2];
+ SL(sp)[-2] = saveSP[-1];
+ SL(sp)[-1] = thunk;
+
+ SL_TRY{+ v = apply_cl(0);
+ }
+ SL_CATCH{+ v = saveSP[-2];
+ PUSH(v);
+ PUSH(SL(lasterror));
+ v = apply_cl(1);
+ }
+ SL(sp) = saveSP;
+ return v;
+}
+
+/*
+ argument layout on stack is
+ |--required args--|--opt args--|--kw args--|--rest args...
+*/
+static int
+process_keys(value_t kwtable, int nreq, int nkw, int nopt, value_t *bp, int nargs, int va)
+{+ int extr = nopt+nkw;
+ int ntot = nreq+extr;
+ value_t args[64], v = SL_nil;
+ int i, a = 0, nrestargs;
+ value_t s1 = SL(sp)[-1];
+ value_t s3 = SL(sp)[-3];
+ value_t s4 = SL(sp)[-4];
+ if(sl_unlikely(nargs < nreq))
+ lerrorf(SL_ArgError, "too few arguments");
+ if(sl_unlikely(extr > nelem(args)))
+ lerrorf(SL_ArgError, "too many arguments");
+ for(i = 0; i < extr; i++)
+ args[i] = UNBOUND;
+ for(i = nreq; i < nargs; i++){+ v = bp[i];
+ if(issymbol(v) && iskeyword((symbol_t*)ptr(v)))
+ break;
+ if(a >= nopt)
+ goto no_kw;
+ args[a++] = v;
+ }
+ if(i >= nargs)
+ goto no_kw;
+ // now process keywords
+ uintptr_t n = vector_size(kwtable)/2;
+ do{+ i++;
+ if(sl_unlikely(i >= nargs))
+ lerrorf(SL_ArgError, "keyword %s requires an argument", symbol_name(v));
+ value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
+ fixnum_t lx = numval(hv);
+ uintptr_t x = 2*((lx < 0 ? -lx : lx) % n);
+ if(sl_likely(vector_elt(kwtable, x) == v)){+ intptr_t idx = numval(vector_elt(kwtable, x+1));
+ assert(idx < nkw);
+ idx += nopt;
+ if(args[idx] == UNBOUND){+ // if duplicate key, keep first value
+ args[idx] = bp[i];
+ }
+ }else{+ lerrorf(SL_ArgError, "unsupported keyword %s", symbol_name(v));
+ }
+ i++;
+ if(i >= nargs)
+ break;
+ v = bp[i];
+ }while(issymbol(v) && iskeyword((symbol_t*)ptr(v)));
+no_kw:
+ nrestargs = nargs - i;
+ if(sl_unlikely(!va && nrestargs > 0))
+ lerrorf(SL_ArgError, "too many arguments");
+ nargs = ntot + nrestargs;
+ if(nrestargs)
+ memmove(bp+ntot, bp+i, nrestargs*sizeof(value_t));
+ memmove(bp+nreq, args, extr*sizeof(value_t));
+ SL(sp) = bp + nargs;
+ assert((intptr_t)(SL(sp)-SL(stack)) < (intptr_t)SL(nstack)-4);
+ PUSH(s4);
+ PUSH(s3);
+ PUSH(nargs);
+ PUSH(s1);
+ SL(curr_frame) = SL(sp);
+ return nargs;
+}
+
+#if BYTE_ORDER == LITTLE_ENDIAN && defined(MEM_UNALIGNED_ACCESS)
+#define GET_INT32(a) *(const int32_t*)(a)
+#define GET_INT16(a) *(const int16_t*)(a)
+#else
+#define GET_INT32(a) (int32_t)((a)[0]<<0 | (a)[1]<<8 | (a)[2]<<16 | (uint32_t)(a)[3]<<24)
+#define GET_INT16(a) (int16_t)((a)[0]<<0 | (a)[1]<<8)
+#endif
+
+/*
+ stack on entry: <func> <nargs args...>
+ caller's responsibility:
+ - put the stack in this state
+ - provide arg count
+ - respect tail position
+ - restore SP
+
+ callee's responsibility:
+ - check arg counts
+ - allocate vararg array
+ - push closed env, set up new environment
+*/
+static value_t
+apply_cl(int nargs)
+{+ value_t *top_frame = SL(curr_frame), *bp, *ipd;
+ register value_t *sp = SL(sp);
+ const uint8_t *ip;
+ bool tail;
+ int n;
+
+ goto apply_func;
+
+#if defined(COMPUTED_GOTO)
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wpedantic"
+ static const void * const ops[] = {+#define GOTO_OP_OFFSET(op) [op] = &&op_##op
+#include "vm_goto.inc"
+#undef GOTO_OP_OFFSET
+ };
+#define NEXT_OP goto *ops[*ip++]
+#define LABEL(x) x
+#define OP(x) op_##x:
+#include "vm.inc"
+#undef OP
+#undef LABEL
+#undef NEXT_OP
+#pragma GCC diagnostic pop
+#else /* just a usual (portable) switch/case */
+ uint8_t op;
+ while(1){+ switch(op){+#define NEXT_OP break
+#define LABEL(x) x
+#define OP(x) case x:
+#include "vm.inc"
+#undef OP
+#undef LABEL
+#undef NEXT_OP
+ }
+ op = *ip++;
+ }
+#endif
+}
+
+// top = top frame pointer to start at
+static value_t
+_stacktrace(value_t *top)
+{+ value_t lst = SL_nil;
+ value_t *stack = SL(stack);
+
+ sl_gc_handle(&lst);
+ while(top > stack){+ const uint8_t *ip1 = (void*)top[-1];
+ int sz = top[-2]+1;
+ value_t *bp = top-4-sz;
+ value_t func = bp[0];
+ const uint8_t *ip0 = cvalue_data(fn_bcode(func));
+ intptr_t ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */
+ value_t v = alloc_vector(sz+1, 0);
+ vector_elt(v, 0) = fixnum(ip);
+ vector_elt(v, 1) = func;
+ for(int i = 1; i < sz; i++){+ value_t si = bp[i];
+ // if there's an error evaluating argument defaults some slots
+ // might be left set to UNBOUND
+ vector_elt(v, i+1) = si == UNBOUND ? SL_void : si;
+ }
+ lst = sl_cons(v, lst);
+ top = (value_t*)top[-3];
+ }
+ sl_free_gc_handles(1);
+ return lst;
+}
+
+// builtins -------------------------------------------------------------------
+
+BUILTIN("gc", gc)+{+ USED(args);
+ argcount(nargs, 0);
+ sl_gc(false);
+ return SL_void;
+}
+
+BUILTIN("function", function)+{+ if(nargs == 1 && issymbol(args[0]))
+ return fn_builtin_builtin(args, nargs);
+ if(nargs < 2 || nargs > 4)
+ argcount(nargs, 2);
+ if(sl_unlikely(!sl_isstring(args[0])))
+ type_error("string", args[0]);+ if(sl_unlikely(!isvector(args[1])))
+ type_error("vector", args[1]);+ cvalue_t *arr = ptr(args[0]);
+ cv_pin(arr);
+ uint8_t *data = cv_data(arr);
+ if(SL(loading)){+ // read syntax, shifted 48 for compact text representation
+ size_t i, sz = cv_len(arr);
+ for(i = 0; i < sz; i++)
+ data[i] -= 48;
+ }
+ function_t *fn = alloc_words(sizeof(function_t)/sizeof(value_t));
+ value_t fv = tagptr(fn, TAG_FUNCTION);
+ fn->bcode = args[0];
+ fn->vals = args[1];
+ fn->env = SL_nil;
+ fn->name = SL_lambda;
+ if(nargs > 2){+ if(issymbol(args[2])){+ fn->name = args[2];
+ if(nargs > 3)
+ fn->env = args[3];
+ }else{+ fn->env = args[2];
+ if(nargs > 3){+ if(sl_unlikely(!issymbol(args[3])))
+ type_error("symbol", args[3]);+ fn->name = args[3];
+ }
+ }
+ if(sl_unlikely(isgensym(fn->name)))
+ lerrorf(SL_ArgError, "name should not be a gensym");
+ }
+ return fv;
+}
+
+sl_purefn
+BUILTIN("function:code", function_code)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(sl_unlikely(!isfunction(v)))
+ type_error("function", v);+ return fn_bcode(v);
+}
+
+sl_purefn
+BUILTIN("function:vals", function_vals)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(sl_unlikely(!isfunction(v)))
+ type_error("function", v);+ return fn_vals(v);
+}
+
+sl_purefn
+BUILTIN("function:env", function_env)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(sl_unlikely(!isfunction(v)))
+ type_error("function", v);+ return fn_env(v);
+}
+
+BUILTIN("function:name", function_name)+{+ argcount(nargs, 1);
+ value_t v = args[0];
+ if(isfunction(v))
+ return fn_name(v);
+ if(isbuiltin(v))
+ return symbol(builtins[uintval(v)].name, false);
+ if(iscbuiltin(v)){+ v = (value_t)ptrhash_get(&SL(reverse_dlsym_lookup_table), ptr(v));
+ if(v == (value_t)HT_NOTFOUND)
+ return SL_nil;
+ return v;
+ }
+ type_error("function", v);+}
+
+BUILTIN("copy-list", copy_list)+{+ argcount(nargs, 1);
+ return copy_list(args[0]);
+}
+
+BUILTIN("append", append)+{+ value_t first = SL_nil, lst, lastcons = SL_nil;
+ int i;
+ if(nargs == 0)
+ return SL_nil;
+ sl_gc_handle(&first);
+ sl_gc_handle(&lastcons);
+ for(i = 0; i < nargs; i++){+ lst = args[i];
+ if(iscons(lst)){+ lst = copy_list(lst);
+ if(first == SL_nil)
+ first = lst;
+ else
+ cdr_(lastcons) = lst;
+ lastcons = tagptr((((cons_t*)SL(curheap))-1), TAG_CONS);
+ }else if(lst != SL_nil){+ type_error("cons", lst);+ }
+ }
+ sl_free_gc_handles(2);
+ return first;
+}
+
+BUILTIN("list*", liststar)+{+ if(nargs == 1)
+ return args[0];
+ if(nargs == 0)
+ argcount(nargs, 1);
+ return list(args, nargs, true);
+}
+
+BUILTIN("stacktrace", stacktrace)+{+ USED(args);
+ argcount(nargs, 0);
+ return _stacktrace(SL(throwing_frame) ? SL(throwing_frame) : SL(curr_frame));
+}
+
+BUILTIN("map", map)+{+ if(sl_unlikely(nargs < 2))
+ lerrorf(SL_ArgError, "too few arguments");
+ value_t *k = SL(sp);
+ PUSH(SL_nil);
+ PUSH(SL_nil);
+ for(bool first = true;;){+ PUSH(args[0]);
+ for(int i = 1; i < nargs; i++){+ if(!iscons(args[i])){+ POPN(2+i);
+ return k[1];
+ }
+ PUSH(car(args[i]));
+ args[i] = cdr_(args[i]);
+ }
+ value_t v = _applyn(nargs-1);
+ POPN(nargs);
+ PUSH(v);
+ value_t c = mk_cons();
+ car_(c) = POP(); cdr_(c) = SL_nil;
+ if(first)
+ k[1] = c;
+ else
+ cdr_(k[0]) = c;
+ k[0] = c;
+ first = false;
+ }
+}
+
+BUILTIN("for-each", for_each)+{+ if(sl_unlikely(nargs < 2))
+ lerrorf(SL_ArgError, "too few arguments");
+ for(size_t n = 0;; n++){+ PUSH(args[0]);
+ int pargs = 0;
+ for(int i = 1; i < nargs; i++, pargs++){+ value_t v = args[i];
+ if(iscons(v)){+ PUSH(car_(v));
+ args[i] = cdr_(v);
+ continue;
+ }
+ if(isvector(v)){+ size_t sz = vector_size(v);
+ if(n < sz){+ PUSH(vector_elt(v, n));
+ continue;
+ }
+ }
+ if(isarray(v)){+ size_t sz = cvalue_arraylen(v);
+ if(n < sz){+ value_t a[2];
+ a[0] = v;
+ a[1] = fixnum(n);
+ PUSH(cvalue_array_aref(a));
+ continue;
+ }
+ }
+ if(ishashtable(v)){+ htable_t *h = totable(v);
+ assert(n != 0 || h->i == 0);
+ void **table = h->table;
+ for(; h->i < h->size; h->i += 2){+ if(table[h->i+1] != HT_NOTFOUND)
+ break;
+ }
+ if(h->i < h->size){+ PUSH((value_t)table[h->i]);
+ pargs++;
+ PUSH((value_t)table[h->i+1]);
+ h->i += 2;
+ continue;
+ }
+ h->i = 0;
+ }
+ POPN(pargs+1);
+ return SL_void;
+ }
+ _applyn(pargs);
+ POPN(pargs+1);
+ }
+}
+
+BUILTIN("sleep", sl_sleep)+{+ if(nargs > 1)
+ argcount(nargs, 1);
+ double s = nargs > 0 ? todouble(args[0]) : 0;
+ sleep_ms(s * 1000.0);
+ return SL_void;
+}
+
+BUILTIN("vm-stats", vm_stats)+{+ USED(args);
+ argcount(nargs, 0);
+ ios_printf(ios_stderr, "heap total %10"PRIuPTR" bytes\n", SL(heapsize));
+ ios_printf(ios_stderr, "heap free %10"PRIuPTR" bytes\n", (uintptr_t)(SL(lim)-SL(curheap)));
+ ios_printf(ios_stderr, "heap used %10"PRIuPTR" bytes\n", (uintptr_t)(SL(curheap)-SL(fromspace)));
+ ios_printf(ios_stderr, "stack %10"PRIu64" bytes\n", (uint64_t)SL(nstack)*sizeof(value_t));
+ ios_printf(ios_stderr, "finalizers %10"PRIu32"\n", (uint32_t)SL(nfinalizers));
+ ios_printf(ios_stderr, "max finalizers %10"PRIu32"\n", (uint32_t)SL(maxfinalizers));
+ ios_printf(ios_stderr, "gc handles %10"PRIu32"\n", (uint32_t)SL(ngchandles));
+ ios_printf(ios_stderr, "gc calls %10"PRIu64"\n", (uint64_t)SL(gccalls));
+ ios_printf(ios_stderr, "opcodes %10d\n", N_OPCODES);
+ return SL_void;
+}
+
+static const builtinspec_t builtin_fns[] = {+#define BUILTIN_FN(l, c, attr){l, (builtin_t)fn_builtin_##c},+#include "builtin_fns.h"
+#undef BUILTIN_FN
+};
+
+// initialization -------------------------------------------------------------
+
+int
+sl_init(size_t heapsize, size_t stacksize)
+{+ int i;
+
+ if((sl = MEM_CALLOC(1, sizeof(*sl))) == nil)
+ return -1;
+ SL(scr_width) = 100;
+
+ SL(heapsize) = heapsize*sizeof(value_t);
+
+ if((SL(fromspace) = MEM_ALLOC(SL(heapsize))) == nil){+failed:
+ MEM_FREE(SL(fromspace));
+ MEM_FREE(SL(tospace));
+ MEM_FREE(SL(consflags));
+ MEM_FREE(SL(finalizers));
+ sl_segfree(SL(stack), stacksize*sizeof(value_t));
+ htable_free(&SL(printconses));
+ MEM_FREE(sl);
+ return -1;
+ }
+
+ if((SL(tospace) = MEM_ALLOC(SL(heapsize))) == nil)
+ goto failed;
+ SL(curheap) = SL(fromspace);
+ SL(lim) = SL(curheap)+SL(heapsize)-sizeof(cons_t);
+
+ if((SL(stack) = sl_segalloc(stacksize*sizeof(value_t))) == nil)
+ goto failed;
+ SL(curr_frame) = SL(sp) = SL(stack);
+ SL(nstack) = stacksize;
+
+ SL(maxfinalizers) = 512;
+ if((SL(finalizers) = MEM_ALLOC(SL(maxfinalizers) * sizeof(*SL(finalizers)))) == nil)
+ goto failed;
+
+ if((SL(consflags) = bitvector_new(SL(heapsize)/sizeof(cons_t), 1)) == nil)
+ goto failed;
+ if((htable_new(&SL(printconses), 32)) == nil)
+ goto failed;
+
+ comparehash_init();
+
+ SL_lambda = csymbol("λ");+ SL_function = csymbol("function");+ SL_quote = csymbol("quote");+ SL_trycatch = csymbol("trycatch");+ SL_backquote = csymbol("quasiquote");+ SL_comma = csymbol("unquote");+ SL_commaat = csymbol("unquote-splicing");+ SL_commadot = csymbol("unquote-nsplicing");+ SL_IOError = csymbol("io-error");+ SL_ParseError = csymbol("parse-error");+ SL_TypeError = csymbol("type-error");+ SL_ArgError = csymbol("arg-error");+ SL_UnboundError = csymbol("unbound-error");+ SL_KeyError = csymbol("key-error");+ SL_MemoryError = csymbol("memory-error");+ SL_BoundsError = csymbol("bounds-error");+ SL_DivideError = csymbol("divide-error");+ SL_Error = csymbol("error");+ SL_conssym = csymbol("cons");+ SL_symbolsym = csymbol("symbol");+ SL_fixnumsym = csymbol("fixnum");+ SL_vectorsym = csymbol("vector");+ SL_builtinsym = csymbol("builtin");+ SL_booleansym = csymbol("boolean");+ SL_nullsym = csymbol("null");+ SL_defsym = csymbol("def");+ SL_defmacrosym = csymbol("defmacro");+ SL_forsym = csymbol("for");+ SL_setqsym = csymbol("set!");+ SL_evalsym = csymbol("eval");+ SL_vu8sym = csymbol("vu8");+ SL_fnsym = csymbol("fn");+ SL_nulsym = csymbol("nul");+ SL_alarmsym = csymbol("alarm");+ SL_backspacesym = csymbol("backspace");+ SL_tabsym = csymbol("tab");+ SL_linefeedsym = csymbol("linefeed");+ SL_vtabsym = csymbol("vtab");+ SL_pagesym = csymbol("page");+ SL_returnsym = csymbol("return");+ SL_escsym = csymbol("esc");+ SL_spacesym = csymbol("space");+ SL_deletesym = csymbol("delete");+ SL_newlinesym = csymbol("newline");+ SL_builtins_table_sym = csymbol("*builtins*");+
+ set(SL_printprettysym = csymbol("*print-pretty*"), SL_t);+ set(SL_printreadablysym = csymbol("*print-readably*"), SL_t);+ set(SL_printwidthsym = csymbol("*print-width*"), fixnum(SL(scr_width)));+ set(SL_printlengthsym = csymbol("*print-length*"), SL_nil);+ set(SL_printlevelsym = csymbol("*print-level*"), SL_nil);+ SL(lasterror) = SL_nil;
+
+ for(i = 0; i < nelem(builtins); i++){+ if(builtins[i].name)
+ set(symbol(builtins[i].name, false), builtin(i));
+ }
+ setc(csymbol("procedure?"), builtin(OP_FUNCTIONP));+ setc(csymbol("top-level-bound?"), builtin(OP_BOUNDP));+
+ SL(the_empty_vector) = tagptr(alloc_words(1), TAG_VECTOR);
+ vector_setsize(SL(the_empty_vector), 0);
+
+ cvalues_init();
+
+ set(csymbol("*os-name*"), cvalue_static_cstring(__os_name__));+#if defined(__os_version__)
+ set(csymbol("*os-version*"), cvalue_static_cstring(__os_version__));+#endif
+ SL(memory_exception_value) = sl_list2(SL_MemoryError, cvalue_static_cstring("out of memory"));+
+ const builtinspec_t *b;
+ for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++)
+ cbuiltin(b->name, b->fptr);
+ table_init();
+ iostream_init();
+ compress_init();
+ return 0;
+}
+
+// top level ------------------------------------------------------------------
+
+value_t
+sl_toplevel_eval(value_t expr)
+{+ return sl_applyn(1, symbol_value(SL_evalsym), expr);
+}
+
+int
+sl_load_system_image(value_t sys_image_iostream)
+{+ SL(loading) = true;
+ PUSH(sys_image_iostream);
+ value_t *saveSP = SL(sp);
+ SL_TRY{+ while(1){+ SL(sp) = saveSP;
+ value_t e = sl_read_sexpr(SL(sp)[-1]);
+ if(ios_eof(value2c(ios_t*, SL(sp)[-1])))
+ break;
+ if(isfunction(e)){+ // stage 0 format: series of thunks
+ PUSH(e);
+ (void)_applyn(0);
+ }else{+ // stage 1 format: list alternating symbol/value
+ while(iscons(e)){+ symbol_t *sym = tosymbol(car_(e));
+ e = cdr_(e);
+ if(sym->binding != UNBOUND)
+ ios_printf(ios_stderr, "%s redefined on boot\n", sym->name);
+ sym->binding = car_(e);
+ e = cdr_(e);
+ }
+ break;
+ }
+ }
+ }
+ SL_CATCH_NO_INC{+ ios_puts(ios_stderr, "fatal error during bootstrap: ");
+ sl_print(ios_stderr, SL(lasterror));
+ ios_putc(ios_stderr, '\n');
+ return -1;
+ }
+ SL(sp) = saveSP-1;
+ SL(loading) = false;
+ return 0;
+}
--- /dev/null
+++ b/src/sl.h
@@ -1,0 +1,452 @@
+#pragma once
+
+#include "platform.h"
+#include "utf8.h"
+#include "ios.h"
+#include "tbl.h"
+#include "bitvector.h"
+#include "htableh.inc"
+HTPROT(ptrhash)
+
+typedef struct sltype_t sltype_t;
+
+enum {+ TAG_NUM,
+ TAG_CPRIM,
+ TAG_FUNCTION,
+ TAG_VECTOR,
+ TAG_NUM1,
+ TAG_CVALUE,
+ TAG_SYM,
+ TAG_CONS,
+
+ /* those were set to 7 and 3 strategically on purpose */
+ TAG_NONLEAF_MASK = TAG_CONS & TAG_VECTOR,
+};
+
+enum {+ FLAG_CONST = 1<<0,
+ FLAG_KEYWORD = 1<<1,
+};
+
+typedef enum {+ T_INT8, T_UINT8,
+ T_INT16, T_UINT16,
+ T_INT32, T_UINT32,
+ T_INT64, T_UINT64,
+ T_MPINT,
+ T_FLOAT,
+ T_DOUBLE,
+}numerictype_t;
+
+typedef uintptr_t value_t;
+
+#if defined(BITS64)
+typedef int64_t fixnum_t;
+#define FIXNUM_BITS 62
+#define TOP_BIT (1ULL<<63)
+#define T_FIXNUM T_INT64
+#define PRIdFIXNUM PRId64
+#else
+typedef int32_t fixnum_t;
+#define FIXNUM_BITS 30
+#define TOP_BIT (1U<<31)
+#define T_FIXNUM T_INT32
+#define PRIdFIXNUM PRId32
+#endif
+
+#if !defined(FWD_BIT)
+#define FWD_BIT TOP_BIT
+#endif
+
+typedef struct {+ value_t car;
+ value_t cdr;
+}sl_aligned(8) cons_t;
+
+// NOTE: symbol_t MUST have the same fields as gensym_t first
+// there are places where gensyms are treated as normal symbols
+typedef struct {+ uint64_t hash;
+ sltype_t *type;
+ value_t binding; // global value binding
+ uint8_t numtype;
+ uint8_t size;
+ uint8_t flags;
+ uint8_t _dummy;
+ const char *name;
+}sl_aligned(8) symbol_t;
+
+typedef struct {+ uint64_t id;
+ sltype_t *type;
+ value_t binding;
+}sl_aligned(8) gensym_t;
+
+typedef struct Builtin Builtin;
+
+struct Builtin {+ const char *name;
+ int nargs;
+};
+
+typedef value_t (*builtin_t)(value_t*, int);
+
+#define fits_bits(x, b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
+#define fits_fixnum(x) fits_bits(x, FIXNUM_BITS)
+
+#define ANYARGS -10000
+#define NONNUMERIC (0xff)
+#define valid_numtype(v) ((v) <= T_DOUBLE)
+#define UNBOUND ((value_t)1) // an invalid value
+#define tag(x) ((x) & 7)
+#define ptr(x) ((void*)((uintptr_t)(x) & (~(uintptr_t)7)))
+#define tagptr(p, t) ((value_t)(p) | (t))
+#define fixnum(x) ((value_t)(x)<<2)
+#define numval(x) ((fixnum_t)(x)>>2)
+#define uintval(x) (((unsigned int)(x))>>3)
+#define builtin(n) tagptr(((value_t)n<<3), TAG_FUNCTION)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isfixnum(x) (((x)&3) == TAG_NUM)
+#define bothfixnums(x, y) (isfixnum(x) && isfixnum(y))
+#define isvector(x) (tag(x) == TAG_VECTOR)
+#define iscvalue(x) (tag(x) == TAG_CVALUE)
+#define iscprim(x) (tag(x) == TAG_CPRIM)
+// doesn't lead to other values
+#define leafp(a) (((a)&TAG_NONLEAF_MASK) != TAG_NONLEAF_MASK)
+
+// allocate n consecutive conses
+#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)SL(fromspace)))
+#define ismarked(c) bitvector_get(SL(consflags), cons_index(c))
+#define mark_cons(c) bitvector_set(SL(consflags), cons_index(c))
+#define unmark_cons(c) bitvector_reset(SL(consflags), cons_index(c))
+
+#define isforwarded(v) (*(value_t*)ptr(v) & FWD_BIT)
+#define forwardloc(v) (*(value_t*)ptr(v) ^ FWD_BIT)
+#define forward(v, to) \
+ do{ \+ *(value_t*)ptr(v) = (value_t)(to) | FWD_BIT; \
+ }while(0)
+
+#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
+#define vector_setsize(v, n) (((size_t*)ptr(v))[0] = ((n)<<2))
+#define vector_elt(v, i) (((value_t*)ptr(v))[1+(i)])
+#define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons(v)->car)
+#define cdr(v) (tocons(v)->cdr)
+#define fn_bcode(f) (((function_t*)ptr(f))->bcode)
+#define fn_vals(f) (((function_t*)ptr(f))->vals)
+#define fn_env(f) (((function_t*)ptr(f))->env)
+#define fn_name(f) (((function_t*)ptr(f))->name)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) \
+ do{ \+ symbol_t *sy = (symbol_t*)ptr(s); \
+ sy->flags |= FLAG_CONST; \
+ sy->binding = (v); \
+ }while(0)
+#define isconstant(s) ((s)->flags & FLAG_CONST)
+#define iskeyword(s) ((s)->flags & FLAG_KEYWORD)
+#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
+#define sym_to_numtype(s) (((symbol_t*)ptr(s))->numtype)
+#define ismanaged(v) ((((uint8_t*)ptr(v)) >= SL(fromspace)) && (((uint8_t*)ptr(v)) < SL(fromspace)+SL(heapsize)))
+#define isgensym(x) (issymbol(x) && ismanaged(x))
+#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
+#define iscbuiltin(x) (iscvalue(x) && cv_class(ptr(x)) == SL(builtintype))
+// utility for iterating over all arguments in a builtin
+// i=index, i0=start index, arg = var for each arg, args = arg array
+// assumes "nargs" is the argument count
+#define FOR_ARGS(i, i0, arg, args) for(i=i0; i<nargs && ((arg=args[i]) || 1); i++)
+#define N_BUILTINS ((int)N_OPCODES)
+
+#define PUSH(v) \
+ do{ \+ *SL(sp)++ = (v); \
+ }while(0)
+#define POPN(n) \
+ do{ \+ SL(sp) -= (n); \
+ }while(0)
+#define POP() *(--SL(sp))
+
+bool isbuiltin(value_t x) sl_constfn sl_hotfn;
+int sl_init(size_t heapsize, size_t stacksize);
+int sl_load_system_image(value_t ios);
+
+_Noreturn void sl_exit(int status);
+
+/* collector */
+value_t relocate(value_t v) sl_hotfn;
+void sl_gc(bool mustgrow);
+void sl_gc_handle(value_t *pv);
+void sl_free_gc_handles(int n);
+
+/* symbol table */
+value_t gensym(void);
+value_t symbol(const char *str, bool copy) sl_hotfn;
+value_t csymbol_(const char *str, int len);
+#define csymbol(str) csymbol_(str, sizeof(str)-1)
+const char *symbol_name(value_t v);
+
+/* read, eval, print main entry points */
+value_t sl_toplevel_eval(value_t expr);
+value_t sl_apply(value_t f, value_t l);
+value_t sl_applyn(int n, value_t f, ...);
+
+/* object model manipulation */
+value_t sl_cons(value_t a, value_t b);
+value_t sl_list2(value_t a, value_t b);
+value_t sl_listn(int n, ...);
+bool sl_isnumber(value_t v) sl_purefn;
+value_t alloc_vector(size_t n, bool init);
+
+/* consistent iswprint and wcwidth */
+int sl_iswprint(Rune c) sl_constfn;
+int sl_wcwidth(Rune c) sl_constfn;
+
+/* safe casts */
+cons_t *tocons(value_t v) sl_purefn;
+symbol_t *tosymbol(value_t v) sl_purefn;
+fixnum_t tofixnum(value_t v) sl_purefn;
+char *tostring(value_t v) sl_purefn;
+double todouble(value_t a) sl_purefn;
+
+/* conses */
+value_t mk_cons(void) sl_hotfn;
+void *alloc_words(int n) sl_hotfn;
+
+char *uint2str(char *dest, size_t len, uint64_t num, int base);
+
+/* error handling */
+typedef struct _sl_readstate_t {+ htable_t backrefs;
+ htable_t gensyms;
+ value_t source;
+ struct _sl_readstate_t *prev;
+}sl_readstate_t;
+
+typedef struct _ectx_t {+ sl_readstate_t *rdst;
+ struct _ectx_t *prev;
+ jmp_buf buf;
+ value_t *sp;
+ value_t *frame;
+ int ngchnd;
+}sl_exception_context_t;
+
+void free_readstate(sl_readstate_t *rs);
+
+#define SL_TRY_EXTERN \
+ sl_exception_context_t _ctx; int l__tr, l__ca; \
+ sl_savestate(&_ctx); SL(exctx) = &_ctx; \
+ if(!sl_setjmp(_ctx.buf)) \
+ for(l__tr = 1; l__tr; l__tr = 0, (void)(SL(exctx) = SL(exctx)->prev))
+
+#define SL_CATCH_EXTERN_NO_RESTORE \
+ else \
+ for(l__ca=1; l__ca;)
+
+#define SL_CATCH_EXTERN \
+ else \
+ for(l__ca=1; l__ca; l__ca=0, sl_restorestate(&_ctx))
+
+_Noreturn void lerrorf(value_t e, const char *format, ...) sl_printfmt(2, 3);
+void sl_savestate(sl_exception_context_t *_ctx);
+void sl_restorestate(sl_exception_context_t *_ctx);
+_Noreturn void sl_raise(value_t e);
+_Noreturn void type_error(const char *expected, value_t got);
+_Noreturn void bounds_error(value_t arr, value_t ind);
+_Noreturn void unbound_error(value_t sym);
+_Noreturn void arity_error(int nargs, int c);
+
+#define argcount(nargs, c) \
+ do{ \+ if(sl_unlikely(nargs != c)) \
+ arity_error(nargs, c); \
+ }while(0)
+
+typedef struct {+ void (*print)(value_t self, ios_t *f);
+ void (*relocate)(value_t oldv, value_t newv);
+ void (*finalize)(value_t self);
+ void (*print_traverse)(value_t self);
+} cvtable_t;
+
+typedef void (*cvinitfunc_t)(sltype_t*, value_t, void*);
+
+struct sltype_t {+ value_t type;
+ cvtable_t *vtable;
+ sltype_t *eltype; // for arrays
+ sltype_t *artype; // (array this)
+ cvinitfunc_t init;
+ size_t size;
+ size_t elsz;
+ numerictype_t numtype;
+};
+
+typedef struct {+ sltype_t *type;
+ union {+ void *data;
+ builtin_t cbuiltin;
+ };
+ size_t len; // length of *data in bytes
+ uint8_t _space[]; // variable size
+}sl_aligned(8) cvalue_t;
+
+typedef struct {+ sltype_t *type;
+ uint8_t _space[];
+}sl_aligned(8) cprim_t;
+
+typedef struct {+ value_t bcode;
+ value_t vals;
+ value_t env;
+ value_t name;
+}sl_aligned(8) function_t;
+
+#define CPRIM_NWORDS sizeof(cprim_t)/sizeof(value_t)
+#define cv_class(cv) ((sltype_t*)(((uintptr_t)((cvalue_t*)cv)->type)&~(uintptr_t)3))
+#define cv_len(cv) (((cvalue_t*)(cv))->len)
+#define cv_type(cv) (cv_class(cv)->type)
+#define cv_data(cv) (((cvalue_t*)(cv))->data)
+#define cv_isstr(cv) (cv_class(cv)->eltype == SL(bytetype))
+#define cv_isPOD(cv) (cv_class(cv)->init != nil)
+#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
+#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
+#define value2c(type, v) ((type)cvalue_data(v))
+#define cp_class(cp) (((cprim_t*)(cp))->type)
+#define cp_type(cp) (cp_class(cp)->type)
+#define cp_numtype(cp) (cp_class(cp)->numtype)
+#define cp_data(cp) (((cprim_t*)(cp))->_space)
+// WARNING: multiple evaluation!
+#define cptr(v) (iscprim(v) ? cp_data(ptr(v)) : cvalue_data(v))
+
+#define ismpint(v) (iscvalue(v) && cp_numtype(ptr(v)) == T_MPINT)
+#define tompint(v) (*(mpint**)cv_data(ptr(v)))
+
+#define BUILTIN(lname, cname) \
+ value_t fn_builtin_##cname(value_t *args, int nargs)
+
+#define BUILTIN_FN(l, c, attr) attr BUILTIN(l, c);
+#include "builtin_fns.h"
+#undef BUILTIN_FN
+
+#include "opcodes.h"
+
+enum {+ SL_nil = builtin(OP_LOADNIL),
+ SL_t = builtin(OP_LOADT),
+ SL_void = builtin(OP_LOADVOID),
+ SL_eof = builtin(OP_EOF_OBJECT),
+};
+
+#define N_GC_HANDLES 1024
+
+typedef struct Sl Sl;
+
+struct Sl {+ value_t *sp;
+ uint8_t *curheap;
+ value_t *curr_frame;
+
+ uint8_t *fromspace;
+ uint8_t *tospace;
+ uint8_t *lim;
+
+ value_t *stack;
+
+ uintptr_t heapsize;//bytes
+ size_t malloc_pressure;
+ uint32_t nstack;
+
+ cvalue_t **finalizers;
+ size_t nfinalizers;
+ size_t maxfinalizers;
+
+ sl_readstate_t *readstate;
+ Tbl *symtab;
+
+ // saved execution state for an unwind target
+ sl_exception_context_t *exctx;
+ value_t *throwing_frame; // active frame when exception was thrown
+ value_t lasterror;
+
+ sltype_t *tabletype;
+
+ sltype_t *iostreamtype;
+
+ value_t the_empty_vector;
+ value_t the_empty_string;
+ value_t memory_exception_value;
+
+ sltype_t *mpinttype;
+ sltype_t *int8type, *uint8type;
+ sltype_t *int16type, *uint16type;
+ sltype_t *int32type, *uint32type;
+ sltype_t *int64type, *uint64type;
+ sltype_t *floattype, *doubletype;
+ sltype_t *bytetype, *runetype;
+ sltype_t *stringtype, *runestringtype;
+ sltype_t *builtintype;
+
+ uint32_t gensym_ctr;
+ // two static buffers for gensym printing so there can be two
+ // gensym names available at a time, mostly for compare()
+ char gsname[2][16];
+ int gsnameno;
+
+ bool loading;
+ bool exiting;
+ bool grew;
+
+ uint32_t *consflags;
+ size_t gccalls;
+
+ htable_t printconses;
+ uint32_t printlabel;
+ int print_pretty;
+ int print_princ;
+ fixnum_t print_length;
+ fixnum_t print_level;
+ fixnum_t p_level;
+ int scr_width;
+ ssize_t hpos, vpos;
+
+ htable_t reverse_dlsym_lookup_table;
+ htable_t TypeTable;
+ int ngchandles;
+ value_t *gchandles[N_GC_HANDLES];
+};
+
+extern sl_thread(Sl *sl);
+#define SL(f) sl->f
+
+extern value_t SL_builtins_table_sym, SL_quote, SL_lambda, SL_function, SL_comma, SL_commaat;
+extern value_t SL_commadot, SL_trycatch, SL_backquote;
+extern value_t SL_conssym, SL_symbolsym, SL_fixnumsym, SL_vectorsym, SL_builtinsym, SL_vu8sym;
+extern value_t SL_defsym, SL_defmacrosym, SL_forsym, SL_setqsym;
+extern value_t SL_booleansym, SL_nullsym, SL_evalsym, SL_fnsym;
+extern value_t SL_nulsym, SL_alarmsym, SL_backspacesym, SL_tabsym, SL_linefeedsym, SL_newlinesym;
+extern value_t SL_vtabsym, SL_pagesym, SL_returnsym, SL_escsym, SL_spacesym, SL_deletesym;
+extern value_t SL_IOError, SL_ParseError, SL_TypeError, SL_ArgError, SL_MemoryError;
+extern value_t SL_DivideError, SL_BoundsError, SL_Error, SL_KeyError, SL_UnboundError;
+
+extern value_t SL_printwidthsym, SL_printreadablysym, SL_printprettysym, SL_printlengthsym;
+extern value_t SL_printlevelsym;
+extern value_t SL_arraysym;
+extern value_t SL_iostreamsym, SL_rdsym, SL_wrsym, SL_apsym, SL_crsym, SL_truncsym;
+extern value_t SL_instrsym, SL_outstrsym;
+extern value_t SL_int8sym, SL_uint8sym, SL_int16sym, SL_uint16sym, SL_int32sym, SL_uint32sym;
+extern value_t SL_int64sym, SL_uint64sym, SL_bignumsym;
+extern value_t SL_bytesym, SL_runesym, SL_floatsym, SL_doublesym;
+extern value_t SL_stringtypesym, SL_runestringtypesym;
+
+_Noreturn void slmain(const uint8_t *boot, int bootsz, int argc, char **argv);
--- /dev/null
+++ b/src/sl_arith_any.inc
@@ -1,0 +1,158 @@
+//value_t
+//sl_*_any(value_t *args, uint32_t nargs)
+// input: ACCUM_DEFAULT ARITH_OP(a,b) MP_OP ARITH_OVERFLOW
+// add: 0 a+b mpadd sadd_overflow_64
+// mul: 1 a*b mpmul smul_overflow_64
+
+ mpint *Maccum = nil, *m = nil;
+ int64_t Saccum = ACCUM_DEFAULT, x;
+ uint64_t u64;
+ double Faccum = ACCUM_DEFAULT;
+ bool inexact = false;
+ value_t arg;
+ numerictype_t pt;
+ void *a;
+ cprim_t *cp;
+ cvalue_t *cv;
+
+ uint32_t i, j;
+ FOR_ARGS(i, 0, arg, args){+ if(isfixnum(arg))
+ x = numval(arg);
+ else{+ if(iscprim(arg)){+ cp = ptr(arg);
+ a = cp_data(cp);
+ pt = cp_numtype(cp);
+ }else if(iscvalue(arg)){+ cv = ptr(arg);
+ a = cv_data(cv);
+ pt = cv_class(cv)->numtype;
+ }else{+typeerr:
+ mpfree(Maccum);
+ mpfree(m);
+ type_error("number", arg);+ }
+ switch(pt){+ case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
+ case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
+ case T_INT8: x = *(int8_t*)a; break;
+ case T_UINT8: x = *(uint8_t*)a; break;
+ case T_INT16: x = *(int16_t*)a; break;
+ case T_UINT16: x = *(uint16_t*)a; break;
+ case T_INT32: x = *(int32_t*)a; break;
+ case T_UINT32: x = *(uint32_t*)a; break;
+ case T_INT64: x = *(int64_t*)a; break;
+ case T_UINT64:
+ u64 = *(uint64_t*)a;
+ if(u64 > INT64_MAX){+ x = ACCUM_DEFAULT;
+ goto overflow;
+ }
+ x = u64;
+ break;
+ case T_MPINT:
+ x = ACCUM_DEFAULT;
+ u64 = ACCUM_DEFAULT;
+ m = mpcopy(*(mpint**)a);
+ goto overflow;
+ default:
+ goto typeerr;
+ }
+ }
+
+ int64_t accu;
+ if(ARITH_OVERFLOW(Saccum, x, &accu)){+ u64 = ACCUM_DEFAULT;
+ goto overflow;
+ }
+ Saccum = accu;
+ }
+
+ if(inexact)
+ return mk_double(ARITH_OP(Faccum, Saccum));
+ if(fits_fixnum(Saccum))
+ return fixnum((fixnum_t)Saccum);
+ u64 = ACCUM_DEFAULT;
+ x = ACCUM_DEFAULT;
+
+overflow:
+ i++;
+ if(Maccum == nil)
+ Maccum = vtomp(Saccum, nil);
+ if(m == nil)
+ m = u64 != ACCUM_DEFAULT ? uvtomp(u64, nil) : vtomp(x, nil);
+
+ MP_OP(Maccum, m, Maccum);
+
+ FOR_ARGS(j, i, arg, args){+ if(isfixnum(arg)){+ vtomp(numval(arg), m);
+ MP_OP(Maccum, m, Maccum);
+ continue;
+ }
+
+ if(iscprim(arg)){+ cp = ptr(arg);
+ a = cp_data(cp);
+ pt = cp_numtype(cp);
+ }else if(iscvalue(arg)){+ cv = ptr(arg);
+ a = cv_data(cv);
+ pt = cv_class(cv)->numtype;
+ }else{+ goto typeerr;
+ }
+ switch(pt){+ case T_DOUBLE: Faccum = ARITH_OP(Faccum, *(double*)a); inexact = true; continue;
+ case T_FLOAT: Faccum = ARITH_OP(Faccum, *(float*)a); inexact = true; continue;
+ case T_INT8: x = *(int8_t*)a; break;
+ case T_UINT8: x = *(uint8_t*)a; break;
+ case T_INT16: x = *(int16_t*)a; break;
+ case T_UINT16: x = *(uint16_t*)a; break;
+ case T_INT32: x = *(int32_t*)a; break;
+ case T_UINT32: x = *(uint32_t*)a; break;
+ case T_INT64: x = *(int64_t*)a; break;
+ case T_UINT64:
+ uvtomp(*(uint64_t*)a, m);
+ MP_OP(Maccum, m, Maccum);
+ continue;
+ case T_MPINT:
+ MP_OP(Maccum, *(mpint**)a, Maccum);
+ continue;
+ default:
+ goto typeerr;
+ }
+ vtomp(x, m);
+ MP_OP(Maccum, m, Maccum);
+ }
+
+ int n = mpsignif(Maccum);
+ if(n >= FIXNUM_BITS){+ if(inexact){+ dtomp(Faccum, m);
+ MP_OP(Maccum, m, Maccum);
+ n = mpsignif(Maccum);
+ if(n < FIXNUM_BITS){+ inexact = false;
+ goto down;
+ }
+ }
+ mpfree(m);
+ return mk_mpint(Maccum);
+ }
+
+down:
+ mpfree(m);
+ Saccum = mptov(Maccum);
+ mpfree(Maccum);
+ if(inexact)
+ return mk_double(ARITH_OP(Faccum, Saccum));
+ assert(fits_fixnum(Saccum));
+ return fixnum((fixnum_t)Saccum);
+
+#undef ACCUM_DEFAULT
+#undef ARITH_OP
+#undef MP_OP
+#undef ARITH_OVERFLOW
--- /dev/null
+++ b/src/slmain.c
@@ -1,0 +1,145 @@
+#include "sl.h"
+#include "cvalues.h"
+#include "print.h"
+#include "iostream.h"
+#include "random.h"
+#include "brieflz.h"
+#include "nan.h"
+
+#if !defined(ARGBEGIN)
+/* straight from 9front */
+static char *argv0 = nil;
+#define ARGBEGIN \
+ for((argv0 ? 0 : (argv0=*argv)), argv++, argc--; argv[0] && argv[0][0]=='-' && argv[0][1]; argc--, argv++){ \+ const char *_args, *_argt; \
+ Rune _argc; \
+ _args = &argv[0][1]; \
+ if(_args[0]=='-' && _args[1]==0){ \+ argc--; \
+ argv++; \
+ break; \
+ }\
+ _argc = 0; \
+ while(*_args && (_args += chartorune(&_argc, _args))) \
+ switch(_argc)
+#define ARGEND USED(_argt); USED(_argc); USED(_args);}USED(argv); USED(argc);
+#define ARGF() (_argt=_args, _args="", (*_argt? _argt: argv[1]? (argc--, *++argv): 0))
+#define ARGC() _argc
+#define EARGF(x) (_argt=_args, _args="", (*_argt? _argt: argv[1]? (argc--, *++argv): (x, (char*)0)))
+#endif
+
+static value_t
+argv_list(int argc, char **argv)
+{+ int i;
+ value_t lst = SL_nil, temp;
+ sl_gc_handle(&lst);
+ sl_gc_handle(&temp);
+ for(i = argc-1; i >= 0; i--){+ temp = cvalue_static_cstring(argv[i]);
+ lst = sl_cons(temp, lst);
+ }
+ lst = sl_cons(cvalue_static_cstring(argv0), lst);
+ sl_free_gc_handles(2);
+ return lst;
+}
+
+static void
+sizesuffix(size_t *sz, char su)
+{+ switch(tolower(su)){+ case 'k':
+ *sz *= 1024;
+ break;
+ case 'm':
+ *sz *= 1024*1024;
+ break;
+ case 0:
+ break;
+ default:
+ ios_printf(ios_stderr, "invalid size suffix '%c'\n", su);
+ exit(1);
+ }
+}
+
+_Noreturn static void
+usage(void)
+{+ ios_printf(ios_stderr, "%s: [-H heapsize] [-S stacksize] ...\n", argv0);
+ exit(0);
+}
+
+
+_Noreturn void
+slmain(const uint8_t *boot, int bootsz, int argc, char **argv)
+{+ size_t heapsize = HEAP_SIZE0, stacksize = STACK_SIZE0;
+ char *e;
+
+ nan_init();
+ randomize();
+ ios_init_stdstreams();
+ mpsetminbits(sizeof(fixnum_t)*8);
+
+ ARGBEGIN{+ case 'H':
+ heapsize = strtoull(EARGF(usage()), &e, 0);
+ sizesuffix(&heapsize, *e);
+ break;
+ case 'S':
+ stacksize = strtoull(EARGF(usage()), &e, 0);
+ sizesuffix(&stacksize, *e);
+ break;
+ case 'h':
+ usage();
+ default:
+ break;
+ }ARGEND
+
+ if(sl_init(heapsize, stacksize) != 0){+ ios_puts(ios_stderr, "init failed\n");
+ exit(1);
+ }
+
+ value_t f = cvalue(SL(iostreamtype), (int)sizeof(ios_t));
+ sl_gc_handle(&f);
+ value_t args = argv_list(argc, argv);
+ sl_gc_handle(&args);
+ ios_t *s = value2c(ios_t*, f);
+ uint8_t *unpacked = nil;
+ if(boot[0] == 0){+ uint32_t unpackedsz =
+ boot[1]<<0 |
+ boot[2]<<8 |
+ boot[3]<<16|
+ boot[4]<<24;
+ unpacked = MEM_ALLOC(unpackedsz);
+ unsigned long n = blz_depack_safe(boot+5, bootsz-5, unpacked, unpackedsz);
+ if(n == BLZ_ERROR){+ ios_puts(ios_stderr, "failed to unpack boot image\n");
+ sl_exit(1);
+ }
+ boot = unpacked;
+ bootsz = n;
+ }
+ ios_static_buffer(s, boot, bootsz);
+
+ int r = 1;
+ SL_TRY_EXTERN{+ if(sl_load_system_image(f) == 0){+ MEM_FREE(unpacked);
+ s = value2c(ios_t*, f);
+ sl_free_gc_handles(2);
+ ios_close(s);
+ sl_applyn(1, symbol_value(symbol("__start", false)), args);+ r = 0;
+ }
+ }
+ SL_CATCH_EXTERN_NO_RESTORE{+ ios_puts(ios_stderr, "fatal error:\n");
+ sl_print(ios_stderr, SL(lasterror));
+ ios_putc(ios_stderr, '\n');
+ break;
+ }
+ sl_exit(r);
+}
--- a/src/string.c
+++ b/src/string.c
@@ -1,7 +1,7 @@
/*
string functions
*/
-#include "flisp.h"
+#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "print.h"
@@ -9,11 +9,11 @@
#include "equal.h"
#include "iostream.h"
-fl_purefn
+sl_purefn
BUILTIN("string?", stringp) {argcount(nargs, 1);
- return fl_isstring(args[0]) ? FL_t : FL_nil;
+ return sl_isstring(args[0]) ? SL_t : SL_nil;
}
BUILTIN("string-length", string_length)@@ -21,7 +21,7 @@
size_t start = 0;
if(nargs < 1 || nargs > 3)
argcount(nargs, 1);
- if(!fl_isstring(args[0]))
+ if(!sl_isstring(args[0]))
type_error("string", args[0]);size_t len = cv_len(ptr(args[0]));
size_t stop = len;
@@ -46,23 +46,23 @@
argcount(nargs, 1);
if(iscprim(args[0])){cprim_t *cp = ptr(args[0]);
- if(cp_class(cp) == FL(runetype)){- int w = fl_wcwidth(*(Rune*)cp_data(cp));
- return w < 0 ? FL_nil : fixnum(w);
+ if(cp_class(cp) == SL(runetype)){+ int w = sl_wcwidth(*(Rune*)cp_data(cp));
+ return w < 0 ? SL_nil : fixnum(w);
}
}
- if(!fl_isstring(args[0]))
+ if(!sl_isstring(args[0]))
type_error("string", args[0]);char *str = tostring(args[0]);
size_t len = cv_len(ptr(args[0]));
ssize_t w = u8_strwidth(str, len);
- return w < 0 ? FL_nil : size_wrap(w);
+ return w < 0 ? SL_nil : size_wrap(w);
}
BUILTIN("string-reverse", string_reverse) {argcount(nargs, 1);
- if(!fl_isstring(args[0]))
+ if(!sl_isstring(args[0]))
type_error("string", args[0]);size_t len = cv_len(ptr(args[0]));
value_t ns = cvalue_string(len);
@@ -75,8 +75,8 @@
argcount(nargs, 1);
if(iscvalue(args[0])){cvalue_t *cv = ptr(args[0]);
- fltype_t *t = cv_class(cv);
- if(t->eltype == FL(runetype)){+ sltype_t *t = cv_class(cv);
+ if(t->eltype == SL(runetype)){size_t nr = cv_len(cv) / sizeof(Rune);
Rune *r = (Rune*)cv_data(cv);
size_t nb = runenlen(r, nr);
@@ -94,10 +94,10 @@
{bool term = false;
if(nargs == 2)
- term = args[1] != FL_nil;
+ term = args[1] != SL_nil;
else
argcount(nargs, 1);
- if(!fl_isstring(args[0]))
+ if(!sl_isstring(args[0]))
type_error("string", args[0]);cvalue_t *cv = ptr(args[0]);
char *ptr = (char*)cv_data(cv);
@@ -106,7 +106,7 @@
size_t newsz = nc*sizeof(Rune);
if(term)
newsz += sizeof(Rune);
- value_t runestr = cvalue(FL(runestringtype), newsz);
+ value_t runestr = cvalue(SL(runestringtype), newsz);
ptr = cvalue_data(args[0]); // relocatable pointer
Rune *r = cvalue_data(runestr);
for(size_t i = 0; i < nb; i++)
@@ -118,24 +118,24 @@
BUILTIN("string", string) {- if(nargs == 1 && fl_isstring(args[0]))
+ if(nargs == 1 && sl_isstring(args[0]))
return args[0];
value_t arg, buf = fn_builtin_buffer(nil, 0);
- fl_gc_handle(&buf);
+ sl_gc_handle(&buf);
ios_t *s = value2c(ios_t*, buf);
- value_t oldpr = symbol_value(FL_printreadablysym);
- value_t oldpp = symbol_value(FL_printprettysym);
- set(FL_printreadablysym, FL_nil);
- set(FL_printprettysym, FL_nil);
+ value_t oldpr = symbol_value(SL_printreadablysym);
+ value_t oldpp = symbol_value(SL_printprettysym);
+ set(SL_printreadablysym, SL_nil);
+ set(SL_printprettysym, SL_nil);
int i;
FOR_ARGS(i, 0, arg, args){USED(arg);
- fl_print(s, args[i]);
+ sl_print(s, args[i]);
}
- set(FL_printreadablysym, oldpr);
- set(FL_printprettysym, oldpp);
+ set(SL_printreadablysym, oldpr);
+ set(SL_printprettysym, oldpp);
value_t outp = stream_to_string(&buf);
- fl_free_gc_handles(1);
+ sl_free_gc_handles(1);
return outp;
}
@@ -147,10 +147,10 @@
size_t len = cv_len(ptr(args[0]));
size_t dlen = cv_len(ptr(args[1]));
size_t ssz, tokend, tokstart, i = 0;
- value_t first = FL_nil, c = FL_nil, last;
+ value_t first = SL_nil, c = SL_nil, last;
size_t junk;
- fl_gc_handle(&first);
- fl_gc_handle(&last);
+ sl_gc_handle(&first);
+ sl_gc_handle(&last);
do{// find and allocate next token
@@ -159,7 +159,7 @@
tokend = i;
ssz = tokend - tokstart;
last = c; // save previous cons cell
- c = fl_cons(cvalue_string(ssz), FL_nil);
+ c = sl_cons(cvalue_string(ssz), SL_nil);
// we've done allocation; reload movable pointers
s = cvalue_data(args[0]);
@@ -169,7 +169,7 @@
memmove(cvalue_data(car_(c)), &s[tokstart], ssz);
// link new cell
- if(last == FL_nil)
+ if(last == SL_nil)
first = c; // first time, save first cons
else
((cons_t*)ptr(last))->cdr = c;
@@ -178,7 +178,7 @@
// delimiter, we need to go around one more time to add an
// empty string. this happens when (i == len && tokend < i)
}while(i < len || (i == len && (tokend != i)));
- fl_free_gc_handles(2);
+ sl_free_gc_handles(2);
return first;
}
@@ -226,7 +226,7 @@
{argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);return mk_rune(toupperrune(*(Rune*)cp_data(cp)));
}
@@ -235,7 +235,7 @@
{argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);return mk_rune(tolowerrune(*(Rune*)cp_data(cp)));
}
@@ -244,69 +244,69 @@
{argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);return mk_rune(totitlerune(*(Rune*)cp_data(cp)));
}
-fl_purefn
+sl_purefn
BUILTIN("char-alphabetic?", char_alphabeticp) {argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);- return isalpharune(*(Rune*)cp_data(cp)) ? FL_t : FL_nil;
+ return isalpharune(*(Rune*)cp_data(cp)) ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("char-lower-case?", char_lower_casep) {argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);- return islowerrune(*(Rune*)cp_data(cp)) ? FL_t : FL_nil;
+ return islowerrune(*(Rune*)cp_data(cp)) ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("char-upper-case?", char_upper_casep) {argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);- return isupperrune(*(Rune*)cp_data(cp)) ? FL_t : FL_nil;
+ return isupperrune(*(Rune*)cp_data(cp)) ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("char-title-case?", char_title_casep) {argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);- return istitlerune(*(Rune*)cp_data(cp)) ? FL_t : FL_nil;
+ return istitlerune(*(Rune*)cp_data(cp)) ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("char-numeric?", char_numericp) {argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);- return isdigitrune(*(Rune*)cp_data(cp)) ? FL_t : FL_nil;
+ return isdigitrune(*(Rune*)cp_data(cp)) ? SL_t : SL_nil;
}
-fl_purefn
+sl_purefn
BUILTIN("char-whitespace?", char_whitespacep) {argcount(nargs, 1);
cprim_t *cp = ptr(args[0]);
- if(!iscprim(args[0]) || cp_class(cp) != FL(runetype))
+ if(!iscprim(args[0]) || cp_class(cp) != SL(runetype))
type_error("rune", args[0]);- return isspacerune(*(Rune*)cp_data(cp)) ? FL_t : FL_nil;
+ return isspacerune(*(Rune*)cp_data(cp)) ? SL_t : SL_nil;
}
BUILTIN("string-find", string_find)@@ -325,17 +325,17 @@
value_t v = args[1];
cprim_t *cp = ptr(v);
- if(iscprim(v) && cp_class(cp) == FL(runetype)){+ if(iscprim(v) && cp_class(cp) == SL(runetype)){Rune r = *(Rune*)cp_data(cp);
needlesz = runetochar(cbuf, &r);
needle = cbuf;
needle[needlesz] = 0;
- }else if(iscprim(v) && cp_class(cp) == FL(bytetype)){+ }else if(iscprim(v) && cp_class(cp) == SL(bytetype)){needlesz = 1;
needle = cbuf;
needle[0] = *(char*)cp_data(cp);
needle[needlesz] = 0;
- }else if(fl_isstring(v)){+ }else if(sl_isstring(v)){cvalue_t *cv = ptr(v);
needlesz = cv_len(cv);
needle = (char*)cv_data(cv);
@@ -343,7 +343,7 @@
type_error("string", args[1]);}
if(needlesz > len-start)
- return FL_nil;
+ return SL_nil;
if(needlesz == 0)
return size_wrap(start);
size_t i;
@@ -351,7 +351,7 @@
if(s[i] == needle[0] && memcmp(&s[i+1], needle+1, needlesz-1) == 0)
return size_wrap(i);
}
- return FL_nil;
+ return SL_nil;
}
static unsigned long
@@ -359,7 +359,7 @@
{unsigned long radix = tosize(arg);
if(radix < 2 || radix > 36)
- lerrorf(FL_ArgError, "invalid radix");
+ lerrorf(SL_ArgError, "invalid radix");
return radix;
}
@@ -380,12 +380,12 @@
if(cp_numtype(data) < T_FLOAT)
num = conv_to_uint64(cp_data(data), cp_numtype(data));
else if(radix != 10)
- lerrorf(FL_ArgError, "invalid radix with floating point");
+ lerrorf(SL_ArgError, "invalid radix with floating point");
else
return fn_builtin_string(args, nargs);
}else if(ismpint(n)){if(radix != 16 && radix != 10 && radix != 8 && radix != 4 && radix != 2)
- lerrorf(FL_ArgError, "invalid radix with bignum");
+ lerrorf(SL_ArgError, "invalid radix with bignum");
mpint *i = tompint(n);
char *s = mptoa(i, radix, nil, 0);
assert(s != nil);
@@ -399,7 +399,7 @@
}else{ type_error("integer", n);}
- if(numval(fl_compare(args[0], fixnum(0), false)) < 0){+ if(numval(sl_compare(args[0], fixnum(0), false)) < 0){num = -num;
neg = true;
}
@@ -418,16 +418,16 @@
unsigned long radix = 0;
if(nargs == 2)
radix = get_radix_arg(args[1]);
- if(!fl_read_numtok(str, &n, (int)radix))
- return FL_nil;
+ if(!sl_read_numtok(str, &n, (int)radix))
+ return SL_nil;
return n;
}
-fl_purefn
+sl_purefn
BUILTIN("string-utf8?", string_utf8p) {argcount(nargs, 1);
char *s = tostring(args[0]);
size_t len = cv_len(ptr(args[0]));
- return u8_isvalid(s, len) ? FL_t : FL_nil;
+ return u8_isvalid(s, len) ? SL_t : SL_nil;
}
--- a/src/system.lsp
+++ b/src/system.lsp
@@ -1,4 +1,4 @@
-; femtoLisp standard library
+; StreetLISP standard library
; by Jeff Bezanson (C) 2009
; Distributed under the BSD License
@@ -1125,10 +1125,10 @@
(let* ((homevar (case *os-name*
(("unknown") nil) (("plan9") "home")- (("macos") (princ "\x1b]0;femtolisp v0.999\007") nil)+ (("macos") (princ "\x1b]0;StreetLISP v0.999\007") nil)(else "HOME")))
(home (and homevar (os-getenv homevar)))
- (fname (and home (string home *directory-separator* ".flisprc"))))
+ (fname (and home (string home *directory-separator* ".slrc"))))
(when (and fname (path-exists? fname)) (load fname))))
(def (__start argv)
--- a/src/table.c
+++ b/src/table.c
@@ -1,4 +1,4 @@
-#include "flisp.h"
+#include "sl.h"
#include "equalhash.h"
#include "cvalues.h"
#include "types.h"
@@ -12,18 +12,18 @@
{htable_t *h = cvalue_data(v);
int first = 1;
- fl_print_str(f, "#table(");+ sl_print_str(f, "#table("); for(int i = 0; i < h->size; i += 2){ if(h->table[i+1] != HT_NOTFOUND){if(!first)
- fl_print_str(f, " ");
- fl_print_child(f, (value_t)h->table[i]);
- fl_print_chr(f, ' ');
- fl_print_child(f, (value_t)h->table[i+1]);
+ sl_print_str(f, " ");
+ sl_print_child(f, (value_t)h->table[i]);
+ sl_print_chr(f, ' ');
+ sl_print_child(f, (value_t)h->table[i+1]);
first = 0;
}
}
- fl_print_chr(f, ')');
+ sl_print_chr(f, ')');
}
static void
@@ -69,14 +69,14 @@
bool
ishashtable(value_t v)
{- return iscvalue(v) && cv_class(ptr(v)) == FL(tabletype);
+ return iscvalue(v) && cv_class(ptr(v)) == SL(tabletype);
}
-fl_purefn
+sl_purefn
BUILTIN("table?", tablep) {argcount(nargs, 1);
- return ishashtable(args[0]) ? FL_t : FL_nil;
+ return ishashtable(args[0]) ? SL_t : SL_nil;
}
htable_t *
@@ -91,16 +91,16 @@
{int cnt = nargs;
if(cnt & 1)
- lerrorf(FL_ArgError, "arguments must come in pairs");
+ lerrorf(SL_ArgError, "arguments must come in pairs");
value_t nt;
// prevent small tables from being added to finalizer list
if(cnt <= HT_N_INLINE)
- nt = cvalue_nofinalizer(FL(tabletype), sizeof(htable_t));
+ nt = cvalue_nofinalizer(SL(tabletype), sizeof(htable_t));
else
- nt = cvalue(FL(tabletype), sizeof(htable_t)-inline_space);
+ nt = cvalue(SL(tabletype), sizeof(htable_t)-inline_space);
htable_t *h = cvalue_data(nt);
htable_new(h, cnt/2);
- value_t k = FL_nil, arg;
+ value_t k = SL_nil, arg;
int i;
FOR_ARGS(i, 0, arg, args){if(i & 1)
@@ -132,11 +132,11 @@
static void
key_error(value_t key)
{- lerrorf(fl_list2(FL_KeyError, key), "key not found");
+ lerrorf(sl_list2(SL_KeyError, key), "key not found");
}
// (get table key [default])
-fl_purefn
+sl_purefn
BUILTIN("get", get) {if(nargs != 3)
@@ -152,12 +152,12 @@
}
// (has? table key)
-fl_purefn
+sl_purefn
BUILTIN("has?", has) {argcount(nargs, 2);
htable_t *h = totable(args[0]);
- return equalhash_has(h, (void*)args[1]) ? FL_t : FL_nil;
+ return equalhash_has(h, (void*)args[1]) ? SL_t : SL_nil;
}
// (del! table key)
@@ -177,19 +177,19 @@
htable_t *h = totable(t);
int n = h->size;
void **table = h->table;
- fl_gc_handle(&f);
- fl_gc_handle(&zero);
- fl_gc_handle(&t);
+ sl_gc_handle(&f);
+ sl_gc_handle(&zero);
+ sl_gc_handle(&t);
for(int i = 0; i < n; i += 2){if(table[i+1] == HT_NOTFOUND)
continue;
- zero = fl_applyn(3, f, (value_t)table[i], (value_t)table[i+1], zero);
+ zero = sl_applyn(3, f, (value_t)table[i], (value_t)table[i+1], zero);
// reload pointer
h = cvalue_data(t);
n = h->size;
table = h->table;
}
- fl_free_gc_handles(3);
+ sl_free_gc_handles(3);
return zero;
}
@@ -196,5 +196,5 @@
void
table_init(void)
{- FL(tabletype) = define_opaque_type(symbol("table", false), sizeof(htable_t), &table_vtable, nil);+ SL(tabletype) = define_opaque_type(symbol("table", false), sizeof(htable_t), &table_vtable, nil);}
--- a/src/table.h
+++ b/src/table.h
@@ -1,3 +1,3 @@
-bool ishashtable(value_t v) fl_purefn;
-htable_t *totable(value_t v) fl_purefn;
+bool ishashtable(value_t v) sl_purefn;
+htable_t *totable(value_t v) sl_purefn;
void table_init(void);
--- a/src/types.c
+++ b/src/types.c
@@ -1,24 +1,24 @@
-#include "flisp.h"
+#include "sl.h"
#include "cvalues.h"
#include "equalhash.h"
#include "types.h"
-fltype_t *
+sltype_t *
get_type(value_t t)
{- fltype_t *ft;
+ sltype_t *ft;
if(issymbol(t)){ft = ((symbol_t*)ptr(t))->type;
if(ft != nil)
return ft;
}
- void **bp = equalhash_bp(&FL(TypeTable), (void*)t);
+ void **bp = equalhash_bp(&SL(TypeTable), (void*)t);
if(*bp != HT_NOTFOUND){assert(*bp != nil);
return *bp;
}
- bool isarray = iscons(t) && car_(t) == FL_arraysym && iscons(cdr_(t));
+ bool isarray = iscons(t) && car_(t) == SL_arraysym && iscons(cdr_(t));
size_t sz;
if(isarray && !iscons(cdr_(cdr_(t)))){// special case: incomplete array type
@@ -27,7 +27,7 @@
sz = ctype_sizeof(t);
}
- ft = MEM_CALLOC(1, sizeof(fltype_t));
+ ft = MEM_CALLOC(1, sizeof(sltype_t));
assert(ft != nil);
ft->type = t;
ft->numtype = NONNUMERIC;
@@ -38,7 +38,7 @@
}
ft->size = sz;
if(isarray && iscons(t)){- fltype_t *eltype = get_type(car_(cdr_(t)));
+ sltype_t *eltype = get_type(car_(cdr_(t)));
assert(eltype != nil && eltype->size > 0);
ft->elsz = eltype->size;
ft->eltype = eltype;
@@ -49,19 +49,19 @@
return ft;
}
-fltype_t *
+sltype_t *
get_array_type(value_t eltype)
{- fltype_t *et = get_type(eltype);
+ sltype_t *et = get_type(eltype);
if(et->artype == nil)
- et->artype = get_type(fl_list2(FL_arraysym, eltype));
+ et->artype = get_type(sl_list2(SL_arraysym, eltype));
return et->artype;
}
-fltype_t *
+sltype_t *
define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init)
{- fltype_t *ft = MEM_CALLOC(1, sizeof(fltype_t));
+ sltype_t *ft = MEM_CALLOC(1, sizeof(sltype_t));
assert(ft != nil);
ft->type = sym;
ft->numtype = NONNUMERIC;
@@ -74,13 +74,13 @@
void
relocate_typetable(void)
{- htable_t *h = &FL(TypeTable);
+ htable_t *h = &SL(TypeTable);
for(int i = 0; i < h->size; i += 2){ if(h->table[i] != HT_NOTFOUND){void *nv = (void*)relocate((value_t)h->table[i]);
h->table[i] = nv;
if(h->table[i+1] != HT_NOTFOUND)
- ((fltype_t*)h->table[i+1])->type = (value_t)nv;
+ ((sltype_t*)h->table[i+1])->type = (value_t)nv;
}
}
}
--- a/src/types.h
+++ b/src/types.h
@@ -1,6 +1,6 @@
#pragma once
-fltype_t *get_type(value_t t);
-fltype_t *get_array_type(value_t eltype);
-fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init);
+sltype_t *get_type(value_t t);
+sltype_t *get_array_type(value_t eltype);
+sltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init);
void relocate_typetable(void);
--- a/src/utf8.c
+++ b/src/utf8.c
@@ -13,7 +13,7 @@
A UTF-8 validation routine is included.
*/
-#include "flisp.h"
+#include "sl.h"
static const uint32_t offsetsFromUTF8[6] = {0x00000000U, 0x00003080U, 0x000E2080U,
@@ -70,7 +70,7 @@
assert(n >= 0);
for(i = w = 0; i < n;){i += chartorune(&r, s+i);
- ssize_t x = fl_wcwidth(r);
+ ssize_t x = sl_wcwidth(r);
if(x < 0)
return -1;
w += x;
@@ -176,7 +176,7 @@
}else{i0 = i;
ch = u8_nextmemchar(src, &i);
- if(ascii || !fl_iswprint(ch)){+ if(ascii || !sl_iswprint(ch)){buf += u8_escape_rune(buf, sz - (buf-start), ch);
}else{i = i0;
--- a/src/utf8.h
+++ b/src/utf8.h
@@ -4,18 +4,18 @@
#define isutf(c) (((c)&0xC0) != 0x80)
/* byte offset to character number */
-size_t u8_charnum(const char *s, size_t offset) fl_purefn;
+size_t u8_charnum(const char *s, size_t offset) sl_purefn;
/* next character without NUL character terminator */
Rune u8_nextmemchar(const char *s, size_t *i);
/* returns length of next utf-8 sequence */
-size_t u8_seqlen(const char *s) fl_purefn;
+size_t u8_seqlen(const char *s) sl_purefn;
/* length of a utf-8 string in runes */
-size_t u8_runelen(const char *s, size_t nb) fl_purefn;
+size_t u8_runelen(const char *s, size_t nb) sl_purefn;
-char read_escape_control_char(char c) fl_constfn;
+char read_escape_control_char(char c) sl_constfn;
/* given a wide character, convert it to an ASCII escape sequence stored in
buf, where buf is "sz" bytes. returns the number of characters output.
@@ -41,8 +41,8 @@
bool escape_quotes, bool ascii);
/* utility predicates used by the above */
-bool octal_digit(char c) fl_constfn;
-bool hex_digit(char c) fl_constfn;
+bool octal_digit(char c) sl_constfn;
+bool hex_digit(char c) sl_constfn;
/* same as the above, but searches a buffer of a given size instead of
a NUL-terminated string. */
@@ -49,10 +49,10 @@
char *u8_memchr(char *s, Rune ch, size_t sz, size_t *charn);
/* number of columns occupied by a string */
-ssize_t u8_strwidth(const char *s, ssize_t n) fl_purefn;
+ssize_t u8_strwidth(const char *s, ssize_t n) sl_purefn;
/* determine whether a sequence of bytes is valid UTF-8. length is in bytes */
-bool u8_isvalid(const char *str, int length) fl_purefn;
+bool u8_isvalid(const char *str, int length) sl_purefn;
/* reverse a UTF-8 string. len is length in bytes. dest and src must both
be allocated to at least len+1 bytes. returns 1 for error, 0 otherwise */
--- a/src/vm.inc
+++ b/src/vm.inc
@@ -33,7 +33,7 @@
if(v > (N_BUILTINS<<3)){nargs = n;
if(tail){- FL(curr_frame) = (value_t*)FL(curr_frame)[-3];
+ SL(curr_frame) = (value_t*)SL(curr_frame)[-3];
for(fixnum_t s = -1; s < (fixnum_t)n; s++)
bp[s] = sp[s-n];
sp = bp+n;
@@ -45,10 +45,10 @@
ip = cvalue_data(fn->bcode);
assert(!ismanaged((uintptr_t)ip));
*sp++ = fn->env;
- *sp++ = (value_t)FL(curr_frame);
+ *sp++ = (value_t)SL(curr_frame);
*sp++ = nargs;
ipd = sp++;
- FL(curr_frame) = sp;
+ SL(curr_frame) = sp;
NEXT_OP;
}
int i = uintval(v);
@@ -55,10 +55,10 @@
assert(isbuiltin(v));
fixnum_t s = builtins[i].nargs;
if(s >= 0){- FL(sp) = sp;
+ SL(sp) = sp;
argcount(n, s);
}else if(s != ANYARGS && n < -s){- FL(sp) = sp;
+ SL(sp) = sp;
argcount(n, -s);
}
// remove function arg
@@ -85,15 +85,15 @@
continue;
#endif
}
- }else if(fl_likely(iscbuiltin(v))){+ }else if(sl_likely(iscbuiltin(v))){value_t *p = sp - n;
- FL(sp) = sp;
+ SL(sp) = sp;
v = ((cvalue_t*)ptr(v))->cbuiltin(p, n);
sp = p;
p[-1] = v;
NEXT_OP;
}
- FL(sp) = sp;
+ SL(sp) = sp;
type_error("function", v);}
@@ -104,9 +104,9 @@
na = GET_INT32(ip);
ip += 4;
}
- if(fl_unlikely(nargs != na)){+ if(sl_unlikely(nargs != na)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
arity_error(nargs, na);
}
NEXT_OP;
@@ -118,17 +118,17 @@
OP(OP_RET) {value_t v = *(--sp);
- sp = FL(curr_frame);
- FL(curr_frame) = (value_t*)sp[-3];
- if(FL(curr_frame) == top_frame){- FL(sp) = sp;
+ sp = SL(curr_frame);
+ SL(curr_frame) = (value_t*)sp[-3];
+ if(SL(curr_frame) == top_frame){+ SL(sp) = sp;
return v;
}
sp -= 4+nargs;
- ipd = FL(curr_frame)-1;
+ ipd = SL(curr_frame)-1;
ip = (uint8_t*)*ipd;
- nargs = FL(curr_frame)[-2];
- bp = FL(curr_frame) - 4 - nargs;
+ nargs = SL(curr_frame)[-2];
+ bp = SL(curr_frame) - 4 - nargs;
sp[-1] = v;
NEXT_OP;
}
@@ -142,7 +142,7 @@
NEXT_OP;
OP(OP_BRN)
- ip += *(--sp) == FL_nil ? GET_INT16(ip) : 2;
+ ip += *(--sp) == SL_nil ? GET_INT16(ip) : 2;
NEXT_OP;
OP(OP_LOADG) {@@ -158,9 +158,9 @@
}
assert(issymbol(v));
symbol_t *sym = ptr(v);
- if(fl_unlikely(sym->binding == UNBOUND)){+ if(sl_unlikely(sym->binding == UNBOUND)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
unbound_error(v);
}
*sp++ = sym->binding;
@@ -173,20 +173,20 @@
{int i = n;
value_t a = sp[-i], b, v;
- for(v = FL_t; i > 1; a = b){+ for(v = SL_t; i > 1; a = b){i--;
b = sp[-i];
if(bothfixnums(a, b)){ if((fixnum_t)a >= (fixnum_t)b){- v = FL_nil;
+ v = SL_nil;
break;
}
}else{int x = numeric_compare(a, b, false, false, false);
if(x > 1)
- x = numval(fl_compare(a, b, false));
+ x = numval(sl_compare(a, b, false));
if(x >= 0){- v = FL_nil;
+ v = SL_nil;
break;
}
}
@@ -214,7 +214,7 @@
*ipd = (uintptr_t)ip;
v = sp[-1];
int64_t i64;
- b = isfixnum(v) ? fixnum_neg(v) : fl_neg(v);
+ b = isfixnum(v) ? fixnum_neg(v) : sl_neg(v);
}else{b = sp[-1];
}
@@ -223,7 +223,7 @@
v = q;
else{sp[-1] = b;
- v = fl_add_any(sp-2, 2);
+ v = sl_add_any(sp-2, 2);
}
sp--;
sp[-1] = v;
@@ -239,7 +239,7 @@
NEXT_OP;
OP(OP_BRNN)
- ip += *(--sp) != FL_nil ? GET_INT16(ip) : 2;
+ ip += *(--sp) != SL_nil ? GET_INT16(ip) : 2;
NEXT_OP;
OP(OP_DUP)
@@ -253,11 +253,11 @@
OP(OP_CAR) {value_t v = sp[-1];
- if(fl_likely(iscons(v)))
+ if(sl_likely(iscons(v)))
v = car_(v);
- else if(fl_unlikely(v != FL_nil)){+ else if(sl_unlikely(v != SL_nil)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
type_error("cons", v);}
sp[-1] = v;
@@ -267,7 +267,7 @@
OP(OP_CLOSURE) {int x = *ip++;
assert(x > 0);
- FL(sp) = sp;
+ SL(sp) = sp;
value_t *pv = alloc_words(
1+x+
#if !defined(BITS64)
@@ -297,12 +297,12 @@
}
OP(OP_CONS) {- if(FL(curheap) > FL(lim)){- FL(sp) = sp;
- fl_gc(0);
+ if(SL(curheap) > SL(lim)){+ SL(sp) = sp;
+ sl_gc(0);
}
- cons_t *c = (cons_t*)FL(curheap);
- FL(curheap) += sizeof(cons_t);
+ cons_t *c = (cons_t*)SL(curheap);
+ SL(curheap) += sizeof(cons_t);
c->car = sp[-2];
c->cdr = sp[-1];
sp[-2] = tagptr(c, TAG_CONS);
@@ -317,11 +317,11 @@
OP(OP_CDR) {value_t v = sp[-1];
- if(fl_likely(iscons(v)))
+ if(sl_likely(iscons(v)))
v = cdr_(v);
- else if(fl_unlikely(v != FL_nil)){+ else if(sl_unlikely(v != SL_nil)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
type_error("cons", v);}
sp[-1] = v;
@@ -329,11 +329,11 @@
}
OP(OP_LOADVOID)
- *sp++ = FL_void;
+ *sp++ = SL_void;
NEXT_OP;
OP(OP_NOT)
- sp[-1] = sp[-1] == FL_nil ? FL_t : FL_nil;
+ sp[-1] = sp[-1] == SL_nil ? SL_t : SL_nil;
NEXT_OP;
OP(OP_SETA)
@@ -357,19 +357,19 @@
bp[i+3] = i+1;
bp[i+4] = 0;
sp = bp+i+5;
- FL(curr_frame) = sp;
+ SL(curr_frame) = sp;
}
- }else if(fl_unlikely(s < 0)){+ }else if(sl_unlikely(s < 0)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
- lerrorf(FL_ArgError, "too few arguments");
+ SL(sp) = sp;
+ lerrorf(SL_ArgError, "too few arguments");
}else{sp++;
sp[-2] = i+1;
sp[-3] = sp[-4];
sp[-4] = sp[-5];
- sp[-5] = FL_nil;
- FL(curr_frame) = sp;
+ sp[-5] = SL_nil;
+ SL(curr_frame) = sp;
}
ipd = sp-1;
nargs = i+1;
@@ -385,9 +385,9 @@
OP(OP_SETCAR) {value_t v = sp[-2];
- if(fl_unlikely(!iscons(v))){+ if(sl_unlikely(!iscons(v))){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
type_error("cons", v);}
car_(v) = sp[-1];
@@ -396,15 +396,15 @@
}
OP(OP_LOADNIL)
- *sp++ = FL_nil;
+ *sp++ = SL_nil;
NEXT_OP;
OP(OP_BOX) {int i = *ip++;
- FL(sp) = sp;
+ SL(sp) = sp;
value_t v = mk_cons();
car_(v) = bp[i];
- cdr_(v) = FL_nil;
+ cdr_(v) = SL_nil;
bp[i] = v;
NEXT_OP;
}
@@ -414,7 +414,7 @@
NEXT_OP;
OP(OP_ATOMP)
- sp[-1] = iscons(sp[-1]) ? FL_nil : FL_t;
+ sp[-1] = iscons(sp[-1]) ? SL_nil : SL_t;
NEXT_OP;
OP(OP_AREF2) {@@ -435,15 +435,15 @@
value_t e = sp[-i];
size_t isz = tosize(e);
if(isvector(v)){- if(fl_unlikely(isz >= vector_size(v))){- FL(sp) = sp;
+ if(sl_unlikely(isz >= vector_size(v))){+ SL(sp) = sp;
bounds_error(v, e);
}
v = vector_elt(v, isz);
continue;
}
- if(!iscons(v) && v != FL_nil){- FL(sp) = sp;
+ if(!iscons(v) && v != SL_nil){+ SL(sp) = sp;
type_error("sequence", v);}
for(value_t v0 = v;; isz--){@@ -452,8 +452,8 @@
break;
}
v = cdr_(v);
- if(fl_unlikely(!iscons(v))){- FL(sp) = sp;
+ if(sl_unlikely(!iscons(v))){+ SL(sp) = sp;
bounds_error(v0, e);
}
}
@@ -466,18 +466,18 @@
OP(OP_NANP) {value_t v = sp[-1];
if(!iscprim(v))
- v = FL_nil;
+ v = SL_nil;
else{void *p = ptr(v);
switch(cp_numtype(p)){case T_DOUBLE:
- v = isnan(*(double*)cp_data(p)) ? FL_t : FL_nil;
+ v = isnan(*(double*)cp_data(p)) ? SL_t : SL_nil;
break;
case T_FLOAT:
- v = isnan(*(float*)cp_data(p)) ? FL_t : FL_nil;
+ v = isnan(*(float*)cp_data(p)) ? SL_t : SL_nil;
break;
default:
- v = FL_nil;
+ v = SL_nil;
break;
}
}
@@ -491,9 +491,9 @@
OP(OP_SETCDR) {value_t v = sp[-2];
- if(fl_unlikely(!iscons(v))){+ if(sl_unlikely(!iscons(v))){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
type_error("cons", v);}
cdr_(v) = sp[-1];
@@ -521,15 +521,15 @@
value_t e = sp[-i];
size_t isz = tosize(e);
if(isvector(v)){- if(fl_unlikely(isz >= vector_size(v))){- FL(sp) = sp;
+ if(sl_unlikely(isz >= vector_size(v))){+ SL(sp) = sp;
bounds_error(v, e);
}
v = vector_elt(v, isz);
continue;
}
- if(!iscons(v) && v != FL_nil){- FL(sp) = sp;
+ if(!iscons(v) && v != SL_nil){+ SL(sp) = sp;
type_error("sequence", v);}
for(value_t v0 = v;; isz--){@@ -538,8 +538,8 @@
break;
}
v = cdr_(v);
- if(fl_unlikely(!iscons(v))){- FL(sp) = sp;
+ if(sl_unlikely(!iscons(v))){+ SL(sp) = sp;
bounds_error(v0, e);
}
}
@@ -549,12 +549,12 @@
value_t e = sp[-2];
size_t isz = tosize(e);
if(isvector(v)){- if(fl_unlikely(isz >= vector_size(v))){- FL(sp) = sp;
+ if(sl_unlikely(isz >= vector_size(v))){+ SL(sp) = sp;
bounds_error(v, e);
}
vector_elt(v, isz) = (e = sp[-1]);
- }else if(iscons(v) || v == FL_nil){+ }else if(iscons(v) || v == SL_nil){ for(value_t v0 = v;; isz--){ if(isz == 0){car_(v) = (e = sp[-1]);
@@ -561,8 +561,8 @@
break;
}
v = cdr_(v);
- if(fl_unlikely(!iscons(v))){- FL(sp) = sp;
+ if(sl_unlikely(!iscons(v))){+ SL(sp) = sp;
bounds_error(v0, e);
}
}
@@ -569,7 +569,7 @@
}else if(isarray(v)){e = cvalue_array_aset(sp-3);
}else{- FL(sp) = sp;
+ SL(sp) = sp;
type_error("sequence", v);}
sp -= n;
@@ -580,9 +580,9 @@
OP(OP_EQUAL) {value_t v;
if(sp[-2] == sp[-1])
- v = FL_t;
+ v = SL_t;
else
- v = fl_compare(sp[-2], sp[-1], true) == 0 ? FL_t : FL_nil;
+ v = sl_compare(sp[-2], sp[-1], true) == 0 ? SL_t : SL_nil;
sp[-2] = v;
sp--;
NEXT_OP;
@@ -589,7 +589,7 @@
}
OP(OP_CONSP)
- sp[-1] = iscons(sp[-1]) ? FL_t : FL_nil;
+ sp[-1] = iscons(sp[-1]) ? SL_t : SL_nil;
NEXT_OP;
OP(OP_LOADC) {@@ -602,15 +602,15 @@
}
OP(OP_SYMBOLP)
- sp[-1] = issymbol(sp[-1]) ? FL_t : FL_nil;
+ sp[-1] = issymbol(sp[-1]) ? SL_t : SL_nil;
NEXT_OP;
OP(OP_NUMBERP)
- sp[-1] = fl_isnumber(sp[-1]) ? FL_t : FL_nil;
+ sp[-1] = sl_isnumber(sp[-1]) ? SL_t : SL_nil;
NEXT_OP;
OP(OP_BRBOUND)
- *sp++ = bp[GET_INT32(ip)] != UNBOUND ? FL_t : FL_nil;
+ *sp++ = bp[GET_INT32(ip)] != UNBOUND ? SL_t : SL_nil;
ip += 4;
NEXT_OP;
@@ -619,20 +619,20 @@
ip += 4;
int x = GET_INT32(ip);
ip += 4;
- if(fl_unlikely(nargs < i)){+ if(sl_unlikely(nargs < i)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
- lerrorf(FL_ArgError, "too few arguments");
+ SL(sp) = sp;
+ lerrorf(SL_ArgError, "too few arguments");
}
if(x > 0){- if(fl_unlikely(nargs > x)){+ if(sl_unlikely(nargs > x)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
- lerrorf(FL_ArgError, "too many arguments");
+ SL(sp) = sp;
+ lerrorf(SL_ArgError, "too many arguments");
}
}else
x = -x;
- if(fl_likely(x > nargs)){+ if(sl_likely(x > nargs)){x -= nargs;
sp += x;
sp[-1] = sp[-x-1];
@@ -639,7 +639,7 @@
sp[-2] = nargs+x;
sp[-3] = sp[-x-3];
sp[-4] = sp[-x-4];
- FL(curr_frame) = sp;
+ SL(curr_frame) = sp;
ipd = sp-1;
for(i = 0; i < x; i++)
bp[nargs+i] = UNBOUND;
@@ -649,7 +649,7 @@
}
OP(OP_EQ)
- sp[-2] = sp[-2] == sp[-1] ? FL_t : FL_nil;
+ sp[-2] = sp[-2] == sp[-1] ? SL_t : SL_nil;
sp--;
NEXT_OP;
@@ -666,7 +666,7 @@
OP(OP_BOUNDP) {*ipd = (uintptr_t)ip;
symbol_t *sym = tosymbol(sp[-1]);
- sp[-1] = sym->binding == UNBOUND ? FL_nil : FL_t;
+ sp[-1] = sym->binding == UNBOUND ? SL_nil : SL_t;
NEXT_OP;
}
@@ -675,16 +675,16 @@
LABEL(apply_numeq):;
int i = n;
value_t a = sp[-i], b, v;
- for(v = FL_t; i > 1; a = b){+ for(v = SL_t; i > 1; a = b){i--;
b = sp[-i];
if(bothfixnums(a, b)){ if(a != b){- v = FL_nil;
+ v = SL_nil;
break;
}
}else if(numeric_compare(a, b, true, false, true) != 0){- v = FL_nil;
+ v = SL_nil;
break;
}
}
@@ -695,17 +695,17 @@
OP(OP_CADR) {value_t v = sp[-1];
- if(fl_likely(iscons(v))){+ if(sl_likely(iscons(v))){v = cdr_(v);
- if(fl_likely(iscons(v)))
+ if(sl_likely(iscons(v)))
v = car_(v);
else
goto LABEL(cadr_nil);
}else{LABEL(cadr_nil):
- if(fl_unlikely(v != FL_nil)){+ if(sl_unlikely(v != SL_nil)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
type_error("cons", v);}
}
@@ -727,10 +727,10 @@
*sp++ = car_(v);
v = cdr_(v);
}
- if(v != FL_nil){+ if(v != SL_nil){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
- lerrorf(FL_ArgError, "apply: last argument: not a list");
+ SL(sp) = sp;
+ lerrorf(SL_ArgError, "apply: last argument: not a list");
}
n = sp-p;
goto LABEL(do_call);
@@ -737,12 +737,12 @@
}
OP(OP_LOADT)
- *sp++ = FL_t;
+ *sp++ = SL_t;
NEXT_OP;
OP(OP_BUILTINP) {value_t v = sp[-1];
- sp[-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_t : FL_nil;
+ sp[-1] = (isbuiltin(v) || iscbuiltin(v)) ? SL_t : SL_nil;
NEXT_OP;
}
@@ -751,12 +751,12 @@
*ipd = (uintptr_t)ip;
value_t v = sp[-1];
int64_t i64;
- sp[-1] = isfixnum(v) ? fixnum_neg(v) : fl_neg(v);
+ sp[-1] = isfixnum(v) ? fixnum_neg(v) : sl_neg(v);
NEXT_OP;
}
OP(OP_FIXNUMP)
- sp[-1] = isfixnum(sp[-1]) ? FL_t : FL_nil;
+ sp[-1] = isfixnum(sp[-1]) ? SL_t : SL_nil;
NEXT_OP;
OP(OP_MUL) {@@ -763,7 +763,7 @@
n = *ip++;
LABEL(apply_mul):
*ipd = (uintptr_t)ip;
- value_t v = fl_mul_any(sp-n, n);
+ value_t v = sl_mul_any(sp-n, n);
sp -= n;
*sp++ = v;
NEXT_OP;
@@ -772,9 +772,9 @@
OP(OP_IDIV) {value_t a = sp[-2];
value_t b = sp[-1];
- if(fl_unlikely(b == 0)){+ if(sl_unlikely(b == 0)){*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
divide_by_0_error();
}
value_t v;
@@ -782,7 +782,7 @@
v = fixnum((fixnum_t)a / (fixnum_t)b);
else{*ipd = (uintptr_t)ip;
- v = fl_idiv2(a, b);
+ v = sl_idiv2(a, b);
}
sp--;
sp[-1] = v;
@@ -795,15 +795,15 @@
*ipd = (uintptr_t)ip;
value_t *p = sp-n;
if(n == 1){- sp[-1] = fl_div2(fixnum(1), *p);
+ sp[-1] = sl_div2(fixnum(1), *p);
}else{- if(fl_unlikely(n > 2)){+ if(sl_unlikely(n > 2)){*sp++ = *p;
*p = fixnum(1);
- p[1] = fl_mul_any(p, n);
+ p[1] = sl_mul_any(p, n);
*p = *(--sp);
}
- value_t v = fl_div2(p[0], p[1]);
+ value_t v = sl_div2(p[0], p[1]);
sp -= n;
*sp++ = v;
}
@@ -813,7 +813,7 @@
OP(OP_VECTOR) {n = *ip++;
LABEL(apply_vector):;
- FL(sp) = sp;
+ SL(sp) = sp;
value_t v = alloc_vector(n, 0);
memcpy(&vector_elt(v, 0), sp-n, n*sizeof(value_t));
sp -= n;
@@ -822,7 +822,7 @@
}
OP(OP_COMPARE)
- sp[-2] = fl_compare(sp[-2], sp[-1], false);
+ sp[-2] = sl_compare(sp[-2], sp[-1], false);
sp--;
NEXT_OP;
@@ -833,8 +833,8 @@
fixnum_t s = tofixnum(p[-3]);
fixnum_t hi = tofixnum(p[-2]);
sp += 2;
- FL(sp) = sp;
- for(v = FL_void; s <= hi; s++){+ SL(sp) = sp;
+ for(v = SL_void; s <= hi; s++){p[0] = p[-1];
p[1] = fixnum(s);
v = _applyn(1);
@@ -863,12 +863,12 @@
}
OP(OP_VECTORP)
- sp[-1] = isvector(sp[-1]) ? FL_t : FL_nil;
+ sp[-1] = isvector(sp[-1]) ? SL_t : SL_nil;
NEXT_OP;
OP(OP_TRYCATCH) {*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
value_t v = do_trycatch();
sp--;
sp[-1] = v;
@@ -881,7 +881,7 @@
goto LABEL(do_add2);
LABEL(apply_add):
*ipd = (uintptr_t)ip;
- value_t v = fl_add_any(sp-n, n);
+ value_t v = sl_add_any(sp-n, n);
sp -= n;
*sp++ = v;
NEXT_OP;
@@ -896,11 +896,11 @@
OP(OP_EQV) {value_t v;
if(sp[-2] == sp[-1])
- v = FL_t;
+ v = SL_t;
else if(!leafp(sp[-2]) || !leafp(sp[-1]))
- v = FL_nil;
+ v = SL_nil;
else
- v = fl_compare(sp[-2], sp[-1], true) == 0 ? FL_t : FL_nil;
+ v = sl_compare(sp[-2], sp[-1], true) == 0 ? SL_t : SL_nil;
sp[-2] = v;
sp--;
NEXT_OP;
@@ -916,9 +916,9 @@
fixnum_t s = GET_INT32(ip);
ip += 4;
*ipd = (uintptr_t)ip;
- FL(sp) = sp;
+ SL(sp) = sp;
nargs = process_keys(v, i, x, labs(s)-(i+x), bp, nargs, s<0);
- sp = FL(sp);
+ sp = SL(sp);
ipd = sp-1;
NEXT_OP;
}
@@ -932,15 +932,15 @@
goto LABEL(do_neg);
*ipd = (uintptr_t)ip;
value_t *p = sp-n;
- // we need to pass the full arglist on to fl_add_any
+ // we need to pass the full arglist on to sl_add_any
// so it can handle rest args properly
*sp++ = *p;
*p = fixnum(0);
- value_t v = fl_add_any(p, n);
+ value_t v = sl_add_any(p, n);
int64_t i64;
- p[1] = isfixnum(v) ? fixnum_neg(v) : fl_neg(v);
+ p[1] = isfixnum(v) ? fixnum_neg(v) : sl_neg(v);
p[0] = *(--sp);
- v = fl_add_any(p, 2);
+ v = sl_add_any(p, 2);
sp -= n;
*sp++ = v;
NEXT_OP;
@@ -947,7 +947,7 @@
}
OP(OP_BRNL)
- ip += *(--sp) == FL_nil ? GET_INT32(ip) : 4;
+ ip += *(--sp) == SL_nil ? GET_INT32(ip) : 4;
NEXT_OP;
OP(OP_SETAL)
@@ -958,10 +958,10 @@
OP(OP_BOXL) {int i = GET_INT32(ip);
ip += 4;
- FL(sp) = sp;
+ SL(sp) = sp;
value_t v = mk_cons();
car_(v) = bp[i];
- cdr_(v) = FL_nil;
+ cdr_(v) = SL_nil;
bp[i] = v;
NEXT_OP;
}
@@ -971,7 +971,7 @@
sp[-1] =
((tag(v) == TAG_FUNCTION &&
(isbuiltin(v) || v>(N_BUILTINS<<3))) ||
- iscbuiltin(v)) ? FL_t : FL_nil;
+ iscbuiltin(v)) ? SL_t : SL_nil;
NEXT_OP;
}
@@ -985,7 +985,7 @@
NEXT_OP;
OP(OP_BRNNL)
- ip += *(--sp) != FL_nil ? GET_INT32(ip) : 4;
+ ip += *(--sp) != SL_nil ? GET_INT32(ip) : 4;
NEXT_OP;
OP(OP_LOADCL)
--- a/test/torture.lsp
+++ b/test/torture.lsp
@@ -8,7 +8,7 @@
0
`(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
-; https://todo.sr.ht/~ft/femtolisp/2
+; https://todo.sr.ht/~ft/sl/2
;(def nst (big 100000))
;(write (eval nst))
;(newline)
--- a/tools/bootstrap.sh
+++ b/tools/bootstrap.sh
@@ -1,14 +1,14 @@
#!/bin/sh
test -e
-F="$(pwd)/build/flisp"
+F="$(pwd)/build/sl"
test -x $F || { meson setup -Dbuildtype=debug build . && ninja -C build || exit 1; } test -x $F || { echo no $F found; exit 1; }cd src && \
$F ../tools/gen.lsp && \
-cp ../boot/flisp.boot.builtin ../boot/flisp.boot.builtin.bak && \
-$F ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/flisp.boot && \
-cp ../boot/flisp.boot ../boot/flisp.boot.builtin && \
+cp ../boot/sl.boot.builtin ../boot/sl.boot.builtin.bak && \
+$F ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/sl.boot && \
+cp ../boot/sl.boot ../boot/sl.boot.builtin && \
ninja -C ../build && \
cd ../boot && \
$F ../tools/mkboot1.lsp && \
-ninja -C ../build || { cp flisp.boot.builtin.bak flisp.boot.builtin; exit 1; }+ninja -C ../build || { cp sl.boot.builtin.bak sl.boot.builtin; exit 1; }--- a/tools/builtins2h.sh
+++ b/tools/builtins2h.sh
@@ -1,7 +1,7 @@
#!/bin/sh
set -e
awk -F '[()]' '\
- /^fl_.*fn/ {attr=$1; next} \+ /^sl_.*fn/ {attr=$1; next} \ /^_Noreturn/ {attr=$1; next} \ /^BUILTIN[_]?/ {printf "BUILTIN_FN(%s, %s)\n", $2, attr} \ {attr=""}' $* | sort--- a/tools/disenv.lsp
+++ b/tools/disenv.lsp
@@ -1,4 +1,4 @@
-#!/usr/bin/env flisp
+#!/usr/bin/env sl
(for-each (lambda (e)
(let ((v (top-level-value e)))
(when (and (function? v)
--- a/tools/gen.lsp
+++ b/tools/gen.lsp
@@ -138,7 +138,7 @@
(io-write c-header "\tN_OPCODES\n}opcode_t;\n\n")
(io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
(io-close c-header)
- (io-write c-code "#include \"flisp.h\"\n\n")
+ (io-write c-code "#include \"sl.h\"\n\n")
(io-write c-code "const Builtin builtins[N_OPCODES] = {\n")(for-each
(λ (c la) (begin (io-write c-code "\t[")
--- a/tools/mkboot1.lsp
+++ b/tools/mkboot1.lsp
@@ -4,4 +4,4 @@
#.(load "../src/docs_extra.lsp")
#.(load "../src/docs_ops.lsp")
(load "../src/compiler.lsp")
-(make-system-image "flisp.boot")
+(make-system-image "sl.boot")
--
⑨