mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2025-10-16 16:27:40 +00:00
Code Issues 1 Releases Wiki Activity

Fix web build again, simplify fibers and fiber

Browse Source 
implementation code.
This commit is contained in:
Calvin Rose
2018-11-26 09:02:07 -05:00
parent beffba9f04
commit 8bfea73ee7
14 changed files with 269 additions and 283 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@@ -29,7 +29,7 @@ LIBDIR=$(PREFIX)/lib
BINDIR=$(PREFIX)/bin BINDIR=$(PREFIX)/bin
JANET_VERSION?="\"commit-$(shell git log --pretty=format:'%h' -n 1)\"" JANET_VERSION?="\"commit-$(shell git log --pretty=format:'%h' -n 1)\""
#CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -fpic -g #CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -fpic -g -DJANET_VERSION=$(JANET_VERSION)
CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -fpic -O2 -fvisibility=hidden \ CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -fpic -O2 -fvisibility=hidden \
-DJANET_VERSION=$(JANET_VERSION) -DJANET_VERSION=$(JANET_VERSION)
CLIBS=-lm -ldl CLIBS=-lm -ldl
@@ -112,7 +112,8 @@ $(JANET_LIBRARY): $(JANET_CORE_OBJECTS)
EMCC=emcc EMCC=emcc
EMCCFLAGS=-std=c99 -Wall -Wextra -Isrc/include -O2 \ EMCCFLAGS=-std=c99 -Wall -Wextra -Isrc/include -O2 \
-s EXTRA_EXPORTED_RUNTIME_METHODS='["cwrap"]' \ -s EXTRA_EXPORTED_RUNTIME_METHODS='["cwrap"]' \
-s ALLOW_MEMORY_GROWTH=1 -s WASM=1 \ -s ALLOW_MEMORY_GROWTH=1 \
-s AGGRESSIVE_VARIABLE_ELIMINATION=1 \
-DJANET_VERSION=$(JANET_VERSION) -DJANET_VERSION=$(JANET_VERSION)
JANET_EMTARGET=janet.js JANET_EMTARGET=janet.js
JANET_WEB_SOURCES=$(JANET_CORE_SOURCES) $(JANET_WEBCLIENT_SOURCES) JANET_WEB_SOURCES=$(JANET_CORE_SOURCES) $(JANET_WEBCLIENT_SOURCES)

88
src/core/core.janet
View File

