This commit is contained in:
dzaima 2021-03-30 00:57:07 +03:00
commit bad822447f
20 changed files with 1903 additions and 0 deletions

6
.gitignore vendored Normal file
View File

@ -0,0 +1,6 @@
main.s
BQN
src/runtime
src/compiler
src/interp
c.bqn

2
asmBuild Executable file
View File

@ -0,0 +1,2 @@
#!/usr/bin/env bash
clang -std=c11 -Wall -Wno-microsoft-anon-tag -fms-extensions -O3 -masm=intel -S src/main.c

2
build Executable file
View File

@ -0,0 +1,2 @@
#!/usr/bin/env bash
clang -std=c11 -O3 -Wall -Wno-microsoft-anon-tag -fms-extensions -o BQN -lm src/main.c

42
cc.bqn Executable file
View File

@ -0,0 +1,42 @@
#! /usr/bin/env dbqn
args•args
return 1args
args˜ return
"call with argument specifying path of mlochbaum/BQN!"!2args
path(args)"/src/"
args˜1
L {"m_vaB("(𝕩)(","¨𝕩)")"}
LI {"m_cai32("(𝕩)",(i32[]){"(1","¨𝕩)"})"}
# Escape the special characters that appear in BQN sources.
Esc{
in (@+091013)"'""" # Null, Tab, LF, CR, and quotes
out "0tnr" # Whitespace characters changed to letters
i in𝕩
𝕩 i out((i<out)/) 𝕩 # Replace
(i<in) /"\"¨ 𝕩 # Insert \
}
Str "m_str32(U"""Esc""")"˜ # A BQN string
Char {"m_c32(U'"(Esc𝕩)"')"} # A BQN character
Num {s"-"/˜𝕩<0 =|"m_f64("")"˜s| "m_f64("s"1.0/0.0)"𝕩} # Format number
F # Format number
Import •Import path
FChars •FChars path
compile Import "c.bqn"
useInd "-i"args args˜useInd
Comp (3+useInd) ((<"inci(runtime[""])"˙)¨62)Compile
J \n¨
Fconst @NumChar, Str,
prov {"inci("𝕩")"}¨"bi_type""bi_fill""bi_log""bi_grLen""bi_grOrd""bi_asrt""bi_add""bi_sub""bi_mul""bi_div""bi_pow""bi_floor""bi_eq""bi_le""bi_fne""bi_shape""bi_pick""bi_ud""bi_tbl""bi_scan""bi_fillBy""bi_val"
Fout {((𝕩)LI F¨,L ·prov(𝕨0) Fconst¨,L (LI F¨)¨,L (L F¨)¨) {𝕎𝕩}¨ 𝕩}
Frun 1Fout
Long {¯2𝕩¨<","\n}
•Out(¬return) ("r""c""f""e")
{𝕩reflenImport "pr.bqn"Long Frun len(1)Comp ref}
{𝕩Long Fout Comp FChars "c.bqn"}
{𝕩Long Fout Comp FChars "f.bqn"}
{𝕩Long Fout Comp "Modify←GetHighlights←⊢⋄" (FChars )".bqn"¨ "../svg""e"}
¯1 · J LFoutComp¨
args

2
debugBuild Executable file
View File

@ -0,0 +1,2 @@
#!/usr/bin/env bash
clang -DDEBUG -std=c11 -g -Wall -Wno-microsoft-anon-tag -fms-extensions -o BQN -lm src/main.c

3
genRuntime Executable file
View File

@ -0,0 +1,3 @@
#!/usr/bin/env bash
./cc.bqn $1 r > src/runtime
./cc.bqn $1 c > src/compiler

72
src/arith.c Normal file
View File

@ -0,0 +1,72 @@
#include "h.h"
#include <math.h>
#define ffnx(name, expr, extra) B name(B t, B w, B x) { \
if (isF64(w) & isF64(x)) return m_f64(expr); \
extra \
return err(#name ": invalid arithmetic"); \
}
#define ffn(name, op, extra) ffnx(name, w.f op x.f, extra)
ffn(add_c2, +, {
if (isC32(w) & isF64(x)) return m_c32((u32)w.u + o2i(x));
if (isF64(w) & isC32(x)) return m_c32((u32)x.u + o2i(w));
})
ffn(sub_c2, -, {
if (isC32(w) & isF64(x)) return m_c32((u32)w.u - o2i(x));
if (isC32(w) & isC32(x)) return m_f64((u32)w.u - (i64)(u32)x.u);
})
ffn(mul_c2, *, {})
ffn(div_c2, /, {})
ffn(le_c2, <=, {
if (isC32(w) & isC32(x)) return m_f64(w.u<=x.u);
if (isF64(w) & isC32(x)) return m_f64(1);
if (isC32(w) & isF64(x)) return m_f64(0);
})
ffnx(pow_c2, pow(w.f,x.f), {})
ffnx(log_c2, log(x.f)/log(w.f), {})
#undef ffn
#undef ffnx
B decp_c1(B t, B x);
B eq_c2(B t, B w, B x) {
if(isF64(w)&isF64(x)) return m_i32(w.f==x.f);
if (w.u==x.u) return m_i32(1);
if (!isVal(w) | !isVal(x)) { dec(w);dec(x); return m_i32(0); }
if (v(w)->type!=v(x)->type) { dec(w);dec(x); return m_i32(0); }
B2B dcf = TI(w).decompose;
if (dcf == def_decompose) { dec(w);dec(x); return m_i32(0); }
w=dcf(w); B* wp = harr_ptr(w);
x=dcf(x); B* xp = harr_ptr(x);
if (o2i(wp[0])<=1) { dec(w);dec(x); return m_i32(0); }
i32 wia = a(w)->ia;
i32 xia = a(x)->ia;
if (wia != xia) { dec(w);dec(x); return m_i32(0); }
for (i32 i = 0; i<wia; i++) if(!o2i(eq_c2(t,inci(wp[i]),inci(xp[i]))))
{ dec(w);dec(x); return m_i32(0); }
dec(w);dec(x); return m_i32(1);
}
B add_c1(B t, B x) { return x; }
B sub_c1(B t, B x) { if (isF64(x)) return m_f64( -x.f ); return err("negating non-number"); }
B mul_c1(B t, B x) { if (isF64(x)) return m_f64(x.f?x.f>0?1:-1:0); return err("getting sign of non-number"); }
B div_c1(B t, B x) { if (isF64(x)) return m_f64( 1/x.f ); return err("getting reciprocal of non-number"); }
B pow_c1(B t, B x) { if (isF64(x)) return m_f64( exp(x.f)); return err("getting exp of non-number"); }
B floor_c1(B t, B x) { if (isF64(x)) return m_f64(floor(x.f)); return err("getting floor of non-number"); }
B log_c1(B t, B x) { if (isF64(x)) return m_f64( log(x.f)); return err("getting log of non-number"); }
B eq_c1(B t, B x) { B r = m_i32(isArr(x)? a(x)->rank : 0); dec(x); return r; }
#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME;
#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = c1_invalid; c(Fun,bi_##NAME)->id=pf_##NAME;
#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = c2_invalid;c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME;
B bi_add, bi_sub, bi_mul, bi_div, bi_pow, bi_floor, bi_eq, bi_le, bi_log;
void arith_init() { ba(add) ba(sub) ba(mul) ba(div) ba(pow) bm(floor) ba(eq) bd(le) ba(log) }
#undef ba
#undef bd
#undef bm

78
src/derv.c Normal file
View File

@ -0,0 +1,78 @@
#include "h.h"
typedef struct Md1D { // F _md
struct Fun;
B m; // known to be Md1 at creation; kept as type B as refc-- might want to know tagged ptr info
B f;
} Md1D;
typedef struct Md2D { // F _md_ G
struct Fun;
B m;
B f, g;
} Md2D;
typedef struct Md2H { // _md_ G
struct Md1;
B m;
B g;
} Md2H;
typedef struct Fork {
struct Fun;
B f, g, h;
} Fork;
typedef struct Atop {
struct Fun;
B g, h;
} Atop;
void md1D_free(B x) { dec(c(Md1D,x)->m); dec(c(Md1D,x)->f); }
void md2D_free(B x) { dec(c(Md2D,x)->m); dec(c(Md2D,x)->f); dec(c(Md2D,x)->g); }
void md2H_free(B x) { dec(c(Md2H,x)->m); dec(c(Md2H,x)->g); }
void fork_free(B x) { dec(c(Fork,x)->f); dec(c(Fork,x)->g); dec(c(Fork,x)->h); }
void atop_free(B x) { dec(c(Atop,x)->g); dec(c(Atop,x)->h); }
void md1D_print(B x) { printf("(md1D ");print(c(Md1D,x)->f);printf(" ");print(c(Md1D,x)->m); printf(")"); }
void md2D_print(B x) { printf("(md2D ");print(c(Md2D,x)->f);printf(" ");print(c(Md2D,x)->m);printf(" ");print(c(Md2D,x)->g);printf(")"); }
void md2H_print(B x) { printf("(md2H "); print(c(Md2H,x)->m);printf(" ");print(c(Md2H,x)->g);printf(")"); }
void fork_print(B x) { printf("(fork ");print(c(Fork,x)->f);printf(" ");print(c(Fork,x)->g);printf(" ");print(c(Fork,x)->h);printf(")"); }
void atop_print(B x) { printf("(atop "); print(c(Atop,x)->g);printf(" ");print(c(Atop,x)->h);printf(")"); }
B md1D_c1(B t , B x) { return c(Md1,c(Md1D, t)->m)->c1(c(Md1D, t)->m, c(Md1D, t)->f, x); }
B md1D_c2(B t, B w, B x) { return c(Md1,c(Md1D, t)->m)->c2(c(Md1D, t)->m, c(Md1D, t)->f, w, x); }
B md2D_c1(B t , B x) { return c(Md2,c(Md2D, t)->m)->c1(c(Md2D, t)->m, c(Md2D, t)->f, c(Md2D, t)->g, x); }
B md2D_c2(B t, B w, B x) { return c(Md2,c(Md2D, t)->m)->c2(c(Md2D, t)->m, c(Md2D, t)->f, c(Md2D, t)->g, w, x); }
B atop_c1(B t , B x) { return c1(c(Atop,t)->g, c1(c(Atop,t)->h, x)); }
B atop_c2(B t, B w, B x) { return c1(c(Atop,t)->g, c2(c(Atop,t)->h, w, x)); }
B fork_c1(B t , B x) { B g=c1(c(Fork,t)->h, inci(x)); return c2(c(Fork,t)->g, c1(c(Fork,t)->f, x), g); }
B fork_c2(B t, B w, B x) { B g=c2(c(Fork,t)->h, inci(w), inci(x)); return c2(c(Fork,t)->g, c2(c(Fork,t)->f, w, x), g); }
B md2H_c1(B t, B f , B x) { return c(Md2,c(Md2H, t)->m)->c1(c(Md2H,t)->m, f, c(Md2H,t)->g, x); }
B md2H_c2(B t, B f, B w, B x) { return c(Md2,c(Md2H, t)->m)->c2(c(Md2H,t)->m, f, c(Md2H,t)->g, w, x); }
B md1D_decompose(B x) { B r=m_v3(m_i32(4),inci(c(Md1D,x)->f),inci(c(Md1D,x)->m) ); dec(x); return r; }
B md2D_decompose(B x) { B r=m_v4(m_i32(5),inci(c(Md2D,x)->f),inci(c(Md2D,x)->m), inci(c(Md2D,x)->g)); dec(x); return r; }
B md2H_decompose(B x) { B r=m_v3(m_i32(6), inci(c(Md2H,x)->m), inci(c(Md2H,x)->g)); dec(x); return r; }
B fork_decompose(B x) { B r=m_v4(m_i32(3),inci(c(Fork,x)->f),inci(c(Fork,x)->g), inci(c(Fork,x)->h)); dec(x); return r; }
B atop_decompose(B x) { B r=m_v3(m_i32(2), inci(c(Atop,x)->g), inci(c(Atop,x)->h)); dec(x); return r; }
// consume all args
B m_md1D(B m, B f ) { B r = mm_alloc(sizeof(Md1D), t_md1D, ftag(FUN_TAG)); c(Md1D,r)->f = f; c(Md1D,r)->m = m; c(Md1D,r)->c1=md1D_c1; c(Md1D,r)->c2=md1D_c2; c(Md1D,r)->id=pf_md1d; return r; }
B m_md2D(B m, B f, B g) { B r = mm_alloc(sizeof(Md2D), t_md2D, ftag(FUN_TAG)); c(Md2D,r)->f = f; c(Md2D,r)->m = m; c(Md2D,r)->g = g; c(Md2D,r)->c1=md2D_c1; c(Md2D,r)->c2=md2D_c2; c(Md2D,r)->id=pf_md2d; return r; }
B m_md2H(B m, B g) { B r = mm_alloc(sizeof(Md2H), t_md2H, ftag(MD1_TAG)); c(Md2H,r)->m = m; c(Md2H,r)->g = g; c(Md2H,r)->c1=md2H_c1; c(Md2H,r)->c2=md2H_c2; return r; }
B m_fork(B f, B g, B h) { B r = mm_alloc(sizeof(Fork), t_fork, ftag(FUN_TAG)); c(Fork,r)->f = f; c(Fork,r)->g = g; c(Fork,r)->h = h; c(Fork,r)->c1=fork_c1; c(Fork,r)->c2=fork_c2; c(Fork,r)->id=pf_fork; return r; }
B m_atop( B g, B h) { B r = mm_alloc(sizeof(Atop), t_atop, ftag(FUN_TAG)); c(Atop,r)->g = g; c(Atop,r)->h = h; c(Atop,r)->c1=atop_c1; c(Atop,r)->c2=atop_c2; c(Atop,r)->id=pf_atop; return r; }
// consume all args
B m1_d(B m, B f ) { if(isMd1(m)) return TI(m).m1_d(m, f ); return err("Interpreting non-1-modifier as 1-modifier"); }
B m2_d(B m, B f, B g) { if(isMd2(m)) return TI(m).m2_d(m, f, g); return err("Interpreting non-2-modifier as 2-modifier"); }
B m2_h(B m, B g) { return m_md2H(m, g); }
void derv_init() {
ti[t_md1D].free = md1D_free; ti[t_md1D].print = md1D_print; ti[t_md1D].decompose = md1D_decompose;
ti[t_md2D].free = md2D_free; ti[t_md2D].print = md2D_print; ti[t_md2D].decompose = md2D_decompose;
ti[t_md2H].free = md2H_free; ti[t_md2H].print = md2H_print; ti[t_md2H].decompose = md2H_decompose;
ti[t_fork].free = fork_free; ti[t_fork].print = fork_print; ti[t_fork].decompose = fork_decompose;
ti[t_atop].free = atop_free; ti[t_atop].print = atop_print; ti[t_atop].decompose = atop_decompose;
ti[t_md1_def].m1_d = m_md1D;
ti[t_md2_def].m2_d = m_md2D;
}

441
src/h.h Normal file
View File

@ -0,0 +1,441 @@
#pragma once
#include <inttypes.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stddef.h>
#include <stdarg.h>
#define i8 int8_t
#define u8 uint8_t
#define i16 int16_t
#define u16 uint16_t
#define i32 int32_t
#define u32 uint32_t
#define i64 int64_t
#define u64 uint64_t
#define f64 double
#define I32_MAX ((i32)((1LL<<31)-1))
#define U16_MAX ((u16)-1)
#define UD __builtin_unreachable();
#ifdef DEBUG
#include<assert.h>
#define VALIDATE(x) validate(x) // preferred validating level
#else
#define assert(x) {if (!(x)) __builtin_unreachable();}
#define VALIDATE(x) x
#endif
#define fsizeof(T,F,E,n) (offsetof(T, F) + sizeof(E)*n) // type; FAM name; FAM type; amount
#define usz u32
#define ur u8
#define ftag(x) ((u64)(x) << 48)
#define tag(v, t) b(((u64)(v)) | ftag(t))
// .111111111110000000000000000000000000000000000000000000000000000 infinity
// .111111111111000000000000000000000000000000000000000000000000000 qNaN
// .111111111110nnn................................................ sNaN aka tagged aka not f64, if nnn≠0
// 0111111111110................................................... direct value with no need of refcounting
u16 C32_TAG = 0b0111111111110001; // 0111111111110001................00000000000ccccccccccccccccccccc char
u16 TAG_TAG = 0b0111111111110010; // 0111111111110010................nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn special value (0=nothing, 1=undefined var, 2=bad header; 3=optimized out; 4=error?)
u16 VAR_TAG = 0b0111111111110011; // 0111111111110011ddddddddddddddddnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn variable reference
u16 I32_TAG = 0b0111111111110111; // 0111111111110111................nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn 32-bit int; unused
u16 MD1_TAG = 0b1111111111110010; // 1111111111110010ppppppppppppppppppppppppppppppppppppppppppppp000 1-modifier
u16 MD2_TAG = 0b1111111111110011; // 1111111111110011ppppppppppppppppppppppppppppppppppppppppppppp000 2-modifier
u16 FUN_TAG = 0b1111111111110100; // 1111111111110100ppppppppppppppppppppppppppppppppppppppppppppp000 function
u16 NSP_TAG = 0b1111111111110101; // 1111111111110101ppppppppppppppppppppppppppppppppppppppppppppp000 namespace maybe?
u16 OBJ_TAG = 0b1111111111110110; // 1111111111110110ppppppppppppppppppppppppppppppppppppppppppppp000 custom object (e.g. bigints)
u16 ARR_TAG = 0b1111111111110111; // 1111111111110111ppppppppppppppppppppppppppppppppppppppppppppp000 array (everything else is an atom)
u16 VAL_TAG = 0b1111111111110 ; // 1111111111110................................................... pointer to Value, needs refcounting
enum Type {
/* 0*/ t_empty, // empty bucket placeholder
/* 1*/ t_fun_def, t_fun_block,
/* 3*/ t_md1_def, t_md1_block,
/* 5*/ t_md2_def, t_md2_block,
/* 7*/ t_noGC, // doesn't get visited, shouldn't be unallocated by gc
/* 8*/ t_fork, t_atop,
/*10*/ t_md1D, t_md2D, t_md2H,
/*13*/ t_harr, t_i32arr,
/*15*/ t_comp, t_block, t_body, t_scope,
Type_MAX
};
enum PrimFns {
pf_not,
pf_add, pf_sub, pf_mul, pf_div, pf_pow, pf_floor, pf_eq, pf_le, pf_log, // arith.c
pf_shape, pf_pick, pf_ud, pf_pair, pf_fne, pf_lt, pf_rt, // sfns.c
pf_fork, pf_atop, pf_md1d, pf_md2d, // derv.c
pf_type, pf_decp, pf_primInd, pf_glyph, pf_fill, pf_grLen, pf_grOrd, pf_asrt, // sysfn.c
};
char* format_pf(u8 u) {
switch(u) {
default: case pf_not: return"(unknown fn)";
case pf_add:return"+"; case pf_sub:return"-"; case pf_mul:return"×"; case pf_div:return"÷"; case pf_pow:return""; case pf_floor:return""; case pf_eq:return"="; case pf_le:return""; case pf_log:return"⋆⁼";
case pf_shape:return""; case pf_pick:return""; case pf_ud:return""; case pf_pair:return"{𝕨‿𝕩}"; case pf_fne:return""; case pf_lt:return""; case pf_rt:return"";
case pf_fork:return"(fork)"; case pf_atop:return"(atop)"; case pf_md1d:return"(derived 1-modifier)"; case pf_md2d:return"(derived 2-modifier)";
case pf_type:return"•Type"; case pf_decp:return"•Decompose"; case pf_primInd:return"•PrimInd"; case pf_glyph:return"•Glyph"; case pf_fill:return"•FillFn"; case pf_grLen:return"•GroupLen"; case pf_grOrd:return"•GroupOrd"; case pf_asrt:return"!"; }
}
enum PrimMd1 {
pm1_not,
pm1_tbl, pm1_scan, // md1.c
};
char* format_pm1(u8 u) {
switch(u) {
default: case pf_not: return"(unknown 1-modifier)";
case pm1_tbl: return""; case pm1_scan: return"`";
}
}
typedef union B {
u64 u;
i64 s;
f64 f;
} B;
#define b(x) ((B)(x))
typedef struct Value {
i32 refc;
u16 flags; // incl GC stuff when that's a thing, possibly whether is sorted/a permutation/whatever, bucket size, etc
u8 type; // needed globally so refc-- and GC know what to visit
} Value;
typedef struct Arr {
struct Value;
ur rank;
usz ia;
usz* sh;
} Arr;
// memory manager
B mm_alloc(usz sz, u8 type, u64 tag);
void mm_free(Value* x);
void mm_visit(B x);
// some primitive actions
void dec(B x);
void inc(B x);
void ptr_dec(void* x);
void ptr_inc(void* x);
void print(B x);
B m_v1(B a );
B m_v2(B a, B b );
B m_v3(B a, B b, B c );
B m_v4(B a, B b, B c, B d);
#define c(T,x) ((T*)((x).u&0xFFFFFFFFFFFFull))
Value* v(B x) { return c(Value, x); }
Arr* a(B x) { return c(Arr , x); }
void print_vmStack();
#ifdef DEBUG
B validate(B x);
B recvalidate(B x);
#else
#define validate(x) x
#define recvalidate(x) x
#endif
B err(char* s) {
puts(s); fflush(stdout);
print_vmStack();
exit(1);
}
// tag checks
#ifdef ATOM_I32
bool isI32(B x) { return (x.u>>48) == I32_TAG; }
#else
bool isI32(B x) { return false; }
#endif
bool isFun(B x) { return (x.u>>48) == FUN_TAG; }
bool isArr(B x) { return (x.u>>48) == ARR_TAG; }
bool isC32(B x) { return (x.u>>48) == C32_TAG; }
bool isVar(B x) { return (x.u>>48) == VAR_TAG; }
bool isMd1(B x) { return (x.u>>48) == MD1_TAG; }
bool isMd2(B x) { return (x.u>>48) == MD2_TAG; }
bool isMd (B x) { return (x.u>>49) ==(MD2_TAG>>1); }
bool isNsp(B x) { return (x.u>>48) == NSP_TAG; }
bool isObj(B x) { return (x.u>>48) == OBJ_TAG; }
// bool isVal(B x) { return ((x.u>>51) == VAL_TAG) & ((x.u<<13) != 0); }
// bool isF64(B x) { return ((x.u>>51&0xFFF) != 0xFFE) | ((x.u<<1)==(b(1.0/0.0).u<<1)); }
bool isVal(B x) { return (x.u - (((u64)VAL_TAG<<51) + 1)) < ((1ull<<51) - 1); } // ((x.u>>51) == VAL_TAG) & ((x.u<<13) != 0);
bool isF64(B x) { return (x.u<<1) - ((0xFFEull<<52) + 2) >= (1ull<<52) - 2; }
bool isAtm(B x) { return !isVal(x); }
// shape mess
typedef struct ShArr {
struct Value;
usz a[];
} ShArr;
usz* allocSh(ur r) {
assert(r>0);
B x = mm_alloc(fsizeof(ShArr, a, usz, r), t_noGC, ftag(OBJ_TAG));
return ((ShArr*)v(x))->a;
}
ShArr* shObj(B x) { return (ShArr*)((u64)a(x)->sh-offsetof(ShArr,a)); }
void decSh(B x) { if (a(x)->rank>1) ptr_dec(shObj(x)); }
void arr_shVec(B x, usz ia) {
a(x)->ia = ia;
a(x)->rank = 1;
a(x)->sh = &a(x)->ia;
}
usz* arr_shAlloc(B x, usz ia, usz r) {
a(x)->ia = ia;
a(x)->rank = r;
if (r>1) return a(x)->sh = allocSh(r);
a(x)->sh = &a(x)->ia;
return 0;
}
void arr_shCopy(B n, B o) { // copy shape from o to n
a(n)->ia = a(o)->ia;
ur r = a(n)->rank = a(o)->rank;
if (r<=1) {
a(n)->sh = &a(n)->ia;
} else {
a(n)->sh = a(o)->sh;
ptr_inc(shObj(o));
}
}
bool shEq(B w, B x) { // assumes both are Arr
ur wr = a(w)->rank; usz* wsh = a(w)->sh;
ur xr = a(x)->rank; usz* xsh = a(x)->sh;
if (wr!=xr) return false;
if (wsh==xsh) return true;
return memcmp(wsh,xsh,wr*sizeof(usz))==0;
}
usz arr_csz(B x) {
ur xr = a(x)->rank;
if (xr<=1) return 1;
usz* sh = a(x)->sh;
usz r = 1;
for (i32 i = 1; i < xr; i++) r*= sh[i];
return r;
}
// make objects
B m_arr(usz min, u8 type) { return mm_alloc(min, type, ftag(ARR_TAG)); }
B m_f64(f64 n) { assert(isF64(b(n))); return b(n); } // assert just to make sure we're actually creating a float
B m_c32(i32 n) { return tag(n, C32_TAG); } // TODO check validity?
#ifdef ATOM_I32
B m_i32(i32 n) { return tag(n, I32_TAG); }
#else
B m_i32(i32 n) { return m_f64(n); }
#endif
B m_error() { return tag(4, TAG_TAG); }
B m_usz(usz n) { return n==(i32)n? m_i32(n) : m_f64(n); }
i32 o2i (B x) { if ((i32)x.f!=x.f) err("o2i"": expected integer"); return (i32)x.f; }
usz o2s (B x) { if ((usz)x.f!=x.f) err("o2s"": expected integer"); return (usz)x.f; }
i64 o2i64(B x) { if ((i64)x.f!=x.f) err("o2i64: expected integer"); return (i64)x.f; }
typedef void (*B2V)(B);
typedef B (*BS2B)(B, usz);
typedef B (* B2B)(B);
typedef B (* BB2B)(B, B);
typedef B (* BBB2B)(B, B, B);
typedef B (* BBBB2B)(B, B, B, B);
typedef B (*BBBBB2B)(B, B, B, B, B);
typedef struct TypeInfo {
B2V free; // expects refc==0
B2V visit; // for GC when that comes around
B2V print; // doesn't consume
BS2B get; // increments result, doesn't consume arg
BB2B m1_d; // consume all args
BBB2B m2_d; // consume all args
B2B decompose; // consumes; must return a HArr
} TypeInfo;
TypeInfo ti[Type_MAX];
#define TI(x) (ti[v(x)->type])
void do_nothing(B x) { }
B get_self(B x, usz n) { return x; }
void def_print(B x) { printf("(type %d)", v(x)->type); }
B def_m1_d(B m, B f ) { return err("cannot derive this"); }
B def_m2_d(B m, B f, B g) { return err("cannot derive this"); }
B def_decompose(B x) { return m_v2(m_i32((isFun(x)|isMd(x))? 0 : -1),x); }
B bi_nothing, bi_noVar, bi_badHdr, bi_optOut;
void hdr_init() {
for (i32 i = 0; i < Type_MAX; ++i) {
ti[i].visit = ti[i].free = do_nothing;
ti[i].get = get_self;
ti[i].print = def_print;
ti[i].m1_d = def_m1_d;
ti[i].m2_d = def_m2_d;
ti[i].decompose = def_decompose;
}
bi_nothing = tag(0, TAG_TAG);
bi_noVar = tag(1, TAG_TAG);
bi_badHdr = tag(2, TAG_TAG);
bi_optOut = tag(3, TAG_TAG);
}
bool isNothing(B b) { return b.u==bi_nothing.u; }
// refcount
void dec(B x) {
if (!isVal(VALIDATE(x))) return;
Value* vx = v(x);
assert(vx->refc>0);
if (!--vx->refc) {
// printf("freeing type %d: %p\n", vx->type, (void*)x.u);fflush(stdout);
ti[vx->type].free(x);
mm_free(vx);
}
}
void inc (B x) { if (isVal(VALIDATE(x))) v(x)->refc++; }
B inci(B x) { inc(x); return x; }
void ptr_dec(void* x) { dec(tag(x, OBJ_TAG)); }
void ptr_inc(void* x) { inc(tag(x, OBJ_TAG)); }
bool reusable(B x) { return v(x)->refc==1; }
void printUTF8(u32 c) {
if (c<128) printf("%c", c);
else if (c<=0x07FF) printf("%c%c" , 0xC0| c>>6 , 0x80| (c &0x3F) );
else if (c<=0xFFFF) printf("%c%c%c" , 0xE0| c>>12, 0x80| (c>>6 &0x3F), 0x80| (c &0x3F) );
else printf("%c%c%c%c", 0xF0| c>>18, 0x80| (c>>12 &0x3F), 0x80| (c>>6 &0x3F), 0x80| (c&0x3F));
}
void print(B x) {
if (isF64(x)) {
printf("%g", x.f);
} else if (isC32(x)) {
if ((u32)x.u>=32) { printf("'"); printUTF8((u32)x.u); printf("'"); }
else printf("\\x%x", (u32)x.u);
} else if (isI32(x)) {
printf("%d", (i32)x.u);
} else if (isVal(x)) {
#ifdef DEBUG
if (isVal(x) && v(x)->refc<0) {printf("(FREED)"); exit(1);} else
#endif
TI(x).print(x);
}
else if (isVar(x)) printf("(var d=%d i=%d)", (u16)(x.u>>32), (i32)x.u);
else if (x.u==bi_nothing.u) printf("·");
else if (x.u==bi_optOut.u) printf("(value optimized out)");
else if (x.u==bi_noVar.u) printf("(unset variable placeholder)");
else if (x.u==bi_badHdr.u) printf("(bad header note)");
else printf("(todo tag %lx)", x.u>>48);
}
typedef struct Fun {
struct Value;
u8 id;
BB2B c1;
BBB2B c2;
} Fun;
B c1_invalid(B f, B x) { return err("This function can't be called monadically"); }
B c2_invalid(B f, B w, B x) { return err("This function can't be called dyadically"); }
B c1(B f, B x) { // BQN-call f monadically; consumes x
if (isFun(f)) return VALIDATE(c(Fun,f)->c1(f, x));
dec(x);
if (isMd(f)) return err("Calling a modifier");
return inci(VALIDATE(f));
}
B c2(B f, B w, B x) { // BQN-call f dyadically; consumes w,x
if (isFun(f)) return VALIDATE(c(Fun,f)->c2(f, w, x));
dec(w);dec(x);
if (isMd(f)) return err("Calling a modifier");
return inci(VALIDATE(f));
}
typedef struct Md1 {
struct Value;
u8 id;
BBB2B c1; // f(m,f, x); consumes x
BBBB2B c2; // f(m,f,w,x); consumes w,x
} Md1;
typedef struct Md2 {
struct Value;
u8 id;
BBBB2B c1; // f(m,f,g, x); consumes x
BBBBB2B c2; // f(m,f,g,w,x); consumes w,x
} Md2;
void arr_print(B x) {
usz r = a(x)->rank;
BS2B xget = TI(x).get;
usz ia = a(x)->ia;
if (r!=1) {
if (r==0) {
printf("<");
print(xget(x,0));
return;
}
usz* sh = a(x)->sh;
for (i32 i = 0; i < r; i++) {
if(i==0)printf("%d",sh[i]);
else printf("‿%d",sh[i]);
}
printf("");
} else if (ia>0) {
for (usz i = 0; i < ia; i++) {
B c = xget(x,i);
bool is = isC32(c);
dec(c);
if (!is) goto reg;
}
printf("\"");
for (usz i = 0; i < ia; i++) printUTF8((u32)xget(x,i).u); // c32, no need to decrement
printf("\"");
return;
}
reg:;
printf("");
for (usz i = 0; i < ia; i++) {
if (i!=0) printf(", ");
B c = xget(x,i);
print(c);
dec(c);
}
printf("");
}
#ifdef DEBUG
B validate(B x) {
if (!isVal(x)) return x;
if (v(x)->refc<=0 || (v(x)->refc>>28) == 'a') {
printf("bad refcount for type %d: %d; val=%p\nattempting to print: ", v(x)->type, v(x)->refc, (void*)x.u); fflush(stdout);
print(x); puts(""); fflush(stdout);
err("");
}
if (isArr(x)) {
ur r = a(x)->rank;
if (r<=1) assert(a(x)->sh == &a(x)->ia);
else validate(tag(shObj(x),OBJ_TAG));
}
return x;
}
B recvalidate(B x) {
validate(x);
if (isArr(x)) {
BS2B xget = TI(x).get;
usz ia = a(x)->ia;
for (usz i = 0; i < ia; i++) {
B c = xget(x,i);
assert(c.u!=x.u);
recvalidate(c);
dec(c);
}
}
return x;
}
#endif

96
src/harr.c Normal file
View File

@ -0,0 +1,96 @@
#include "h.h"
typedef struct HArr {
struct Arr;
B a[];
} HArr;
typedef struct HArr_p {
B b;
B* a;
HArr* c;
} HArr_p;
HArr_p harr_parts(B b) {
HArr* p = c(HArr,b);
return (HArr_p){.b = b, .a = p->a, .c = p};
}
HArr_p m_harrv(usz ia) {
B r = m_arr(fsizeof(HArr,a,B,ia), t_harr);
arr_shVec(r, ia);
return harr_parts(r);
}
HArr_p m_harrc(B x) { assert(isArr(x));
B r = m_arr(fsizeof(HArr,a,B,a(x)->ia), t_harr);
arr_shCopy(r, x);
return harr_parts(r);
}
HArr_p m_harrp(usz ia) { // doesn't write any shape/size info! be careful!
return harr_parts(m_arr(fsizeof(HArr,a,B,ia), t_harr));
}
B* harr_ptr(B x) {
assert(v(x)->type==t_harr);
return c(HArr,x)->a;
}
HArr* toHArr(B x) {
if (v(x)->type==t_harr) return c(HArr,x);
HArr_p r = m_harrc(x);
usz ia = r.c->ia;
BS2B xget = TI(x).get;
for (usz i = 0; i < ia; i++) r.a[i] = xget(x,i);
dec(x);
return r.c;
}
B m_vaf64(usz sz, ...) {
va_list vargs;
va_start(vargs, sz);
HArr_p r = m_harrv(sz);
for (usz i = 0; i < sz; i++) r.a[i] = m_f64(va_arg(vargs, f64));
va_end(vargs);
return r.b;
}
B m_vaB(usz sz, ...) {
va_list vargs;
va_start(vargs, sz);
HArr_p r = m_harrv(sz);
for (usz i = 0; i < sz; i++) r.a[i] = va_arg(vargs, B);
va_end(vargs);
return r.b;
}
B m_v1(B a ) { HArr_p r = m_harrv(1); r.a[0] = a; return r.b; }
B m_v2(B a, B b ) { HArr_p r = m_harrv(2); r.a[0] = a; r.a[1] = b; return r.b; }
B m_v3(B a, B b, B c ) { HArr_p r = m_harrv(3); r.a[0] = a; r.a[1] = b; r.a[2] = c; return r.b; }
B m_v4(B a, B b, B c, B d) { HArr_p r = m_harrv(4); r.a[0] = a; r.a[1] = b; r.a[2] = c; r.a[3] = d; return r.b; }
void harr_print(B x) {
arr_print(x);
}
B harr_get(B x, usz n) {
return inci(c(HArr,x)->a[n]);
}
void harr_free(B x) {
decSh(x);
B* p = harr_ptr(x);
usz ia = a(x)->ia;
for (usz i = 0; i < ia; i++) dec(p[i]);
}
void harr_init() {
ti[t_harr].free = harr_free;
ti[t_harr].print = harr_print;
ti[t_harr].get = harr_get;
}

61
src/i32arr.c Normal file
View File

@ -0,0 +1,61 @@
#include "h.h"
typedef struct I32Arr {
struct Arr;
i32 a[];
} I32Arr;
B m_i32arrv(usz ia) {
B r = m_arr(fsizeof(I32Arr,a,i32,ia), t_i32arr);
arr_shVec(r, ia);
return r;
}
B m_i32arrc(B x) { assert(isArr(x));
B r = m_arr(fsizeof(I32Arr,a,B,a(x)->ia), t_i32arr);
arr_shCopy(r, x);
return r;
}
B m_i32arrp(usz ia) { // doesn't write any shape/size info! be careful!
return m_arr(fsizeof(I32Arr,a,i32,ia), t_i32arr);
}
i32* i32arr_ptr(B x) {
assert(v(x)->type==t_i32arr);
return c(I32Arr,x)->a;
}
B m_vai32(usz sz, ...) {
va_list vargs;
va_start(vargs, sz);
B r = m_i32arrv(sz);
i32* rp = i32arr_ptr(r);
for (usz i = 0; i < sz; i++) rp[i] = va_arg(vargs, i32);
va_end(vargs);
return r;
}
I32Arr* toI32Arr(B x) {
if (v(x)->type==t_i32arr) return c(I32Arr,x);
B r = m_i32arrc(x);
i32* rp = i32arr_ptr(r);
usz ia = a(r)->ia;
BS2B xget = TI(x).get;
for (usz i = 0; i < ia; i++) rp[i] = o2i(xget(x,i));
dec(x);
return c(I32Arr,r);
}
void i32arr_free(B x) { decSh(x); }
void i32arr_print(B x) { arr_print(x); }
B i32arr_get(B x, usz n) { assert(v(x)->type==t_i32arr); return m_i32(c(I32Arr,x)->a[n]); }
void i32arr_init() {
ti[t_i32arr].free = i32arr_free;
ti[t_i32arr].print = i32arr_print;
ti[t_i32arr].get = i32arr_get;
}

166
src/main.c Normal file
View File

@ -0,0 +1,166 @@
// #define ATOM_I32
#ifdef DEBUG
// #define DEBUG_VM
#endif
// #define ALLOC_STAT
#include "h.h"
#include "mm.c"
#include "harr.c"
#include "i32arr.c"
#include "arith.c"
#include "sfns.c"
#include "md1.c"
#include "md2.c"
#include "sysfn.c"
#include "derv.c"
#include "vm.c"
#include "utf.c"
void pr(char* a, B b) {
printf("%s", a);
print(b);
puts("");
dec(b);
fflush(stdout);
}
Block* ca3(B b) {
B* ps = harr_ptr(b);
Block* r = compile(inci(ps[0]),inci(ps[1]),inci(ps[2]));
dec(b);
return r;
}
B m_str8(char* s) {
u64 sz = strlen(s);
HArr_p r = m_harrv(sz);
for (u64 i = 0; i < sz; i++) r.a[i] = m_c32(s[i]);
return r.b;
}
B m_str32(u32* s) {
u64 sz = 0;
while(s[sz])sz++;
HArr_p r = m_harrv(sz);
for (u64 i = 0; i < sz; i++) r.a[i] = m_c32(s[i]);
return r.b;
}
B m_cai32(usz ia, i32* a) {
B r = m_i32arrv(ia);
i32* rp = i32arr_ptr(r);
for (usz i = 0; i < ia; i++) rp[i] = a[i];
return r;
}
__ssize_t getline (char **__restrict __lineptr, size_t *restrict n, FILE *restrict stream);
int main() {
hdr_init();
harr_init();
i32arr_init();
arith_init();
sfns_init();
md1_init();
md2_init();
sysfn_init();
derv_init();
comp_init();
// fake runtime
// B bi_N = bi_nothing;
// B runtime[] = {
// /* +-×÷⋆√⌊⌈|¬ */ bi_add, bi_sub , bi_mul , bi_div, bi_pow, bi_N , bi_floor, bi_N , bi_N, bi_N,
// /* ∧∨<>≠=≤≥≡≢ */ bi_N , bi_N , bi_N , bi_N , bi_N , bi_eq, bi_le , bi_N , bi_N, bi_fne,
// /* ⊣⊢⥊∾≍↑↓↕«» */ bi_lt , bi_rt , bi_shape, bi_N , bi_N , bi_N , bi_N , bi_ud , bi_N, bi_N,
// /* ⌽⍉/⍋⍒⊏⊑⊐⊒∊ */ bi_N , bi_N , bi_N , bi_N , bi_N , bi_N , bi_pick , bi_N , bi_N, bi_N,
// /* ⍷⊔!˙˜˘¨⌜⁼´ */ bi_N , bi_N , bi_asrt , bi_N , bi_N , bi_N , bi_N , bi_tbl, bi_N, bi_N,
// /* ˝`∘○⊸⟜⌾⊘◶⎉ */ bi_N , bi_scan, bi_N , bi_N , bi_N , bi_N , bi_N , bi_val, bi_N, bi_N,
// /* ⚇⍟ */ bi_N , bi_N
// };
// Block* c = ca3(
// #include "interp"
// );
// B interp = m_funBlock(c, 0); ptr_dec(c);
// pr("interpreted: ", interp);
Block* runtime_b = compile(
#include "runtime"
);
B rtRes = m_funBlock(runtime_b, 0); ptr_dec(runtime_b);
B rtObj = TI(rtRes).get(rtRes,0);
B rtFinish = TI(rtRes).get(rtRes,1);
B* runtime = toHArr(rtObj)->a;
runtimeLen = c(Arr,rtObj)->ia;
for (usz i = 0; i < runtimeLen; i++) {
if (isVal(runtime[i])) v(runtime[i])->flags|= i+1;
}
c1(rtFinish, m_v2(inci(bi_decp), inci(bi_primInd)));
// uncomment to use src/interp; needed for test.bqn
// Block* c = ca3(
// #include "interp"
// );
// B interp = m_funBlock(c, 0); ptr_dec(c);
// pr("result: ", interp);
// exit(0);
Block* comp_b = compile(
#include "compiler"
);
B comp = m_funBlock(comp_b, 0); ptr_dec(comp_b);
// uncomment to self-compile and use that for the REPL; expects a copy of mlochbaum/BQN/src/c.bqn to be at the execution directory
// char* c_src = 0;
// u64 c_len;
// FILE* f = fopen("c.bqn", "rb");
// if (f) {
// fseek(f, 0, SEEK_END);
// c_len = ftell(f);
// fseek(f, 0, SEEK_SET);
// c_src = malloc(c_len);
// if (c_src) fread(c_src, 1, c_len, f);
// fclose(f);
// } else {
// printf("couldn't read c.bqn\n");
// exit(1);
// }
// if (c_src) {
// B cbc = c2(comp, inci(rtObj), fromUTF8(c_src, c_len));
// Block* cbc_b = ca3(cbc);
// comp = m_funBlock(cbc_b, 0);
// free(c_src);
// }
while (true) { // exit by evaluating an empty expression
char* ln = NULL;
size_t gl = 0;
getline(&ln, &gl, stdin);
if (ln[0]==10) break;
B obj = fromUTF8(ln, strlen(ln));
B cbc = c2(comp, inci(rtObj), obj);
free(ln);
Block* cbc_b = ca3(cbc);
pr("", m_funBlock(cbc_b, 0));
}
dec(rtRes);
dec(comp);
#ifdef ALLOC_STAT
printf("ctrA←"); for (i64 j = 0; j < Type_MAX; j++) { if(j)printf(""); printf("%lu", ctr_a[j]); } printf("\n");
printf("ctrF←"); for (i64 j = 0; j < Type_MAX; j++) { if(j)printf(""); printf("%lu", ctr_f[j]); } printf("\n");
for(i64 i = 0; i < actrc; i++) {
u32* c = actrs[i];
bool any = false;
for (i64 j = 0; j < Type_MAX; j++) if (c[j]) any=true;
if (any) {
printf("%ld", i);
for (i64 j = 0; j < Type_MAX; j++) printf("‿%u", c[j]);
printf("\n");
}
}
#endif
}

103
src/md1.c Normal file
View File

@ -0,0 +1,103 @@
#include "h.h"
B tbl_c1(B t, B f, B x) {
if (!isArr(x)) return err("⌜: argument was atom");
usz ia = a(x)->ia;
HArr_p r = m_harrc(x);
BS2B xget = TI(x).get;
for (usz i = 0; i < ia; i++) r.a[i] = c1(f, xget(x,i));
dec(x);
return r.b;
}
B tbl_c2(B t, B f, B w, B x) {
if (isArr(w) & isArr(x)) {
usz wia = a(w)->ia; ur wr = a(w)->rank;
usz xia = a(x)->ia; ur xr = a(x)->rank;
usz ria = wia*xia; ur rr = wr+xr;
if (rr<xr) return err("⌜: result rank too large");
HArr_p r = m_harrp(ria);
usz* rsh = arr_shAlloc(r.b, ria, rr);
if (rsh) {
memcpy(rsh , a(w)->sh, wr*sizeof(usz));
memcpy(rsh+wr, a(x)->sh, xr*sizeof(usz));
}
BS2B wget = TI(w).get;
BS2B xget = TI(x).get;
usz ri = 0;
for (usz wi = 0; wi < wia; wi++) {
B cw = wget(w,wi);
for (usz xi = 0; xi < xia; xi++) {
r.a[ri++] = c2(f, inci(cw), xget(x,xi));
}
dec(cw);
}
dec(w); dec(x);
return r.b;
} else return err("⌜: one argument was an atom");
}
B scan_c1(B t, B f, B x) {
if (!isArr(x)) return err("`: argument cannot be a scalar");
ur xr = a(x)->rank;
if (xr==0) return err("`: argument cannot be a scalar");
HArr_p r = m_harrc(x);
usz ia = r.c->ia;
if (ia==0) return r.b;
BS2B xget = TI(x).get;
if (xr==1) {
r.a[0] = xget(x,0);
for (usz i = 1; i < ia; i++) r.a[i] = c2(f, inci(r.a[i-1]), xget(x,i));
} else {
usz csz = arr_csz(x);
for (usz i = 0; i < csz; i++) r.a[i] = xget(x,i);
for (usz i = csz; i < ia; i++) r.a[i] = c2(f, inci(r.a[i-csz]), xget(x,i));
}
dec(x);
return r.b;
}
B scan_c2(B t, B f, B w, B x) {
if (!isArr(x)) return err("`: 𝕩 cannot be a scalar");
ur xr = a(x)->rank; usz* xsh = a(x)->sh; BS2B xget = TI(x).get;
if (isArr(w)) {
ur wr = a(w)->rank; usz* wsh = a(w)->sh; BS2B wget = TI(w).get;
if (xr==0) return err("`: 𝕩 cannot be a scalar");
if (wr+1 != xr) return err("`: shape of 𝕨 must match the cell of 𝕩");
if (memcmp(wsh, xsh+1, wr)) return err("`: shape of 𝕨 must match the cell of 𝕩");
HArr_p r = m_harrc(x);
usz ia = r.c->ia;
if (ia==0) return r.b;
usz csz = arr_csz(x);
for (usz i = 0; i < csz; i++) r.a[i] = c2(f, wget(w,i), xget(x,i));
for (usz i = csz; i < ia; i++) r.a[i] = c2(f, inci(r.a[i-csz]), xget(x,i));
dec(w);
dec(x);
return r.b;
} else {
if (xr!=1) return err("`: if 𝕨 is scalar, 𝕩 must be a vector");
HArr_p r = m_harrc(x);
usz ia = r.c->ia;
if (ia==0) return r.b;
B pr = r.a[0] = c2(f, w, xget(x,0));
for (usz i = 1; i < ia; i++) r.a[i] = pr = c2(f, inci(pr), xget(x,i));
dec(x);
return r.b;
}
}
#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1_def, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = NAME##_c2; c(Md1,bi_##NAME)->c1 = NAME##_c1 ; c(Md1,bi_##NAME)->id=pm1_##NAME;
#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1_def, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = NAME##_c2; c(Md1,bi_##NAME)->c1 = c1_invalid; c(Md1,bi_##NAME)->id=pm1_##NAME;
#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1_def, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = c2_invalid;c(Md1,bi_##NAME)->c1 = NAME##_c1 ; c(Md1,bi_##NAME)->id=pm1_##NAME;
void print_md1_def(B x) { printf("%s", format_pm1(c(Md1,x)->id)); }
B bi_tbl, bi_scan;
void md1_init() { ba(tbl) ba(scan)
ti[t_md1_def].print = print_md1_def;
}
#undef ba
#undef bd
#undef bm

20
src/md2.c Normal file
View File

@ -0,0 +1,20 @@
#include "h.h"
B val_c1(B t, B f, B g, B x) { return c1(f, x); }
B val_c2(B t, B f, B g, B w, B x) { return c2(g,w,x); }
B fillBy_c1(B t, B f, B g, B x) { return c1(f, x); }
B fillBy_c2(B t, B f, B g, B w, B x) { return c2(f,w,x); }
#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Md2), t_md2_def, ftag(MD2_TAG)); c(Md2,bi_##NAME)->c2 = NAME##_c2; c(Md2,bi_##NAME)->c1 = NAME##_c1;
#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Md2), t_md2_def, ftag(MD2_TAG)); c(Md2,bi_##NAME)->c2 = NAME##_c2; c(Md2,bi_##NAME)->c1 = c1_invalid;
#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Md2), t_md2_def, ftag(MD2_TAG)); c(Md2,bi_##NAME)->c2 = c2_invalid;c(Md2,bi_##NAME)->c1 = NAME##_c1;
B bi_val, bi_fillBy;
void md2_init() { ba(val) ba(fillBy) }
#undef ba
#undef bd
#undef bm

50
src/mm.c Normal file
View File

@ -0,0 +1,50 @@
#include "h.h"
#include<stdlib.h>
#ifdef ALLOC_STAT
u64* ctr_a = 0;
u64* ctr_f = 0;
u64 actrc = 21000;
u32** actrs;
#endif
void* aalloc(usz sz) { // actual allocate
void* p = malloc(sz);
return p;
}
void* mm_allocN(usz sz, u8 type) {
Value* x = aalloc(sz);
#ifdef ALLOC_STAT
if (!actrs) {
actrs = malloc(sizeof(u32*)*actrc);
ctr_a = calloc(Type_MAX, sizeof(u64));
ctr_f = calloc(Type_MAX, sizeof(u64));
for (i32 i = 0; i < actrc; i++) actrs[i] = calloc(Type_MAX, sizeof(u32));
}
assert(type<Type_MAX);
actrs[(sz+3)/4>=actrc? actrc-1 : (sz+3)/4][type]++;
ctr_a[type]++;
#endif
#ifdef DEBUG
memset(x, 'a', sz);
#endif
x->refc = 1;
x->flags = 0;
x->type = type;
return x;
}
B mm_alloc(usz sz, u8 type, u64 tag) {
assert(tag>1LL<<16); // make sure it's `ftag`ged :|
return b((u64)mm_allocN(sz,type) | tag);
}
void mm_free(Value* x) {
#ifdef ALLOC_STAT
ctr_f[x->type]++;
x->refc = 0x61616161;
#endif
free(x);
}
void mm_visit(B x) {
}

116
src/sfns.c Normal file
View File

@ -0,0 +1,116 @@
#include "h.h"
B shape_c1(B t, B x) {
if (isArr(x)) {
usz ia = a(x)->ia;
if (reusable(x)) {
decSh(x);
arr_shVec(x, ia);
return x;
}
HArr_p r = m_harrv(ia);
BS2B xget = TI(x).get;
for (i32 i = 0; i < ia; i++) r.a[i] = xget(x,i);
dec(x);
return r.b;
} else return err("reshaping non-array");
}
B shape_c2(B t, B w, B x) {
if (isArr(x)) {
if (!isArr(w)) return shape_c1(t, x);
BS2B wget = TI(w).get;
ur nr = a(w)->ia;
usz nia = a(x)->ia;
B r;
bool reuse = reusable(x);
if (reuse) {
r = x;
decSh(x);
} else {
HArr_p rg = m_harrp(nia);
BS2B xget = TI(x).get;
for (usz i = 0; i < nia; i++) rg.a[i] = xget(x,i);
r = rg.b;
}
usz* sh = arr_shAlloc(r, nia, nr);
if (sh) for (i32 i = 0; i < nr; i++) sh[i] = o2i(wget(w,i));
if (!reuse) dec(x);
dec(w);
return r;
} else return err("reshaping non-array");
}
B pick_c1(B t, B x) {
if (!isArr(x)) return x;
// if (a(x)->ia==0) return err("⊑: called on empty array"); // no bounds check for now
B r = TI(x).get(x, 0);
dec(x);
return r;
}
B pick_c2(B t, B w, B x) {
usz wu = o2s(w);
if (isArr(x)) {
// if (wu >= a(x)->ia) err("⊑: 𝕨 is greater than length of 𝕩"); // no bounds check for now
B r = TI(x).get(x, wu);
dec(x);
return r;
}
dec(x); return err("n⊑atom");
}
B ud_c1(B t, B x) {
usz xu = o2s(x);
if (xu<I32_MAX) {
B r = m_i32arrv(xu);
i32* pr = i32arr_ptr(r);
for (usz i = 0; i < xu; i++) pr[i] = i;
return r;
}
HArr_p r = m_harrv(xu);
for (usz i = 0; i < xu; i++) r.a[i] = m_f64(i);
return r.b;
}
B pair_c1(B t, B x) { return m_v1( x); }
B pair_c2(B t, B w, B x) { return m_v2(w, x); }
B fne_c1(B t, B x) {
if (isArr(x)) {
ur xr = a(x)->rank;
usz* sh = a(x)->sh;
for (i32 i = 0; i < xr; i++) if (sh[i]>I32_MAX) {
HArr_p r = m_harrv(xr);
for (i32 j = 0; j < xr; j++) r.a[j] = m_f64(sh[j]);
dec(x);
return r.b;
}
B r = m_i32arrv(xr); i32* rp = i32arr_ptr(r);
for (i32 i = 0; i < xr; i++) rp[i] = sh[i];
dec(x);
return r;
} else {
dec(x);
return m_i32arrv(0);
}
}
B lt_c1(B t, B x) { return x; }
B lt_c2(B t, B w, B x) { dec(x); return w; }
B rt_c1(B t, B x) { return x; }
B rt_c2(B t, B w, B x) { dec(w); return x; }
#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME;
#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = c1_invalid; c(Fun,bi_##NAME)->id=pf_##NAME;
#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = c2_invalid;c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME;
void print_fun_def(B x) { printf("%s", format_pf(c(Fun,x)->id)); }
B bi_shape, bi_pick, bi_ud, bi_pair, bi_fne, bi_lt, bi_rt;
void sfns_init() { ba(shape) ba(pick) bm(ud) ba(pair) bm(fne) ba(lt) ba(rt)
ti[t_fun_def].print = print_fun_def;
}
#undef ba
#undef bd
#undef bm

120
src/sysfn.c Normal file
View File

@ -0,0 +1,120 @@
#include "h.h"
B type_c1(B t, B x) {
i32 r = -1;
if (isArr(x)) r = 0;
else if (isI32(x)) r = 1;
else if (isF64(x)) r = 1;
else if (isC32(x)) r = 2;
else if (isFun(x)) r = 3;
else if (isMd1(x)) r = 4;
else if (isMd2(x)) r = 5;
dec(x);
if (r==-1) return err("getting type");
return m_i32(r);
}
B decp_c1(B t, B x) {
if (!isVal(x)) return m_v2(m_i32(-1), x);
if (v(x)->flags) return m_v2(m_i32(0), x);
return TI(x).decompose(x);
}
usz runtimeLen;
B primInd_c1(B t, B x) {
if (!isVal(x)) return m_i32(runtimeLen);
if (v(x)->flags) return m_i32(v(x)->flags-1);
return m_i32(runtimeLen);
}
B glyph_c1(B t, B x) {
return x;
}
B fill_c1(B t, B x) { dec(x); return m_f64(0); }
B fill_c2(B t, B w, B x) { dec(w); return x; }
B grLen_c1(B t, B x) {
i64 ria = -1;
usz ia = a(x)->ia;
BS2B xget = TI(x).get;
for (usz i = 0; i < ia; i++) {
i64 c = o2i64(xget(x, i));
if (c>ria) ria = c;
}
ria++;
HArr_p r = m_harrv(ria);
for (usz i = 0; i < ria; i++) r.a[i] = m_f64(0);
for (usz i = 0; i < ia; i++) {
i64 n = o2i64(xget(x, i));
if (n>=0) r.a[n].f++;
}
dec(x);
return r.b;
}
B grLen_c2(B t, B w, B x) {
i64 ria = o2s(w)-1;
usz ia = a(x)->ia;
BS2B xget = TI(x).get;
for (usz i = 0; i < ia; i++) {
i64 c = o2i64(xget(x, i));
if (c>ria) ria = c;
}
ria++;
HArr_p r = m_harrv(ria);
for (usz i = 0; i < ria; i++) r.a[i] = m_f64(0);
for (usz i = 0; i < ia; i++) {
i64 n = o2i64(xget(x, i));
if (n>=0) r.a[n].f++;
}
dec(x);
return r.b;
}
B grOrd_c2(B t, B w, B x) {
usz wia = a(w)->ia;
usz xia = a(x)->ia;
if (wia==0) return c1(bi_ud, m_i32(0));
if (xia==0) return x;
BS2B wget = TI(w).get;
BS2B xget = TI(x).get;
usz tmp[wia];
tmp[0] = 0;
for (int i = 1; i < wia; i++) tmp[i] = tmp[i-1]+o2s(wget(w,i-1));
usz ria = tmp[wia-1]+o2s(wget(w,wia-1));
HArr_p r = m_harrv(ria);
for (usz i = 0; i < xia; i++) {
i64 c = o2i64(xget(x,i));
if (c>=0) r.a[tmp[c]++] = m_usz(i);
}
dec(w);
dec(x);
return r.b;
}
B asrt_c1(B t, B x) {
if (isI32(x) && 1==(i32)x.u) return x;
if (isF64(x) && 1==x.f) return x;
dec(x);
return err("assertion error");
}
B asrt_c2(B t, B w, B x) {
if (isI32(x) && 1==(i32)x.u) return x;
if (isF64(x) && 1==x.f) return x;
dec(x);
printf("Assertion error: "); fflush(stdout); print(w); printf("\n");
dec(w);
return err("assertion error with message");
}
#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME;
#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = c1_invalid; c(Fun,bi_##NAME)->id=pf_##NAME;
#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = c2_invalid;c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME;
B bi_type, bi_decp, bi_primInd, bi_glyph, bi_fill, bi_grLen, bi_grOrd, bi_asrt;
void sysfn_init() { bm(type) bm(decp) bm(primInd) bm(glyph) ba(fill) ba(grLen) bd(grOrd) ba(asrt) }
#undef ba
#undef bd
#undef bm

27
src/utf.c Normal file
View File

@ -0,0 +1,27 @@
i32 utf8_len(u8 ch) {
if (ch<128) return 1;
if ((ch>>5)== 0b110) return 2;
if ((ch>>4)== 0b1110) return 3;
if ((ch>>3)==0b11110) return 4;
return -1;
}
u32 utf8_p(u8* p) {
i32 len = utf8_len(*p);
switch (len) { default: UD;
case -1: return (u32)-1;
case 1: return *p;
case 2: return (0b11111&*p)<< 6 | (0b111111&p[1]);
case 3: return (0b1111 &*p)<<12 | (0b111111&p[2]) | (0b111111&p[1])<<6;
case 4: return (0b111 &*p)<<18 | (0b111111&p[3]) | (0b111111&p[2])<<6 | (0b111111&p[1])<<12;
}
}
B fromUTF8(char* s, u64 len) {
u64 sz = 0;
u64 j;
for (j = 0; j < len; j+= utf8_len(s[j])) sz++;
if (j!=len) return err("invalid UTF-8");
HArr_p r = m_harrv(sz);
u64 p = 0;
for (u64 i = 0; i < len; i+= utf8_len(s[i])) r.a[p++] = m_c32(utf8_p((u8*)s+i)); // may read after end, eh
return r.b;
}

467
src/vm.c Normal file
View File

@ -0,0 +1,467 @@
#include "h.h"
enum {
PUSH = 0, // N; push object from objs[N]
VARO = 1, // N; push variable with name strs[N]
VARM = 2, // N; push mutable variable with name strs[N]
ARRO = 3, // N; create a vector of top N items
ARRM = 4, // N; create a mutable vector of top N items
FN1C = 5, // monadic function call ⟨…,x,f ⟩ → F x
FN2C = 6, // dyadic function call ⟨…,x,f,w⟩ → w F x
OP1D = 7, // derive 1-modifier to function; ⟨…, _m,f⟩ → (f _m)
OP2D = 8, // derive 2-modifier to function; ⟨…,g,_m,f⟩ → (f _m_ g)
TR2D = 9, // derive 2-train aka atop; ⟨…, g,f⟩ → (f g)
TR3D = 10, // derive 3-train aka fork; ⟨…,h,g,f⟩ → (f g h)
SETN = 11, // set new; _ ←_; ⟨…,x, mut⟩ → mut←x
SETU = 12, // set upd; _ ↩_; ⟨…,x, mut⟩ → mut↩x
SETM = 13, // set mod; _ F↩_; ⟨…,x,F,mut⟩ → mut F↩x
POPS = 14, // pop object from stack
DFND = 15, // N; push dfns[N], derived to current scope
FN1O = 16, // optional monadic call (FN1C but checks for · at 𝕩)
FN2O = 17, // optional dyadic call (FN2C but checks for · at 𝕩 & 𝕨)
CHKV = 18, // throw error if top of stack is ·
TR3O = 19, // TR3D but creates an atop if F is ·
OP2H = 20, // derive 2-modifier to 1-modifier ⟨…,g,_m_⟩ → (_m_ g)
LOCO = 21, // N0,N1; push variable at depth N0 and position N1
LOCM = 22, // N0,N1; push mutable variable at depth N0 and position N1
VFYM = 23, // push a mutable version of ToS that fails if set to a non-equal value (for header assignment)
SETH = 24, // set header; acts like SETN, but it doesn't push to stack, and, instead of erroring in cases it would, it skips to the next body
RETN = 25, // returns top of stack
FLDO = 26, // N; get field objs[N] of ToS
FLDM = 27, // N; set field objs[N] from ToS
NSPM = 28, // N0,N1; create a destructible namespace from top N0 items, with the keys objs[N1]
RETD = 29, // return a namespace of exported items
SYSV = 30, // N; get system function N
};
i32* nextBC(i32* p) {
switch(*p) {
case PUSH: case DFND: case ARRO: case ARRM:
case VARO: case VARM: case FLDO: case FLDM:
case SYSV:
return p+2;
case FN1C: case FN2C: case FN1O: case FN2O:
case OP1D: case OP2D: case OP2H:
case TR2D: case TR3D: case TR3O:
case SETN: case SETU: case SETM: case SETH:
case POPS: case CHKV: case VFYM: case RETN: case RETD:
return p+1;
case LOCO: case LOCM: case NSPM:
return p+3;
default: return 0;
}
}
i32 stackDiff(i32* p) {
switch(*p) {
case PUSH: case VARO: case VARM: case DFND: case LOCO: case LOCM: case SYSV:
return 1;
case CHKV: case VFYM: case FLDO: case FLDM: case RETD:
return 0;
case FN1C: case OP1D: case TR2D: case SETN: case SETU: case POPS: case FN1O: case OP2H: case SETH: case RETN:
return -1;
case FN2C: case OP2D: case TR3D: case SETM: case FN2O: case TR3O:
return -2;
case ARRO: case ARRM: case NSPM:
return 1-p[1];
default: return 9999999;
}
}
char* nameBC(i32* p) {
switch(*p) { default: return "(unknown)";
case PUSH:return "PUSH";case VARO:return "VARO";case VARM:return "VARM";case ARRO:return "ARRO";
case ARRM:return "ARRM";case FN1C:return "FN1C";case FN2C:return "FN2C";case OP1D:return "OP1D";
case OP2D:return "OP2D";case TR2D:return "TR2D";case TR3D:return "TR3D";case SETN:return "SETN";
case SETU:return "SETU";case SETM:return "SETM";case POPS:return "POPS";case DFND:return "DFND";
case FN1O:return "FN1O";case FN2O:return "FN2O";case CHKV:return "CHKV";case TR3O:return "TR3O";
case OP2H:return "OP2H";case LOCO:return "LOCO";case LOCM:return "LOCM";case VFYM:return "VFYM";
case SETH:return "SETH";case RETN:return "RETN";case FLDO:return "FLDO";case FLDM:return "FLDM";
case NSPM:return "NSPM";case RETD:return "RETD";case SYSV:return "SYSV";
}
}
void printBC(i32* p) {
printf("%s", nameBC(p));
i32* n = nextBC(p);
p++;
i32 am = n-p;
i32 len = 0;
for (i32 i = 0; i < am; i++) printf(" %d", p[i]);
while(p!=n) {
i32 c = *p++;
i32 pow = 10;
i32 log = 1;
while (pow<=c) { pow*=10; log++; }
len+= log+1;
}
len = 6-len;
while(len-->0) printf(" ");
}
typedef struct Block Block;
typedef struct Body Body;
typedef struct Scope Scope;
typedef struct Comp {
struct Value;
B bc;
HArr* objs;
Block* blocks[];
} Comp;
typedef struct Block {
struct Value;
bool imm;
u8 ty;
Body* body;
} Block;
typedef struct Body {
struct Value;
Comp* comp;
// B* objs;
i32* bc; // pointer in comp->bc
u32 maxStack;
u16 varAm;
// HArr* vNames;
} Body;
typedef struct Scope {
struct Value;
u64 bcInd; // DEBUG: place of this in bytecode array
u16 varAm;
Scope* psc;
B vars[];
} Scope;
typedef struct FunBlock { struct Fun; Scope* sc; Block* bl; } FunBlock;
typedef struct Md1Block { struct Md1; Scope* sc; Block* bl; } Md1Block;
typedef struct Md2Block { struct Md2; Scope* sc; Block* bl; } Md2Block;
Block* compile(B bcq, B objs, B blocks) {
usz bam = a(blocks)->ia;
I32Arr* bca = toI32Arr(bcq);
i32* bc = bca->a;
usz bcl = bca->ia;
Comp* comp = mm_allocN(fsizeof(Comp,blocks,Block*,bam), t_comp);
comp->bc = tag(bca, ARR_TAG);
comp->objs = toHArr(objs);
B* blockDefs = toHArr(blocks)->a;
for (usz i = 0; i < bam; i++) {
B cbld = blockDefs[i];
if (a(cbld)->ia != 4) return c(Block,err("bad compile block")); // todo not cast errors here weirdly
BS2B bget = TI(cbld).get;
usz ty = o2s(bget(cbld,0)); if (ty<0|ty>2) return c(Block,err("bad block type"));
bool imm = o2s(bget(cbld,1)); // todo o2b or something
usz idx = o2s(bget(cbld,2)); if (idx>=bcl) return c(Block,err("oob bytecode index"));
usz vam = o2s(bget(cbld,3));
i32* cbc = bc+idx;
i32* scan = cbc;
i32 ssz = 0, mssz=0;
bool needsV0 = false;
while (*scan!=RETN & *scan!=RETD) {
ssz+= stackDiff(scan);
if (ssz>mssz) mssz = ssz;
if (*scan==LOCO|*scan==LOCM) { i32 d=scan[1]; i32 p=scan[2];
if (d>U16_MAX) return c(Block,err("LOC_ too deep"));
if (d==0 & p==0) needsV0 = true;
}
scan = nextBC(scan);
if (scan-bc >= bcl) return c(Block,err("no RETN/RETD found at end of bytecode"));
}
Body* body = mm_allocN(sizeof(Body), t_body);
body->comp = comp;
body->bc = cbc;
body->maxStack = mssz;
body->varAm = vam;
if (needsV0) body->flags|= 1;
Block* bl = mm_allocN(sizeof(Block), t_block);
bl->body = body;
bl->imm = imm;
bl->ty = ty;
comp->blocks[i] = bl;
}
Block* ret = c(Block,inci(tag(comp->blocks[0], OBJ_TAG)));
// TODO store blocks in each body, then decrement each of comp->blocks; also then move temp block list out of Comp as it's useless then
// for (usz i = 0; i < bam; i++) ptr_dec(comp->blocks[i]);
dec(blocks);
return ret;
}
Scope* scd(Scope* sc, u16 d) {
for (i32 i = 0; i < d; i++) sc = sc->psc;
return sc;
}
B v_set(Scope* sc, B s, B x, bool upd) { // frees s, consumes x, returns previous value
if (isVar(s)) {
sc = scd(sc, (u16)(s.u>>32));
B prev = sc->vars[(u32)s.u];
if (upd) {
if (prev.u==bi_noVar.u) return err("updating undefined variable");
dec(prev);
} else {
if (prev.u!=bi_noVar.u) return err("redefining variable");
}
sc->vars[(u32)s.u] = x;
} else {
assert(isArr(s) && v(s)->type==t_harr);
if (!shEq(s, x)) return err("spread assignment: mismatched shape");
usz ia = a(x)->ia;
B* sp = harr_ptr(s);
BS2B xget = TI(x).get;
for (u64 i = 0; i < ia; i++) v_set(sc, sp[i], xget(x,i), upd);
dec(s); dec(x);
}
return m_f64(0);
}
B v_get(Scope* sc, B s) { // get value representing s, replacing with bi_optOut; doesn't consume
if (isVar(s)) {
sc = scd(sc, (u16)(s.u>>32));
B r = sc->vars[(u32)s.u];
sc->vars[(u32)s.u] = bi_optOut;
return r;
} else {
assert(isArr(s) && v(s)->type==t_harr);
usz ia = a(s)->ia;
B* sp = harr_ptr(s);
HArr_p r = m_harrv(ia);
for (u64 i = 0; i < ia; i++) r.a[i] = v_get(sc, sp[i]);
return r.b;
}
}
// none consume anything consume
B m_funBlock(Block* bl, Scope* psc); // may return evaluated result, whatever
B m_md1Block(Block* bl, Scope* psc);
B m_md2Block(Block* bl, Scope* psc);
#ifdef DEBUG_VM
i32 bcDepth=-2;
i32* vmStack;
i32 bcCtr = 0;
#endif
B evalBC(Body* b, Scope* sc) {
#ifdef DEBUG_VM
bcDepth+= 2;
if (!vmStack) vmStack = malloc(400);
i32 stackNum = bcDepth>>1;
vmStack[stackNum] = -1;
printf("new eval\n");
#endif
B* objs = b->comp->objs->a;
Block** blocks = b->comp->blocks;
i32* bc = b->bc;
B stack[b->maxStack];
i32 sh = 0;
#define POP stack[--sh]
#define P(N) B N=POP;
#define ADD stack[sh++] =
while(true) {
#ifdef DEBUG_VM
i32* sbc = bc;
i32 bcPos = sbc-c(I32Arr,b->comp->bc)->a;
vmStack[stackNum] = bcPos;
for(i32 i = 0; i < bcDepth; i++) printf(" ");
printBC(sbc); printf("@%d << ", bcPos);
for (i32 i = 0; i < sh; i++) { if(i)printf(""); print(stack[i]); } puts(""); fflush(stdout);
bcCtr++;
for (i32 i = 0; i < sc->varAm; i++) validate(sc->vars[i]);
#endif
switch(*bc++) {
case POPS: dec(POP); break;
case PUSH: {
ADD inci(objs[*bc++]);
break;
}
case FN1C: { P(f)P(x)
ADD c1(f, x); dec(f);
break;
}
case FN1O: { P(f)P(x)
ADD isNothing(x)? x : c1(f, x); dec(f);
break;
}
case FN2C: { P(w)P(f)P(x)
ADD c2(f, w, x); dec(f);
break;
}
case FN2O: { P(w)P(f)P(x)
if (isNothing(x)) { dec(w); ADD x; }
else ADD isNothing(w)? c1(f, x) : c2(f, w, x);
dec(f);
break;
}
case ARRO: case ARRM: {
i32 sz = *bc++;
HArr_p r = m_harrv(sz);
for (i32 i = 0; i < sz; i++) r.a[sz-i-1] = POP;
ADD r.b;
break;
}
case DFND: {
Block* bl = blocks[*bc++];
switch(bl->ty) { default: UD;
case 0: ADD m_funBlock(bl, sc); break;
case 1: ADD m_md1Block(bl, sc); break;
case 2: ADD m_md2Block(bl, sc); break;
}
break;
}
case OP1D: { P(f)P(m) ADD m1_d (m,f ); break; }
case OP2D: { P(f)P(m)P(g) ADD m2_d (m,f,g); break; }
case OP2H: { P(m)P(g) ADD m2_h (m, g); break; }
case TR2D: { P(g)P(h) ADD m_atop( g,h); break; }
case TR3D: { P(f)P(g)P(h) ADD m_fork(f,g,h); break; }
case TR3O: { P(f)P(g)P(h)
if (isNothing(f)) { ADD m_atop(g,h); dec(f); }
else ADD m_fork(f,g,h);
break;
}
case LOCM: { i32 d = *bc++; i32 p = *bc++;
ADD tag((u64)d<<32 | p, VAR_TAG);
break;
}
case LOCO: { i32 d = *bc++; i32 p = *bc++;
ADD inci(scd(sc,d)->vars[p]);
break;
}
case SETN: { P(s) P(x) v_set(sc, s, inci(x), false); ADD x; break; }
case SETU: { P(s) P(x) v_set(sc, s, inci(x), true ); ADD x; break; }
case SETM: { P(s)P(f)P(x)
B w = v_get(sc, s);
B r = c2(f,w,x); dec(f);
v_set(sc, s, inci(r), true);
ADD r;
break;
}
// not implemented: VARO VARM CHKV VFYM SETH FLDO FLDM NSPM RETD SYSV
default: printf("todo %d\n", bc[-1]); bc++; break;
case RETN: goto end;
}
#ifdef DEBUG_VM
for(i32 i = 0; i < bcDepth; i++) printf(" ");
printBC(sbc); printf("@%ld: ", sbc-c(I32Arr,b->comp->bc)->a);
for (i32 i = 0; i < sh; i++) { if(i)printf(""); print(stack[i]); } puts(""); fflush(stdout);
#endif
}
#undef P
#undef ADD
#undef POP
end:;
#ifdef DEBUG_VM
bcDepth-= 2;
#endif
assert(sh==1);
return stack[0];
}
B actualExec(Block* bl, Scope* psc, u32 ga, ...) {
Body* bdy = bl->body;
Scope* sc = mm_allocN(fsizeof(Scope, vars, B, bdy->varAm), t_scope);
sc->psc = psc; if(psc)ptr_inc(psc);
u16 varAm = sc->varAm = bdy->varAm;
assert(varAm>=ga);
sc->bcInd = bdy->bc-c(I32Arr,bdy->comp->bc)->a;
i32 i = 0;
va_list vargs;
va_start(vargs, ga);
while (i<ga) sc->vars[i++] = va_arg(vargs, B);
while (i<varAm) sc->vars[i++] = bi_noVar;
va_end(vargs);
// if (ga & !(bdy->flags&1)) {
// B v0 = sc->vars[0];
// dec(v0); sc->vars[0] = bi_optOut; // prevent reference cycle; TODO more properly do this (or just remove, it doesn't seem to be doing much)
// }
B r = evalBC(bdy, sc);
ptr_dec(sc);
return r;
}
B funBl_c1(B t, B x) { return actualExec(c(FunBlock, t)->bl, c(FunBlock, t)->sc, 3, inci(t), x, bi_nothing); }
B funBl_c2(B t, B w, B x) { return actualExec(c(FunBlock, t)->bl, c(FunBlock, t)->sc, 3, inci(t), x, w); }
B md1Bl_c1(B t, B f, B x) { return actualExec(c(Md1Block, t)->bl, c(Md1Block, t)->sc, 5, m_md1D(inci(t),inci(f) ), x, bi_nothing, inci(t), inci(f)); }
B md1Bl_c2(B t, B f, B w, B x) { return actualExec(c(Md1Block, t)->bl, c(Md1Block, t)->sc, 5, m_md1D(inci(t),inci(f) ), x, w , inci(t), inci(f)); }
B md2Bl_c1(B t, B f, B g, B x) { return actualExec(c(Md2Block, t)->bl, c(Md2Block, t)->sc, 6, m_md2D(inci(t),inci(f),inci(g)), x, bi_nothing, inci(t), inci(f), inci(g)); }
B md2Bl_c2(B t, B f, B g, B w, B x) { return actualExec(c(Md2Block, t)->bl, c(Md2Block, t)->sc, 6, m_md2D(inci(t),inci(f),inci(g)), x, w , inci(t), inci(f), inci(g)); }
B m_funBlock(Block* bl, Scope* psc) {
if (bl->imm) return actualExec(bl, psc, 0);
B r = mm_alloc(sizeof(FunBlock), t_fun_block, ftag(FUN_TAG));
c(FunBlock, r)->bl = bl; ptr_inc(bl);
c(FunBlock, r)->sc = psc; ptr_inc(psc);
c(FunBlock, r)->c1 = funBl_c1;
c(FunBlock, r)->c2 = funBl_c2;
return r;
}
B m_md1Block(Block* bl, Scope* psc) {
B r = mm_alloc(sizeof(Md1Block), t_md1_block, ftag(MD1_TAG));
c(Md1Block, r)->bl = bl; ptr_inc(bl);
c(Md1Block, r)->sc = psc; ptr_inc(psc);
c(Md1Block, r)->c1 = md1Bl_c1;
c(Md1Block, r)->c2 = md1Bl_c2;
return r;
}
B m_md2Block(Block* bl, Scope* psc) {
B r = mm_alloc(sizeof(Md2Block), t_md2_block, ftag(MD2_TAG));
c(Md2Block, r)->bl = bl; ptr_inc(bl);
c(Md2Block, r)->sc = psc; ptr_inc(psc);
c(Md2Block, r)->c1 = md2Bl_c1;
c(Md2Block, r)->c2 = md2Bl_c2;
return r;
}
void comp_free(B x) { Comp* c = c(Comp ,x); ptr_dec(c->objs); dec(c->bc); }
void body_free(B x) { Body* c = c(Body ,x); ptr_dec(c->comp); }
void block_free(B x) { Block* c = c(Block,x); ptr_dec(c->body); }
void scope_free(B x) {
Scope* c = c(Scope,x);
if (c->psc) ptr_dec(c->psc);
u16 am = c->varAm;
for (u32 i = 0; i < am; i++) dec(c->vars[i]);
}
void funBl_free(B x) { FunBlock* c = c(FunBlock,x); ptr_dec(c->sc); ptr_dec(c->bl); }
void md1Bl_free(B x) { Md1Block* c = c(Md1Block,x); ptr_dec(c->sc); ptr_dec(c->bl); }
void md2Bl_free(B x) { Md2Block* c = c(Md2Block,x); ptr_dec(c->sc); ptr_dec(c->bl); }
void comp_print (B x) { printf("(%p: comp)",v(x)); }
void body_print (B x) { printf("(%p: body varam=%d)",v(x),c(Body,x)->varAm); }
void block_print(B x) { printf("(%p: block for %p)",v(x),c(Block,x)->body); }
void scope_print(B x) { printf("(%p: scope; vars:",v(x));Scope*sc=c(Scope,x);for(u64 i=0;i<sc->varAm;i++){printf(" ");print(sc->vars[i]);}printf(")"); }
// void funBl_print(B x) { printf("(%p: function"" block bl=%p sc=%p)",v(x),c(FunBlock,x)->bl,c(FunBlock,x)->sc); }
// void md1Bl_print(B x) { printf("(%p: 1-modifier block bl=%p sc=%p)",v(x),c(Md1Block,x)->bl,c(Md1Block,x)->sc); }
// void md2Bl_print(B x) { printf("(%p: 2-modifier block bl=%p sc=%p)",v(x),c(Md2Block,x)->bl,c(Md2Block,x)->sc); }
// void funBl_print(B x) { printf("(%p: function"" block @%ld)",v(x),c(FunBlock,x)->bl->body->bc-c(I32Arr,c(FunBlock,x)->bl->body->comp->bc)->a); }
// void md1Bl_print(B x) { printf("(%p: 1-modifier block @%ld)",v(x),c(Md1Block,x)->bl->body->bc-c(I32Arr,c(Md1Block,x)->bl->body->comp->bc)->a); }
// void md2Bl_print(B x) { printf("(%p: 2-modifier block @%ld)",v(x),c(Md2Block,x)->bl->body->bc-c(I32Arr,c(Md2Block,x)->bl->body->comp->bc)->a); }
void funBl_print(B x) { printf("{function""}"); }
void md1Bl_print(B x) { printf("{1-modifier}"); }
void md2Bl_print(B x) { printf("{2-modifier}"); }
B block_decompose(B x) { return m_v2(m_i32(1), x); }
B bl_m1d(B m, B f ) { Md1Block* c = c(Md1Block,m); return c->bl->imm? actualExec(c(Md1Block, m)->bl, c(Md1Block, m)->sc, 2, m, f ) : m_md1D(m,f ); }
B bl_m2d(B m, B f, B g) { Md2Block* c = c(Md2Block,m); return c->bl->imm? actualExec(c(Md2Block, m)->bl, c(Md2Block, m)->sc, 3, m, f, g) : m_md2D(m,f,g); }
void comp_init() {
ti[t_comp ].free = comp_free; ti[t_comp ].print = comp_print;
ti[t_body ].free = body_free; ti[t_body ].print = body_print;
ti[t_block ].free = block_free; ti[t_block ].print = block_print;
ti[t_scope ].free = scope_free; ti[t_scope ].print = scope_print;
ti[t_fun_block].free = funBl_free; ti[t_fun_block].print = funBl_print; ti[t_fun_block].decompose = block_decompose;
ti[t_md1_block].free = md1Bl_free; ti[t_md1_block].print = md1Bl_print; ti[t_md1_block].decompose = block_decompose; ti[t_md1_block].m1_d=bl_m1d;
ti[t_md2_block].free = md2Bl_free; ti[t_md2_block].print = md2Bl_print; ti[t_md2_block].decompose = block_decompose; ti[t_md2_block].m2_d=bl_m2d;
}
void print_vmStack() {
#ifdef DEBUG_VM
printf("vm stack:");
for (i32 i = 0; i < (bcDepth>>1) + 1; i++) { printf(" %d", vmStack[i]); fflush(stdout); }
printf("\n"); fflush(stdout);
#endif
}

29
test.bqn Executable file
View File

@ -0,0 +1,29 @@
#! /usr/bin/env dbqn
"usage: test.bqn path/to/mlochbaum/BQN ""$PATH"" [optional expressions to evaluate]"!2•args
path0•args
envP1•args
tests •FLines path"/test/cases/prim.bqn"
# tests ← •FLines path∾"/test/cases/identity.bqn"
# tests ← •FLines path∾"/test/cases/under.bqn"
# tests ← •FLines path∾"/test/cases/fill.bqn"
# tests ← •FLines "primLeft.bqn"
{tests𝕩}(×) 2•args
('#' · "#")@{
'%'{𝕤
•Out 𝕩
"src/interp" •FChars 1,path,𝕩 •Import "cc.bqn"
(×)@{𝕤•Out "############ Failed to compile! ############" •Out¨1𝕩}{env<"PATH="envP}•SH"./debugBuild"
codeouterr•SH"./BQN"
•Out out
{𝕤•Out"exit code "(code) •Out err}(×code) err
}{𝕤
# •Out 𝕩
# "src/interp" •FChars ⟨1,path,3↓𝕩⟩ •Import "cc.bqn"
# (×⊑)◶@‿{𝕤⋄•Out "############ Failed to compile! ############" ⋄ •Out¨1↓𝕩}{env⇐<"PATH="∾envP}•SH"./debugBuild"
# code‿out‿err←•SH"./BQN"
# •Out out
# {𝕤⋄•Out"exit code "∾(⍕code) ⋄ •Out err}⍟(×code) err
}
}¨tests