mirror of
https://github.com/janet-lang/janet
synced 2025-01-12 16:40:27 +00:00
Merge branch 'master' into net
This commit is contained in:
Calvin Rose
commit
8f1527712e
@ -10,4 +10,3 @@ tasks:
|
||||
gmake test
|
||||
sudo gmake install
|
||||
gmake test-install
|
||||
gmake test-amalg
|
||||
|
||||
@ -10,4 +10,3 @@ tasks:
|
||||
gmake test
|
||||
doas gmake install
|
||||
gmake test-install
|
||||
gmake test-amalg
|
||||
|
||||
@ -4,7 +4,6 @@ script:
|
||||
- make test
|
||||
- sudo make install
|
||||
- make test-install
|
||||
- make test-amalg
|
||||
- make build/janet-${TRAVIS_TAG}-${TRAVIS_OS_NAME}.tar.gz
|
||||
compiler:
|
||||
- clang
|
||||
|
||||
12
CHANGELOG.md
12
CHANGELOG.md
@ -1,6 +1,18 @@
|
||||
# Changelog
|
||||
All notable changes to this project will be documented in this file.
|
||||
|
||||
## Unreleased
|
||||
- Improve `janet_formatc` and `janet_panicf` formatters to be more like `string/format`.
|
||||
This makes it easier to make nice error messages from C.
|
||||
- Add `signal`
|
||||
- Add `fiber/can-resume?`
|
||||
- Allow fiber functions to accept arguments that are passed in via `resume`.
|
||||
- Make flychecking slightly less strict but more useful
|
||||
- Correct arity for `next`
|
||||
- Correct arity for `marshal`
|
||||
- Add `flush` and `eflush`
|
||||
- Add `prompt` and `return` on top of signal for user friendly delimited continuations.
|
||||
|
||||
## 1.7.0 - 2020-02-01
|
||||
- Remove `file/fileno` and `file/fdopen`.
|
||||
- Remove `==`, `not==`, `order<`, `order>`, `order<=`, and `order>=`. Instead, use the normal
|
||||
|
||||
76
Makefile
76
Makefile
@ -27,7 +27,7 @@ PREFIX?=/usr/local
|
||||
INCLUDEDIR?=$(PREFIX)/include
|
||||
BINDIR?=$(PREFIX)/bin
|
||||
LIBDIR?=$(PREFIX)/lib
|
||||
JANET_BUILD?="\"$(shell git log --pretty=format:'%h' -n 1 || 'local')\""
|
||||
JANET_BUILD?="\"$(shell git log --pretty=format:'%h' -n 1 || echo local)\""
|
||||
CLIBS=-lm -lpthread
|
||||
JANET_TARGET=build/janet
|
||||
JANET_LIBRARY=build/libjanet.so
|
||||
@ -37,8 +37,7 @@ MANPATH?=$(PREFIX)/share/man/man1/
|
||||
PKG_CONFIG_PATH?=$(LIBDIR)/pkgconfig
|
||||
DEBUGGER=gdb
|
||||
|
||||
CFLAGS:=$(CFLAGS) -std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fPIC -O2 -fvisibility=hidden \
|
||||
-DJANET_BUILD=$(JANET_BUILD)
|
||||
CFLAGS:=$(CFLAGS) -std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fPIC -O2 -fvisibility=hidden
|
||||
LDFLAGS:=$(LDFLAGS) -rdynamic
|
||||
|
||||
# For installation
|
||||
@ -48,13 +47,13 @@ LDCONFIG:=ldconfig "$(LIBDIR)"
|
||||
UNAME:=$(shell uname -s)
|
||||
ifeq ($(UNAME), Darwin)
|
||||
CLIBS:=$(CLIBS) -ldl
|
||||
LDCONFIG:=
|
||||
LDCONFIG:=true
|
||||
else ifeq ($(UNAME), Linux)
|
||||
CLIBS:=$(CLIBS) -lrt -ldl
|
||||
endif
|
||||
# For other unix likes, add flags here!
|
||||
ifeq ($(UNAME), Haiku)
|
||||
LDCONFIG:=
|
||||
LDCONFIG:=true
|
||||
LDFLAGS=-Wl,--export-dynamic
|
||||
endif
|
||||
|
||||
@ -130,14 +129,15 @@ JANET_BOOT_HEADERS=src/boot/tests.h
|
||||
##########################################################
|
||||
|
||||
JANET_BOOT_OBJECTS=$(patsubst src/%.c,build/%.boot.o,$(JANET_CORE_SOURCES) $(JANET_BOOT_SOURCES))
|
||||
BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) $(CFLAGS)
|
||||
|
||||
$(JANET_BOOT_OBJECTS): $(JANET_BOOT_HEADERS)
|
||||
|
||||
build/%.boot.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS)
|
||||
$(CC) $(CFLAGS) -DJANET_BOOTSTRAP -o $@ -c $<
|
||||
$(CC) $(BOOT_CFLAGS) -o $@ -c $<
|
||||
|
||||
build/janet_boot: $(JANET_BOOT_OBJECTS)
|
||||
$(CC) $(CFLAGS) -DJANET_BOOTSTRAP -o $@ $(JANET_BOOT_OBJECTS) $(CLIBS)
|
||||
$(CC) $(BOOT_CFLAGS) -o $@ $(JANET_BOOT_OBJECTS) $(CLIBS)
|
||||
|
||||
# Now the reason we bootstrap in the first place
|
||||
build/janet.c: build/janet_boot src/boot/boot.janet
|
||||
@ -231,7 +231,7 @@ build/doc.html: $(JANET_TARGET) tools/gendoc.janet
|
||||
|
||||
SONAME=libjanet.so.1
|
||||
|
||||
.PHONY: build/janet.pc
|
||||
.INTERMEDIATE: build/janet.pc
|
||||
build/janet.pc: $(JANET_TARGET)
|
||||
echo 'prefix=$(PREFIX)' > $@
|
||||
echo 'exec_prefix=$${prefix}' >> $@
|
||||
@ -247,33 +247,33 @@ build/janet.pc: $(JANET_TARGET)
|
||||
echo 'Libs.private: $(CLIBS)' >> $@
|
||||
|
||||
install: $(JANET_TARGET) build/janet.pc
|
||||
mkdir -p '$(BINDIR)'
|
||||
cp $(JANET_TARGET) '$(BINDIR)/janet'
|
||||
mkdir -p '$(INCLUDEDIR)/janet'
|
||||
cp -rf $(JANET_HEADERS) '$(INCLUDEDIR)/janet'
|
||||
mkdir -p '$(JANET_PATH)'
|
||||
mkdir -p '$(LIBDIR)'
|
||||
cp $(JANET_LIBRARY) '$(LIBDIR)/libjanet.so.$(shell $(JANET_TARGET) -e '(print janet/version)')'
|
||||
cp $(JANET_STATIC_LIBRARY) '$(LIBDIR)/libjanet.a'
|
||||
ln -sf $(SONAME) '$(LIBDIR)/libjanet.so'
|
||||
ln -sf libjanet.so.$(shell $(JANET_TARGET) -e '(print janet/version)') $(LIBDIR)/$(SONAME)
|
||||
cp -rf auxbin/* '$(BINDIR)'
|
||||
mkdir -p '$(MANPATH)'
|
||||
cp janet.1 '$(MANPATH)'
|
||||
cp jpm.1 '$(MANPATH)'
|
||||
mkdir -p '$(PKG_CONFIG_PATH)'
|
||||
cp build/janet.pc '$(PKG_CONFIG_PATH)/janet.pc'
|
||||
-$(LDCONFIG)
|
||||
mkdir -p '$(DESTDIR)$(BINDIR)'
|
||||
cp $(JANET_TARGET) '$(DESTDIR)$(BINDIR)/janet'
|
||||
mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet'
|
||||
cp -rf $(JANET_HEADERS) '$(DESTDIR)$(INCLUDEDIR)/janet'
|
||||
mkdir -p '$(DESTDIR)$(JANET_PATH)'
|
||||
mkdir -p '$(DESTDIR)$(LIBDIR)'
|
||||
cp $(JANET_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.so.$(shell $(JANET_TARGET) -e '(print janet/version)')'
|
||||
cp $(JANET_STATIC_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.a'
|
||||
ln -sf $(SONAME) '$(DESTDIR)$(LIBDIR)/libjanet.so'
|
||||
ln -sf libjanet.so.$(shell $(JANET_TARGET) -e '(print janet/version)') $(DESTDIR)$(LIBDIR)/$(SONAME)
|
||||
cp -rf auxbin/* '$(DESTDIR)$(BINDIR)'
|
||||
mkdir -p '$(DESTDIR)$(MANPATH)'
|
||||
cp janet.1 '$(DESTDIR)$(MANPATH)'
|
||||
cp jpm.1 '$(DESTDIR)$(MANPATH)'
|
||||
mkdir -p '$(DESTDIR)$(PKG_CONFIG_PATH)'
|
||||
cp build/janet.pc '$(DESTDIR)$(PKG_CONFIG_PATH)/janet.pc'
|
||||
[ -z '$(DESTDIR)' ] && $(LDCONFIG) || true
|
||||
|
||||
uninstall:
|
||||
-rm '$(BINDIR)/janet'
|
||||
-rm '$(BINDIR)/jpm'
|
||||
-rm -rf '$(INCLUDEDIR)/janet'
|
||||
-rm -rf '$(LIBDIR)'/libjanet.*
|
||||
-rm '$(PKG_CONFIG_PATH)/janet.pc'
|
||||
-rm '$(MANPATH)/janet.1'
|
||||
-rm '$(MANPATH)/jpm.1'
|
||||
# -rm -rf '$(JANET_PATH)'/* - err on the side of correctness here
|
||||
-rm '$(DESTDIR)$(BINDIR)/janet'
|
||||
-rm '$(DESTDIR)$(BINDIR)/jpm'
|
||||
-rm -rf '$(DESTDIR)$(INCLUDEDIR)/janet'
|
||||
-rm -rf '$(DESTDIR)$(LIBDIR)'/libjanet.*
|
||||
-rm '$(DESTDIR)$(PKG_CONFIG_PATH)/janet.pc'
|
||||
-rm '$(DESTDIR)$(MANPATH)/janet.1'
|
||||
-rm '$(DESTDIR)$(MANPATH)/jpm.1'
|
||||
# -rm -rf '$(DESTDIR)$(JANET_PATH)'/* - err on the side of correctness here
|
||||
|
||||
#################
|
||||
##### Other #####
|
||||
@ -302,15 +302,5 @@ test-install:
|
||||
cd test/install && jpm --verbose --test --modpath=. install https://github.com/janet-lang/path.git
|
||||
cd test/install && jpm --verbose --test --modpath=. install https://github.com/janet-lang/argparse.git
|
||||
|
||||
build/embed_janet.o: build/janet.c $(JANET_HEADERS)
|
||||
$(CC) $(CFLAGS) -c $< -o $@
|
||||
build/embed_main.o: test/amalg/main.c $(JANET_HEADERS)
|
||||
$(CC) $(CFLAGS) -c $< -o $@
|
||||
build/embed_test: build/embed_janet.o build/embed_main.o
|
||||
$(CC) $(LDFLAGS) $(CFLAGS) -o $@ $^ $(CLIBS)
|
||||
|
||||
test-amalg: build/embed_test
|
||||
./build/embed_test
|
||||
|
||||
.PHONY: clean install repl debug valgrind test \
|
||||
valtest emscripten dist uninstall docs grammar format
|
||||
|
||||
@ -218,7 +218,8 @@ test_files = [
|
||||
'test/suite4.janet',
|
||||
'test/suite5.janet',
|
||||
'test/suite6.janet',
|
||||
'test/suite7.janet'
|
||||
'test/suite7.janet',
|
||||
'test/suite8.janet'
|
||||
]
|
||||
foreach t : test_files
|
||||
test(t, janet_nativeclient, args : files([t]), workdir : meson.current_source_dir())
|
||||
@ -231,6 +232,11 @@ run_target('repl', command : [janet_nativeclient])
|
||||
janet_dep = declare_dependency(include_directories : incdir,
|
||||
link_with : libjanet)
|
||||
|
||||
# pkgconfig
|
||||
pkg = import('pkgconfig')
|
||||
pkg.generate(libjanet,
|
||||
description: 'Library for the Janet programming language.')
|
||||
|
||||
# Installation
|
||||
install_man('janet.1')
|
||||
install_man('jpm.1')
|
||||
|
||||
@ -104,7 +104,8 @@ int main(int argc, const char **argv) {
|
||||
}
|
||||
fclose(boot_file);
|
||||
|
||||
status = janet_dobytes(env, boot_buffer, boot_size, boot_filename, NULL);
|
||||
status = janet_dobytes(env, boot_buffer, (int32_t) boot_size, boot_filename, NULL);
|
||||
free(boot_buffer);
|
||||
|
||||
/* Deinitialize vm */
|
||||
janet_deinit();
|
||||
|
||||
@ -287,17 +287,44 @@
|
||||
~(let (,;accum) ,;body))
|
||||
|
||||
(defmacro defer
|
||||
"Run form unconditionally after form, even if the body throws an error."
|
||||
"Run form unconditionally after body, even if the body throws an error.
|
||||
Will also run form if a user signal 0-4 is received."
|
||||
[form & body]
|
||||
(with-syms [f r]
|
||||
~(do
|
||||
(def ,f (,fiber/new (fn [] ,;body) :ie))
|
||||
(def ,f (,fiber/new (fn [] ,;body) :ti))
|
||||
(def ,r (,resume ,f))
|
||||
,form
|
||||
(if (= (,fiber/status ,f) :dead)
|
||||
,r
|
||||
(propagate ,r ,f)))))
|
||||
|
||||
(defmacro prompt
|
||||
"Set up a checkpoint that can be returned to. Tag should be a value
|
||||
that is used in a return statement, like a keyword."
|
||||
[tag & body]
|
||||
(with-syms [res target payload fib]
|
||||
~(do
|
||||
(def ,fib (,fiber/new (fn [] [,tag (do ,;body)]) :i0))
|
||||
(def ,res (,resume ,fib))
|
||||
(def [,target ,payload] ,res)
|
||||
(if (,= ,tag ,target)
|
||||
,payload
|
||||
(propagate ,res ,fib)))))
|
||||
|
||||
(defmacro label
|
||||
"Set a label point that is lexically scoped. Name should be a symbol
|
||||
that will be bound to the label."
|
||||
[name & body]
|
||||
~(do
|
||||
(def ,name @"")
|
||||
,(apply prompt name body)))
|
||||
|
||||
(defn return
|
||||
"Return to a prompt point."
|
||||
[to &opt value]
|
||||
(signal 0 [to value]))
|
||||
|
||||
(defmacro with
|
||||
"Evaluate body with some resource, which will be automatically cleaned up
|
||||
if there is an error in body. binding is bound to the expression ctor, and
|
||||
@ -975,11 +1002,10 @@
|
||||
(with-syms [ret f s]
|
||||
~(do
|
||||
,;saveold
|
||||
(def ,f (,fiber/new (fn [] ,;setnew ,;body) :ei))
|
||||
(def ,f (,fiber/new (fn [] ,;setnew ,;body) :ti))
|
||||
(def ,ret (,resume ,f))
|
||||
,;restoreold
|
||||
(if (= (,fiber/status ,f) :error) (,propagate ,ret ,f))
|
||||
,ret)))
|
||||
(if (= (,fiber/status ,f) :dead) ,ret (,propagate ,ret ,f)))))
|
||||
|
||||
(defn partial
|
||||
"Partial function application."
|
||||
@ -1291,7 +1317,7 @@
|
||||
~(if (= ,pattern ,expr) ,(onmatch) ,sentinel)
|
||||
(do
|
||||
(put seen pattern true)
|
||||
~(if (= nil (def ,pattern ,expr)) ,sentinel ,(onmatch))))
|
||||
~(do (def ,pattern ,expr) ,(onmatch))))
|
||||
|
||||
(and (tuple? pattern) (= :parens (tuple/type pattern)))
|
||||
(if (and (= (pattern 0) '@) (symbol? (pattern 1)))
|
||||
@ -1308,12 +1334,14 @@
|
||||
(var i -1)
|
||||
(with-idemp
|
||||
$arr expr
|
||||
~(if (indexed? ,$arr)
|
||||
~(if (,indexed? ,$arr)
|
||||
(if (< (,length ,$arr) ,len)
|
||||
,sentinel
|
||||
,((fn aux []
|
||||
(++ i)
|
||||
(if (= i len)
|
||||
(onmatch)
|
||||
(match-1 (in pattern i) (tuple in $arr i) aux seen))))
|
||||
(match-1 (in pattern i) (tuple in $arr i) aux seen)))))
|
||||
,sentinel)))
|
||||
|
||||
(dictionary? pattern)
|
||||
@ -1321,12 +1349,12 @@
|
||||
(var key nil)
|
||||
(with-idemp
|
||||
$dict expr
|
||||
~(if (dictionary? ,$dict)
|
||||
~(if (,dictionary? ,$dict)
|
||||
,((fn aux []
|
||||
(set key (next pattern key))
|
||||
(if (= key nil)
|
||||
(onmatch)
|
||||
(match-1 (in pattern key) (tuple in $dict key) aux seen))))
|
||||
(match-1 [(in pattern key) [not= (in pattern key) nil]] [in $dict key] aux seen))))
|
||||
,sentinel)))
|
||||
|
||||
:else ~(if (= ,pattern ,expr) ,(onmatch) ,sentinel)))
|
||||
@ -1856,8 +1884,7 @@
|
||||
(on-compile-error msg errf where))))
|
||||
guard))
|
||||
(fiber/setenv f env)
|
||||
(while (let [fs (fiber/status f)]
|
||||
(and (not= :dead fs) (not= :error fs)))
|
||||
(while (fiber/can-resume? f)
|
||||
(def res (resume f resumeval))
|
||||
(when good (when going (set resumeval (onstatus f res))))))
|
||||
|
||||
@ -2226,6 +2253,29 @@
|
||||
###
|
||||
###
|
||||
|
||||
(defn- no-side-effects
|
||||
"Check if form may have side effects. If returns true, then the src
|
||||
must not have side effects, such as calling a C function."
|
||||
[src]
|
||||
(cond
|
||||
(tuple? src)
|
||||
(if (= (tuple/type src) :brackets)
|
||||
(all no-side-effects src))
|
||||
(array? src)
|
||||
(all no-side-effects src)
|
||||
(dictionary? src)
|
||||
(and (all no-side-effects (keys src))
|
||||
(all no-side-effects (values src)))
|
||||
true))
|
||||
|
||||
(defn- is-safe-def [x] (no-side-effects (last x)))
|
||||
|
||||
(def- safe-forms {'defn true 'defn- true 'defmacro true 'defmacro- true
|
||||
'def is-safe-def 'var is-safe-def 'def- is-safe-def 'var- is-safe-def
|
||||
'defglobal is-safe-def 'varglobal is-safe-def})
|
||||
|
||||
(def- importers {'import true 'import* true 'use true 'dofile true 'require true})
|
||||
|
||||
(defn cli-main
|
||||
"Entrance for the Janet CLI tool. Call this functions with the command line
|
||||
arguments as an array or tuple of strings to invoke the CLI interface."
|
||||
@ -2293,16 +2343,21 @@
|
||||
(def h (in handlers n))
|
||||
(if h (h i) (do (print "unknown flag -" n) ((in handlers "h")))))
|
||||
|
||||
# Use special evaulator for fly checking (-k option)
|
||||
(def- safe-forms {'defn true 'defn- true 'defmacro true 'defmacro- true})
|
||||
(def- importers {'import true 'import* true 'use true 'dofile true 'require true})
|
||||
(defn- evaluator
|
||||
[thunk source env where]
|
||||
(if *compile-only*
|
||||
(when (tuple? source)
|
||||
(def head (source 0))
|
||||
(def safe-check (safe-forms head))
|
||||
(cond
|
||||
(safe-forms (source 0)) (thunk)
|
||||
(importers (source 0))
|
||||
# Sometimes safe form
|
||||
(function? safe-check)
|
||||
(if (safe-check source) (thunk))
|
||||
# Always safe form
|
||||
safe-check
|
||||
(thunk)
|
||||
# Import-like form
|
||||
(importers head)
|
||||
(do
|
||||
(let [[l c] (tuple/sourcemap source)
|
||||
newtup (tuple/setmap (tuple ;source :evaluator evaluator) l c)]
|
||||
@ -2349,6 +2404,11 @@
|
||||
(setdyn :err-color (if *colorize* true))
|
||||
(repl getchunk onsig env)))
|
||||
|
||||
(put _env 'no-side-effects nil)
|
||||
(put _env 'is-safe-def nil)
|
||||
(put _env 'safe-forms nil)
|
||||
(put _env 'importers nil)
|
||||
|
||||
|
||||
###
|
||||
###
|
||||
@ -2466,7 +2526,8 @@
|
||||
|
||||
(defn do-one-flie
|
||||
[fname]
|
||||
(print "\n/* " fname " */\n")
|
||||
(print "\n/* " fname " */")
|
||||
(print "#line 0 \"" fname "\"\n")
|
||||
(def source (slurp fname))
|
||||
(print (string/replace-all "\r" "" source)))
|
||||
|
||||
|
||||
@ -387,7 +387,7 @@ static const JanetReg buffer_cfuns[] = {
|
||||
"buffer/push-word", cfun_buffer_word,
|
||||
JDOC("(buffer/push-word buffer x)\n\n"
|
||||
"Append a machine word to a buffer. The 4 bytes of the integer are appended "
|
||||
"in twos complement, big endian order, unsigned. Returns the modified buffer. Will "
|
||||
"in twos complement, little endian order, unsigned. Returns the modified buffer. Will "
|
||||
"throw an error if the buffer overflows.")
|
||||
},
|
||||
{
|
||||
|
||||
@ -82,7 +82,8 @@ static JanetSlot opfunction(
|
||||
t = janetc_gettarget(opts);
|
||||
janetc_emit_sss(c, op, t, args[0], janetc_cslot(defaultArg2), 1);
|
||||
return t;
|
||||
} else if (len == 2) {
|
||||
} else {
|
||||
/* len == 2 */
|
||||
t = janetc_gettarget(opts);
|
||||
janetc_emit_sss(c, op, t, args[0], args[1], 1);
|
||||
}
|
||||
|
||||
@ -202,7 +202,7 @@ JanetSlot janetc_resolve(
|
||||
switch (btype) {
|
||||
default:
|
||||
case JANET_BINDING_NONE:
|
||||
janetc_error(c, janet_formatc("unknown symbol %q", sym));
|
||||
janetc_error(c, janet_formatc("unknown symbol %q", janet_wrap_symbol(sym)));
|
||||
return janetc_cslot(janet_wrap_nil());
|
||||
case JANET_BINDING_DEF:
|
||||
case JANET_BINDING_MACRO: /* Macro should function like defs when not in calling pos */
|
||||
@ -455,6 +455,7 @@ static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun) {
|
||||
break;
|
||||
case JANET_CFUNCTION:
|
||||
case JANET_ABSTRACT:
|
||||
case JANET_NIL:
|
||||
break;
|
||||
case JANET_KEYWORD:
|
||||
if (min_arity == 0) {
|
||||
|
||||
@ -489,6 +489,26 @@ ret_false:
|
||||
return janet_wrap_false();
|
||||
}
|
||||
|
||||
static Janet janet_core_signal(int32_t argc, Janet *argv) {
|
||||
janet_arity(argc, 1, 2);
|
||||
int sig;
|
||||
if (janet_checkint(argv[0])) {
|
||||
int32_t s = janet_unwrap_integer(argv[0]);
|
||||
if (s < 0 || s > 9) {
|
||||
janet_panicf("expected user signal between 0 and 9, got %d", s);
|
||||
}
|
||||
sig = JANET_SIGNAL_USER0 + s;
|
||||
} else {
|
||||
JanetKeyword kw = janet_getkeyword(argv, 0);
|
||||
if (!janet_cstrcmp(kw, "yield")) sig = JANET_SIGNAL_YIELD;
|
||||
if (!janet_cstrcmp(kw, "error")) sig = JANET_SIGNAL_ERROR;
|
||||
if (!janet_cstrcmp(kw, "debug")) sig = JANET_SIGNAL_DEBUG;
|
||||
janet_panicf("unknown signal, expected :yield, :error, or :debug, got %v", argv[0]);
|
||||
}
|
||||
Janet payload = argc == 2 ? argv[1] : janet_wrap_nil();
|
||||
janet_signalv(sig, payload);
|
||||
}
|
||||
|
||||
static const JanetReg corelib_cfuns[] = {
|
||||
{
|
||||
"native", janet_core_native,
|
||||
@ -599,11 +619,10 @@ static const JanetReg corelib_cfuns[] = {
|
||||
{
|
||||
"type", janet_core_type,
|
||||
JDOC("(type x)\n\n"
|
||||
"Returns the type of x as a keyword symbol. x is one of\n"
|
||||
"Returns the type of x as a keyword. x is one of\n"
|
||||
"\t:nil\n"
|
||||
"\t:boolean\n"
|
||||
"\t:integer\n"
|
||||
"\t:real\n"
|
||||
"\t:number\n"
|
||||
"\t:array\n"
|
||||
"\t:tuple\n"
|
||||
"\t:table\n"
|
||||
@ -614,7 +633,7 @@ static const JanetReg corelib_cfuns[] = {
|
||||
"\t:keyword\n"
|
||||
"\t:function\n"
|
||||
"\t:cfunction\n\n"
|
||||
"or another symbol for an abstract type.")
|
||||
"or another keyword for an abstract type.")
|
||||
},
|
||||
{
|
||||
"hash", janet_core_hash,
|
||||
@ -680,6 +699,11 @@ static const JanetReg corelib_cfuns[] = {
|
||||
JDOC("(slice x &opt start end)\n\n"
|
||||
"Extract a sub-range of an indexed data strutrue or byte sequence.")
|
||||
},
|
||||
{
|
||||
"signal", janet_core_signal,
|
||||
JDOC("(signal what x)\n\n"
|
||||
"Raise a signal with payload x. ")
|
||||
},
|
||||
{NULL, NULL, NULL}
|
||||
};
|
||||
|
||||
|
||||
@ -65,7 +65,14 @@ JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t
|
||||
if (newstacktop >= fiber->capacity) {
|
||||
janet_fiber_setcapacity(fiber, 2 * newstacktop);
|
||||
}
|
||||
safe_memcpy(fiber->data + fiber->stacktop, argv, argc * sizeof(Janet));
|
||||
if (argv) {
|
||||
memcpy(fiber->data + fiber->stacktop, argv, argc * sizeof(Janet));
|
||||
} else {
|
||||
/* If argv not given, fill with nil */
|
||||
for (int32_t i = 0; i < argc; i++) {
|
||||
fiber->data[fiber->stacktop + i] = janet_wrap_nil();
|
||||
}
|
||||
}
|
||||
fiber->stacktop = newstacktop;
|
||||
}
|
||||
if (janet_fiber_funcframe(fiber, callee)) return NULL;
|
||||
@ -366,10 +373,10 @@ static Janet cfun_fiber_new(int32_t argc, Janet *argv) {
|
||||
janet_arity(argc, 1, 2);
|
||||
JanetFunction *func = janet_getfunction(argv, 0);
|
||||
JanetFiber *fiber;
|
||||
if (func->def->min_arity != 0) {
|
||||
janet_panic("expected nullary function in fiber constructor");
|
||||
if (func->def->min_arity > 1) {
|
||||
janet_panicf("fiber function must accept 0 or 1 arguments");
|
||||
}
|
||||
fiber = janet_fiber(func, 64, 0, NULL);
|
||||
fiber = janet_fiber(func, 64, func->def->min_arity, NULL);
|
||||
if (argc == 2) {
|
||||
int32_t i;
|
||||
JanetByteView view = janet_getbytes(argv, 1);
|
||||
@ -390,6 +397,15 @@ static Janet cfun_fiber_new(int32_t argc, Janet *argv) {
|
||||
JANET_FIBER_MASK_USER |
|
||||
JANET_FIBER_MASK_YIELD;
|
||||
break;
|
||||
case 't':
|
||||
fiber->flags |=
|
||||
JANET_FIBER_MASK_ERROR |
|
||||
JANET_FIBER_MASK_USER0 |
|
||||
JANET_FIBER_MASK_USER1 |
|
||||
JANET_FIBER_MASK_USER2 |
|
||||
JANET_FIBER_MASK_USER3 |
|
||||
JANET_FIBER_MASK_USER4;
|
||||
break;
|
||||
case 'd':
|
||||
fiber->flags |= JANET_FIBER_MASK_DEBUG;
|
||||
break;
|
||||
@ -452,6 +468,20 @@ static Janet cfun_fiber_setmaxstack(int32_t argc, Janet *argv) {
|
||||
return argv[0];
|
||||
}
|
||||
|
||||
static Janet cfun_fiber_can_resume(int32_t argc, Janet *argv) {
|
||||
janet_fixarity(argc, 1);
|
||||
JanetFiber *fiber = janet_getfiber(argv, 0);
|
||||
JanetFiberStatus s = janet_fiber_status(fiber);
|
||||
int isFinished = s == JANET_STATUS_DEAD ||
|
||||
s == JANET_STATUS_ERROR ||
|
||||
s == JANET_STATUS_USER0 ||
|
||||
s == JANET_STATUS_USER1 ||
|
||||
s == JANET_STATUS_USER2 ||
|
||||
s == JANET_STATUS_USER3 ||
|
||||
s == JANET_STATUS_USER4;
|
||||
return janet_wrap_boolean(!isFinished);
|
||||
}
|
||||
|
||||
static const JanetReg fiber_cfuns[] = {
|
||||
{
|
||||
"fiber/new", cfun_fiber_new,
|
||||
@ -467,6 +497,7 @@ static const JanetReg fiber_cfuns[] = {
|
||||
"\ta - block all signals\n"
|
||||
"\td - block debug signals\n"
|
||||
"\te - block error signals\n"
|
||||
"\tt - block termination signals: error + user[0-4]\n"
|
||||
"\tu - block user signals\n"
|
||||
"\ty - block yield signals\n"
|
||||
"\t0-9 - block a specific user signal\n\n"
|
||||
@ -517,6 +548,11 @@ static const JanetReg fiber_cfuns[] = {
|
||||
"Sets the environment table for a fiber. Set to nil to remove the current "
|
||||
"environment.")
|
||||
},
|
||||
{
|
||||
"fiber/can-resume?", cfun_fiber_can_resume,
|
||||
JDOC("(fiber/can-resume? fiber)\n\n"
|
||||
"Check if a fiber is finished and cannot be resumed.")
|
||||
},
|
||||
{NULL, NULL, NULL}
|
||||
};
|
||||
|
||||
|
||||
@ -1274,7 +1274,7 @@ static Janet cfun_env_lookup(int32_t argc, Janet *argv) {
|
||||
}
|
||||
|
||||
static Janet cfun_marshal(int32_t argc, Janet *argv) {
|
||||
janet_arity(argc, 1, 2);
|
||||
janet_arity(argc, 1, 3);
|
||||
JanetBuffer *buffer;
|
||||
JanetTable *rreg = NULL;
|
||||
if (argc > 1) {
|
||||
|
||||
@ -476,7 +476,7 @@ JANET_NO_RETURN static void peg_panic(Builder *b, const char *msg) {
|
||||
|
||||
static void peg_fixarity(Builder *b, int32_t argc, int32_t arity) {
|
||||
if (argc != arity) {
|
||||
peg_panicf(b, "expected %d argument%s, got %d%",
|
||||
peg_panicf(b, "expected %d argument%s, got %d",
|
||||
arity,
|
||||
arity == 1 ? "" : "s",
|
||||
argc);
|
||||
|
||||
225
src/core/pp.c
225
src/core/pp.c
@ -688,96 +688,6 @@ static void pushtypes(JanetBuffer *buffer, int types) {
|
||||
}
|
||||
}
|
||||
|
||||
void janet_formatb(JanetBuffer *bufp, const char *format, va_list args) {
|
||||
for (const char *c = format; *c; c++) {
|
||||
switch (*c) {
|
||||
default:
|
||||
janet_buffer_push_u8(bufp, *c);
|
||||
break;
|
||||
case '%': {
|
||||
if (c[1] == '\0')
|
||||
break;
|
||||
switch (*++c) {
|
||||
default:
|
||||
janet_buffer_push_u8(bufp, *c);
|
||||
break;
|
||||
case 'f':
|
||||
number_to_string_b(bufp, va_arg(args, double));
|
||||
break;
|
||||
case 'd':
|
||||
integer_to_string_b(bufp, va_arg(args, long));
|
||||
break;
|
||||
case 'S': {
|
||||
const uint8_t *str = va_arg(args, const uint8_t *);
|
||||
janet_buffer_push_bytes(bufp, str, janet_string_length(str));
|
||||
break;
|
||||
}
|
||||
case 's':
|
||||
janet_buffer_push_cstring(bufp, va_arg(args, const char *));
|
||||
break;
|
||||
case 'c':
|
||||
janet_buffer_push_u8(bufp, (uint8_t) va_arg(args, long));
|
||||
break;
|
||||
case 'q': {
|
||||
const uint8_t *str = va_arg(args, const uint8_t *);
|
||||
janet_escape_string_b(bufp, str);
|
||||
break;
|
||||
}
|
||||
case 't': {
|
||||
janet_buffer_push_cstring(bufp, typestr(va_arg(args, Janet)));
|
||||
break;
|
||||
}
|
||||
case 'T': {
|
||||
int types = va_arg(args, long);
|
||||
pushtypes(bufp, types);
|
||||
break;
|
||||
}
|
||||
case 'V': {
|
||||
janet_to_string_b(bufp, va_arg(args, Janet));
|
||||
break;
|
||||
}
|
||||
case 'v': {
|
||||
janet_description_b(bufp, va_arg(args, Janet));
|
||||
break;
|
||||
}
|
||||
case 'p': {
|
||||
janet_pretty(bufp, 4, 0, va_arg(args, Janet));
|
||||
break;
|
||||
}
|
||||
case 'P': {
|
||||
janet_pretty(bufp, 4, JANET_PRETTY_COLOR, va_arg(args, Janet));
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* Helper function for formatting strings. Useful for generating error messages and the like.
|
||||
* Similar to printf, but specialized for operating with janet. */
|
||||
const uint8_t *janet_formatc(const char *format, ...) {
|
||||
va_list args;
|
||||
const uint8_t *ret;
|
||||
JanetBuffer buffer;
|
||||
int32_t len = 0;
|
||||
|
||||
/* Calculate length, init buffer and args */
|
||||
while (format[len]) len++;
|
||||
janet_buffer_init(&buffer, len);
|
||||
va_start(args, format);
|
||||
|
||||
/* Run format */
|
||||
janet_formatb(&buffer, format, args);
|
||||
|
||||
/* Iterate length */
|
||||
va_end(args);
|
||||
|
||||
ret = janet_string(buffer.data, buffer.count);
|
||||
janet_buffer_deinit(&buffer);
|
||||
return ret;
|
||||
}
|
||||
|
||||
/*
|
||||
* code adapted from lua/lstrlib.c http://lua.org
|
||||
*/
|
||||
@ -818,6 +728,141 @@ static const char *scanformat(
|
||||
return p;
|
||||
}
|
||||
|
||||
void janet_formatb(JanetBuffer *b, const char *format, va_list args) {
|
||||
const char *format_end = format + strlen(format);
|
||||
const char *c = format;
|
||||
int32_t startlen = b->count;
|
||||
while (c < format_end) {
|
||||
if (*c != '%') {
|
||||
janet_buffer_push_u8(b, (uint8_t) *c++);
|
||||
} else if (*++c == '%') {
|
||||
janet_buffer_push_u8(b, (uint8_t) *c++);
|
||||
} else {
|
||||
char form[MAX_FORMAT], item[MAX_ITEM];
|
||||
char width[3], precision[3];
|
||||
int nb = 0; /* number of bytes in added item */
|
||||
c = scanformat(c, form, width, precision);
|
||||
switch (*c++) {
|
||||
case 'c': {
|
||||
int n = va_arg(args, long);
|
||||
nb = snprintf(item, MAX_ITEM, form, n);
|
||||
break;
|
||||
}
|
||||
case 'd':
|
||||
case 'i':
|
||||
case 'o':
|
||||
case 'u':
|
||||
case 'x':
|
||||
case 'X': {
|
||||
int32_t n = va_arg(args, long);
|
||||
nb = snprintf(item, MAX_ITEM, form, n);
|
||||
break;
|
||||
}
|
||||
case 'a':
|
||||
case 'A':
|
||||
case 'e':
|
||||
case 'E':
|
||||
case 'f':
|
||||
case 'g':
|
||||
case 'G': {
|
||||
double d = va_arg(args, double);
|
||||
nb = snprintf(item, MAX_ITEM, form, d);
|
||||
break;
|
||||
}
|
||||
case 's':
|
||||
case 'S': {
|
||||
const char *str = va_arg(args, const char *);
|
||||
int32_t len = c[-1] == 's'
|
||||
? (int32_t) strlen(str)
|
||||
: janet_string_length((JanetString) str);
|
||||
if (form[2] == '\0')
|
||||
janet_buffer_push_bytes(b, (const uint8_t *) str, len);
|
||||
else {
|
||||
if (len != (int32_t) strlen((const char *) str))
|
||||
janet_panic("string contains zeros");
|
||||
if (!strchr(form, '.') && len >= 100) {
|
||||
janet_panic("no precision and string is too long to be formatted");
|
||||
} else {
|
||||
nb = snprintf(item, MAX_ITEM, form, str);
|
||||
}
|
||||
}
|
||||
break;
|
||||
}
|
||||
case 'V':
|
||||
janet_to_string_b(b, va_arg(args, Janet));
|
||||
break;
|
||||
case 'v':
|
||||
janet_description_b(b, va_arg(args, Janet));
|
||||
break;
|
||||
case 't':
|
||||
janet_buffer_push_cstring(b, typestr(va_arg(args, Janet)));
|
||||
break;
|
||||
case 'T': {
|
||||
int types = va_arg(args, long);
|
||||
pushtypes(b, types);
|
||||
break;
|
||||
}
|
||||
case 'Q':
|
||||
case 'q':
|
||||
case 'P':
|
||||
case 'p': { /* janet pretty , precision = depth */
|
||||
int depth = atoi(precision);
|
||||
if (depth < 1) depth = 4;
|
||||
char d = c[-1];
|
||||
int has_color = (d == 'P') || (d == 'Q');
|
||||
int has_oneline = (d == 'Q') || (d == 'q');
|
||||
int flags = 0;
|
||||
flags |= has_color ? JANET_PRETTY_COLOR : 0;
|
||||
flags |= has_oneline ? JANET_PRETTY_ONELINE : 0;
|
||||
janet_pretty_(b, depth, flags, va_arg(args, Janet), startlen);
|
||||
break;
|
||||
}
|
||||
case 'j': {
|
||||
int depth = atoi(precision);
|
||||
if (depth < 1)
|
||||
depth = JANET_RECURSION_GUARD;
|
||||
janet_jdn_(b, depth, va_arg(args, Janet), startlen);
|
||||
break;
|
||||
}
|
||||
default: {
|
||||
/* also treat cases 'nLlh' */
|
||||
janet_panicf("invalid conversion '%s' to 'format'",
|
||||
form);
|
||||
}
|
||||
}
|
||||
if (nb >= MAX_ITEM)
|
||||
janet_panicf("format buffer overflow", form);
|
||||
if (nb > 0)
|
||||
janet_buffer_push_bytes(b, (uint8_t *) item, nb);
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
/* Helper function for formatting strings. Useful for generating error messages and the like.
|
||||
* Similar to printf, but specialized for operating with janet. */
|
||||
const uint8_t *janet_formatc(const char *format, ...) {
|
||||
va_list args;
|
||||
const uint8_t *ret;
|
||||
JanetBuffer buffer;
|
||||
int32_t len = 0;
|
||||
|
||||
/* Calculate length, init buffer and args */
|
||||
while (format[len]) len++;
|
||||
janet_buffer_init(&buffer, len);
|
||||
va_start(args, format);
|
||||
|
||||
/* Run format */
|
||||
janet_formatb(&buffer, format, args);
|
||||
|
||||
/* Iterate length */
|
||||
va_end(args);
|
||||
|
||||
ret = janet_string(buffer.data, buffer.count);
|
||||
janet_buffer_deinit(&buffer);
|
||||
return ret;
|
||||
}
|
||||
|
||||
/* Shared implementation between string/format and
|
||||
* buffer/format */
|
||||
void janet_buffer_format(
|
||||
|
||||
@ -51,10 +51,6 @@ struct JanetMailbox {
|
||||
pthread_cond_t cond;
|
||||
#endif
|
||||
|
||||
/* Setup procedure - requires a parent mailbox
|
||||
* to receive thunk from */
|
||||
JanetMailbox *parent;
|
||||
|
||||
/* Memory management - reference counting */
|
||||
int refCount;
|
||||
int closed;
|
||||
@ -70,6 +66,11 @@ struct JanetMailbox {
|
||||
JanetBuffer messages[];
|
||||
};
|
||||
|
||||
typedef struct {
|
||||
JanetMailbox *original;
|
||||
JanetMailbox *newbox;
|
||||
} JanetMailboxPair;
|
||||
|
||||
static JANET_THREAD_LOCAL JanetMailbox *janet_vm_mailbox = NULL;
|
||||
static JANET_THREAD_LOCAL JanetThread *janet_vm_thread_current = NULL;
|
||||
static JANET_THREAD_LOCAL JanetTable *janet_vm_thread_decode = NULL;
|
||||
@ -82,7 +83,7 @@ static JanetTable *janet_thread_get_decode(void) {
|
||||
return janet_vm_thread_decode;
|
||||
}
|
||||
|
||||
static JanetMailbox *janet_mailbox_create(JanetMailbox *parent, int refCount, uint16_t capacity) {
|
||||
static JanetMailbox *janet_mailbox_create(int refCount, uint16_t capacity) {
|
||||
JanetMailbox *mailbox = malloc(sizeof(JanetMailbox) + sizeof(JanetBuffer) * (size_t) capacity);
|
||||
if (NULL == mailbox) {
|
||||
JANET_OUT_OF_MEMORY;
|
||||
@ -96,7 +97,6 @@ static JanetMailbox *janet_mailbox_create(JanetMailbox *parent, int refCount, ui
|
||||
#endif
|
||||
mailbox->refCount = refCount;
|
||||
mailbox->closed = 0;
|
||||
mailbox->parent = parent;
|
||||
mailbox->messageCount = 0;
|
||||
mailbox->messageCapacity = capacity;
|
||||
mailbox->messageFirst = 0;
|
||||
@ -175,6 +175,23 @@ static int thread_mark(void *p, size_t size) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
static JanetMailboxPair *make_mailbox_pair(JanetMailbox *original) {
|
||||
JanetMailboxPair *pair = malloc(sizeof(JanetMailboxPair));
|
||||
if (NULL == pair) {
|
||||
JANET_OUT_OF_MEMORY;
|
||||
}
|
||||
pair->original = original;
|
||||
janet_mailbox_ref(original, 1);
|
||||
pair->newbox = janet_mailbox_create(1, 16);
|
||||
return pair;
|
||||
}
|
||||
|
||||
static void destroy_mailbox_pair(JanetMailboxPair *pair) {
|
||||
janet_mailbox_ref(pair->original, -1);
|
||||
janet_mailbox_ref(pair->newbox, -1);
|
||||
free(pair);
|
||||
}
|
||||
|
||||
/* Abstract waiting for timeout across windows/posix */
|
||||
typedef struct {
|
||||
int timedwait;
|
||||
@ -402,6 +419,7 @@ static JanetAbstractType Thread_AT = {
|
||||
|
||||
static JanetThread *janet_make_thread(JanetMailbox *mailbox, JanetTable *encode) {
|
||||
JanetThread *thread = janet_abstract(&Thread_AT, sizeof(JanetThread));
|
||||
janet_mailbox_ref(mailbox, 1);
|
||||
thread->mailbox = mailbox;
|
||||
thread->encode = encode;
|
||||
return thread;
|
||||
@ -412,12 +430,13 @@ JanetThread *janet_getthread(const Janet *argv, int32_t n) {
|
||||
}
|
||||
|
||||
/* Runs in new thread */
|
||||
static int thread_worker(JanetMailbox *mailbox) {
|
||||
static int thread_worker(JanetMailboxPair *pair) {
|
||||
JanetFiber *fiber = NULL;
|
||||
Janet out;
|
||||
|
||||
/* Use the mailbox we were given */
|
||||
janet_vm_mailbox = mailbox;
|
||||
janet_vm_mailbox = pair->newbox;
|
||||
janet_mailbox_ref(pair->newbox, 1);
|
||||
|
||||
/* Init VM */
|
||||
janet_init();
|
||||
@ -426,9 +445,7 @@ static int thread_worker(JanetMailbox *mailbox) {
|
||||
JanetTable *encode = janet_get_core_table("make-image-dict");
|
||||
|
||||
/* Create parent thread */
|
||||
JanetThread *parent = janet_make_thread(mailbox->parent, encode);
|
||||
janet_mailbox_ref(mailbox->parent, -1);
|
||||
mailbox->parent = NULL; /* only used to create the thread */
|
||||
JanetThread *parent = janet_make_thread(pair->original, encode);
|
||||
Janet parentv = janet_wrap_abstract(parent);
|
||||
|
||||
/* Unmarshal the function */
|
||||
@ -449,7 +466,7 @@ static int thread_worker(JanetMailbox *mailbox) {
|
||||
fiber = janet_fiber(func, 64, 1, argv);
|
||||
JanetSignal sig = janet_continue(fiber, janet_wrap_nil(), &out);
|
||||
if (sig != JANET_SIGNAL_OK && sig < JANET_SIGNAL_USER0) {
|
||||
janet_eprintf("in thread %v: ", janet_wrap_abstract(janet_make_thread(mailbox, encode)));
|
||||
janet_eprintf("in thread %v: ", janet_wrap_abstract(janet_make_thread(pair->newbox, encode)));
|
||||
janet_stacktrace(fiber, out);
|
||||
}
|
||||
|
||||
@ -458,11 +475,13 @@ static int thread_worker(JanetMailbox *mailbox) {
|
||||
#endif
|
||||
|
||||
/* Normal exit */
|
||||
destroy_mailbox_pair(pair);
|
||||
janet_deinit();
|
||||
return 0;
|
||||
|
||||
/* Fail to set something up */
|
||||
error:
|
||||
destroy_mailbox_pair(pair);
|
||||
janet_eprintf("\nthread failed to start\n");
|
||||
janet_deinit();
|
||||
return 1;
|
||||
@ -471,12 +490,12 @@ error:
|
||||
#ifdef JANET_WINDOWS
|
||||
|
||||
static DWORD WINAPI janet_create_thread_wrapper(LPVOID param) {
|
||||
thread_worker((JanetMailbox *)param);
|
||||
thread_worker((JanetMailboxPair *)param);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int janet_thread_start_child(JanetThread *thread) {
|
||||
HANDLE handle = CreateThread(NULL, 0, janet_create_thread_wrapper, thread->mailbox, 0, NULL);
|
||||
static int janet_thread_start_child(JanetMailboxPair *pair) {
|
||||
HANDLE handle = CreateThread(NULL, 0, janet_create_thread_wrapper, pair, 0, NULL);
|
||||
int ret = NULL == handle;
|
||||
/* Does not kill thread, simply detatches */
|
||||
if (!ret) CloseHandle(handle);
|
||||
@ -486,13 +505,13 @@ static int janet_thread_start_child(JanetThread *thread) {
|
||||
#else
|
||||
|
||||
static void *janet_pthread_wrapper(void *param) {
|
||||
thread_worker((JanetMailbox *)param);
|
||||
thread_worker((JanetMailboxPair *)param);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static int janet_thread_start_child(JanetThread *thread) {
|
||||
static int janet_thread_start_child(JanetMailboxPair *pair) {
|
||||
pthread_t handle;
|
||||
int error = pthread_create(&handle, NULL, janet_pthread_wrapper, thread->mailbox);
|
||||
int error = pthread_create(&handle, NULL, janet_pthread_wrapper, pair);
|
||||
if (error) {
|
||||
return 1;
|
||||
} else {
|
||||
@ -509,7 +528,7 @@ static int janet_thread_start_child(JanetThread *thread) {
|
||||
|
||||
void janet_threads_init(void) {
|
||||
if (NULL == janet_vm_mailbox) {
|
||||
janet_vm_mailbox = janet_mailbox_create(NULL, 1, 10);
|
||||
janet_vm_mailbox = janet_mailbox_create(1, 10);
|
||||
}
|
||||
janet_vm_thread_decode = NULL;
|
||||
janet_vm_thread_current = NULL;
|
||||
@ -533,7 +552,6 @@ static Janet cfun_thread_current(int32_t argc, Janet *argv) {
|
||||
janet_fixarity(argc, 0);
|
||||
if (NULL == janet_vm_thread_current) {
|
||||
janet_vm_thread_current = janet_make_thread(janet_vm_mailbox, janet_get_core_table("make-image-dict"));
|
||||
janet_mailbox_ref(janet_vm_mailbox, 1);
|
||||
janet_gcroot(janet_wrap_abstract(janet_vm_thread_current));
|
||||
}
|
||||
return janet_wrap_abstract(janet_vm_thread_current);
|
||||
@ -548,15 +566,11 @@ static Janet cfun_thread_new(int32_t argc, Janet *argv) {
|
||||
janet_panicf("bad slot #1, expected integer in range [1, 65535], got %d", cap);
|
||||
}
|
||||
JanetTable *encode = janet_get_core_table("make-image-dict");
|
||||
JanetMailbox *mailbox = janet_mailbox_create(janet_vm_mailbox, 2, (uint16_t) cap);
|
||||
|
||||
/* one for created thread, one for ->parent reference in new mailbox */
|
||||
janet_mailbox_ref(janet_vm_mailbox, 2);
|
||||
|
||||
JanetThread *thread = janet_make_thread(mailbox, encode);
|
||||
if (janet_thread_start_child(thread)) {
|
||||
janet_mailbox_ref(mailbox, -1); /* mailbox reference */
|
||||
janet_mailbox_ref(janet_vm_mailbox, -1); /* ->parent reference */
|
||||
JanetMailboxPair *pair = make_mailbox_pair(janet_vm_mailbox);
|
||||
JanetThread *thread = janet_make_thread(pair->newbox, encode);
|
||||
if (janet_thread_start_child(pair)) {
|
||||
destroy_mailbox_pair(pair);
|
||||
janet_panic("could not start thread");
|
||||
}
|
||||
|
||||
|
||||
@ -1252,6 +1252,7 @@ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
|
||||
}
|
||||
if (old_status == JANET_STATUS_ALIVE ||
|
||||
old_status == JANET_STATUS_DEAD ||
|
||||
(old_status >= JANET_STATUS_USER0 && old_status <= JANET_STATUS_USER4) ||
|
||||
old_status == JANET_STATUS_ERROR) {
|
||||
const uint8_t *str = janet_formatc("cannot resume fiber with status :%s",
|
||||
janet_status_names[old_status]);
|
||||
@ -1272,6 +1273,19 @@ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
|
||||
fiber->child = NULL;
|
||||
}
|
||||
|
||||
/* Handle new fibers being resumed with a non-nil value */
|
||||
if (old_status == JANET_STATUS_NEW && !janet_checktype(in, JANET_NIL)) {
|
||||
Janet *stack = fiber->data + fiber->frame;
|
||||
JanetFunction *func = janet_stack_frame(stack)->func;
|
||||
if (func) {
|
||||
if (func->def->arity > 0) {
|
||||
stack[0] = in;
|
||||
} else if (func->def->flags & JANET_FUNCDEF_FLAG_VARARG) {
|
||||
stack[0] = janet_wrap_tuple(janet_tuple_n(&in, 1));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* Save global state */
|
||||
int32_t oldn = janet_vm_stackn++;
|
||||
int handle = janet_vm_gc_suspend;
|
||||
|
||||
@ -686,8 +686,8 @@ JANET_API int janet_checkint(Janet x);
|
||||
JANET_API int janet_checkint64(Janet x);
|
||||
JANET_API int janet_checksize(Janet x);
|
||||
JANET_API JanetAbstract janet_checkabstract(Janet x, const JanetAbstractType *at);
|
||||
#define janet_checkintrange(x) ((x) == (int32_t)(x))
|
||||
#define janet_checkint64range(x) ((x) == (int64_t)(x))
|
||||
#define janet_checkintrange(x) ((x) >= INT32_MIN && (x) <= INT32_MAX && (x) == (int32_t)(x))
|
||||
#define janet_checkint64range(x) ((x) >= INT64_MIN && (x) <= INT64_MAX && (x) == (int64_t)(x))
|
||||
#define janet_unwrap_integer(x) ((int32_t) janet_unwrap_number(x))
|
||||
#define janet_wrap_integer(x) janet_wrap_number((int32_t)(x))
|
||||
|
||||
|
||||
@ -620,8 +620,12 @@ static int line() {
|
||||
clearlines();
|
||||
return -1;
|
||||
case 4: /* ctrl-d, eof */
|
||||
if (gbl_len == 0) { /* quit on empty line */
|
||||
clearlines();
|
||||
return -1;
|
||||
}
|
||||
kdelete(1);
|
||||
break;
|
||||
case 5: /* ctrl-e */
|
||||
gbl_pos = gbl_len;
|
||||
refresh();
|
||||
|
||||
110
test/suite8.janet
Normal file
110
test/suite8.janet
Normal file
@ -0,0 +1,110 @@
|
||||
# Copyright (c) 2020 Calvin Rose & contributors
|
||||
#
|
||||
# Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
# of this software and associated documentation files (the "Software"), to
|
||||
# deal in the Software without restriction, including without limitation the
|
||||
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
|
||||
# sell copies of the Software, and to permit persons to whom the Software is
|
||||
# furnished to do so, subject to the following conditions:
|
||||
#
|
||||
# The above copyright notice and this permission notice shall be included in
|
||||
# all copies or substantial portions of the Software.
|
||||
#
|
||||
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
|
||||
# IN THE SOFTWARE.
|
||||
|
||||
(import ./helper :prefix "" :exit true)
|
||||
(start-suite 8)
|
||||
|
||||
###
|
||||
### Compiling brainfuck to Janet.
|
||||
###
|
||||
|
||||
(def- bf-peg
|
||||
"Peg for compiling brainfuck into a Janet source ast."
|
||||
(peg/compile
|
||||
~{:+ (/ '(some "+") ,(fn [x] ~(+= (DATA POS) ,(length x))))
|
||||
:- (/ '(some "-") ,(fn [x] ~(-= (DATA POS) ,(length x))))
|
||||
:> (/ '(some ">") ,(fn [x] ~(+= POS ,(length x))))
|
||||
:< (/ '(some "<") ,(fn [x] ~(-= POS ,(length x))))
|
||||
:. (* "." (constant (prinf "%c" (get DATA POS))))
|
||||
:loop (/ (* "[" :main "]") ,(fn [& captures]
|
||||
~(while (not= (get DATA POS) 0)
|
||||
,;captures)))
|
||||
:main (any (+ :s :loop :+ :- :> :< :.)) }))
|
||||
|
||||
(defn bf
|
||||
"Run brainfuck."
|
||||
[text]
|
||||
(eval
|
||||
~(let [DATA (array/new-filled 100 0)]
|
||||
(var POS 50)
|
||||
,;(peg/match bf-peg text))))
|
||||
|
||||
(defn test-bf
|
||||
"Test some bf for expected output."
|
||||
[input output]
|
||||
(def b @"")
|
||||
(with-dyns [:out b]
|
||||
(bf input))
|
||||
(assert (= (string output) (string b))
|
||||
(string "bf input '"
|
||||
input
|
||||
"' failed, expected "
|
||||
(describe output)
|
||||
", got "
|
||||
(describe (string b))
|
||||
".")))
|
||||
|
||||
(test-bf "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++." "Hello World!\n")
|
||||
|
||||
(test-bf ">++++++++[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]>-----.>->
|
||||
+++..+++.>-.<<+[>[+>+]>>]<--------------.>>.+++.------.--------.>+.>+."
|
||||
"Hello World!\n")
|
||||
|
||||
(test-bf "+[+[<<<+>>>>]+<-<-<<<+<++]<<.<++.<++..+++.<<++.<---.>>.>.+++.------.>-.>>--."
|
||||
"Hello, World!")
|
||||
|
||||
# Prompts and Labels
|
||||
|
||||
(assert (= 10 (label a (for i 0 10 (if (= i 5) (return a 10))))) "label 1")
|
||||
|
||||
(defn recur
|
||||
[lab x y]
|
||||
(when (= x y) (return lab :done))
|
||||
(def res (label newlab (recur (or lab newlab) (+ x 1) y)))
|
||||
(if lab :oops res))
|
||||
(assert (= :done (recur nil 0 10)) "label 2")
|
||||
|
||||
(assert (= 10 (prompt :a (for i 0 10 (if (= i 5) (return :a 10))))) "prompt 1")
|
||||
|
||||
(defn- inner-loop
|
||||
[i]
|
||||
(if (= i 5)
|
||||
(return :a 10)))
|
||||
|
||||
(assert (= 10 (prompt :a (for i 0 10 (inner-loop i)))) "prompt 2")
|
||||
|
||||
(defn- inner-loop2
|
||||
[i]
|
||||
(try
|
||||
(if (= i 5)
|
||||
(error 10))
|
||||
([err] (return :a err))))
|
||||
|
||||
(assert (= 10 (prompt :a (for i 0 10 (inner-loop2 i)))) "prompt 3")
|
||||
|
||||
# Match checks
|
||||
|
||||
(assert (= :hi (match nil nil :hi)) "match 1")
|
||||
(assert (= :hi (match {:a :hi} {:a a} a)) "match 2")
|
||||
(assert (= nil (match {:a :hi} {:a a :b b} a)) "match 3")
|
||||
(assert (= nil (match [1 2] [a b c] a)) "match 4")
|
||||
(assert (= 2 (match [1 2] [a b] b)) "match 5")
|
||||
|
||||
(end-suite)
|
||||
Loading…
Reference in New Issue
Block a user