mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2024-06-25 06:33:16 +00:00
Code Issues 1 Releases Wiki Activity

Merge branch 'master' of https://github.com/bakpakin/dst

Browse Source
This commit is contained in:
Calvin Rose 2018-08-05 21:20:45 -04:00
commit 44b8c5a8c8
28 changed files with 880 additions and 468 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -130,6 +130,10 @@ natives: $(DST_TARGET)
$(MAKE) -C natives/hello
$(MAKE) -j 8 -C natives/sqlite3
clean-natives:
$(MAKE) -C natives/hello clean
$(MAKE) -C natives/sqlite3 clean
#################
##### Other #####
#################

3
appveyor.yml
View File

@ -2,6 +2,7 @@ version: 1.0.{build}
branches:
only:
- master
- alpha
clone_folder: c:\projects\dst
image:
- Visual Studio 2017
@ -30,4 +31,4 @@ build:
only_commits:
files:
- appveyor.yml
- src/
- src/

51
extra/metabuild.dst Normal file
View File

@ -0,0 +1,51 @@
# A script to help generate build files on different platforms
(def- make-cflags "-std=c99 -Wall -Wextra -O2 -shared -fpic")
(def- make-ldflags "")
(defn $
"Do and get the value of a subshell command"
[command]
(def f (file.popen command))
(def ret (file.read f :all))
(file.close f)
ret)
(defn- emit-rule
"Emit a rule in a makefile"
@[out target deps recipe]
(default recipe "@echo '-----'")
(file.write
out
target
": "
(if (indexed? deps) (string.join deps " ") deps)
"\n\t"
(if (indexed? recipe) (string.join recipe "\n\t") recipe)
"\n\n")
out)
(defn generate-make
"Generate a makefile"
[out-path sources target]
(def out (file.open out-path :w))
(def csources (filter (fn [x] (= ".c" (string.slice x -2))) sources))
(def hsources (filter (fn [x] (= ".h" (string.slice x -2))) sources))
(file.write
out
"# Autogenerated Makefile, do not edit\n"
"# Generated at " ($ `date`)
"\nCFLAGS:=" make-cflags
"\nLDFLAGS:=" make-ldflags
"\nSOURCES:=" (string.join csources " ")
"\nHEADERS:=" (string.join hsources " ")
"\nOBJECTS:=$(patsubst %.c,%.o,${SOURCES})"
"\nTARGET:=" target ".so"
"\n\n")
(emit-rule out "all" "${TARGET}")
(emit-rule out "%.o" @["%.c" "${HEADERS}"] "${CC} ${CFLAGS} -o $@ $< ${LDFLAGS}")
(emit-rule out "${TARGET}" "${SOURCES}" "${CC} ${CFLAGS} -o $@ $^ ${LDFLAGS}")
(emit-rule out "clean" "" "rm ${OBJECTS}")
# Phony targets
(emit-rule out ".PHONY" @["all" "clean"])
nil)

3
natives/sqlite3/Makefile
View File

@ -54,4 +54,7 @@ clean:
rm sqlite3.h
rm $(TARGET)
install:
cp $(TARGET) $(DST_PATH)
.PHONY: clean all

2
natives/sqlite3/main.c
View File

