From 2d7df6b78e64e0a44b70f37be632223de279c9ec Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Tue, 16 Apr 2019 15:41:45 -0400 Subject: [PATCH] Many changes for adding dynamic (fiber-level) scope. - Allow passing a table to fibers, which make fiber level scope easier. - Add fiber/getenv, fiber/setenv, dyn, and setdyn - Remove meta, *env*, and *doc-width* - Some functions changed dignatures, and no longer take an env --- examples/3sum.janet | 4 +- src/boot/boot.janet | 106 +++++++++++++++--------------------- src/core/corelib.c | 33 +++++++++++ src/core/fiber.c | 41 +++++++++++++- src/core/gc.c | 3 + src/core/marsh.c | 15 +++++ src/core/run.c | 1 + src/include/janet.h | 1 + src/mainclient/init.janet | 7 ++- src/webclient/webinit.janet | 1 + test/suite1.janet | 4 +- tools/bars.janet | 2 +- tools/gendoc.janet | 2 +- 13 files changed, 149 insertions(+), 71 deletions(-) diff --git a/examples/3sum.janet b/examples/3sum.janet index 40fa42d0..e59aa220 100644 --- a/examples/3sum.janet +++ b/examples/3sum.janet @@ -14,5 +14,5 @@ (map keys (keys solutions))) (def arr @[2 4 1 3 8 7 -3 -1 12 -5 -8]) -(print "3sum of " (string/pretty arr) ":") -(print (string/pretty (sum3 arr))) +(printf "3sum of %P: " arr) +(printf "%P\n" (sum3 arr)) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 6e8a54dd..796b0219 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -7,8 +7,6 @@ ### ### -(var *env* "The current environment." _env) - (def defn :macro "(def name & more)\n\nDefine a function. Equivalent to (def name (fn name [args] ...))." (fn defn [name & more] @@ -64,14 +62,14 @@ "Dynamically create a global def." [name value] (def name* (symbol name)) - (put *env* name* @{:value value}) + (setdyn name* @{:value value}) nil) (defn varglobal "Dynamically create a global var." [name init] (def name* (symbol name)) - (put *env* name* @{:ref @[init]}) + (setdyn name* @{:ref @[init]}) nil) # Basic predicates @@ -216,7 +214,7 @@ (let [[[err fib]] catch f (gensym) r (gensym)] - ~(let [,f (,fiber/new (fn [] ,body) :e) + ~(let [,f (,fiber/new (fn [] ,body) :ie) ,r (resume ,f)] (if (= (,fiber/status ,f) :error) (do (def ,err ,r) ,(if fib ~(def ,fib ,f)) ,;(tuple/slice catch 1)) @@ -414,12 +412,12 @@ "Create a generator expression using the loop syntax. Returns a fiber that yields all values inside the loop in order. See loop for details." [head & body] - ~(fiber/new (fn [] (loop ,head (yield (do ,;body)))))) + ~(fiber/new (fn [] (loop ,head (yield (do ,;body)))) :yi)) (defmacro coro - "A wrapper for making fibers. Same as (fiber/new (fn [] ...body))." + "A wrapper for making fibers. Same as (fiber/new (fn [] ...body) :yi)." [& body] - (tuple fiber/new (tuple 'fn '[] ;body))) + (tuple fiber/new (tuple 'fn '[] ;body) :yi)) (defn sum "Returns the sum of xs. If xs is empty, returns 0." @@ -1068,6 +1066,12 @@ (file/close f) nil) +(defn printf + "Print formatted strings to stdout, followed by + a new line." + [f & args] + (file/write stdout (buffer/format @"" f ;args))) + ### ### ### Pattern Matching @@ -1173,15 +1177,11 @@ ### ### -(var *doc-width* - "Width in columns to print documentation." - 80) - (defn doc-format "Reformat text to wrap at a given line." [text] - (def maxcol (- *doc-width* 8)) + (def maxcol (- (dyn :doc-width 80) 8)) (var buf @" ") (var word @"") (var current 0) @@ -1217,8 +1217,8 @@ (defn doc* "Get the documentation for a symbol in a given environment." - [env sym] - (def x (get env sym)) + [sym] + (def x (dyn sym)) (if (not x) (print "symbol " sym " not found.") (do @@ -1241,7 +1241,7 @@ (defmacro doc "Shows documentation for the given symbol." [sym] - ~(,doc* *env* ',sym)) + ~(,doc* ',sym)) ### ### @@ -1320,7 +1320,7 @@ (defn dotup [t] (def h (get t 0)) (def s (get specs h)) - (def entry (or (get *env* h) {})) + (def entry (or (dyn h) {})) (def m (entry :value)) (def m? (entry :macro)) (cond @@ -1390,7 +1390,7 @@ (defn pp "Pretty print to stdout." [x] - (print (buffer/format @"" "%p" x))) + (print (buffer/format @"" (dyn :pretty-format "%p") x))) ### ### @@ -1436,11 +1436,11 @@ opts is a table or struct of options. The options are as follows:\n\n\t :chunks - callback to read into a buffer - default is getline\n\t :on-parse-error - callback when parsing fails - default is bad-parse\n\t - :env - the environment to compile against - default is *env*\n\t + :env - the environment to compile against - default is the current env\n\t :source - string path of source for better errors - default is \"\"\n\t :on-compile-error - callback when compilation fails - default is bad-compile\n\t :on-status - callback when a value is evaluated - default is debug/stacktrace\n\t - :fiber-flags - what flags to wrap the compilation fiber with. Default is :a." + :fiber-flags - what flags to wrap the compilation fiber with. Default is :ia." [opts] (def {:env env @@ -1450,7 +1450,7 @@ :on-parse-error on-parse-error :fiber-flags guard :source where} opts) - (default env *env*) + (default env (fiber/getenv (fiber/current))) (default chunks getline) (default onstatus debug/stacktrace) (default on-compile-error bad-compile) @@ -1463,7 +1463,7 @@ # The parser object (def p (parser/new)) - # Evaluate 1 source form + # Evaluate 1 source form in a protected manner (defn eval1 [source] (var good true) (def f @@ -1481,13 +1481,11 @@ err)) (on-compile-error msg errf where)))) (or guard :a))) + (fiber/setenv f env) (def res (resume f nil)) (when good (if going (onstatus f res)))) - (def oldenv *env*) - (set *env* env) - - # Run loop + # Loop (def buf @"") (while going (buffer/clear buf) @@ -1504,21 +1502,18 @@ (eval1 (parser/produce p))) (when (= (parser/status p) :error) (on-parse-error p where)))) - # Check final parser state (while (parser/has-more p) (eval1 (parser/produce p))) (when (= (parser/status p) :error) (on-parse-error p where)) - (set *env* oldenv) - env) (defn eval-string "Evaluates a string in the current environment. If more control over the environment is needed, use run-context." - [str &opt env] + [str] (var state (string str)) (defn chunks [buf _] (def ret state) @@ -1527,26 +1522,24 @@ (buffer/push-string buf str) (buffer/push-string buf "\n"))) (var returnval nil) - (run-context {:env env - :chunks chunks + (run-context {:chunks chunks :on-compile-error (fn [msg errf &] (error (string "compile error: " msg))) :on-parse-error (fn [p x] (error (string "parse error: " (parser/error p)))) - :fiber-flags : + :fiber-flags :i :on-status (fn [f val] (if-not (= (fiber/status f) :dead) (error val)) (set returnval val)) - :source "eval"}) + :source "eval-string"}) returnval) (defn eval "Evaluates a form in the current environment. If more control over the environment is needed, use run-context." - [form &opt env] - (default env *env*) - (def res (compile form env "eval")) + [form] + (def res (compile form (fiber/getenv (fiber/current)) "eval")) (if (= (type res) :function) (res) (error (res :error)))) @@ -1605,7 +1598,7 @@ (defn module/find "Try to match a module or path name from the patterns in module/paths. Returns a tuple (fullpath kind) where the kind is one of :source, :native, - or image if the module is found, otherise a tuple with nil followed by + or image if the module is found, otherwise a tuple with nil followed by an error message." [path] (def parts (string/split "/" path)) @@ -1684,10 +1677,10 @@ env))) (defn import* - "Import a module into a given environment table. This is the - functional form of (import ...) that expects and explicit environment - table." - [env path & args] + "Function form of import. Same parameters, but the path + and other symbol parameters should be strings instead." + [path & args] + (def env (fiber/getenv (fiber/current))) (def {:as as :prefix prefix :export ep} (table ;args)) @@ -1709,39 +1702,30 @@ x (string x))) args)) - (tuple import* '*env* (string path) ;argm)) + (tuple import* (string path) ;argm)) (defn repl "Run a repl. The first parameter is an optional function to call to get a chunk of source code that should return nil for end of file. The second parameter is a function that is called when a signal is - caught. fmt is a format string used to print results, and defaults to - \"%.20P\"" - [&opt chunks onsignal fmt] + caught." + [&opt chunks onsignal] (def newenv (make-env)) - (default fmt "%.20P") (default onsignal (fn [f x] (case (fiber/status f) :dead (do - (put newenv '_ @{:value x}) - (print (buffer/format @"" fmt x))) + (pp x) + (put newenv '_ @{:value x})) (debug/stacktrace f x)))) (run-context {:env newenv :chunks chunks :on-status onsignal :source "repl"})) -(defmacro meta - "Add metadata to the current environment." - [& args] - (def opts (table ;args)) - (loop [[k v] :pairs opts] - (put *env* k v))) - (defn all-bindings "Get all symbols available in the current environment." - [&opt env] - (default env *env*) + [] + (def env (fiber/getenv (fiber/current))) (def envs @[]) (do (var e env) (while e (array/push envs e) (set e (table/getproto e)))) (def symbol-set @{}) @@ -1762,12 +1746,12 @@ ### (do - - (def image (let [env-pairs (pairs (env-lookup *env*)) + (def env (fiber/getenv (fiber/current))) + (def image (let [env-pairs (pairs (env-lookup env)) essential-pairs (filter (fn [[k v]] (or (cfunction? v) (abstract? v))) env-pairs) lookup (table ;(mapcat identity essential-pairs)) reverse-lookup (invert lookup)] - (marshal *env* reverse-lookup))) + (marshal env reverse-lookup))) # Create C source file that contains images a uint8_t buffer. This # can be compiled and linked statically into the main janet library diff --git a/src/core/corelib.c b/src/core/corelib.c index e780a235..78fc5ae5 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -69,6 +69,29 @@ JanetModule janet_native(const char *name, const uint8_t **error) { return init; } +static Janet janet_core_dyn(int32_t argc, Janet *argv) { + janet_arity(argc, 1, 2); + Janet value; + if (janet_vm_fiber->env) { + value = janet_table_get(janet_vm_fiber->env, argv[0]); + } else { + value = janet_wrap_nil(); + } + if (argc == 2 && janet_checktype(value, JANET_NIL)) { + return argv[1]; + } + return value; +} + +static Janet janet_core_setdyn(int32_t argc, Janet *argv) { + janet_fixarity(argc, 2); + if (!janet_vm_fiber->env) { + janet_vm_fiber->env = janet_table(2); + } + janet_table_put(janet_vm_fiber->env, argv[0], argv[1]); + return argv[1]; +} + static Janet janet_core_native(int32_t argc, Janet *argv) { JanetModule init; janet_arity(argc, 1, 2); @@ -419,6 +442,16 @@ static const JanetReg corelib_cfuns[] = { "Reads a line of input into a buffer, including the newline character, using a prompt. Returns the modified buffer. " "Use this function to implement a simple interface for a terminal program.") }, + { + "dyn", janet_core_dyn, + JDOC("(dyn key [, default=nil])\n\n" + "Get a dynamic binding. Returns the default value if no binding found.") + }, + { + "setdyn", janet_core_setdyn, + JDOC("(setdyn key value)\n\n" + "Set a dynamic binding. Returns value.") + }, {NULL, NULL, NULL} }; diff --git a/src/core/fiber.c b/src/core/fiber.c index 9cc3b537..5a5047dc 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -35,6 +35,7 @@ static void fiber_reset(JanetFiber *fiber) { fiber->stacktop = JANET_FRAME_SIZE; fiber->child = NULL; fiber->flags = JANET_FIBER_MASK_YIELD; + fiber->env = NULL; janet_fiber_set_status(fiber, JANET_STATUS_NEW); } @@ -293,6 +294,25 @@ void janet_fiber_popframe(JanetFiber *fiber) { /* CFuns */ +static Janet cfun_fiber_getenv(int32_t argc, Janet *argv) { + janet_fixarity(argc, 1); + JanetFiber *fiber = janet_getfiber(argv, 0); + return fiber->env ? + janet_wrap_table(fiber->env) : + janet_wrap_nil(); +} + +static Janet cfun_fiber_setenv(int32_t argc, Janet *argv) { + janet_fixarity(argc, 2); + JanetFiber *fiber = janet_getfiber(argv, 0); + if (janet_checktype(argv[1], JANET_NIL)) { + fiber->env = NULL; + } else { + fiber->env = janet_gettable(argv, 1); + } + return argv[0]; +} + static Janet cfun_fiber_new(int32_t argc, Janet *argv) { janet_arity(argc, 1, 2); JanetFunction *func = janet_getfunction(argv, 0); @@ -333,6 +353,12 @@ static Janet cfun_fiber_new(int32_t argc, Janet *argv) { case 'y': fiber->flags |= JANET_FIBER_MASK_YIELD; break; + case 'i': + if (!janet_vm_fiber->env) { + janet_vm_fiber->env = janet_table(0); + } + fiber->env = janet_vm_fiber->env; + break; } } } @@ -388,7 +414,8 @@ static const JanetReg fiber_cfuns[] = { "\te - block error signals\n" "\tu - block user signals\n" "\ty - block yield signals\n" - "\t0-9 - block a specific user signal") + "\t0-9 - block a specific user signal\n" + "\ti - inherit the environment from the current fiber") }, { "fiber/status", cfun_fiber_status, @@ -420,6 +447,18 @@ static const JanetReg fiber_cfuns[] = { "Sets the maximum stack size in janet values for a fiber. By default, the " "maximum stack size is usually 8192.") }, + { + "fiber/getenv", cfun_fiber_getenv, + JDOC("(fiber/getenv fiber)\n\n" + "Gets the environment for a fiber. Returns nil if no such table is " + "set yet.") + }, + { + "fiber/setenv", cfun_fiber_setenv, + JDOC("(fiber/setenv fiber table)\n\n" + "Sets the environment table for a fiber. Set to nil to remove the current " + "environment.") + }, {NULL, NULL, NULL} }; diff --git a/src/core/gc.c b/src/core/gc.c index d6fca000..ee7e6385 100644 --- a/src/core/gc.c +++ b/src/core/gc.c @@ -236,6 +236,9 @@ recur: i = frame->prevframe; } + if (fiber->env) + janet_mark_table(fiber->env); + /* Explicit tail recursion */ if (fiber->child) { fiber = fiber->child; diff --git a/src/core/marsh.c b/src/core/marsh.c index 98b8f1f3..5de85268 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -249,6 +249,7 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) { } #define JANET_FIBER_FLAG_HASCHILD (1 << 29) +#define JANET_FIBER_FLAG_HASENV (1 << 28) #define JANET_STACKFRAME_HASENV (1 << 30) /* Marshal a fiber */ @@ -256,6 +257,7 @@ static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags) { MARSH_STACKCHECK; int32_t fflags = fiber->flags; if (fiber->child) fflags |= JANET_FIBER_FLAG_HASCHILD; + if (fiber->env) fflags |= JANET_FIBER_FLAG_HASENV; if (janet_fiber_status(fiber) == JANET_STATUS_ALIVE) janet_panic("cannot marshal alive fiber"); pushint(st, fflags); @@ -282,6 +284,9 @@ static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags) { j = i - JANET_FRAME_SIZE; i = frame->prevframe; } + if (fiber->env) { + marshal_one(st, janet_wrap_table(fiber->env), flags + 1); + } if (fiber->child) marshal_one(st, janet_wrap_fiber(fiber->child), flags + 1); } @@ -837,6 +842,7 @@ static const uint8_t *unmarshal_one_fiber( fiber->maxstack = 0; fiber->data = NULL; fiber->child = NULL; + fiber->env = NULL; /* Push fiber to seen stack */ janet_array_push(&st->lookup, janet_wrap_fiber(fiber)); @@ -934,6 +940,15 @@ static const uint8_t *unmarshal_one_fiber( janet_panic("fiber has too many stackframes"); } + /* Check for fiber env */ + if (fiber->flags & JANET_FIBER_FLAG_HASENV) { + Janet envv; + fiber->flags &= ~JANET_FIBER_FLAG_HASENV; + data = unmarshal_one(st, data, &envv, flags + 1); + janet_asserttype(envv, JANET_TABLE); + fiber->env = janet_unwrap_table(envv); + } + /* Check for child fiber */ if (fiber->flags & JANET_FIBER_FLAG_HASCHILD) { Janet fiberv; diff --git a/src/core/run.c b/src/core/run.c index a1387a53..151e81f9 100644 --- a/src/core/run.c +++ b/src/core/run.c @@ -47,6 +47,7 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char if (cres.status == JANET_COMPILE_OK) { JanetFunction *f = janet_thunk(cres.funcdef); JanetFiber *fiber = janet_fiber(f, 64, 0, NULL); + fiber->env = env; JanetSignal status = janet_continue(fiber, janet_wrap_nil(), &ret); if (status != JANET_SIGNAL_OK) { janet_stacktrace(fiber, ret); diff --git a/src/include/janet.h b/src/include/janet.h index 0bdfae8d..169dca0c 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -645,6 +645,7 @@ struct JanetFiber { int32_t stacktop; /* Top of stack. Where values are pushed and popped from. */ int32_t capacity; int32_t maxstack; /* Arbitrary defined limit for stack overflow */ + JanetTable *env; /* Dynamic bindings table (usually current environment). */ Janet *data; JanetFiber *child; /* Keep linked list of fibers for restarting pending fibers */ }; diff --git a/src/mainclient/init.janet b/src/mainclient/init.janet index 0eed4730..02159718 100644 --- a/src/mainclient/init.janet +++ b/src/mainclient/init.janet @@ -46,7 +46,7 @@ 3) "-" (fn [&] (set *handleopts* false) 1) "l" (fn [i &] - (import* *env* (get process/args (+ i 1)) + (import* (get process/args (+ i 1)) :prefix "" :exit *exit-on-error*) 2) "e" (fn [i &] @@ -67,7 +67,7 @@ (+= i (dohandler (string/slice arg 1 2) i)) (do (set *no-file* false) - (import* *env* arg :prefix "" :exit *exit-on-error*) + (import* arg :prefix "" :exit *exit-on-error*) (set i lenargs)))) (when (or *should-repl* *no-file*) @@ -86,4 +86,5 @@ (defn getchunk [buf p] (getter (prompter p) buf)) (def onsig (if *quiet* (fn [x &] x) nil)) - (repl getchunk onsig (if *colorize* "%.20P" "%.20p")))) + (setdyn :pretty-format (if *colorize* "%.20P" "%.20p")) + (repl getchunk onsig))) diff --git a/src/webclient/webinit.janet b/src/webclient/webinit.janet index dbe55abf..82c19373 100644 --- a/src/webclient/webinit.janet +++ b/src/webclient/webinit.janet @@ -1,6 +1,7 @@ # Copyright 2017-2019 (C) Calvin Rose (print (string "Janet " janet/version "-" janet/build " Copyright (C) 2017-2019 Calvin Rose")) +(setdyn :pretty-format "%.20P") (fiber/new (fn webrepl [] (repl (fn get-line [buf p] diff --git a/test/suite1.janet b/test/suite1.janet index 257b0a77..c9540d90 100644 --- a/test/suite1.janet +++ b/test/suite1.janet @@ -140,7 +140,7 @@ # Marshal -(def um-lookup (env-lookup *env*)) +(def um-lookup (env-lookup (fiber/getenv (fiber/current)))) (def m-lookup (invert um-lookup)) (defn testmarsh [x msg] @@ -182,7 +182,7 @@ # Large functions (def manydefs (seq [i :range [0 300]] (tuple 'def (gensym) (string "value_" i)))) (array/push manydefs (tuple * 10000 3 5 7 9)) -(def f (compile ['do ;manydefs] *env*)) +(def f (compile ['do ;manydefs] (fiber/getenv (fiber/current)))) (assert (= (f) (* 10000 3 5 7 9)) "long function compilation") # Some higher order functions and macros diff --git a/tools/bars.janet b/tools/bars.janet index 1f573d6e..c0e4d3fd 100644 --- a/tools/bars.janet +++ b/tools/bars.janet @@ -49,7 +49,7 @@ # Make ast from forms (def ast ~(fn [&opt params] (default params @{}) (,buffer ,;forms))) - (def ctor (compile ast *env* source)) + (def ctor (compile ast (fiber/getenv (fiber/current)) source)) (if-not (function? ctor) (error (string "could not compile template"))) (ctor)) diff --git a/tools/gendoc.janet b/tools/gendoc.janet index a03631e8..360082aa 100644 --- a/tools/gendoc.janet +++ b/tools/gendoc.janet @@ -103,7 +103,7 @@ # Generate parts and print them to stdout (def parts (seq [[k entry] - :in (sort (pairs (table/getproto *env*))) + :in (sort (pairs (table/getproto (fiber/getenv (fiber/current))))) :when (and (get entry :doc) (not (get entry :private)))] (emit-item k entry))) (print