@@ -371,7 +371,7 @@
:generate (do :generate (do
(def $fiber (gensym)) (def $fiber (gensym))
(def $yieldval (gensym)) (def $yieldval (gensym))
(def preds @['and (def preds @['and
(do (do
(def s (gensym)) (def s (gensym))
(tuple 'do (tuple 'do
@@ -417,7 +417,7 @@
that yields all values inside the loop in order. See loop for details." that yields all values inside the loop in order. See loop for details."
[head & body] [head & body]
(tuple fiber.new (tuple fiber.new
(tuple 'fn [tuple '&] (tuple 'fn '[&]
(tuple 'loop head (tuple yield (tuple.prepend body 'do)))))) (tuple 'loop head (tuple yield (tuple.prepend body 'do))))))
(defn sum [xs] (defn sum [xs]
@@ -433,7 +433,7 @@
(defmacro coro (defmacro coro
"A wrapper for making fibers. Same as (fiber.new (fn [&] ...body))." "A wrapper for making fibers. Same as (fiber.new (fn [&] ...body))."
[& body] [& body]
(tuple fiber.new (apply tuple 'fn [tuple '&] body))) (tuple fiber.new (apply tuple 'fn '[&] body)))
(defmacro if-let (defmacro if-let
"Takes the first one or two forms in a vector and if both are true binds "Takes the first one or two forms in a vector and if both are true binds
@@ -1078,15 +1078,15 @@ value, one key will be ignored."
(def method (apply symbol (tuple.slice parts 1))) (def method (apply symbol (tuple.slice parts 1)))
(tuple (tuple 'quote method) self)) (tuple (tuple 'quote method) self))
(def class (def class
"(class obj)\n\nGets the class of an object." "(class obj)\n\nGets the class of an object."
table.getproto) table.getproto)
(defn instance-of? (defn instance-of?
"Checks if an object is an instance of a class." "Checks if an object is an instance of a class."
[class obj] [class obj]
(if obj (or (if obj (or
(= class obj) (= class obj)
(instance-of? class (table.getproto obj))))) (instance-of? class (table.getproto obj)))))
(defmacro call (defmacro call
@@ -1169,41 +1169,12 @@ value, one key will be ignored."
# The parser object # The parser object
(def p (parser.new)) (def p (parser.new))
# Fiber stream of characters
(def chars
(coro
(def buf @"")
(var len 1)
(while (< 0 len)
(buffer.clear buf)
(chunks buf p)
(:= len (length buf))
(loop [i :range [0 len]]
(yield (get buf i))))
0))
# Fiber stream of values
(def vals
(coro
(while going
(case (parser.status p)
:full (yield (parser.produce p))
:error (do
(def (line col) (parser.where p))
(onerr where "parse" (string (parser.error p) " on line " line ", column " col)))
(case (fiber.status chars)
:new (parser.byte p (resume chars nil))
:pending (parser.byte p (resume chars nil))
(:= going false))))
(when (not= :root (parser.status p))
(onerr where "parse" "unexpected end of source"))))
# Evaluate 1 source form # Evaluate 1 source form
(defn eval1 [source] (defn eval1 [source]
(var good true) (var good true)
(def f (def f
(fiber.new (fiber.new
(fn [&] (fn _thunk [&]
(def res (compile source env where)) (def res (compile source env where))
(if (= (type res) :function) (if (= (type res) :function)
(res) (res)
@@ -1226,10 +1197,28 @@ value, one key will be ignored."
(onvalue res) (onvalue res)
(onerr where "runtime" res f))))) (onerr where "runtime" res f)))))
# Run loop
(def oldenv *env*) (def oldenv *env*)
(:= *env* env) (:= *env* env)
(while going (eval1 (resume vals nil)))
# Run loop
(def buf @"")
(while going
(buffer.clear buf)
(chunks buf p)
(var pindex 0)
(def len (length buf))
(if (= len 0) (:= going false))
(while (> len pindex)
(+= pindex (parser.consume p buf pindex))
(case (parser.status p)
:full (eval1 (parser.produce p))
:error (do
(def (line col) (parser.where p))
(onerr where "parse"
(string (parser.error p)
" on line " line
", column " col))))))
(:= *env* oldenv) (:= *env* oldenv)
env) env)
@@ -1242,19 +1231,21 @@ value, one key will be ignored."
"\n") "\n")
(when f (when f
(loop (loop
[{:function func [nf :in (array.reverse (fiber.lineage f))
:before (file.write stderr " (fiber)\n")
{:function func
:tail tail :tail tail
:pc pc :pc pc
:c c :c c
:name name :name name
:source source :source source
:line source-line :line source-line
:column source-col} :in (fiber.stack f)] :column source-col} :in (fiber.stack nf)]
(file.write stderr " in") (file.write stderr " in")
(when c (file.write stderr " cfunction")) (when c (file.write stderr " cfunction"))
(if name (if name
(file.write stderr " " name) (file.write stderr " " name)
(when func (file.write stderr " " (string func)))) (when func (file.write stderr " <anonymous>")))
(if source (if source
(do (do
(file.write stderr " [" source "]") (file.write stderr " [" source "]")
@@ -1279,7 +1270,7 @@ value, one key will be ignored."
(def ret state) (def ret state)
(:= state nil) (:= state nil)
(when ret (when ret
(buffer.push-string buf ret) (buffer.push-string buf str)
(buffer.push-string buf "\n"))) (buffer.push-string buf "\n")))
(var returnval nil) (var returnval nil)
(run-context *env* chunks (fn [x] (:= returnval x)) default-error-handler "eval") (run-context *env* chunks (fn [x] (:= returnval x)) default-error-handler "eval")
@@ -1416,17 +1407,14 @@ value, one key will be ignored."
(defn repl (defn repl
"Run a repl. The first parameter is an optional function to call to "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." get a chunk of source code. Should return nil for end of file."
[getchunk onvalue onerr &] [chunks onvalue onerr &]
(def newenv (make-env)) (def newenv (make-env))
(default getchunk (fn [buf &] (default chunks (fn [&] (file.read stdin :line)))
(file.read stdin :line buf)))
(def buf @"")
(default onvalue (fn [x] (default onvalue (fn [x]
(put newenv '_ @{:value x}) (put newenv '_ @{:value x})
(print (string.pretty x 20 buf)) (print (string.pretty x 20))))
(buffer.clear buf)))
(default onerr default-error-handler) (default onerr default-error-handler)
(run-context newenv getchunk onvalue onerr "repl")) (run-context newenv chunks onvalue onerr "repl"))
(defn all-symbols (defn all-symbols
"Get all symbols available in the current environment." "Get all symbols available in the current environment."

47
src/core/fiber.c
View File

@@ -25,36 +25,49 @@
#include "state.h" #include "state.h"
#include "gc.h" #include "gc.h"
/* Initialize a new fiber */ static JanetFiber *make_fiber(int32_t capacity) {
JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity) { Janet *data;
JanetFiber *fiber = janet_gcalloc(JANET_MEMORY_FIBER, sizeof(JanetFiber)); JanetFiber *fiber = janet_gcalloc(JANET_MEMORY_FIBER, sizeof(JanetFiber));
if (capacity < 16) { if (capacity < 16) {
capacity = 16; capacity = 16;
} }
fiber->capacity = capacity; fiber->capacity = capacity;
if (capacity) { data = malloc(sizeof(Janet) * capacity);
Janet *data = malloc(sizeof(Janet) * capacity); if (NULL == data) {
if (NULL == data) { JANET_OUT_OF_MEMORY;
JANET_OUT_OF_MEMORY;
}
fiber->data = data;
} }
fiber->data = data;
fiber->maxstack = JANET_STACK_MAX; fiber->maxstack = JANET_STACK_MAX;
return janet_fiber_reset(fiber, callee);
}
/* Clear a fiber (reset it) */
JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee) {
fiber->frame = 0; fiber->frame = 0;
fiber->stackstart = JANET_FRAME_SIZE; fiber->stackstart = JANET_FRAME_SIZE;
fiber->stacktop = JANET_FRAME_SIZE; fiber->stacktop = JANET_FRAME_SIZE;
fiber->root = callee;
fiber->child = NULL; fiber->child = NULL;
fiber->flags = JANET_FIBER_MASK_YIELD; fiber->flags = JANET_FIBER_MASK_YIELD;
janet_fiber_set_status(fiber, JANET_STATUS_NEW); janet_fiber_set_status(fiber, JANET_STATUS_NEW);
return fiber; return fiber;
} }
/* Initialize a new fiber */
JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity) {
JanetFiber *fiber = make_fiber(capacity);
janet_fiber_funcframe(fiber, callee);
return fiber;
}
/* Clear a fiber (reset it) with argn values on the stack. */
JanetFiber *janet_fiber_n(JanetFunction *callee, int32_t capacity, const Janet *argv, int32_t argn) {
int32_t newstacktop;
JanetFiber *fiber = make_fiber(capacity);
newstacktop = fiber->stacktop + argn;
if (newstacktop >= fiber->capacity) {
janet_fiber_setcapacity(fiber, 2 * newstacktop);
}
memcpy(fiber->data + fiber->stacktop, argv, argn * sizeof(Janet));
fiber->stacktop = newstacktop;
janet_fiber_funcframe(fiber, callee);
return fiber;
}
/* Ensure that the fiber has enough extra capacity */ /* Ensure that the fiber has enough extra capacity */
void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n) { void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n) {
Janet *newData = realloc(fiber->data, sizeof(Janet) * n); Janet *newData = realloc(fiber->data, sizeof(Janet) * n);
@@ -284,8 +297,8 @@ static int cfun_new(JanetArgs args) {
JANET_MAXARITY(args, 2); JANET_MAXARITY(args, 2);
JANET_ARG_FUNCTION(func, args, 0); JANET_ARG_FUNCTION(func, args, 0);
if (func->def->flags & JANET_FUNCDEF_FLAG_FIXARITY) { if (func->def->flags & JANET_FUNCDEF_FLAG_FIXARITY) {
if (func->def->arity != 1) { if (func->def->arity != 0) {
JANET_THROW(args, "expected unit arity function in fiber constructor"); JANET_THROW(args, "expected nullary function in fiber constructor");
} }
} }
fiber = janet_fiber(func, 64); fiber = janet_fiber(func, 64);
@@ -460,7 +473,7 @@ static const JanetReg cfuns[] = {
"Create a new fiber with function body func. Can optionally " "Create a new fiber with function body func. Can optionally "
"take a set of signals to block from the current parent fiber " "take a set of signals to block from the current parent fiber "
"when called. The mask is specified as symbol where each character " "when called. The mask is specified as symbol where each character "
"is used to indicate a signal to block. " "is used to indicate a signal to block. The default sigmask is :y. "
"For example, \n\n" "For example, \n\n"
"\t(fiber.new myfun :e123)\n\n" "\t(fiber.new myfun :e123)\n\n"
"blocks error signals and user signals 1, 2 and 3. The signals are " "blocks error signals and user signals 1, 2 and 3. The signals are "

1
src/core/fiber.h
View File

@@ -34,7 +34,6 @@ extern JANET_THREAD_LOCAL JanetFiber *janet_vm_fiber;
#define janet_stack_frame(s) ((JanetStackFrame *)((s) - JANET_FRAME_SIZE)) #define janet_stack_frame(s) ((JanetStackFrame *)((s) - JANET_FRAME_SIZE))
#define janet_fiber_frame(f) janet_stack_frame((f)->data + (f)->frame) #define janet_fiber_frame(f) janet_stack_frame((f)->data + (f)->frame)
JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee);
void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n); void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n);
void janet_fiber_push(JanetFiber *fiber, Janet x); void janet_fiber_push(JanetFiber *fiber, Janet x);
void janet_fiber_push2(JanetFiber *fiber, Janet x, Janet y); void janet_fiber_push2(JanetFiber *fiber, Janet x, Janet y);

4
src/core/gc.c
View File

@@ -195,10 +195,6 @@ recur:
if (janet_gc_reachable(fiber)) if (janet_gc_reachable(fiber))
return; return;
janet_gc_mark(fiber); janet_gc_mark(fiber);
if (fiber->root)
janet_mark_function(fiber->root);
i = fiber->frame; i = fiber->frame;
j = fiber->stackstart - JANET_FRAME_SIZE; j = fiber->stackstart - JANET_FRAME_SIZE;
while (i > 0) { while (i > 0) {

49
src/core/marsh.c
View File

@@ -44,7 +44,8 @@ enum {
MR_NYI, MR_NYI,
MR_NRV, MR_NRV,
MR_C_STACKFRAME, MR_C_STACKFRAME,
MR_OVERFLOW MR_OVERFLOW,
MR_LIVEFIBER
} MarshalResult; } MarshalResult;
const char *mr_strings[] = { const char *mr_strings[] = {
@@ -53,7 +54,8 @@ const char *mr_strings[] = {
"type NYI", "type NYI",
"no registry value", "no registry value",
"fiber has c stack frame", "fiber has c stack frame",
"buffer overflow" "buffer overflow",
"alive fiber"
}; };
/* Lead bytes in marshaling protocol */ /* Lead bytes in marshaling protocol */
@@ -162,7 +164,7 @@ static void marshal_one_env(MarshalState *st, JanetFuncEnv *env, int flags) {
pushint(st, env->length); pushint(st, env->length);
if (env->offset) { if (env->offset) {
/* On stack variant */ /* On stack variant */
marshal_one_fiber(st, env->as.fiber, flags + 1); marshal_one(st, janet_wrap_fiber(env->as.fiber), flags + 1);
} else { } else {
/* Off stack variant */ /* Off stack variant */
for (int32_t i = 0; i < env->length; i++) for (int32_t i = 0; i < env->length; i++)
@@ -238,20 +240,21 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) {
} }
#define JANET_FIBER_FLAG_HASCHILD (1 << 29) #define JANET_FIBER_FLAG_HASCHILD (1 << 29)
#define JANET_STACKFRAME_HASENV 2 #define JANET_STACKFRAME_HASENV (1 << 30)
/* Marshal a fiber */ /* Marshal a fiber */
static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags) { static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags) {
int32_t fflags = fiber->flags;
if ((flags & 0xFFFF) > JANET_RECURSION_GUARD) if ((flags & 0xFFFF) > JANET_RECURSION_GUARD)
longjmp(st->err, MR_STACKOVERFLOW); longjmp(st->err, MR_STACKOVERFLOW);
if (fiber->child) fiber->flags |= JANET_FIBER_FLAG_HASCHILD; if (fiber->child) fflags |= JANET_FIBER_FLAG_HASCHILD;
janet_table_put(&st->seen, janet_wrap_fiber(fiber), janet_wrap_integer(st->nextid++)); if (janet_fiber_status(fiber) == JANET_STATUS_ALIVE)
pushint(st, fiber->flags); longjmp(st->err, MR_LIVEFIBER);
pushint(st, fflags);
pushint(st, fiber->frame); pushint(st, fiber->frame);
pushint(st, fiber->stackstart); pushint(st, fiber->stackstart);
pushint(st, fiber->stacktop); pushint(st, fiber->stacktop);
pushint(st, fiber->maxstack); pushint(st, fiber->maxstack);
marshal_one(st, janet_wrap_function(fiber->root), flags + 1);
/* Do frames */ /* Do frames */
int32_t i = fiber->frame; int32_t i = fiber->frame;
int32_t j = fiber->stackstart - JANET_FRAME_SIZE; int32_t j = fiber->stackstart - JANET_FRAME_SIZE;
@@ -272,8 +275,7 @@ static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags) {
i = frame->prevframe; i = frame->prevframe;
} }
if (fiber->child) if (fiber->child)
marshal_one_fiber(st, fiber->child, flags + 1); marshal_one(st, janet_wrap_fiber(fiber->child), flags + 1);
fiber->flags &= ~JANET_FIBER_FLAG_HASCHILD;
} }
/* The main body of the marshaling function. Is the main /* The main body of the marshaling function. Is the main
@@ -439,6 +441,7 @@ static void marshal_one(MarshalState *st, Janet x, int flags) {
goto done; goto done;
case JANET_FIBER: case JANET_FIBER:
{ {
MARK_SEEN();
pushbyte(st, LB_FIBER); pushbyte(st, LB_FIBER);
marshal_one_fiber(st, janet_unwrap_fiber(x), flags + 1); marshal_one_fiber(st, janet_unwrap_fiber(x), flags + 1);
} }
@@ -589,8 +592,11 @@ static const uint8_t *unmarshal_one_env(
int32_t offset = readint(st, &data); int32_t offset = readint(st, &data);
int32_t length = readint(st, &data); int32_t length = readint(st, &data);
if (offset) { if (offset) {
Janet fiberv;
/* On stack variant */ /* On stack variant */
data = unmarshal_one_fiber(st, data, &(env->as.fiber), flags); data = unmarshal_one(st, data, &fiberv, flags);
if (!janet_checktype(fiberv, JANET_FIBER)) longjmp(st->err, UMR_EXPECTED_FIBER);
env->as.fiber = janet_unwrap_fiber(fiberv);
/* Unmarshaling fiber may set values */ /* Unmarshaling fiber may set values */
if (env->offset != 0 && env->offset != offset) longjmp(st->err, UMR_UNKNOWN); if (env->offset != 0 && env->offset != offset) longjmp(st->err, UMR_UNKNOWN);
if (env->length != 0 && env->length != length) longjmp(st->err, UMR_UNKNOWN); if (env->length != 0 && env->length != length) longjmp(st->err, UMR_UNKNOWN);
@@ -763,7 +769,6 @@ static const uint8_t *unmarshal_one_fiber(
fiber->stackstart = 0; fiber->stackstart = 0;
fiber->stacktop = 0; fiber->stacktop = 0;
fiber->capacity = 0; fiber->capacity = 0;
fiber->root = NULL;
fiber->child = NULL; fiber->child = NULL;
/* Set frame later so fiber can be GCed at anytime if unmarshaling fails */ /* Set frame later so fiber can be GCed at anytime if unmarshaling fails */
@@ -782,19 +787,10 @@ static const uint8_t *unmarshal_one_fiber(
if ((int32_t)(frame + JANET_FRAME_SIZE) > fiber->stackstart || if ((int32_t)(frame + JANET_FRAME_SIZE) > fiber->stackstart ||
fiber->stackstart > fiber->stacktop || fiber->stackstart > fiber->stacktop ||
fiber->stacktop > fiber->maxstack) { fiber->stacktop > fiber->maxstack) {
printf("bad flags and ints.\n"); /* printf("bad flags and ints.\n"); */
goto error; goto error;
} }
/* Get root fuction */
Janet funcv;
data = unmarshal_one(st, data, &funcv, flags + 1);
if (!janet_checktype(funcv, JANET_FUNCTION)) {
printf("bad root func.\n");
goto error;
}
fiber->root = janet_unwrap_function(funcv);
/* Allocate stack memory */ /* Allocate stack memory */
fiber->capacity = fiber->stacktop + 10; fiber->capacity = fiber->stacktop + 10;
fiber->data = malloc(sizeof(Janet) * fiber->capacity); fiber->data = malloc(sizeof(Janet) * fiber->capacity);
@@ -808,7 +804,7 @@ static const uint8_t *unmarshal_one_fiber(
while (stack > 0) { while (stack > 0) {
JanetFunction *func; JanetFunction *func;
JanetFuncDef *def; JanetFuncDef *def;
JanetFuncEnv *env; JanetFuncEnv *env = NULL;
int32_t frameflags = readint(st, &data); int32_t frameflags = readint(st, &data);
int32_t prevframe = readint(st, &data); int32_t prevframe = readint(st, &data);
int32_t pcdiff = readint(st, &data); int32_t pcdiff = readint(st, &data);
@@ -821,7 +817,7 @@ static const uint8_t *unmarshal_one_fiber(
Janet funcv; Janet funcv;
data = unmarshal_one(st, data, &funcv, flags + 1); data = unmarshal_one(st, data, &funcv, flags + 1);
if (!janet_checktype(funcv, JANET_FUNCTION)) { if (!janet_checktype(funcv, JANET_FUNCTION)) {
printf("bad root func.\n"); /* printf("bad root func.\n"); */
goto error; goto error;
} }
func = janet_unwrap_function(funcv); func = janet_unwrap_function(funcv);
@@ -864,8 +860,11 @@ static const uint8_t *unmarshal_one_fiber(
/* Check for child fiber */ /* Check for child fiber */
if (fiber->flags & JANET_FIBER_FLAG_HASCHILD) { if (fiber->flags & JANET_FIBER_FLAG_HASCHILD) {
Janet fiberv;
fiber->flags &= ~JANET_FIBER_FLAG_HASCHILD; fiber->flags &= ~JANET_FIBER_FLAG_HASCHILD;
data = unmarshal_one_fiber(st, data, &(fiber->child), flags + 1); data = unmarshal_one(st, data, &fiberv, flags + 1);
if (!janet_checktype(fiberv, JANET_FIBER)) longjmp(st->err, UMR_EXPECTED_FIBER);
fiber->child = janet_unwrap_fiber(fiberv);
} }
/* Return data */ /* Return data */

25
src/core/parse.c
View File

@@ -643,10 +643,19 @@ static int cfun_consume(JanetArgs args) {
int32_t len; int32_t len;
JanetParser *p; JanetParser *p;
int32_t i; int32_t i;
JANET_FIXARITY(args, 2); JANET_MINARITY(args, 2);
JANET_MAXARITY(args, 3);
JANET_CHECKABSTRACT(args, 0, &janet_parse_parsertype); JANET_CHECKABSTRACT(args, 0, &janet_parse_parsertype);
p = (JanetParser *) janet_unwrap_abstract(args.v[0]); p = (JanetParser *) janet_unwrap_abstract(args.v[0]);
JANET_ARG_BYTES(bytes, len, args, 1); JANET_ARG_BYTES(bytes, len, args, 1);
if (args.n == 3) {
int32_t offset;
JANET_ARG_INTEGER(offset, args, 2);
if (offset < 0 || offset > len)
JANET_THROW(args, "invalid offset");
len -= offset;
bytes += offset;
}
for (i = 0; i < len; i++) { for (i = 0; i < len; i++) {
janet_parser_consume(p, bytes[i]); janet_parser_consume(p, bytes[i]);
switch (janet_parser_status(p)) { switch (janet_parser_status(p)) {
@@ -654,14 +663,10 @@ static int cfun_consume(JanetArgs args) {
case JANET_PARSE_PENDING: case JANET_PARSE_PENDING:
break; break;
default: default:
{ JANET_RETURN_INTEGER(args, i + 1);
JanetBuffer *b = janet_buffer(len - i);
janet_buffer_push_bytes(b, bytes + i + 1, len - i - 1);
JANET_RETURN_BUFFER(args, b);
}
} }
} }
JANET_RETURN(args, janet_wrap_nil()); JANET_RETURN_INTEGER(args, i);
} }
static int cfun_byte(JanetArgs args) { static int cfun_byte(JanetArgs args) {
@@ -786,10 +791,10 @@ static const JanetReg cfuns[] = {
"next value." "next value."
}, },
{"parser.consume", cfun_consume, {"parser.consume", cfun_consume,
"(parser.consume parser bytes)\n\n" "(parser.consume parser bytes [, index])\n\n"
"Input bytes into the parser and parse them. Will not throw errors " "Input bytes into the parser and parse them. Will not throw errors "
"if there is a parse error. Returns the bytes not consumed if the parser is " "if there is a parse error. Starts at the byte index given by index. Returns "
"full or errors, or nil if the parser is still pending." "the number of bytes read."
}, },
{"parser.byte", cfun_byte, {"parser.byte", cfun_byte,
"(parser.byte parser b)\n\n" "(parser.byte parser b)\n\n"

82
src/core/run.c
View File

@@ -22,46 +22,58 @@
#include <janet/janet.h> #include <janet/janet.h>
#include "state.h" #include "state.h"
#include "vector.h"
/* Error reporting */ /* Error reporting */
void janet_stacktrace(JanetFiber *fiber, const char *errtype, Janet err) { void janet_stacktrace(JanetFiber *fiber, const char *errtype, Janet err) {
int32_t fi;
const char *errstr = (const char *)janet_to_string(err); const char *errstr = (const char *)janet_to_string(err);
printf("%s error: %s\n", errtype, errstr); JanetFiber **fibers = NULL;
if (!fiber) return; fprintf(stderr, "%s error: %s\n", errtype, errstr);
int32_t i = fiber->frame;
while (i > 0) {
JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE);
JanetFuncDef *def = NULL;
i = frame->prevframe;
printf(" in");
if (frame->func) { while (fiber) {
def = frame->func->def; janet_v_push(fibers, fiber);
printf(" %s", def->name ? (const char *)def->name : "<anonymous>"); fiber = fiber->child;
if (def->source) { }
printf(" [%s]", (const char *)def->source);
} for (fi = janet_v_count(fibers) - 1; fi >= 0; fi--) {
} else { fiber = fibers[fi];
JanetCFunction cfun = (JanetCFunction)(frame->pc); int32_t i = fiber->frame;
if (cfun) { if (i > 0) fprintf(stderr, " (fiber)\n");
Janet name = janet_table_get(janet_vm_registry, janet_wrap_cfunction(cfun)); while (i > 0) {
if (!janet_checktype(name, JANET_NIL)) JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE);
printf(" %s", (const char *)janet_to_string(name)); JanetFuncDef *def = NULL;
} i = frame->prevframe;
} fprintf(stderr, " in");
if (frame->flags & JANET_STACKFRAME_TAILCALL) if (frame->func) {
printf(" (tailcall)"); def = frame->func->def;
if (frame->func && frame->pc) { fprintf(stderr, " %s", def->name ? (const char *)def->name : "<anonymous>");
int32_t off = (int32_t) (frame->pc - def->bytecode); if (def->source) {
if (def->sourcemap) { fprintf(stderr, " [%s]", (const char *)def->source);
JanetSourceMapping mapping = def->sourcemap[off]; }
printf(" on line %d, column %d", mapping.line, mapping.column);
} else { } else {
printf(" pc=%d", off); JanetCFunction cfun = (JanetCFunction)(frame->pc);
if (cfun) {
Janet name = janet_table_get(janet_vm_registry, janet_wrap_cfunction(cfun));
if (!janet_checktype(name, JANET_NIL))
fprintf(stderr, " %s", (const char *)janet_to_string(name));
else
fprintf(stderr, " <cfunction>");
}
} }
if (frame->flags & JANET_STACKFRAME_TAILCALL)
fprintf(stderr, " (tailcall)");
if (frame->func && frame->pc) {
int32_t off = (int32_t) (frame->pc - def->bytecode);
if (def->sourcemap) {
JanetSourceMapping mapping = def->sourcemap[off];
fprintf(stderr, " on line %d, column %d", mapping.line, mapping.column);
} else {
fprintf(stderr, " pc=%d", off);
}
}
fprintf(stderr, "\n");
} }
printf("\n");
} }
} }
@@ -86,7 +98,7 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char
if (cres.status == JANET_COMPILE_OK) { if (cres.status == JANET_COMPILE_OK) {
JanetFunction *f = janet_thunk(cres.funcdef); JanetFunction *f = janet_thunk(cres.funcdef);
JanetFiber *fiber = janet_fiber(f, 64); JanetFiber *fiber = janet_fiber(f, 64);
JanetSignal status = janet_run(fiber, &ret); JanetSignal status = janet_continue(fiber, janet_wrap_nil(), &ret);
if (status != JANET_SIGNAL_OK) { if (status != JANET_SIGNAL_OK) {
janet_stacktrace(fiber, "runtime", ret); janet_stacktrace(fiber, "runtime", ret);
errflags |= 0x01; errflags |= 0x01;
@@ -100,13 +112,13 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char
break; break;
case JANET_PARSE_ERROR: case JANET_PARSE_ERROR:
errflags |= 0x04; errflags |= 0x04;
printf("parse error: %s\n", janet_parser_error(&parser)); fprintf(stderr, "parse error: %s\n", janet_parser_error(&parser));
break; break;
case JANET_PARSE_PENDING: case JANET_PARSE_PENDING:
if (index >= len) { if (index >= len) {
if (dudeol) { if (dudeol) {
errflags |= 0x04; errflags |= 0x04;
printf("internal parse error: unexpected end of source\n"); fprintf(stderr, "internal parse error: unexpected end of source\n");
} else { } else {
dudeol = 1; dudeol = 1;
janet_parser_consume(&parser, '\n'); janet_parser_consume(&parser, '\n');

54
src/core/vm.c
View File

@@ -77,18 +77,6 @@ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
/* Setup fiber state */ /* Setup fiber state */
janet_vm_fiber = fiber; janet_vm_fiber = fiber;
janet_gcroot(janet_wrap_fiber(fiber)); janet_gcroot(janet_wrap_fiber(fiber));
janet_gcroot(in);
if (startstatus == JANET_STATUS_NEW) {
janet_fiber_push(fiber, in);
if (janet_fiber_funcframe(fiber, fiber->root)) {
janet_gcunroot(janet_wrap_fiber(fiber));
janet_gcunroot(in);
*out = janet_wrap_string(janet_formatc(
"Could not start fiber with function of arity %d",
fiber->root->def->arity));
return JANET_SIGNAL_ERROR;
}
}
janet_fiber_set_status(fiber, JANET_STATUS_ALIVE); janet_fiber_set_status(fiber, JANET_STATUS_ALIVE);
stack = fiber->data + fiber->frame; stack = fiber->data + fiber->frame;
pc = janet_stack_frame(stack)->pc; pc = janet_stack_frame(stack)->pc;
@@ -98,17 +86,17 @@ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
* Pulls out unsigned integers */ * Pulls out unsigned integers */
#define oparg(shift, mask) (((*pc) >> ((shift) << 3)) & (mask)) #define oparg(shift, mask) (((*pc) >> ((shift) << 3)) & (mask))
/* Check for child fiber. If there is a child, run child before self.
* This should only be hit when the current fiber is pending on a RESUME
* instruction. */
if (fiber->child) { if (fiber->child) {
/* Check for child fiber. If there is a child, run child before self.
* This should only be hit when the current fiber is pending on a RESUME
* instruction. */
retreg = in; retreg = in;
goto vm_resume_child; goto vm_resume_child;
} else if (fiber->flags & JANET_FIBER_FLAG_SIGNAL_WAITING) { } else if (startstatus != JANET_STATUS_NEW) {
/* Only should be hit if child is waiting on a SIGNAL instruction */
/* If waiting for response to signal, use input and increment pc */ /* If waiting for response to signal, use input and increment pc */
stack[oparg(1, 0xFF)] = in; stack[oparg(1, 0xFF)] = in;
pc++; pc++;
fiber->flags &= ~JANET_FIBER_FLAG_SIGNAL_WAITING;
} }
/* Use computed gotos for GCC and clang, otherwise use switch */ /* Use computed gotos for GCC and clang, otherwise use switch */
@@ -787,7 +775,8 @@ static void *op_lookup[255] = {
retreg = janet_wrap_nil(); retreg = janet_wrap_nil();
args.v = fiber->data + fiber->frame; args.v = fiber->data + fiber->frame;
args.ret = &retreg; args.ret = &retreg;
if ((signal = janet_unwrap_cfunction(callee)(args))) { if (janet_unwrap_cfunction(callee)(args)) {
signal = JANET_SIGNAL_ERROR;
goto vm_exit; goto vm_exit;
} }
goto vm_return_cfunc; goto vm_return_cfunc;
@@ -814,7 +803,8 @@ static void *op_lookup[255] = {
retreg = janet_wrap_nil(); retreg = janet_wrap_nil();
args.v = fiber->data + fiber->frame; args.v = fiber->data + fiber->frame;
args.ret = &retreg; args.ret = &retreg;
if ((signal = janet_unwrap_cfunction(callee)(args))) { if (janet_unwrap_cfunction(callee)(args)) {
signal = JANET_SIGNAL_ERROR;
goto vm_exit; goto vm_exit;
} }
goto vm_return_cfunc_tail; goto vm_return_cfunc_tail;
@@ -840,7 +830,6 @@ static void *op_lookup[255] = {
if (s < 0) s = 0; if (s < 0) s = 0;
signal = s; signal = s;
retreg = stack[oparg(2, 0xFF)]; retreg = stack[oparg(2, 0xFF)];
fiber->flags |= JANET_FIBER_FLAG_SIGNAL_WAITING;
goto vm_exit; goto vm_exit;
} }
@@ -1223,11 +1212,9 @@ static void *op_lookup[255] = {
{ {
JanetFiber *child = fiber->child; JanetFiber *child = fiber->child;
JanetFiberStatus status = janet_fiber_status(child); JanetFiberStatus status = janet_fiber_status(child);
if (status == JANET_STATUS_ALIVE || if (status == JANET_STATUS_ALIVE) vm_throw("cannot resume live fiber");
status == JANET_STATUS_DEAD || if (status == JANET_STATUS_DEAD) vm_throw("cannot resume dead fiber");
status == JANET_STATUS_ERROR) { if (status == JANET_STATUS_ERROR) vm_throw("cannot resume errored fiber");
vm_throw("cannot resume alive, dead, or errored fiber");
}
signal = janet_continue(child, retreg, &retreg); signal = janet_continue(child, retreg, &retreg);
if (signal != JANET_SIGNAL_OK) { if (signal != JANET_SIGNAL_OK) {
if (child->flags & (1 << signal)) { if (child->flags & (1 << signal)) {
@@ -1238,6 +1225,8 @@ static void *op_lookup[255] = {
/* Propogate signal */ /* Propogate signal */
goto vm_exit; goto vm_exit;
} }
} else {
fiber->child = NULL;
} }
stack[oparg(1, 0xFF)] = retreg; stack[oparg(1, 0xFF)] = retreg;
pc++; pc++;
@@ -1273,7 +1262,6 @@ static void *op_lookup[255] = {
{ {
janet_stack_frame(stack)->pc = pc; janet_stack_frame(stack)->pc = pc;
janet_vm_stackn--; janet_vm_stackn--;
janet_gcunroot(in);
janet_gcunroot(janet_wrap_fiber(fiber)); janet_gcunroot(janet_wrap_fiber(fiber));
janet_vm_fiber = old_vm_fiber; janet_vm_fiber = old_vm_fiber;
*out = retreg; *out = retreg;
@@ -1315,18 +1303,8 @@ JanetSignal janet_call(
const Janet *argv, const Janet *argv,
Janet *out, Janet *out,
JanetFiber **f) { JanetFiber **f) {
int32_t i; JanetFiber *fiber = janet_fiber_n(fun, 64, argv, argn);
JanetFiber *fiber = janet_fiber(fun, 64); if (f) *f = fiber;
if (f)
*f = fiber;
for (i = 0; i < argn; i++)
janet_fiber_push(fiber, argv[i]);
if (janet_fiber_funcframe(fiber, fiber->root)) {
*out = janet_cstringv("arity mismatch");
return JANET_SIGNAL_ERROR;
}
/* Prevent push an extra value on the stack */
janet_fiber_set_status(fiber, JANET_STATUS_PENDING);
return janet_continue(fiber, janet_wrap_nil(), out); return janet_continue(fiber, janet_wrap_nil(), out);
} }

12
src/include/janet/janet.h
View File

@@ -573,9 +573,6 @@ struct JanetArgs {
int32_t n; int32_t n;
}; };
/* Fiber flags */
#define JANET_FIBER_FLAG_SIGNAL_WAITING (1 << 30)
/* Fiber signal masks. */ /* Fiber signal masks. */
#define JANET_FIBER_MASK_ERROR 2 #define JANET_FIBER_MASK_ERROR 2
#define JANET_FIBER_MASK_DEBUG 4 #define JANET_FIBER_MASK_DEBUG 4
@@ -603,7 +600,6 @@ struct JanetArgs {
struct JanetFiber { struct JanetFiber {
Janet *data; Janet *data;
JanetFiber *child; /* Keep linked list of fibers for restarting pending fibers */ JanetFiber *child; /* Keep linked list of fibers for restarting pending fibers */
JanetFunction *root; /* First value */
int32_t frame; /* Index of the stack frame */ int32_t frame; /* Index of the stack frame */
int32_t stackstart; /* Beginning of next args */ int32_t stackstart; /* Beginning of next args */
int32_t stacktop; /* Top of stack. Where values are pushed and popped from. */ int32_t stacktop; /* Top of stack. Where values are pushed and popped from. */
@@ -1039,6 +1035,7 @@ JANET_API JanetKV *janet_table_find(JanetTable *t, Janet key);
/* Fiber */ /* Fiber */
JANET_API JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity); JANET_API JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity);
JANET_API JanetFiber *janet_fiber_n(JanetFunction *callee, int32_t capacity, const Janet *argv, int32_t argn);
#define janet_fiber_status(f) (((f)->flags & JANET_FIBER_STATUS_MASK) >> JANET_FIBER_STATUS_OFFSET) #define janet_fiber_status(f) (((f)->flags & JANET_FIBER_STATUS_MASK) >> JANET_FIBER_STATUS_OFFSET)
/* Treat similar types through uniform interfaces for iteration */ /* Treat similar types through uniform interfaces for iteration */
@@ -1100,7 +1097,6 @@ JANET_API JanetBuffer *janet_pretty(JanetBuffer *buffer, int depth, Janet x);
JANET_API int janet_init(void); JANET_API int janet_init(void);
JANET_API void janet_deinit(void); JANET_API void janet_deinit(void);
JANET_API JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out); JANET_API JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out);
#define janet_run(F,O) janet_continue(F, janet_wrap_nil(), O)
JANET_API JanetSignal janet_call(JanetFunction *fun, int32_t argn, const Janet *argv, Janet *out, JanetFiber **f); JANET_API JanetSignal janet_call(JanetFunction *fun, int32_t argn, const Janet *argv, Janet *out, JanetFiber **f);
JANET_API void janet_stacktrace(JanetFiber *fiber, const char *errtype, Janet err); JANET_API void janet_stacktrace(JanetFiber *fiber, const char *errtype, Janet err);
@@ -1132,9 +1128,9 @@ JANET_API int janet_typeabstract_err(JanetArgs args, int32_t n, const JanetAbstr
/***** START SECTION MACROS *****/ /***** START SECTION MACROS *****/
/* Macros */ /* Macros */
#define JANET_THROW(a, e) return (*((a).ret) = janet_cstringv(e), JANET_SIGNAL_ERROR) #define JANET_THROW(a, e) return (*((a).ret) = janet_cstringv(e), 1)
#define JANET_THROWV(a, v) return (*((a).ret) = (v), JANET_SIGNAL_ERROR) #define JANET_THROWV(a, v) return (*((a).ret) = (v), 1)
#define JANET_RETURN(a, v) return (*((a).ret) = (v), JANET_SIGNAL_OK) #define JANET_RETURN(a, v) return (*((a).ret) = (v), 0)
/* Early exit macros */ /* Early exit macros */
#define JANET_MAXARITY(A, N) do { if ((A).n > (N))\ #define JANET_MAXARITY(A, N) do { if ((A).n > (N))\

10
src/webclient/main.c
View File

@@ -34,8 +34,7 @@ static int repl_yield(JanetArgs args) {
JANET_FIXARITY(args, 2); JANET_FIXARITY(args, 2);
JANET_ARG_STRING(line_prompt, args, 0); JANET_ARG_STRING(line_prompt, args, 0);
JANET_ARG_BUFFER(line_buffer, args, 1); JANET_ARG_BUFFER(line_buffer, args, 1);
/* Suspend janet repl by throwing a user defined signal */ JANET_RETURN_NIL(args);
return JANET_SIGNAL_USER9;
} }
/* Re-enter the loop */ /* Re-enter the loop */
@@ -70,15 +69,12 @@ void repl_init(void) {
/* Set up VM */ /* Set up VM */
janet_init(); janet_init();
janet_register("repl-yield", repl_yield);
janet_register("js", cfun_js);
env = janet_core_env(); env = janet_core_env();
/* Janet line getter */
janet_def(env, "repl-yield", janet_wrap_cfunction(repl_yield), NULL); janet_def(env, "repl-yield", janet_wrap_cfunction(repl_yield), NULL);
janet_register("repl-yield", repl_yield);
/* Janet line getter */
janet_def(env, "js", janet_wrap_cfunction(cfun_js), NULL); janet_def(env, "js", janet_wrap_cfunction(cfun_js), NULL);
janet_register("js", cfun_js);
/* Run startup script */ /* Run startup script */
Janet ret; Janet ret;

15
src/webclient/webinit.janet
View File

@@ -1,11 +1,10 @@
# Copyright 2017-2018 (C) Calvin Rose # Copyright 2017-2018 (C) Calvin Rose
(print (string "Janet " janet.version " Copyright (C) 2017-2018 Calvin Rose")) (print (string "Janet " janet.version " Copyright (C) 2017-2018 Calvin Rose"))
(fiber.new (fiber.new (fn webrepl []
(fn [&] (repl (fn get-line [buf p]
(repl (fn [buf p] (def [line] (parser.where p))
(def [line] (parser.where p)) (def prompt (string "janet:" line ":" (parser.state p) "> "))
(def prompt (string "janet:" line ":" (parser.state p) "> ")) (repl-yield prompt buf)
(repl-yield prompt buf) (yield)
buf))) buf))))
:9e) # stop fiber on error signals and user9 signals

157
test/suite0.janet
View File

@@ -38,16 +38,16 @@
(assert (= -7 (% -20 13)) "modulo 2") (assert (= -7 (% -20 13)) "modulo 2")
(assert (order< nil false true (assert (order< nil false true
(fiber.new (fn [x] x)) (fiber.new (fn [] 1))
1 1.0 "hi" 1 1.0 "hi"
(quote hello) (quote hello)
(array 1 2 3) (array 1 2 3)
(tuple 1 2 3) (tuple 1 2 3)
(table "a" "b" "c" "d") (table "a" "b" "c" "d")
(struct 1 2 3 4) (struct 1 2 3 4)
(buffer "hi") (buffer "hi")
(fn [x] (+ x x)) (fn [x] (+ x x))
print) "type ordering") print) "type ordering")
(assert (= (string (buffer "123" "456")) (string @"123456")) "buffer literal") (assert (= (string (buffer "123" "456")) (string @"123456")) "buffer literal")
(assert (= (get {} 1) nil) "get nil from empty struct") (assert (= (get {} 1) nil) "get nil from empty struct")
@@ -109,13 +109,13 @@
# Closure in non function scope # Closure in non function scope
(def outerfun (fn [x y] (def outerfun (fn [x y]
(def c (do (def c (do
(def someval (+ 10 y)) (def someval (+ 10 y))
(def ctemp (if x (fn [] someval) (fn [] y))) (def ctemp (if x (fn [] someval) (fn [] y)))
ctemp ctemp
)) ))
(+ 1 2 3 4 5 6 7) (+ 1 2 3 4 5 6 7)
c)) c))
(assert (= ((outerfun 1 2)) 12) "inner closure 1") (assert (= ((outerfun 1 2)) 12) "inner closure 1")
(assert (= ((outerfun nil 2)) 2) "inner closure 2") (assert (= ((outerfun nil 2)) 2) "inner closure 2")
@@ -124,29 +124,29 @@
(assert (= '(1 2 3) (quote (1 2 3)) (tuple 1 2 3)) "quote shorthand") (assert (= '(1 2 3) (quote (1 2 3)) (tuple 1 2 3)) "quote shorthand")
((fn [] ((fn []
(var accum 1) (var accum 1)
(var count 0) (var count 0)
(while (< count 16) (while (< count 16)
(:= accum (<< accum 1)) (:= accum (<< accum 1))
(:= count (+ 1 count))) (:= count (+ 1 count)))
(assert (= accum 65536) "loop in closure"))) (assert (= accum 65536) "loop in closure")))
(var accum 1) (var accum 1)
(var count 0) (var count 0)
(while (< count 16) (while (< count 16)
(:= accum (<< accum 1)) (:= accum (<< accum 1))
(:= count (+ 1 count))) (:= count (+ 1 count)))
(assert (= accum 65536) "loop globally") (assert (= accum 65536) "loop globally")
(assert (= (struct 1 2 3 4 5 6 7 8) (struct 7 8 5 6 3 4 1 2)) "struct order does not matter 1") (assert (= (struct 1 2 3 4 5 6 7 8) (struct 7 8 5 6 3 4 1 2)) "struct order does not matter 1")
(assert (= (struct (assert (= (struct
:apple 1 :apple 1
6 :bork 6 :bork
'(1 2 3) 5) '(1 2 3) 5)
(struct (struct
6 :bork 6 :bork
'(1 2 3) 5 '(1 2 3) 5
:apple 1)) "struct order does not matter 2") :apple 1)) "struct order does not matter 2")
# Symbol function # Symbol function
@@ -154,9 +154,11 @@
# Fiber tests # Fiber tests
(def afiber (fiber.new (fn [x] (def afiber (fiber.new (fn []
(error (string "hello, " x))) :e)) (def x (yield))
(error (string "hello, " x))) :ye))
(resume afiber) # first resume to prime
(def afiber-result (resume afiber "world!")) (def afiber-result (resume afiber "world!"))
(assert (= afiber-result "hello, world!") "fiber error result") (assert (= afiber-result "hello, world!") "fiber error result")
@@ -214,30 +216,31 @@
# Merge sort # Merge sort
# Imperative merge sort merge # Imperative merge sort merge
(def merge (fn [xs ys] (defn merge
(def ret @[]) [xs ys]
(def xlen (length xs)) (def ret @[])
(def ylen (length ys)) (def xlen (length xs))
(var i 0) (def ylen (length ys))
(var j 0) (var i 0)
# Main merge (var j 0)
(while (if (< i xlen) (< j ylen)) # Main merge
(def xi (get xs i)) (while (if (< i xlen) (< j ylen))
(def yj (get ys j)) (def xi (get xs i))
(if (< xi yj) (def yj (get ys j))
(do (array.push ret xi) (:= i (+ i 1))) (if (< xi yj)
(do (array.push ret yj) (:= j (+ j 1))))) (do (array.push ret xi) (:= i (+ i 1)))
# Push rest of xs (do (array.push ret yj) (:= j (+ j 1)))))
(while (< i xlen) # Push rest of xs
(def xi (get xs i)) (while (< i xlen)
(array.push ret xi) (def xi (get xs i))
(:= i (+ i 1))) (array.push ret xi)
# Push rest of ys (:= i (+ i 1)))
(while (< j ylen) # Push rest of ys
(def yj (get ys j)) (while (< j ylen)
(array.push ret yj) (def yj (get ys j))
(:= j (+ j 1))) (array.push ret yj)
ret)) (:= j (+ j 1)))
ret)
(assert (apply <= (merge @[1 3 5] @[2 4 6])) "merge sort merge 1") (assert (apply <= (merge @[1 3 5] @[2 4 6])) "merge sort merge 1")
(assert (apply <= (merge @[1 2 3] @[4 5 6])) "merge sort merge 2") (assert (apply <= (merge @[1 2 3] @[4 5 6])) "merge sort merge 2")
@@ -248,12 +251,12 @@
(assert (not= (gensym) (gensym)) "two gensyms not equal") (assert (not= (gensym) (gensym)) "two gensyms not equal")
((fn [] ((fn []
(def syms (table)) (def syms (table))
(var count 0) (var count 0)
(while (< count 128) (while (< count 128)
(put syms (gensym) true) (put syms (gensym) true)
(:= count (+ 1 count))) (:= count (+ 1 count)))
(assert (= (length syms) 128) "many symbols"))) (assert (= (length syms) 128) "many symbols")))
# Let # Let
@@ -265,19 +268,19 @@
(defn dub [x] (+ x x)) (defn dub [x] (+ x x))
(assert (= 2 (dub 1)) "defn macro") (assert (= 2 (dub 1)) "defn macro")
(do
(defn trip [x] (+ x x x))
(assert (= 3 (trip 1)) "defn macro triple"))
(do (do
(var i 0) (defn trip [x] (+ x x x))
(when true (assert (= 3 (trip 1)) "defn macro triple"))
(++ i) (do
(++ i) (var i 0)
(++ i) (when true
(++ i) (++ i)
(++ i) (++ i)
(++ i)) (++ i)
(assert (= i 6) "when macro")) (++ i)
(++ i)
(++ i))
(assert (= i 6) "when macro"))
(end-suite) (end-suite)

3
test/suite1.janet
View File

@@ -169,7 +169,8 @@
(testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3") (testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3")
(testmarsh mapa "marshal function 4") (testmarsh mapa "marshal function 4")
(testmarsh reduce "marshal function 5") (testmarsh reduce "marshal function 5")
(testmarsh (fiber.new (fn [&] (yield 1) 2)) "marshal simple fiber") (testmarsh (fiber.new (fn [] (yield 1) 2)) "marshal simple fiber 1")
(testmarsh (fiber.new (fn [&] (yield 1) 2)) "marshal simple fiber 2")
# Large functions # Large functions
(def manydefs (fora [i :range [0 300]] (tuple 'def (gensym) (string "value_" i)))) (def manydefs (fora [i :range [0 300]] (tuple 'def (gensym) (string "value_" i))))