@ -393,7 +393,7 @@ static const DstReg cfuns[] = {
{NULL, NULL}
};
int _dst_init(DstArgs args) {
DST_MODULE_ENTRY(DstArgs args) {
DstTable *env = dst_env_arg(args);
dst_env_cfuns(env, cfuns);
return 0;

36
src/core/asm.c
View File

@ -24,21 +24,6 @@
#include <dst/dst.h>
#include "util.h"
/* Convert a slot to to an integer for bytecode */
/* Types of instructions (some of them) */
/* _0arg - op.---.--.-- (return-nil, noop, vararg arguments)
* _s - op.src.--.-- (push1)
* _l - op.XX.XX.XX (jump)
* _ss - op.dest.XX.XX (move, swap)
* _sl - op.check.XX.XX (jump-if)
* _st - op.check.TT.TT (typecheck)
* _si - op.dest.XX.XX (load-integer)
* _sss - op.dest.op1.op2 (add, subtract, arithmetic, comparison)
* _ses - op.dest.up.which (load-upvalue, save-upvalue)
* _sc - op.dest.CC.CC (load-constant, closure)
*/
/* Definition for an instruction in the assembler */
typedef struct DstInstructionDef DstInstructionDef;
struct DstInstructionDef {
@ -91,6 +76,7 @@ static const DstInstructionDef dst_ops[] = {
{"eq", DOP_EQUALS},
{"eqi", DOP_EQUALS_INTEGER},
{"eqim", DOP_EQUALS_IMMEDIATE},
{"eqn", DOP_NUMERIC_EQUAL},
{"eqr", DOP_EQUALS_REAL},
{"err", DOP_ERROR},
{"get", DOP_GET},
@ -98,7 +84,9 @@ static const DstInstructionDef dst_ops[] = {
{"gt", DOP_GREATER_THAN},
{"gti", DOP_GREATER_THAN_INTEGER},
{"gtim", DOP_GREATER_THAN_IMMEDIATE},
{"gtn", DOP_NUMERIC_GREATER_THAN},
{"gtr", DOP_GREATER_THAN_REAL},
{"gten", DOP_NUMERIC_GREATER_THAN_EQUAL},
{"gter", DOP_GREATER_THAN_EQUAL_REAL},
{"jmp", DOP_JUMP},
{"jmpif", DOP_JUMP_IF},
@ -114,7 +102,9 @@ static const DstInstructionDef dst_ops[] = {
{"lt", DOP_LESS_THAN},
{"lti", DOP_LESS_THAN_INTEGER},
{"ltim", DOP_LESS_THAN_IMMEDIATE},
{"ltn", DOP_NUMERIC_LESS_THAN},
{"ltr", DOP_LESS_THAN_REAL},
{"lten", DOP_NUMERIC_LESS_THAN_EQUAL},
{"lter", DOP_LESS_THAN_EQUAL_REAL},
{"mkarr", DOP_MAKE_ARRAY},
{"mkbuf", DOP_MAKE_BUFFER},
@ -304,7 +294,7 @@ static int32_t doarg_1(
ret = dst_unwrap_integer(result);
}
} else {
dst_asm_errorv(a, dst_formatc("unknown name %q", x));
dst_asm_errorv(a, dst_formatc("unknown name %v", x));
}
} else if (argtype == DST_OAT_TYPE || argtype == DST_OAT_SIMPLETYPE) {
const TypeAlias *alias = dst_strbinsearch(
@ -315,7 +305,7 @@ static int32_t doarg_1(
if (alias) {
ret = alias->mask;
} else {
dst_asm_errorv(a, dst_formatc("unknown type %q", x));
dst_asm_errorv(a, dst_formatc("unknown type %v", x));
}
} else {
goto error;
@ -324,7 +314,7 @@ static int32_t doarg_1(
/* Add a new env */
ret = dst_asm_addenv(a, x);
if (ret < -1) {
dst_asm_errorv(a, dst_formatc("unknown environment %q", x));
dst_asm_errorv(a, dst_formatc("unknown environment %v", x));
}
}
break;
@ -539,6 +529,9 @@ static DstAssembleResult dst_asm1(DstAssembler *parent, Dst source, int flags) {
/* Check for function name */
a.name = dst_get(s, dst_csymbolv("name"));
if (!dst_checktype(a.name, DST_NIL)) {
def->name = dst_to_string(a.name);
}
/* Set function arity */
x = dst_get(s, dst_csymbolv("arity"));
@ -683,7 +676,7 @@ static DstAssembleResult dst_asm1(DstAssembler *parent, Dst source, int flags) {
sizeof(DstInstructionDef),
dst_unwrap_symbol(t[0]));
if (NULL == idef)
dst_asm_errorv(&a, dst_formatc("unknown instruction %v", instr));
dst_asm_errorv(&a, dst_formatc("unknown instruction %v", t[0]));
op = read_instruction(&a, idef, t);
}
def->bytecode[a.bytecode_count++] = op;
@ -842,6 +835,9 @@ Dst dst_disasm(DstFuncDef *def) {
if (def->flags & DST_FUNCDEF_FLAG_VARARG) {
dst_table_put(ret, dst_csymbolv("vararg"), dst_wrap_true());
}
if (NULL != def->name) {
dst_table_put(ret, dst_csymbolv("name"), dst_wrap_string(def->name));
}
/* Add constants */
if (def->constants_length > 0) {
@ -919,7 +915,7 @@ static int cfun_asm(DstArgs args) {
}
}
int cfun_disasm(DstArgs args) {
static int cfun_disasm(DstArgs args) {
DstFunction *f;
DST_FIXARITY(args, 1);
DST_ARG_FUNCTION(f, args, 0);

7
src/core/bytecode.c
View File

@ -102,7 +102,12 @@ enum DstInstructionType dst_instructions[DOP_INSTRUCTION_COUNT] = {
DIT_S, /* DOP_MAKE_TUPLE */
DIT_S, /* DOP_MAKE_STRUCT */
DIT_S, /* DOP_MAKE_TABLE */
DIT_S /* DOP_MAKE_STRING */
DIT_S, /* DOP_MAKE_STRING */
DIT_SSS, /* DOP_NUMERIC_LESS_THAN */
DIT_SSS, /* DOP_NUMERIC_LESS_THAN_EQUAL */
DIT_SSS, /* DOP_NUMERIC_GREATER_THAN */
DIT_SSS, /* DOP_NUMERIC_GREATER_THAN_EQUAL */
DIT_SSS /* DOP_NUMERIC_EQUAL */
};
/* Verify some bytecode */

112
src/core/cfuns.c
View File

@ -36,6 +36,9 @@ static int fixarity1(DstFopts opts, DstSlot *args) {
static int fixarity2(DstFopts opts, DstSlot *args) {
(void) opts;
return dst_v_count(args) == 2;
}static int fixarity3(DstFopts opts, DstSlot *args) {
(void) opts;
return dst_v_count(args) == 3;
}
/* Generic hanldling for $A = op $B */
@ -91,7 +94,8 @@ static DstSlot do_get(DstFopts opts, DstSlot *args) {
return opreduce(opts, args, DOP_GET, dst_wrap_nil());
}
static DstSlot do_put(DstFopts opts, DstSlot *args) {
return opreduce(opts, args, DOP_PUT, dst_wrap_nil());
dstc_emit_sss(opts.compiler, DOP_PUT, args[0], args[1], args[2], 0);
return args[0];
}
static DstSlot do_length(DstFopts opts, DstSlot *args) {
return genericSS(opts, DOP_LENGTH, args[0]);
@ -118,7 +122,7 @@ static DstSlot do_apply1(DstFopts opts, DstSlot *args) {
return target;
}
/* Varidadic operatros specialization */
/* Varidadic operators specialization */
static DstSlot do_add(DstFopts opts, DstSlot *args) {
return opreduce(opts, args, DOP_ADD, dst_wrap_integer(0));
@ -150,6 +154,85 @@ static DstSlot do_rshift(DstFopts opts, DstSlot *args) {
static DstSlot do_rshiftu(DstFopts opts, DstSlot *args) {
return opreduce(opts, args, DOP_SHIFT_RIGHT, dst_wrap_integer(1));
}
static DstSlot do_bnot(DstFopts opts, DstSlot *args) {
return genericSS(opts, DOP_BNOT, args[0]);
}
/* Specialization for comparators */
static DstSlot compreduce(
DstFopts opts,
DstSlot *args,
int op,
int invert) {
DstCompiler *c = opts.compiler;
int32_t i, len;
len = dst_v_count(args);
int32_t *labels = NULL;
DstSlot t;
if (len < 2) {
return invert
? dstc_cslot(dst_wrap_false())
: dstc_cslot(dst_wrap_true());
}
t = dstc_gettarget(opts);
for (i = 1; i < len; i++) {
dstc_emit_sss(c, op, t, args[i - 1], args[i], 1);
if (i != (len - 1)) {
int32_t label = dstc_emit_si(c, DOP_JUMP_IF_NOT, t, 0, 1);
dst_v_push(labels, label);
}
}
int32_t end = dst_v_count(c->buffer);
if (invert) {
dstc_emit_si(c, DOP_JUMP_IF, t, 3, 0);
dstc_emit_s(c, DOP_LOAD_TRUE, t, 1);
dstc_emit(c, DOP_JUMP | (2 << 8));
dstc_emit_s(c, DOP_LOAD_FALSE, t, 1);
}
for (i = 0; i < dst_v_count(labels); i++) {
int32_t label = labels[i];
c->buffer[label] |= ((end - label) << 16);
}
dst_v_free(labels);
return t;
}
static DstSlot do_order_gt(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_GREATER_THAN, 0);
}
static DstSlot do_order_lt(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_LESS_THAN, 0);
}
static DstSlot do_order_gte(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_LESS_THAN, 1);
}
static DstSlot do_order_lte(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_GREATER_THAN, 1);
}
static DstSlot do_order_eq(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_EQUALS, 0);
}
static DstSlot do_order_neq(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_EQUALS, 1);
}
static DstSlot do_gt(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_NUMERIC_GREATER_THAN, 0);
}
static DstSlot do_lt(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_NUMERIC_LESS_THAN, 0);
}
static DstSlot do_gte(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_NUMERIC_GREATER_THAN_EQUAL, 0);
}
static DstSlot do_lte(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_NUMERIC_LESS_THAN_EQUAL, 0);
}
static DstSlot do_eq(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_NUMERIC_EQUAL, 0);
}
static DstSlot do_neq(DstFopts opts, DstSlot *args) {
return compreduce(opts, args, DOP_NUMERIC_EQUAL, 1);
}
/* Arranged by tag */
static const DstFunOptimizer optimizers[] = {
@ -159,7 +242,7 @@ static const DstFunOptimizer optimizers[] = {
{fixarity1, do_yield},
{fixarity2, do_resume},
{fixarity2, do_get},
{fixarity2, do_put},
{fixarity3, do_put},
{fixarity1, do_length},
{NULL, do_add},
{NULL, do_sub},
@ -170,14 +253,29 @@ static const DstFunOptimizer optimizers[] = {
{NULL, do_bxor},
{NULL, do_lshift},
{NULL, do_rshift},
{NULL, do_rshiftu}
{NULL, do_rshiftu},
{fixarity1, do_bnot},
{NULL, do_order_gt},
{NULL, do_order_lt},
{NULL, do_order_gte},
{NULL, do_order_lte},
{NULL, do_order_eq},
{NULL, do_order_neq},
{NULL, do_gt},
{NULL, do_lt},
{NULL, do_gte},
{NULL, do_lte},
{NULL, do_eq},
{NULL, do_neq}
};
const DstFunOptimizer *dstc_funopt(uint32_t flags) {
uint32_t tag = flags & DST_FUNCDEF_FLAG_TAG;
if (tag == 0 || tag >=
((sizeof(optimizers)/sizeof(uint32_t) - 1)))
if (tag == 0)
return NULL;
return optimizers + tag - 1;
uint32_t index = tag - 1;
if (index >= (sizeof(optimizers)/sizeof(optimizers[0])))
return NULL;
return optimizers + index;
}

6
src/core/compile.c
View File

@ -118,6 +118,12 @@ void dstc_popscope(DstCompiler *c) {
/* Move free slots to parent scope if not a new function.
* We need to know the total number of slots used when compiling the function. */
if (!(oldscope->flags & (DST_SCOPE_FUNCTION | DST_SCOPE_UNUSED)) && newscope) {
/* Parent scopes inherit child's closure flag. Needed
* for while loops. (if a while loop creates a closure, it
* is compiled to a tail recursive iife) */
if (oldscope->flags & DST_SCOPE_CLOSURE) {
newscope->flags |= DST_SCOPE_CLOSURE;
}
if (newscope->ra.max < oldscope->ra.max)
newscope->ra.max = oldscope->ra.max;

37
src/core/compile.h
View File

@ -45,6 +45,19 @@
#define DST_FUN_LSHIFT 16
#define DST_FUN_RSHIFT 17
#define DST_FUN_RSHIFTU 18
#define DST_FUN_BNOT 19
#define DST_FUN_ORDER_GT 20
#define DST_FUN_ORDER_LT 21
#define DST_FUN_ORDER_GTE 22
#define DST_FUN_ORDER_LTE 23
#define DST_FUN_ORDER_EQ 24
#define DST_FUN_ORDER_NEQ 25
#define DST_FUN_GT 26
#define DST_FUN_LT 27
#define DST_FUN_GTE 28
#define DST_FUN_LTE 29
#define DST_FUN_EQ 30
#define DST_FUN_NEQ 31
/* Compiler typedefs */
typedef struct DstCompiler DstCompiler;
@ -67,22 +80,23 @@ typedef struct DstSpecial DstSpecial;
/* A stack slot */
struct DstSlot {
Dst constant; /* If the slot has a constant value */
int32_t index;
int32_t envindex; /* 0 is local, positive number is an upvalue */
uint32_t flags;
Dst constant; /* If the slot has a constant value */
};
#define DST_SCOPE_FUNCTION 1
#define DST_SCOPE_ENV 2
#define DST_SCOPE_TOP 4
#define DST_SCOPE_UNUSED 8
#define DST_SCOPE_CLOSURE 16
/* A symbol and slot pair */
typedef struct SymPair {
DstSlot slot;
const uint8_t *sym;
int keep;
DstSlot slot;
} SymPair;
/* A lexical scope during compilation */
@ -101,12 +115,12 @@ struct DstScope {
/* Map of symbols to slots. Use a simple linear scan for symbols. */
SymPair *syms;
/* Regsiter allocator */
DstcRegisterAllocator ra;
/* FuncDefs */
DstFuncDef **defs;
/* Regsiter allocator */
DstcRegisterAllocator ra;
/* Referenced closure environents. The values at each index correspond
* to which index to get the environment from in the parent. The environment
* that corresponds to the direct parent's stack will always have value 0. */
@ -121,7 +135,6 @@ struct DstScope {
/* Compilation state */
struct DstCompiler {
int recursion_guard;
/* Pointer to current scope */
DstScope *scope;
@ -129,16 +142,20 @@ struct DstCompiler {
uint32_t *buffer;
DstSourceMapping *mapbuffer;
/* Keep track of where we are in the source */
DstSourceMapping current_mapping;
/* Hold the environment */
DstTable *env;
/* Name of source to attach to generated functions */
const uint8_t *source;
/* The result of compilation */
DstCompileResult result;
/* Keep track of where we are in the source */
DstSourceMapping current_mapping;
/* Prevent unbounded recursion */
int recursion_guard;
};
#define DST_FOPTS_TAIL 0x10000
@ -148,8 +165,8 @@ struct DstCompiler {
/* Options for compiling a single form */
struct DstFopts {
DstCompiler *compiler;
uint32_t flags; /* bit set of accepted primitive types */
DstSlot hint;
uint32_t flags; /* bit set of accepted primitive types */
};
/* Get the default form options */

439
src/core/core.dst
View File

@ -48,9 +48,29 @@
[name & more]
(apply1 tuple (array.concat @['def name :private] more)))
(defmacro defasm
"Define a function using assembly"
[name & body]
(def tab (apply1 table body))
(tuple 'def name (tuple asm (tuple 'quote tab))))
(defn defglobal
"Dynamically create a global def."
[name value]
(def name* (symbol name))
(put *env* name* @{:value value})
nil)
(defn varglobal
"Dynamically create a global var."
[name init]
(def name* (symbol name))
(put *env* name* @{:ref @[init]})
nil)
# Basic predicates
(defn even? [x] (== 0 (% x 2)))
(defn odd? [x] (== 1 (% x 2)))
(defn odd? [x] (not= 0 (% x 2)))
(defn zero? [x] (== x 0))
(defn pos? [x] (> x 0))
(defn neg? [x] (< x 0))
@ -96,8 +116,6 @@
:table true
:struct true})
(fn [x] (not (get non-atomic-types (type x))))))
(defn sum [xs] (apply1 + xs))
(defn product [xs] (apply1 * xs))
# C style macros and functions for imperative sugar
(defn inc [x] (+ x 1))
@ -214,88 +232,6 @@
(array.concat accum body)
(apply1 tuple accum))
(defmacro loop
"A general purpose loop macro."
[head & body]
(def len (length head))
(defn doone
[i preds]
(default preds @['and])
(if (>= i len)
(tuple.prepend body 'do)
(do
(def {
i bindings
(+ i 1) verb
(+ i 2) object
} head)
(if (keyword? bindings)
(case
bindings
:while (do
(array.push preds verb)
(doone (+ i 2) preds))
:let (tuple 'let verb (doone (+ i 2)))
:when (tuple 'if verb (doone (+ i 2)))
(error ("unexpected loop predicate: " verb)))
(case verb
:iterate (do
(def preds @['and (tuple ':= bindings object)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'var bindings nil)
(tuple 'while (apply1 tuple preds)
subloop)))
:range (do
(def [start end _inc] object)
(def inc (if _inc _inc 1))
(def endsym (gensym))
(def preds @['and (tuple < bindings endsym)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'var bindings start)
(tuple 'def endsym end)
(tuple 'while (apply1 tuple preds)
subloop
(tuple ':= bindings (tuple + bindings inc)))))
:keys (do
(def $dict (gensym))
(def preds @['and (tuple not= nil bindings)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'def $dict object)
(tuple 'var bindings (tuple next $dict nil))
(tuple 'while (apply1 tuple preds)
subloop
(tuple ':= bindings (tuple next $dict bindings)))))
:in (do
(def $len (gensym))
(def $i (gensym))
(def $indexed (gensym))
(def preds @['and (tuple < $i $len)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'def $indexed object)
(tuple 'def $len (tuple length $indexed))
(tuple 'var $i 0)
(tuple 'while (apply1 tuple preds)
(tuple 'def bindings (tuple get $indexed $i))
subloop
(tuple ':= $i (tuple + 1 $i)))))
(error ("unexpected loop verb: " verb)))))))
(doone 0))
(defmacro for
"Similar to loop, but accumulates the loop body into an array and returns that."
[head & body]
(def $accum (gensym))
(tuple 'do
(tuple 'def $accum @[])
(tuple 'loop head
(tuple array.push $accum
(tuple.prepend body 'do)))
$accum))
(defmacro and
"Evaluates to the last argument if all preceding elements are true, otherwise
evaluates to false."
@ -327,16 +263,114 @@
(tuple 'do (tuple 'def $fi fi)
(tuple 'if $fi $fi (aux (inc i))))))))) 0)))
(defmacro loop
"A general purpose loop macro."
[head & body]
(def len (length head))
(defn doone
@[i preds]
(default preds @['and])
(if (>= i len)
(tuple.prepend body 'do)
(do
(def {
i bindings
(+ i 1) verb
(+ i 2) object
} head)
(if (keyword? bindings)
(case
bindings
:while (do
(array.push preds verb)
(doone (+ i 2) preds))
:let (tuple 'let verb (doone (+ i 2)))
:when (tuple 'if verb (doone (+ i 2)))
(error ("unexpected loop predicate: " verb)))
(case verb
:iterate (do
(def $iter (gensym))
(def preds @['and (tuple ':= $iter object)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'var $iter nil)
(tuple 'while (apply1 tuple preds)
(tuple 'def bindings $iter)
subloop)))
:range (do
(def [start end _inc] object)
(def inc (if _inc _inc 1))
(def endsym (gensym))
(def $iter (gensym))
(def preds @['and (tuple < $iter endsym)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'var $iter start)
(tuple 'def endsym end)
(tuple 'while (apply1 tuple preds)
(tuple 'def bindings $iter)
subloop
(tuple ':= $iter (tuple + $iter inc)))))
:keys (do
(def $dict (gensym))
(def $iter (gensym))
(def preds @['and (tuple not= nil $iter)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'def $dict object)
(tuple 'var $iter (tuple next $dict nil))
(tuple 'while (apply1 tuple preds)
(tuple 'def bindings $iter)
subloop
(tuple ':= $iter (tuple next $dict $iter)))))
:in (do
(def $len (gensym))
(def $i (gensym))
(def $indexed (gensym))
(def preds @['and (tuple < $i $len)])
(def subloop (doone (+ i 3) preds))
(tuple 'do
(tuple 'def $indexed object)
(tuple 'def $len (tuple length $indexed))
(tuple 'var $i 0)
(tuple 'while (apply1 tuple preds)
(tuple 'def bindings (tuple get $indexed $i))
subloop
(tuple ':= $i (tuple + 1 $i)))))
(error (string "unexpected loop verb: " verb)))))))
(doone 0 nil))
(defmacro for
"Similar to loop, but accumulates the loop body into an array and returns that."
[head & body]
(def $accum (gensym))
(tuple 'do
(tuple 'def $accum @[])
(tuple 'loop head
(tuple array.push $accum
(tuple.prepend body 'do)))
$accum))
(defn sum [xs]
(var accum 0)
(loop [x :in xs] (+= accum x))
accum)
(defn product [xs]
(var accum 1)
(loop [x :in xs] (*= accum x))
accum)
(defmacro coro
"A wrapper for making fibers. Same as (fiber (fn [] ...body))."
[& body]
(tuple fiber.new (apply tuple 'fn [] body)))
(tuple fiber.new (apply tuple 'fn @[] body)))
(defmacro if-let
"Takes the first one or two forms in a vector and if both are true binds
all the forms with let and evaluates the first expression else
evaluates the second"
[bindings tru fal]
@[bindings tru fal]
(def len (length bindings))
(if (zero? len) (error "expected at least 1 binding"))
(if (odd? len) (error "expected an even number of bindings"))
@ -401,8 +435,8 @@
(when (pos? len)
(var ret (get args 0))
(loop [i :range [0 len]]
(def v (get args i))
(if (order v ret) (:= ret v)))
(def v (get args i))
(if (order v ret) (:= ret v)))
ret))
(defn max [& args] (extreme > args))
@ -425,12 +459,12 @@
(def pivot (get a hi))
(var i lo)
(loop [j :range [lo hi]]
(def aj (get a j))
(when (by aj pivot)
(def ai (get a i))
(put a i aj)
(put a j ai)
(++ i)))
(def aj (get a j))
(when (by aj pivot)
(def ai (get a i))
(put a i aj)
(put a j ai)
(++ i)))
(put a hi (get a i))
(put a i pivot)
i)
@ -443,12 +477,12 @@
(sort-help a (+ piv 1) hi by))
a)
(fn [a by]
(fn @[a by]
(sort-help a 0 (- (length a) 1) (or by order<)))))
(defn sorted
"Returns the sorted version of an indexed data structure."
[ind by]
@[ind by]
(def sa (sort (apply1 array ind) by))
(if (= :tuple (type ind))
(apply1 tuple sa)
@ -457,10 +491,10 @@
(defn reduce
"Reduce, also know as fold-left in many languages, transforms
an indexed type (array, tuple) with a function to produce a value."
[f init ind]
@[f init ind]
(var res init)
(loop [x :in ind]
(:= res (f res x)))
(:= res (f res x)))
res)
(defn map
@ -471,19 +505,19 @@
(if (= 0 ninds) (error "expected at least 1 indexed collection"))
(var limit (length (get inds 0)))
(loop [i :range [0 ninds]]
(def l (length (get inds i)))
(if (< l limit) (:= limit l)))
(def l (length (get inds i)))
(if (< l limit) (:= limit l)))
(def [i1 i2 i3 i4] inds)
(def res (array.new limit))
(case ninds
1 (loop [i :range [0 limit]] (array.push res (f (get i1 i))))
2 (loop [i :range [0 limit]] (array.push res (f (get i1 i) (get i2 i))))
3 (loop [i :range [0 limit]] (array.push res (f (get i1 i) (get i2 i) (get i3 i))))
4 (loop [i :range [0 limit]] (array.push res (f (get i1 i) (get i2 i) (get i3 i) (get i4 i))))
1 (loop [i :range [0 limit]] (put res i (f (get i1 i))))
2 (loop [i :range [0 limit]] (put res i (f (get i1 i) (get i2 i))))
3 (loop [i :range [0 limit]] (put res i (f (get i1 i) (get i2 i) (get i3 i))))
4 (loop [i :range [0 limit]] (put res i (f (get i1 i) (get i2 i) (get i3 i) (get i4 i))))
(loop [i :range [0 limit]]
(def args (array.new ninds))
(loop [j :range [0 ninds]] (array.push args (get (get inds j) i)))
(array.push res (apply1 f args))))
(def args (array.new ninds))
(loop [j :range [0 ninds]] (put args j (get (get inds j) i)))
(put res i (apply1 f args))))
res)
(defn each
@ -494,8 +528,8 @@
(if (= 0 ninds) (error "expected at least 1 indexed collection"))
(var limit (length (get inds 0)))
(loop [i :range [0 ninds]]
(def l (length (get inds i)))
(if (< l limit) (:= limit l)))
(def l (length (get inds i)))
(if (< l limit) (:= limit l)))
(def [i1 i2 i3 i4] inds)
(case ninds
1 (loop [i :range [0 limit]] (f (get i1 i)))
@ -503,18 +537,18 @@
3 (loop [i :range [0 limit]] (f (get i1 i) (get i2 i) (get i3 i)))
4 (loop [i :range [0 limit]] (f (get i1 i) (get i2 i) (get i3 i) (get i4 i)))
(loop [i :range [0 limit]]
(def args (array.new ninds))
(loop [j :range [0 ninds]] (array.push args (get (get inds j) i)))
(apply1 f args))))
(def args (array.new ninds))
(loop [j :range [0 ninds]] (array.push args (get (get inds j) i)))
(apply1 f args))))
(defn mapcat
"Map a function over every element in an array or tuple and
use array to concatenate the results. Returns the same
type as the input sequence."
[f ind t]
@[f ind t]
(def res @[])
(loop [x :in ind]
(array.concat res (f x)))
(array.concat res (f x)))
(if (= :tuple (type (or t ind)))
(apply1 tuple res)
res))
@ -522,21 +556,30 @@
(defn filter
"Given a predicate, take only elements from an array or tuple for
which (pred element) is truthy. Returns the same type as the input sequence."
[pred ind t]
@[pred ind t]
(def res @[])
(loop [item :in ind]
(if (pred item)
(array.push res item)))
(if (pred item)
(array.push res item)))
(if (= :tuple (type (or t ind)))
(apply1 tuple res)
res))
(defn range
"Create an array of values [0, n)."
[n]
(def arr (array.new n))
(loop [i :range [0 n]] (put arr i i))
arr)
[& args]
(case (length args)
1 (do
(def [n] args)
(def arr (array.new n))
(loop [i :range [0 n]] (put arr i i))
arr)
2 (do
(def [n m] args)
(def arr (array.new n))
(loop [i :range [n m]] (put arr (- i n) i))
arr)
(error "expected 1 to 2 arguments to range")))
(defn find-index
"Find the index of indexed type for which pred is true. Returns nil if not found."
@ -587,7 +630,7 @@
(fn [& args]
(def ret @[])
(loop [f :in funs]
(array.push ret (apply1 f args)))
(array.push ret (apply1 f args)))
(apply1 tuple ret)))
(defmacro juxt
@ -595,7 +638,7 @@
(def parts @['tuple])
(def $args (gensym))
(loop [f :in funs]
(array.push parts (tuple apply1 f $args)))
(array.push parts (tuple apply1 f $args)))
(tuple 'fn (tuple '& $args) (apply1 tuple parts)))
(defmacro ->
@ -630,12 +673,12 @@
(if (zero? (length more)) f
(fn [& r] (apply1 f (array.concat @[] more r)))))
(defn every? [pred seq]
(defn every? [pred ind]
(var res true)
(var i 0)
(def len (length seq))
(def len (length ind))
(while (< i len)
(def item (get seq i))
(def item (get ind i))
(if (pred item)
(++ i)
(do (:= res false) (:= i len))))
@ -666,13 +709,13 @@
(defn zipcoll
"Creates an table or tuple from two arrays/tuples. If a third argument of
:struct is given result is struct else is table."
[keys vals t]
@[keys vals t]
(def res @{})
(def lk (length keys))
(def lv (length vals))
(def len (if (< lk lv) lk lv))
(loop [i :range [0 len]]
(put res (get keys i) (get vals i)))
(put res (get keys i) (get vals i)))
(if (= :struct t)
(table.to-struct res)
res))
@ -693,7 +736,7 @@
(def container @{})
(loop [c :in colls
key :keys c]
(put container key (get c key)))
(put container key (get c key)))
(if (table? (get colls 0)) container (table.to-struct container)))
(defn keys
@ -774,33 +817,33 @@
(if (< len 5)
(do
(loop [i :range [0 len]]
(when (not= i 0) (buffer.push-string buf " "))
(recur (get y i))))
(when (not= i 0) (buffer.push-string buf " "))
(recur (get y i))))
(do
(buffer.push-string indent " ")
(loop [i :range [0 len]]
(when (not= i len) (buffer.push-string buf indent))
(recur (get y i)))
(when (not= i len) (buffer.push-string buf indent))
(recur (get y i)))
(buffer.popn indent 2)
(buffer.push-string buf indent))))
(defn pp-dict-nested [y]
(buffer.push-string indent " ")
(loop [[k v] :in (sort (pairs y))]
(buffer.push-string buf indent)
(recur k)
(buffer.push-string buf " ")
(recur v))
(buffer.push-string buf indent)
(recur k)
(buffer.push-string buf " ")
(recur v))
(buffer.popn indent 2)
(buffer.push-string buf indent))
(defn pp-dict-simple [y]
(var i -1)
(loop [[k v] :in (sort (pairs y))]
(if (pos? (++ i)) (buffer.push-string buf " "))
(recur k)
(buffer.push-string buf " ")
(recur v)))
(if (pos? (++ i)) (buffer.push-string buf " "))
(recur k)
(buffer.push-string buf " ")
(recur v)))
(defn pp-dict [y]
(def complex? (> (length y) 4))
@ -866,16 +909,15 @@
(def args (map macroexpand-1 (tuple.slice t 2)))
(apply tuple 'fn (get t 1) args))
(def specs {
':= expanddef
'def expanddef
'do expandall
'fn expandfn
'if expandall
'quote identity
'var expanddef
'while expandall
})
(def specs
{':= expanddef
'def expanddef
'do expandall
'fn expandfn
'if expandall
'quote identity
'var expanddef
'while expandall})
(defn dotup [t]
(def h (get t 0))
@ -888,12 +930,13 @@
m? (apply1 m (tuple.slice t 1))
(apply1 tuple (map macroexpand-1 t))))
(def ret (case (type x)
:tuple (dotup x)
:array (map macroexpand-1 x)
:struct (table.to-struct (dotable x macroexpand-1))
:table (dotable x macroexpand-1)
x))
(def ret
(case (type x)
:tuple (dotup x)
:array (map macroexpand-1 x)
:struct (table.to-struct (dotable x macroexpand-1))
:table (dotable x macroexpand-1)
x))
ret)
(defn all? [xs]
@ -944,7 +987,8 @@
###
###
(defn make-env [parent]
(defn make-env
@[parent]
(def parent (if parent parent _env))
(def newenv (table.setproto @{} parent))
(put newenv '_env @{:value newenv :private true})
@ -962,7 +1006,7 @@
This function can be used to implement a repl very easily, simply
pass a function that reads line from stdin to chunks, and print to
onvalue."
[env chunks onvalue onerr where]
@[env chunks onvalue onerr where]
# Are we done yet?
(var going true)
@ -980,7 +1024,7 @@
(chunks buf p)
(:= len (length buf))
(loop [i :range [0 len]]
(yield (get buf i))))
(yield (get buf i))))
0))
# Fiber stream of values
@ -1004,7 +1048,7 @@
(var good true)
(def f
(fiber.new
(fn []
(fn @[]
(def res (compile source env where))
(if (= (type res) :function)
(res)
@ -1045,16 +1089,14 @@
(when f
(def st (fiber.stack f))
(loop
[{
:function func
[{:function func
:tail tail
:pc pc
:c c
:name name
:source source
:line source-line
:column source-col
} :in st]
:column source-col} :in st]
(file.write stdout " in")
(when c (file.write stdout " cfunction"))
(if name
@ -1063,11 +1105,11 @@
(if source
(do
(file.write stdout " [" source "]")
(if source-line
(file.write
(if source-line
(file.write
stdout
" on line "
(string source-line)
(string source-line)
", column "
(string source-col)))))
(if (and (not source-line) pc)
@ -1080,7 +1122,7 @@
environment is needed, use run-context."
[str]
(var state (string str))
(defn chunks [buf]
(defn chunks [buf _]
(def ret state)
(:= state nil)
(if ret
@ -1089,21 +1131,26 @@
(run-context *env* chunks (fn [x] (:= returnval x)) default-error-handler "eval")
returnval)
(def module.paths
@["./?.dst"
"./?/init.dst"
"./dst_modules/?.dst"
"./dst_modules/?/init.dst"
"/usr/local/dst/0.0.0/?.dst"
"/usr/local/dst/0.0.0/?/init.dst"])
(def module.native-paths
@["./?.so"
"./?/??.so"
"./dst_modules/?.so"
"./dst_modules/?/??.so"
"/usr/local/dst/0.0.0/?.so"
"/usr/local/dst/0.0.0/?/??.so"])
(do
(def syspath (or (os.getenv "DST_PATH") "/usr/local/lib/dst/"))
(defglobal 'module.paths
@["./?.dst"
"./?/init.dst"
"./dst_modules/?.dst"
"./dst_modules/?/init.dst"
(string syspath VERSION "/?.dst")
(string syspath VERSION "/?/init.dst")
(string syspath "/?.dst")
(string syspath "/?/init.dst")])
(defglobal 'module.native-paths
@["./?.so"
"./?/??.so"
"./dst_modules/?.so"
"./dst_modules/?/??.so"
(string syspath VERSION "/?.so")
(string syspath VERSION "/?/??.so")
(string syspath "/?.so")
(string syspath "/?/??.so")]))
(defn module.find
[path paths]
@ -1145,7 +1192,7 @@
(def cache @{})
(def loading @{})
(fn require [path args]
(fn require @[path args]
(when (get loading path)
(error (string "circular dependency: module " path " is loading")))
(def {:exit exit-on-error} (or args {}))
@ -1160,21 +1207,21 @@
(if f
(do
# Normal dst module
(defn chunks [buf] (file.read f 1024 buf))
(defn chunks [buf _] (file.read f 1024 buf))
(run-context newenv chunks identity
(if exit-on-error
(fn [a b c d] (default-error-handler a b c d) (os.exit 1))
(fn @[a b c d] (default-error-handler a b c d) (os.exit 1))
default-error-handler)
path)
(file.close f)
(put loading path nil)
newenv)
(file.close f))
(do
# Try native module
(def n (find-native path))
(if (not n)
(error (string "could not open file for module " path)))
((native n)))))))))
((native n) newenv)))
(put loading path false)
newenv)))))
(defn import* [env path & args]
(def targs (apply1 table args))
@ -1193,11 +1240,12 @@
(put env (symbol prefix k) newv))
(:= k (next newenv k))))
(defmacro import [path & args]
(defmacro import
"Import a module. First requires the module, and then merges its
symbols into the current environment, prepending a given prefix as needed.
(use the :as or :prefix option to set a prefix). If no prefix is provided,
use the name of the module as a prefix."
[path & args]
(def argm (map (fn [x]
(if (and (symbol? x) (= (get x 0) 58))
x
@ -1205,9 +1253,10 @@
args))
(apply tuple import* '_env (string path) argm))
(defn repl [getchunk onvalue onerr]
(defn repl
"Run a repl. The first parameter is an optional function to call to
get a chunk of source code. Should return nil for end of file."
@[getchunk onvalue onerr]
(def newenv (make-env))
(default getchunk (fn [buf]
(file.read stdin :line buf)))
@ -1219,7 +1268,7 @@
(defn all-symbols
"Get all symbols available in the current environment."
[env]
@[env]
(default env *env*)
(def envs @[])
(do (var e env) (while e (array.push envs e) (:= e (table.getproto e))))

201
src/core/corelib.c
View File

@ -256,10 +256,11 @@ static int dst_core_gcinterval(DstArgs args) {
static int dst_core_type(DstArgs args) {
DST_FIXARITY(args, 1);
if (dst_checktype(args.v[0], DST_ABSTRACT)) {
DstType t = dst_type(args.v[0]);
if (t == DST_ABSTRACT) {
DST_RETURN(args, dst_csymbolv(dst_abstract_type(dst_unwrap_abstract(args.v[0]))->name));
} else {
DST_RETURN(args, dst_csymbolv(dst_type_names[dst_type(args.v[0])]));
DST_RETURN(args, dst_csymbolv(dst_type_names[t]));
}
}
@ -282,9 +283,8 @@ static int dst_core_next(DstArgs args) {
: dst_struct_find(st, args.v[1]);
kv = dst_struct_next(st, kv);
}
if (kv) {
if (kv)
DST_RETURN(args, kv->key);
}
DST_RETURN_NIL(args);
}
@ -344,57 +344,11 @@ static void dst_quick_asm(
}
/* Macros for easier inline dst assembly */
#define SSS(op, a, b, c) (op | (a << 8) | (b << 16) | (c << 24))
#define SS(op, a, b) (op | (a << 8) | (b << 16))
#define SSI(op, a, b, I) (op | (a << 8) | (b << 16) | ((uint32_t)(I) << 24))
#define S(op, a) (op | (a << 8))
#define SI(op, a, I) (op | (a << 8) | ((uint32_t)(I) << 16))
/* Variadic operator assembly. Must be templatized for each different opcode. */
/* Reg 0: Argument tuple (args) */
/* Reg 1: Argument count (argn) */
/* Reg 2: Jump flag (jump?) */
/* Reg 3: Accumulator (accum) */
/* Reg 4: Next operand (operand) */
/* Reg 5: Loop iterator (i) */
static DST_THREAD_LOCAL uint32_t varop_asm[] = {
SS(DOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */
/* Check nullary */
SSS(DOP_EQUALS_IMMEDIATE, 2, 1, 0), /* Check if numargs equal to 0 */
SI(DOP_JUMP_IF_NOT, 2, 3), /* If not 0, jump to next check */
/* Nullary */
SI(DOP_LOAD_INTEGER, 3, 0), /* accum = nullary value */
S(DOP_RETURN, 3), /* return accum */
/* Check unary */
SSI(DOP_EQUALS_IMMEDIATE, 2, 1, 1), /* Check if numargs equal to 1 */
SI(DOP_JUMP_IF_NOT, 2, 5), /* If not 1, jump to next check */
/* Unary */
S(DOP_LOAD_INTEGER, 3), /* accum = unary value */
SSI(DOP_GET_INDEX, 4, 0, 0), /* operand = args[0] */
SSS(DOP_NOOP, 3, 3, 4), /* accum = accum op operand */
S(DOP_RETURN, 3), /* return accum */
/* Mutli (2 or more) arity */
/* Prime loop */
SSI(DOP_GET_INDEX, 3, 0, 0), /* accum = args[0] */
SI(DOP_LOAD_INTEGER, 5, 1), /* i = 1 */
/* Main loop */
SSS(DOP_GET, 4, 0, 5), /* operand = args[i] */
SSS(DOP_NOOP, 3, 3, 4), /* accum = accum op operand */
SSI(DOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */
SSI(DOP_EQUALS_INTEGER, 2, 5, 1), /* jump? = (i == argn) */
SI(DOP_JUMP_IF_NOT, 2, -4), /* if not jump? go back 4 */
/* Done, do last and return accumulator */
S(DOP_RETURN, 3) /* return accum */
};
#define VAROP_NULLARY_LOC 3
#define VAROP_UNARY_LOC 7
#define VAROP_OP_LOC1 9
#define VAROP_OP_LOC2 14
#define SSS(op, a, b, c) ((op) | ((a) << 8) | ((b) << 16) | ((c) << 24))
#define SS(op, a, b) ((op) | ((a) << 8) | ((b) << 16))
#define SSI(op, a, b, I) ((op) | ((a) << 8) | ((b) << 16) | ((uint32_t)(I) << 24))
#define S(op, a) ((op) | ((a) << 8))
#define SI(op, a, I) ((op) | ((a) << 8) | ((uint32_t)(I) << 16))
/* Templatize a varop */
static void templatize_varop(
@ -404,10 +358,48 @@ static void templatize_varop(
int32_t nullary,
int32_t unary,
uint32_t op) {
varop_asm[VAROP_NULLARY_LOC] = SS(DOP_LOAD_INTEGER, 3, nullary);
varop_asm[VAROP_UNARY_LOC] = SS(DOP_LOAD_INTEGER, 3, unary);
varop_asm[VAROP_OP_LOC1] = SSS(op, 3, 3, 4);
varop_asm[VAROP_OP_LOC2] = SSS(op, 3, 3, 4);
/* Variadic operator assembly. Must be templatized for each different opcode. */
/* Reg 0: Argument tuple (args) */
/* Reg 1: Argument count (argn) */
/* Reg 2: Jump flag (jump?) */
/* Reg 3: Accumulator (accum) */
/* Reg 4: Next operand (operand) */
/* Reg 5: Loop iterator (i) */
uint32_t varop_asm[] = {
SS(DOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */
/* Check nullary */
SSS(DOP_EQUALS_IMMEDIATE, 2, 1, 0), /* Check if numargs equal to 0 */
SI(DOP_JUMP_IF_NOT, 2, 3), /* If not 0, jump to next check */
/* Nullary */
SI(DOP_LOAD_INTEGER, 3, nullary), /* accum = nullary value */
S(DOP_RETURN, 3), /* return accum */
/* Check unary */
SSI(DOP_EQUALS_IMMEDIATE, 2, 1, 1), /* Check if numargs equal to 1 */
SI(DOP_JUMP_IF_NOT, 2, 5), /* If not 1, jump to next check */
/* Unary */
SI(DOP_LOAD_INTEGER, 3, unary), /* accum = unary value */
SSI(DOP_GET_INDEX, 4, 0, 0), /* operand = args[0] */
SSS(op, 3, 3, 4), /* accum = accum op operand */
S(DOP_RETURN, 3), /* return accum */
/* Mutli (2 or more) arity */
/* Prime loop */
SSI(DOP_GET_INDEX, 3, 0, 0), /* accum = args[0] */
SI(DOP_LOAD_INTEGER, 5, 1), /* i = 1 */
/* Main loop */
SSS(DOP_GET, 4, 0, 5), /* operand = args[i] */
SSS(op, 3, 3, 4), /* accum = accum op operand */
SSI(DOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */
SSI(DOP_EQUALS_INTEGER, 2, 5, 1), /* jump? = (i == argn) */
SI(DOP_JUMP_IF_NOT, 2, -4), /* if not jump? go back 4 */
/* Done, do last and return accumulator */
S(DOP_RETURN, 3) /* return accum */
};
dst_quick_asm(
env,
flags | DST_FUNCDEF_FLAG_VARARG,
@ -418,38 +410,93 @@ static void templatize_varop(
sizeof(varop_asm));
}
DstTable *dst_stl_env(int flags) {
static uint32_t error_asm[] = {
/* Templatize variadic comparators */
static void templatize_comparator(
DstTable *env,
int32_t flags,
const char *name,
int invert,
uint32_t op) {
/* Reg 0: Argument tuple (args) */
/* Reg 1: Argument count (argn) */
/* Reg 2: Jump flag (jump?) */
/* Reg 3: Last value (last) */
/* Reg 4: Next operand (next) */
/* Reg 5: Loop iterator (i) */
uint32_t comparator_asm[] = {
SS(DOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */
SSS(DOP_LESS_THAN_IMMEDIATE, 2, 1, 2), /* Check if numargs less than 2 */
SI(DOP_JUMP_IF, 2, 10), /* If numargs < 2, jump to done */
/* Prime loop */
SSI(DOP_GET_INDEX, 3, 0, 0), /* last = args[0] */
SI(DOP_LOAD_INTEGER, 5, 1), /* i = 1 */
/* Main loop */
SSS(DOP_GET, 4, 0, 5), /* next = args[i] */
SSS(op, 2, 3, 4), /* jump? = last compare next */
SI(DOP_JUMP_IF_NOT, 2, 7), /* if not jump? goto fail (return false) */
SSI(DOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */
SS(DOP_MOVE_NEAR, 3, 4), /* last = next */
SSI(DOP_EQUALS_INTEGER, 2, 5, 1), /* jump? = (i == argn) */
SI(DOP_JUMP_IF_NOT, 2, -6), /* if not jump? go back 6 */
/* Done, return true */
S(invert ? DOP_LOAD_FALSE : DOP_LOAD_TRUE, 3),
S(DOP_RETURN, 3),
/* Failed, return false */
S(invert ? DOP_LOAD_TRUE : DOP_LOAD_FALSE, 3),
S(DOP_RETURN, 3)
};
dst_quick_asm(
env,
flags | DST_FUNCDEF_FLAG_VARARG,
name,
0,
6,
comparator_asm,
sizeof(comparator_asm));
}
DstTable *dst_core_env(void) {
static const uint32_t error_asm[] = {
DOP_ERROR
};
static uint32_t apply_asm[] = {
static const uint32_t apply_asm[] = {
DOP_PUSH_ARRAY | (1 << 8),
DOP_TAILCALL
};
static uint32_t debug_asm[] = {
static const uint32_t debug_asm[] = {
DOP_SIGNAL | (2 << 24),
DOP_RETURN_NIL
};
static uint32_t yield_asm[] = {
static const uint32_t yield_asm[] = {
DOP_SIGNAL | (3 << 24),
DOP_RETURN
};
static uint32_t resume_asm[] = {
static const uint32_t resume_asm[] = {
DOP_RESUME | (1 << 24),
DOP_RETURN
};
static uint32_t get_asm[] = {
static const uint32_t get_asm[] = {
DOP_GET | (1 << 24),
DOP_RETURN
};
static uint32_t put_asm[] = {
static const uint32_t put_asm[] = {
DOP_PUT | (1 << 16) | (2 << 24),
DOP_RETURN
};
static uint32_t length_asm[] = {
static const uint32_t length_asm[] = {
DOP_LENGTH,
DOP_RETURN
};
static const uint32_t bnot_asm[] = {
DOP_BNOT,
DOP_RETURN
};
DstTable *env = dst_table(0);
Dst ret = dst_wrap_table(env);
@ -465,6 +512,7 @@ DstTable *dst_stl_env(int flags) {
dst_quick_asm(env, DST_FUN_GET, "get", 2, 2, get_asm, sizeof(get_asm));
dst_quick_asm(env, DST_FUN_PUT, "put", 3, 3, put_asm, sizeof(put_asm));
dst_quick_asm(env, DST_FUN_LENGTH, "length", 1, 1, length_asm, sizeof(length_asm));
dst_quick_asm(env, DST_FUN_BNOT, "~", 1, 1, bnot_asm, sizeof(bnot_asm));
/* Variadic ops */
templatize_varop(env, DST_FUN_ADD, "+", 0, 0, DOP_ADD);
@ -478,6 +526,20 @@ DstTable *dst_stl_env(int flags) {
templatize_varop(env, DST_FUN_RSHIFT, ">>", 1, 1, DOP_SHIFT_RIGHT);
templatize_varop(env, DST_FUN_RSHIFTU, ">>>", 1, 1, DOP_SHIFT_RIGHT_UNSIGNED);
/* Variadic comparators */
templatize_comparator(env, DST_FUN_ORDER_GT, "order>", 0, DOP_GREATER_THAN);
templatize_comparator(env, DST_FUN_ORDER_LT, "order<", 0, DOP_LESS_THAN);
templatize_comparator(env, DST_FUN_ORDER_GTE, "order>=", 1, DOP_LESS_THAN);
templatize_comparator(env, DST_FUN_ORDER_LTE, "order<=", 1, DOP_GREATER_THAN);
templatize_comparator(env, DST_FUN_ORDER_EQ, "=", 0, DOP_EQUALS);
templatize_comparator(env, DST_FUN_ORDER_NEQ, "not=", 1, DOP_EQUALS);
templatize_comparator(env, DST_FUN_GT, ">", 0, DOP_NUMERIC_GREATER_THAN);
templatize_comparator(env, DST_FUN_LT, "<", 0, DOP_NUMERIC_LESS_THAN);
templatize_comparator(env, DST_FUN_GTE, ">=", 0, DOP_NUMERIC_GREATER_THAN_EQUAL);
templatize_comparator(env, DST_FUN_LTE, "<=", 0, DOP_NUMERIC_LESS_THAN_EQUAL);
templatize_comparator(env, DST_FUN_EQ, "==", 0, DOP_NUMERIC_EQUAL);
templatize_comparator(env, DST_FUN_NEQ, "not==", 1, DOP_NUMERIC_EQUAL);
dst_env_def(env, "VERSION", dst_cstringv(DST_VERSION));
/* Set as gc root */
@ -510,8 +572,5 @@ DstTable *dst_stl_env(int flags) {
/* Run bootstrap source */
dst_dobytes(env, dst_gen_core, sizeof(dst_gen_core), "core.dst");
if (flags & DST_STL_NOGCROOT)
dst_gcunroot(dst_wrap_table(env));
return env;
}

29
src/core/fiber.c
View File

@ -107,7 +107,7 @@ void dst_fiber_pushn(DstFiber *fiber, const Dst *arr, int32_t n) {
}
/* Push a stack frame to a fiber */
void dst_fiber_funcframe(DstFiber *fiber, DstFunction *func) {
int dst_fiber_funcframe(DstFiber *fiber, DstFunction *func) {
DstStackFrame *newframe;
int32_t i;
@ -116,6 +116,13 @@ void dst_fiber_funcframe(DstFiber *fiber, DstFunction *func) {
int32_t nextframe = fiber->stackstart;
int32_t nextstacktop = nextframe + func->def->slotcount + DST_FRAME_SIZE;
/* Check strict arity */
if (func->def->flags & DST_FUNCDEF_FLAG_FIXARITY) {
if (func->def->arity != (fiber->stacktop - fiber->stackstart)) {
return 1;
}
}
if (fiber->capacity < nextstacktop) {
dst_fiber_setcapacity(fiber, 2 * nextstacktop);
}
@ -146,6 +153,9 @@ void dst_fiber_funcframe(DstFiber *fiber, DstFunction *func) {
oldtop - tuplehead));
}
}
/* Good return */
return 0;
}
/* If a frame has a closure environment, detach it from
@ -165,12 +175,19 @@ static void dst_env_detach(DstFuncEnv *env) {
}
/* Create a tail frame for a function */
void dst_fiber_funcframe_tail(DstFiber *fiber, DstFunction *func) {
int dst_fiber_funcframe_tail(DstFiber *fiber, DstFunction *func) {
int32_t i;
int32_t nextframetop = fiber->frame + func->def->slotcount;
int32_t nextstacktop = nextframetop + DST_FRAME_SIZE;
int32_t stacksize;
/* Check strict arity */
if (func->def->flags & DST_FUNCDEF_FLAG_FIXARITY) {
if (func->def->arity != (fiber->stacktop - fiber->stackstart)) {
return 1;
}
}
if (fiber->capacity < nextstacktop) {
dst_fiber_setcapacity(fiber, 2 * nextstacktop);
}
@ -213,6 +230,9 @@ void dst_fiber_funcframe_tail(DstFiber *fiber, DstFunction *func) {
dst_fiber_frame(fiber)->func = func;
dst_fiber_frame(fiber)->pc = func->def->bytecode;
dst_fiber_frame(fiber)->flags |= DST_STACKFRAME_TAILCALL;
/* Good return */
return 0;
}
/* Push a stack frame to a fiber for a c function */
@ -263,6 +283,11 @@ static int cfun_new(DstArgs args) {
DST_MINARITY(args, 1);
DST_MAXARITY(args, 2);
DST_ARG_FUNCTION(func, args, 0);
if (func->def->flags & DST_FUNCDEF_FLAG_FIXARITY) {
if (func->def->arity != 1) {
DST_THROW(args, "expected unit arity function in fiber constructor");
}
}
fiber = dst_fiber(func, 64);
if (args.n == 2) {
const uint8_t *flags;

4
src/core/fiber.h
View File

@ -40,8 +40,8 @@ void dst_fiber_push(DstFiber *fiber, Dst x);
void dst_fiber_push2(DstFiber *fiber, Dst x, Dst y);
void dst_fiber_push3(DstFiber *fiber, Dst x, Dst y, Dst z);
void dst_fiber_pushn(DstFiber *fiber, const Dst *arr, int32_t n);
void dst_fiber_funcframe(DstFiber *fiber, DstFunction *func);
void dst_fiber_funcframe_tail(DstFiber *fiber, DstFunction *func);
int dst_fiber_funcframe(DstFiber *fiber, DstFunction *func);
int dst_fiber_funcframe_tail(DstFiber *fiber, DstFunction *func);
void dst_fiber_cframe(DstFiber *fiber, DstCFunction cfun);
void dst_fiber_popframe(DstFiber *fiber);

22
src/core/gc.c
View File

@ -339,6 +339,24 @@ void dst_gcroot(Dst root) {
dst_vm_root_count = newcount;
}
/* Identity equality for GC purposes */
static int dst_gc_idequals(Dst lhs, Dst rhs) {
if (dst_type(lhs) != dst_type(rhs))
return 0;
switch (dst_type(lhs)) {
case DST_TRUE:
case DST_FALSE:
case DST_NIL:
return 1;
case DST_INTEGER:
return dst_unwrap_integer(lhs) == dst_unwrap_integer(rhs);
case DST_REAL:
return dst_unwrap_real(lhs) == dst_unwrap_real(rhs);
default:
return dst_unwrap_pointer(lhs) == dst_unwrap_pointer(rhs);
}
}
/* Remove a root value from the GC. This allows the gc to potentially reclaim
* a value and all its children. */
int dst_gcunroot(Dst root) {
@ -346,7 +364,7 @@ int dst_gcunroot(Dst root) {
Dst *v = dst_vm_roots;
/* Search from top to bottom as access is most likely LIFO */
for (v = dst_vm_roots; v < vtop; v++) {
if (dst_equals(root, *v)) {
if (dst_gc_idequals(root, *v)) {
*v = dst_vm_roots[--dst_vm_root_count];
return 1;
}
@ -361,7 +379,7 @@ int dst_gcunrootall(Dst root) {
int ret = 0;
/* Search from top to bottom as access is most likely LIFO */
for (v = dst_vm_roots; v < vtop; v++) {
if (dst_equals(root, *v)) {
if (dst_gc_idequals(root, *v)) {
*v = dst_vm_roots[--dst_vm_root_count];
vtop--;
ret = 1;

10
src/core/io.c
View File

@ -154,10 +154,9 @@ static int dst_io_popen(DstArgs args) {
}
flags = (fmode[0] == 'r') ? IO_PIPED | IO_READ : IO_PIPED | IO_WRITE;
#ifdef DST_WINDOWS
f = _popen((const char *)fname, (const char *)fmode);
#else
f = popen((const char *)fname, (const char *)fmode);
#define popen _popen
#endif
f = popen((const char *)fname, (const char *)fmode);
if (!f) {
if (errno == EMFILE) {
DST_THROW(args, "too many streams are open");
@ -317,10 +316,9 @@ static int dst_io_fclose(DstArgs args) {
DST_THROW(args, "file not closable");
if (iof->flags & IO_PIPED) {
#ifdef DST_WINDOWS
if (_pclose(iof->file)) DST_THROW(args, "could not close file");
#else
if (pclose(iof->file)) DST_THROW(args, "could not close file");
#define pclose _pclose
#endif
if (pclose(iof->file)) DST_THROW(args, "could not close file");
} else {
if (fclose(iof->file)) DST_THROW(args, "could not close file");
}

85
src/core/math.c
View File

@ -71,19 +71,6 @@ int dst_real(DstArgs args) {
return 0;
}
int dst_bnot(DstArgs args) {
if (args.n != 1) {
*args.ret = dst_cstringv("expected 1 argument");
return 1;
}
if (!dst_checktype(args.v[0], DST_INTEGER)) {
*args.ret = dst_cstringv("expected integer");
return 1;
}
*args.ret = dst_wrap_integer(~dst_unwrap_integer(args.v[0]));
return 0;
}
int dst_remainder(DstArgs args) {
DST_FIXARITY(args, 2);
if (dst_checktype(args.v[0], DST_INTEGER) &&
@ -137,85 +124,13 @@ int dst_##name(DstArgs args) {\
DST_DEFINE_MATH2OP(atan2, atan2)
DST_DEFINE_MATH2OP(pow, pow)
/* Comparison */
#define DST_DEFINE_COMPARATOR(name, pred)\
static int dst_##name(DstArgs args) {\
int32_t i;\
for (i = 0; i < args.n - 1; i++) {\
if (dst_compare(args.v[i], args.v[i+1]) pred) {\
DST_RETURN_FALSE(args);\
}\
}\
DST_RETURN_TRUE(args);\
}
DST_DEFINE_COMPARATOR(ascending, >= 0)
DST_DEFINE_COMPARATOR(descending, <= 0)
DST_DEFINE_COMPARATOR(notdescending, > 0)
DST_DEFINE_COMPARATOR(notascending, < 0)
/* Boolean logic */
static int dst_strict_equal(DstArgs args) {
int32_t i;
for (i = 0; i < args.n - 1; i++) {
if (!dst_equals(args.v[i], args.v[i+1])) {
DST_RETURN(args, dst_wrap_false());
}
}
DST_RETURN(args, dst_wrap_true());
}
static int dst_strict_notequal(DstArgs args) {
int32_t i;
for (i = 0; i < args.n - 1; i++) {
if (dst_equals(args.v[i], args.v[i+1])) {
DST_RETURN(args, dst_wrap_false());
}
}
DST_RETURN(args, dst_wrap_true());
}
static int dst_not(DstArgs args) {
DST_FIXARITY(args, 1);
DST_RETURN_BOOLEAN(args, !dst_truthy(args.v[0]));
}
#define DEF_NUMERIC_COMP(name, op) \
int dst_numeric_##name(DstArgs args) { \
int32_t i; \
for (i = 1; i < args.n; i++) { \
double x = 0, y = 0; \
DST_ARG_NUMBER(x, args, i-1);\
DST_ARG_NUMBER(y, args, i);\
if (!(x op y)) { \
DST_RETURN(args, dst_wrap_false()); \
} \
} \
DST_RETURN(args, dst_wrap_true()); \
}
DEF_NUMERIC_COMP(gt, >)
DEF_NUMERIC_COMP(lt, <)
DEF_NUMERIC_COMP(lte, <=)
DEF_NUMERIC_COMP(gte, >=)
DEF_NUMERIC_COMP(eq, ==)
DEF_NUMERIC_COMP(neq, !=)
static const DstReg cfuns[] = {
{"%", dst_remainder},
{"=", dst_strict_equal},
{"not=", dst_strict_notequal},
{"order<", dst_ascending},
{"order>", dst_descending},
{"order<=", dst_notdescending},
{"order>=", dst_notascending},
{"==", dst_numeric_eq},
{"not==", dst_numeric_neq},
{"<", dst_numeric_lt},
{">", dst_numeric_gt},
{"<=", dst_numeric_lte},
{">=", dst_numeric_gte},
{"~", dst_bnot},
{"not", dst_not},
{"int", dst_int},
{"real", dst_real},

25
src/core/os.c
View File

@ -153,6 +153,9 @@ static int os_getenv(DstArgs args) {
DST_ARG_STRING(k, args, 0);
const char *cstr = (const char *) k;
const char *res = getenv(cstr);
if (!res) {
DST_RETURN_NIL(args);
}
DST_RETURN(args, cstr
? dst_cstringv(res)
: dst_wrap_nil());
@ -195,10 +198,28 @@ static int os_exit(DstArgs args) {
return 0;
}
/* Clock shim for windows */
#ifdef DST_WINDOWS
static int clock_gettime(int x, struct timespec *spec) {
(void) x;
int64_t wintime = 0LL;
GetSystemTimeAsFileTime((FILETIME*)&wintime);
/* Windows epoch is January 1, 1601 apparently*/
wintime -= 116444736000000000LL;
spec->tv_sec = wintime / 10000000LL;
/* Resolution is 100 nanoseconds. */
spec->tv_nsec = wintime % 10000000LL * 100;
return 0;
}
#define CLOCK_MONOTONIC 0
#endif
static int os_clock(DstArgs args) {
DST_FIXARITY(args, 0);
clock_t time = clock();
double dtime = time / (double) (CLOCKS_PER_SEC);
struct timespec tv;
if (clock_gettime(CLOCK_MONOTONIC, &tv))
DST_THROW(args, "could not get time");
double dtime = tv.tv_sec + (tv.tv_nsec / 1E9);
DST_RETURN_REAL(args, dtime);
}

2
src/core/parse.c
View File

@ -419,7 +419,7 @@ static int longstring(DstParser *p, DstParseState *state, uint8_t c) {
} else if (state->flags & PFLAG_END_CANDIDATE) {
int i;
/* We are checking a potential end of the string */
if (c != '`' && state->qcount == state->argn) {
if (state->qcount == state->argn) {
stringend(p, state);
return 0;
}

120
src/core/specials.c
View File

@ -26,7 +26,7 @@
#include "vector.h"
#include "emit.h"
DstSlot dstc_quote(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_quote(DstFopts opts, int32_t argn, const Dst *argv) {
if (argn != 1) {
dstc_cerror(opts.compiler, "expected 1 argument");
return dstc_cslot(dst_wrap_nil());
@ -91,7 +91,7 @@ static int destructure(DstCompiler *c,
}
}
DstSlot dstc_varset(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_varset(DstFopts opts, int32_t argn, const Dst *argv) {
DstFopts subopts = dstc_fopts_default(opts.compiler);
DstSlot ret, dest;
Dst head;
@ -189,7 +189,7 @@ static int varleaf(
}
}
DstSlot dstc_var(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_var(DstFopts opts, int32_t argn, const Dst *argv) {
DstCompiler *c = opts.compiler;
Dst head;
DstSlot ret = dohead(c, opts, &head, argn, argv);
@ -222,7 +222,7 @@ static int defleaf(
}
}
DstSlot dstc_def(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_def(DstFopts opts, int32_t argn, const Dst *argv) {
DstCompiler *c = opts.compiler;
Dst head;
opts.flags &= ~DST_FOPTS_HINT;
@ -245,13 +245,13 @@ DstSlot dstc_def(DstFopts opts, int32_t argn, const Dst *argv) {
* ...
* :done
*/
DstSlot dstc_if(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_if(DstFopts opts, int32_t argn, const Dst *argv) {
DstCompiler *c = opts.compiler;
int32_t labelr, labeljr, labeld, labeljd;
DstFopts condopts, bodyopts;
DstSlot cond, left, right, target;
Dst truebody, falsebody;
DstScope tempscope;
DstScope condscope, tempscope;
const int tail = opts.flags & DST_FOPTS_TAIL;
const int drop = opts.flags & DST_FOPTS_DROP;
@ -268,7 +268,13 @@ DstSlot dstc_if(DstFopts opts, int32_t argn, const Dst *argv) {
condopts = dstc_fopts_default(c);
bodyopts = opts;
/* Set target for compilation */
target = (drop || tail)
? dstc_cslot(dst_wrap_nil())
: dstc_gettarget(opts);
/* Compile condition */
dstc_scope(&condscope, c, 0, "if");
cond = dstc_value(condopts, argv[0]);
/* Check constant condition. */
@ -283,15 +289,11 @@ DstSlot dstc_if(DstFopts opts, int32_t argn, const Dst *argv) {
dstc_scope(&tempscope, c, 0, "if-body");
target = dstc_value(bodyopts, truebody);
dstc_popscope(c);
dstc_popscope(c);
dstc_throwaway(bodyopts, falsebody);
return target;
}
/* Set target for compilation */
target = (drop || tail)
? dstc_cslot(dst_wrap_nil())
: dstc_gettarget(opts);
/* Compile jump to right */
labeljr = dstc_emit_si(c, DOP_JUMP_IF_NOT, cond, 0, 0);
@ -312,6 +314,9 @@ DstSlot dstc_if(DstFopts opts, int32_t argn, const Dst *argv) {
if (!drop && !tail) dstc_copy(c, target, right);
dstc_popscope(c);
/* Pop main scope */
dstc_popscope(c);
/* Write jumps - only add jump lengths if jump actually emitted */
labeld = dst_v_count(c->buffer);
c->buffer[labeljr] |= (labelr - labeljr) << 16;
@ -323,7 +328,7 @@ DstSlot dstc_if(DstFopts opts, int32_t argn, const Dst *argv) {
/* Compile a do form. Do forms execute their body sequentially and
* evaluate to the last expression in the body. */
DstSlot dstc_do(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_do(DstFopts opts, int32_t argn, const Dst *argv) {
int32_t i;
DstSlot ret = dstc_cslot(dst_wrap_nil());
DstCompiler *c = opts.compiler;
@ -345,6 +350,19 @@ DstSlot dstc_do(DstFopts opts, int32_t argn, const Dst *argv) {
return ret;
}
/* Add a funcdef to the top most function scope */
static int32_t dstc_addfuncdef(DstCompiler *c, DstFuncDef *def) {
DstScope *scope = c->scope;
while (scope) {
if (scope->flags & DST_SCOPE_FUNCTION)
break;
scope = scope->parent;
}
dst_assert(scope, "could not add funcdef");
dst_v_push(scope->defs, def);
return dst_v_count(scope->defs) - 1;
}
/*
* :whiletop
* ...
@ -354,7 +372,7 @@ DstSlot dstc_do(DstFopts opts, int32_t argn, const Dst *argv) {
* jump :whiletop
* :done
*/
DstSlot dstc_while(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_while(DstFopts opts, int32_t argn, const Dst *argv) {
DstCompiler *c = opts.compiler;
DstSlot cond;
DstFopts subopts = dstc_fopts_default(c);
@ -369,6 +387,8 @@ DstSlot dstc_while(DstFopts opts, int32_t argn, const Dst *argv) {
labelwt = dst_v_count(c->buffer);
dstc_scope(&tempscope, c, 0, "while");
/* Compile condition */
cond = dstc_value(subopts, argv[0]);
@ -376,20 +396,17 @@ DstSlot dstc_while(DstFopts opts, int32_t argn, const Dst *argv) {
if (cond.flags & DST_SLOT_CONSTANT) {
/* Loop never executes */
if (!dst_truthy(cond.constant)) {
dstc_popscope(c);
return dstc_cslot(dst_wrap_nil());
}
/* Infinite loop */
infinite = 1;
}
dstc_scope(&tempscope, c, 0, "while");
/* Infinite loop does not need to check condition */
if (!infinite) {
labelc = dstc_emit_si(c, DOP_JUMP_IF_NOT, cond, 0, 0);
} else {
labelc = 0;
}
labelc = infinite
? 0
: dstc_emit_si(c, DOP_JUMP_IF_NOT, cond, 0, 0);
/* Compile body */
for (i = 1; i < argn; i++) {
@ -397,6 +414,44 @@ DstSlot dstc_while(DstFopts opts, int32_t argn, const Dst *argv) {
dstc_freeslot(c, dstc_value(subopts, argv[i]));
}
/* Check if closure created in while scope. If so,
* recompile in a function scope. */
if (tempscope.flags & DST_SCOPE_CLOSURE) {
tempscope.flags |= DST_SCOPE_UNUSED;
dstc_popscope(c);
dst_v__cnt(c->buffer) = labelwt;
dst_v__cnt(c->mapbuffer) = labelwt;
dstc_scope(&tempscope, c, DST_SCOPE_FUNCTION, "while-iife");
/* Recompile in the function scope */
cond = dstc_value(subopts, argv[0]);
if (!(cond.flags & DST_SLOT_CONSTANT)) {
/* If not an infinte loop, return nil when condition false */
dstc_emit_si(c, DOP_JUMP_IF, cond, 2, 0);
dstc_emit(c, DOP_RETURN_NIL);
}
for (i = 1; i < argn; i++) {
subopts.flags = DST_FOPTS_DROP;
dstc_freeslot(c, dstc_value(subopts, argv[i]));
}
/* But now add tail recursion */
int32_t tempself = dstc_regalloc_temp(&tempscope.ra, DSTC_REGTEMP_0);
dstc_emit(c, DOP_LOAD_SELF | (tempself << 8));
dstc_emit(c, DOP_TAILCALL | (tempself << 8));
/* Compile function */
DstFuncDef *def = dstc_pop_funcdef(c);
def->name = dst_cstring("_while");
int32_t defindex = dstc_addfuncdef(c, def);
/* And then load the closure and call it. */
int32_t cloreg = dstc_regalloc_temp(&c->scope->ra, DSTC_REGTEMP_0);
dstc_emit(c, DOP_CLOSURE | (cloreg << 8) | (defindex << 16));
dstc_emit(c, DOP_CALL | (cloreg << 8) | (cloreg << 16));
dstc_regalloc_free(&c->scope->ra, cloreg);
c->scope->flags |= DST_SCOPE_CLOSURE;
return dstc_cslot(dst_wrap_nil());
}
/* Compile jump to whiletop */
labeljt = dst_v_count(c->buffer);
dstc_emit(c, DOP_JUMP);
@ -412,20 +467,7 @@ DstSlot dstc_while(DstFopts opts, int32_t argn, const Dst *argv) {
return dstc_cslot(dst_wrap_nil());
}
/* Add a funcdef to the top most function scope */
static int32_t dstc_addfuncdef(DstCompiler *c, DstFuncDef *def) {
DstScope *scope = c->scope;
while (scope) {
if (scope->flags & DST_SCOPE_FUNCTION)
break;
scope = scope->parent;
}
dst_assert(scope, "could not add funcdef");
dst_v_push(scope->defs, def);
return dst_v_count(scope->defs) - 1;
}
DstSlot dstc_fn(DstFopts opts, int32_t argn, const Dst *argv) {
static DstSlot dstc_fn(DstFopts opts, int32_t argn, const Dst *argv) {
DstCompiler *c = opts.compiler;
DstFuncDef *def;
DstSlot ret;
@ -439,6 +481,7 @@ DstSlot dstc_fn(DstFopts opts, int32_t argn, const Dst *argv) {
int selfref = 0;
/* Begin function */
c->scope->flags |= DST_SCOPE_CLOSURE;
dstc_scope(&fnscope, c, DST_SCOPE_FUNCTION, "function");
if (argn < 2) {
@ -506,7 +549,14 @@ DstSlot dstc_fn(DstFopts opts, int32_t argn, const Dst *argv) {
/* Build function */
def = dstc_pop_funcdef(c);
def->arity = arity;
if (varargs) def->flags |= DST_FUNCDEF_FLAG_VARARG;
/* Tuples indicated fixed arity, arrays indicate flexible arity */
/* TODO - revisit this */
if (varargs)
def->flags |= DST_FUNCDEF_FLAG_VARARG;
else if (dst_checktype(paramv, DST_TUPLE))
def->flags |= DST_FUNCDEF_FLAG_FIXARITY;
if (selfref) def->name = dst_unwrap_symbol(head);
defindex = dstc_addfuncdef(c, def);

22
src/core/string.c
View File

@ -356,6 +356,19 @@ void dst_description_b(DstBuffer *buffer, Dst x) {
}
goto fallthrough;
}
case DST_FUNCTION:
{
DstFunction *fun = dst_unwrap_function(x);
DstFuncDef *def = fun->def;
if (def->name) {
const uint8_t *n = def->name;
dst_buffer_push_cstring(buffer, "<function ");
dst_buffer_push_bytes(buffer, n, dst_string_length(n));
dst_buffer_push_u8(buffer, '>');
break;
}
goto fallthrough;
}
fallthrough:
default:
string_description_b(buffer, dst_type_names[dst_type(x)] + 1, dst_unwrap_pointer(x));
@ -423,6 +436,15 @@ const uint8_t *dst_description(Dst x) {
}
goto fallthrough;
}
case DST_FUNCTION:
{
DstFunction *fun = dst_unwrap_function(x);
DstFuncDef *def = fun->def;
if (def->name) {
return dst_formatc("<function %S>", def->name);
}
goto fallthrough;
}
fallthrough:
default:
return string_description(dst_type_names[dst_type(x)] + 1, dst_unwrap_pointer(x));

2
src/core/symcache.c
View File

@ -209,8 +209,10 @@ static void inc_gensym(void) {
for (int i = sizeof(gensym_counter) - 2; i; i--) {
if (gensym_counter[i] == '9') {
gensym_counter[i] = 'a';
break;
} else if (gensym_counter[i] == 'z') {
gensym_counter[i] = 'A';
break;
} else if (gensym_counter[i] == 'Z') {
gensym_counter[i] = '0';
} else {

66
src/core/vm.c
View File

@ -190,6 +190,11 @@ static void *op_lookup[255] = {
&&label_DOP_MAKE_STRUCT,
&&label_DOP_MAKE_TABLE,
&&label_DOP_MAKE_TUPLE,
&&label_DOP_NUMERIC_LESS_THAN,
&&label_DOP_NUMERIC_LESS_THAN_EQUAL,
&&label_DOP_NUMERIC_GREATER_THAN,
&&label_DOP_NUMERIC_GREATER_THAN_EQUAL,
&&label_DOP_NUMERIC_EQUAL,
&&label_unknown_op
};
#else
@ -257,6 +262,23 @@ static void *op_lookup[255] = {
vm_next();\
}
#define vm_numcomp(op)\
{\
Dst op1 = stack[oparg(2, 0xFF)];\
Dst op2 = stack[oparg(3, 0xFF)];\
vm_assert_types(op1, DST_TFLAG_NUMBER);\
vm_assert_types(op2, DST_TFLAG_NUMBER);\
stack[oparg(1, 0xFF)] = dst_wrap_boolean(dst_checktype(op1, DST_INTEGER)\
? (dst_checktype(op2, DST_INTEGER)\
? dst_unwrap_integer(op1) op dst_unwrap_integer(op2)\
: (double)dst_unwrap_integer(op1) op dst_unwrap_real(op2))\
: (dst_checktype(op2, DST_INTEGER)\
? dst_unwrap_real(op1) op (double)dst_unwrap_integer(op2)\
: dst_unwrap_real(op1) op dst_unwrap_real(op2)));\
pc++;\
vm_next();\
}
/* Main interpreter loop. Semantically is a switch on
* (*pc & 0xFF) inside of an infinte loop. */
VM_START();
@ -325,6 +347,21 @@ static void *op_lookup[255] = {
VM_OP(DOP_MULTIPLY)
vm_binop(*);
VM_OP(DOP_NUMERIC_LESS_THAN)
vm_numcomp(<);
VM_OP(DOP_NUMERIC_LESS_THAN_EQUAL)
vm_numcomp(<=);
VM_OP(DOP_NUMERIC_GREATER_THAN)
vm_numcomp(>);
VM_OP(DOP_NUMERIC_GREATER_THAN_EQUAL)
vm_numcomp(>=);
VM_OP(DOP_NUMERIC_EQUAL)
vm_numcomp(==);
VM_OP(DOP_DIVIDE_INTEGER)
vm_assert(dst_unwrap_integer(stack[oparg(3, 0xFF)]) != 0, "integer divide error");
vm_assert(!(dst_unwrap_integer(stack[oparg(3, 0xFF)]) == -1 &&
@ -385,6 +422,7 @@ static void *op_lookup[255] = {
VM_OP(DOP_BNOT)
stack[oparg(1, 0xFF)] = dst_wrap_integer(~dst_unwrap_integer(stack[oparg(2, 0xFFFF)]));
++pc;
vm_next();
VM_OP(DOP_SHIFT_RIGHT_UNSIGNED)
@ -730,7 +768,8 @@ static void *op_lookup[255] = {
if (dst_checktype(callee, DST_FUNCTION)) {
func = dst_unwrap_function(callee);
dst_stack_frame(stack)->pc = pc;
dst_fiber_funcframe(fiber, func);
if (dst_fiber_funcframe(fiber, func))
goto vm_arity_error;
stack = fiber->data + fiber->frame;
pc = func->def->bytecode;
vm_checkgc_next();
@ -756,7 +795,8 @@ static void *op_lookup[255] = {
Dst callee = stack[oparg(1, 0xFFFFFF)];
if (dst_checktype(callee, DST_FUNCTION)) {
func = dst_unwrap_function(callee);
dst_fiber_funcframe_tail(fiber, func);
if (dst_fiber_funcframe_tail(fiber, func))
goto vm_arity_error;
stack = fiber->data + fiber->frame;
pc = func->def->bytecode;
vm_checkgc_next();
@ -1152,6 +1192,19 @@ static void *op_lookup[255] = {
goto vm_reset;
}
/* Handle function calls with bad arity */
vm_arity_error:
{
int32_t nargs = fiber->stacktop - fiber->stackstart;
retreg = dst_wrap_string(dst_formatc("%V called with %d argument%s, expected %d",
dst_wrap_function(func),
nargs,
nargs == 1 ? "" : "s",
func->def->arity));
signal = DST_SIGNAL_ERROR;
goto vm_exit;
}
/* Resume a child fiber */
vm_resume_child:
{
@ -1255,14 +1308,17 @@ DstSignal dst_call(
*f = fiber;
for (i = 0; i < argn; i++)
dst_fiber_push(fiber, argv[i]);
dst_fiber_funcframe(fiber, fiber->root);
if (dst_fiber_funcframe(fiber, fiber->root)) {
*out = dst_cstringv("arity mismatch");
return DST_SIGNAL_ERROR;
}
/* Prevent push an extra value on the stack */
dst_fiber_set_status(fiber, DST_STATUS_PENDING);
return dst_continue(fiber, dst_wrap_nil(), out);
}
/* Setup VM */
int dst_init() {
int dst_init(void) {
/* Garbage collection */
dst_vm_blocks = NULL;
dst_vm_next_collection = 0;
@ -1283,7 +1339,7 @@ int dst_init() {
}
/* Clear all memory associated with the VM */
void dst_deinit() {
void dst_deinit(void) {
dst_clear_memory();
dst_symcache_deinit();
free(dst_vm_roots);

22
src/include/dst/dst.h
View File

@ -515,9 +515,9 @@ Dst dst_wrap_abstract(void *x);
/* Hold components of arguments passed to DstCFunction. */
struct DstArgs {
int32_t n;
Dst *v;
Dst *ret;
int32_t n;
};
/* Fiber flags */
@ -811,6 +811,11 @@ enum DstOpCode {
DOP_MAKE_STRUCT,
DOP_MAKE_TABLE,
DOP_MAKE_TUPLE,
DOP_NUMERIC_LESS_THAN,
DOP_NUMERIC_LESS_THAN_EQUAL,
DOP_NUMERIC_GREATER_THAN,
DOP_NUMERIC_GREATER_THAN_EQUAL,
DOP_NUMERIC_EQUAL,
DOP_INSTRUCTION_COUNT
};
@ -855,16 +860,16 @@ enum DstCompileStatus {
DST_COMPILE_ERROR
};
struct DstCompileResult {
enum DstCompileStatus status;
DstFuncDef *funcdef;
const uint8_t *error;
DstFiber *macrofiber;
DstSourceMapping error_mapping;
enum DstCompileStatus status;
};
DstCompileResult dst_compile(Dst source, DstTable *env, const uint8_t *where);
/* Get the default environment for dst */
DstTable *dst_stl_env();
DstTable *dst_core_env(void);
int dst_dobytes(DstTable *env, const uint8_t *bytes, int32_t len, const char *sourcePath);
int dst_dostring(DstTable *env, const char *str, const char *sourcePath);
@ -939,7 +944,7 @@ void dst_puts(const uint8_t *str);
const uint8_t *dst_symbol(const uint8_t *str, int32_t len);
const uint8_t *dst_symbol_from_string(const uint8_t *str);
const uint8_t *dst_csymbol(const char *str);
const uint8_t *dst_symbol_gen();
const uint8_t *dst_symbol_gen(void);
#define dst_symbolv(str, len) dst_wrap_symbol(dst_symbol((str), (len)))
#define dst_csymbolv(cstr) dst_wrap_symbol(dst_csymbol(cstr))
@ -1033,10 +1038,6 @@ void dst_env_cfuns(DstTable *env, const DstReg *cfuns);
DstBindingType dst_env_resolve(DstTable *env, const uint8_t *sym, Dst *out);
DstTable *dst_env_arg(DstArgs args);
/* STL */
#define DST_STL_NOGCROOT 1
DstTable *dst_stl_env(int flags);
/* C Function helpers */
int dst_arity_err(DstArgs args, int32_t n, const char *prefix);
int dst_type_err(DstArgs args, int32_t n, DstType expected);
@ -1058,6 +1059,9 @@ int dst_lib_parse(DstArgs args);
int dst_lib_asm(DstArgs args);
int dst_lib_compile(DstArgs args);
/* Helpers for writing modules */
#define DST_MODULE_ENTRY int _dst_init
/***** END SECTION MAIN *****/
/***** START SECTION MACROS *****/
@ -1151,7 +1155,7 @@ int dst_lib_compile(DstArgs args);
#define DST_ARG_CFUNCTION(DEST, A, N) _DST_ARG(DST_CFUNCTION, cfunction, DEST, A, N)
#define DST_ARG_ABSTRACT(DEST, A, N) _DST_ARG(DST_ABSTRACT, abstract, DEST, A, N)
#define DST_RETURN_NIL(A) return DST_SIGNAL_OK
#define DST_RETURN_NIL(A) do { return DST_SIGNAL_OK; } while (0)
#define DST_RETURN_FALSE(A) DST_RETURN(A, dst_wrap_false())
#define DST_RETURN_TRUE(A) DST_RETURN(A, dst_wrap_true())
#define DST_RETURN_BOOLEAN(A, X) DST_RETURN(A, dst_wrap_boolean(X))

16
src/mainclient/init.dst
View File

@ -1,5 +1,5 @@
# Copyright 2017-2018 (C) Calvin Rose
(table.setproto @{ 1 2} @{})
(do
(var *should-repl* :private false)
@ -23,17 +23,17 @@
-- Stop handling options`)
(os.exit 0)
1)
"v" (fn [] (print VERSION) (os.exit 0) 1)
"s" (fn [] (:= *raw-stdin* true) (:= *should-repl* true) 1)
"r" (fn [] (:= *should-repl* true) 1)
"p" (fn [] (:= *exit-on-error* false) 1)
"-" (fn [] (:= *handleopts* false) 1)
"e" (fn [i]
"v" (fn @[] (print VERSION) (os.exit 0) 1)
"s" (fn @[] (:= *raw-stdin* true) (:= *should-repl* true) 1)
"r" (fn @[] (:= *should-repl* true) 1)
"p" (fn @[] (:= *exit-on-error* false) 1)
"-" (fn @[] (:= *handleopts* false) 1)
"e" (fn @[i]
(:= *no-file* false)
(eval (get args (+ i 1)))
2)})
(defn- dohandler [n i]
(defn- dohandler @[n i]
(def h (get handlers n))
(if h (h i) (print "unknown flag -" n)))

2
src/mainclient/main.c
View File

@ -32,7 +32,7 @@ int main(int argc, char **argv) {
/* Set up VM */
dst_init();
env = dst_stl_env(0);
env = dst_core_env();
/* Create args tuple */
args = dst_array(argc);

2
test/suite0.dst
View File

@ -155,7 +155,7 @@
# yield tests
(def t (fiber.new (fn [] (yield 1) (yield 2) 3)))
(def t (fiber.new (fn @[] (yield 1) (yield 2) 3)))
(assert (= 1 (resume t)) "initial transfer to new fiber")
(assert (= 2 (resume t)) "second transfer to fiber")

18
test/suite1.dst
View File

@ -43,7 +43,7 @@
(defn assert-many [f n e]
(var good true)
(loop [i :range [0 n]]
(if (not (f i))
(if (not (f))
(:= good false)))
(assert good e))
@ -76,9 +76,9 @@
# More fiber semantics
(var myvar 0)
(defn fiberstuff []
(defn fiberstuff @[]
(++ myvar)
(def f (fiber.new (fn [] (++ myvar) (debug) (++ myvar))))
(def f (fiber.new (fn @[] (++ myvar) (debug) (++ myvar))))
(resume f)
(++ myvar))
@ -198,4 +198,16 @@
(def xs (apply1 tuple (for [x :range [0 10] :when (even? x)] (tuple (/ x 2) x))))
(assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "for macro 1")
# Some testing for not=
(assert (not= 1 1 0) "not= 1")
(assert (not= 0 1 1) "not= 2")
# Closure in while loop
(def closures (for [i :range [0 5]] (fn [] i)))
(assert (= 0 ((get closures 0))) "closure in loop 0")
(assert (= 1 ((get closures 1))) "closure in loop 1")
(assert (= 2 ((get closures 2))) "closure in loop 2")
(assert (= 3 ((get closures 3))) "closure in loop 3")
(assert (= 4 ((get closures 4))) "closure in loop 4")
(end-suite)