diff --git a/.builds/.freebsd.yaml b/.builds/.freebsd.yaml index e430138e..a2b4b589 100644 --- a/.builds/.freebsd.yaml +++ b/.builds/.freebsd.yaml @@ -10,4 +10,3 @@ tasks: gmake test sudo gmake install gmake test-install - gmake test-amalg diff --git a/.builds/.openbsd.yaml b/.builds/.openbsd.yaml index 1203a4d8..89d411f0 100644 --- a/.builds/.openbsd.yaml +++ b/.builds/.openbsd.yaml @@ -10,4 +10,3 @@ tasks: gmake test doas gmake install gmake test-install - gmake test-amalg diff --git a/.travis.yml b/.travis.yml index 64bb8b5f..67c71a42 100644 --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md index 96e4e9af..5d167fb2 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/Makefile b/Makefile index 6cb818d7..1d8979e4 100644 --- a/Makefile +++ b/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 diff --git a/meson.build b/meson.build index e7c4d38a..e8e1f3f8 100644 --- a/meson.build +++ b/meson.build @@ -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') diff --git a/src/boot/boot.c b/src/boot/boot.c index 89822336..2fae36f2 100644 --- a/src/boot/boot.c +++ b/src/boot/boot.c @@ -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(); diff --git a/src/boot/boot.janet b/src/boot/boot.janet index e9f5e1b6..784a6a4e 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -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) - ,((fn aux [] - (++ i) - (if (= i len) - (onmatch) - (match-1 (in pattern i) (tuple in $arr i) aux seen)))) + ~(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))))) ,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))) diff --git a/src/core/buffer.c b/src/core/buffer.c index 1f2327a5..85213ad7 100644 --- a/src/core/buffer.c +++ b/src/core/buffer.c @@ -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.") }, { diff --git a/src/core/cfuns.c b/src/core/cfuns.c index b2e9b0b5..40db0ff1 100644 --- a/src/core/cfuns.c +++ b/src/core/cfuns.c @@ -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); } diff --git a/src/core/compile.c b/src/core/compile.c index 62fb4b0b..b95e0096 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -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) { diff --git a/src/core/corelib.c b/src/core/corelib.c index 596e4c62..5324b662 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -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} }; diff --git a/src/core/fiber.c b/src/core/fiber.c index 546ac93b..362c8fc8 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -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} }; diff --git a/src/core/marsh.c b/src/core/marsh.c index 48ba55cb..1af1ba9f 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -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) { diff --git a/src/core/peg.c b/src/core/peg.c index 07775412..6e839f9e 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -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); diff --git a/src/core/pp.c b/src/core/pp.c index 4b6a2a90..23e708de 100644 --- a/src/core/pp.c +++ b/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( diff --git a/src/core/thread.c b/src/core/thread.c index daedef9b..4fa2327d 100644 --- a/src/core/thread.c +++ b/src/core/thread.c @@ -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"); } diff --git a/src/core/vm.c b/src/core/vm.c index 10fc7790..770c07d1 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -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; diff --git a/src/include/janet.h b/src/include/janet.h index 20e9570c..cf2640b9 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -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)) diff --git a/src/mainclient/shell.c b/src/mainclient/shell.c index 4b7a3796..24f9da98 100644 --- a/src/mainclient/shell.c +++ b/src/mainclient/shell.c @@ -620,8 +620,12 @@ static int line() { clearlines(); return -1; case 4: /* ctrl-d, eof */ - clearlines(); - return -1; + if (gbl_len == 0) { /* quit on empty line */ + clearlines(); + return -1; + } + kdelete(1); + break; case 5: /* ctrl-e */ gbl_pos = gbl_len; refresh(); diff --git a/test/suite8.janet b/test/suite8.janet new file mode 100644 index 00000000..4c948511 --- /dev/null +++ b/test/suite8.janet @@ -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)