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

@@ -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) ":")
+(printf "3sum of %P: " arr)
-(print (string/pretty (sum3 arr)))
+(printf "%P\n" (sum3 arr))

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]
+  [sym]
-  (def x (get env 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 \"<anonymous>\"\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*)
+  # Loop
-  (set *env* env)
-
-  # Run 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
+  (run-context {:chunks chunks
-                :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]
+  [form]
-  (default env *env*)
+  (def res (compile form (fiber/getenv (fiber/current)) "eval"))
-  (def res (compile form env "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
+  "Function form of import. Same parameters, but the path
-  functional form of (import ...) that expects and explicit environment
+  and other symbol parameters should be strings instead."
-  table."
+  [path & args]
-  [env 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
+  caught."
-  \"%.20P\""
+  [&opt chunks onsignal]
-  [&opt chunks onsignal fmt]
   (def newenv (make-env))
-  (default fmt "%.20P")
   (default onsignal (fn [f x]
                       (case (fiber/status f)
                         :dead (do
-                                (put newenv '_ @{:value x})
+                                (pp x)
-                                (print (buffer/format @"" fmt 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 env (fiber/getenv (fiber/current)))
-  (def image (let [env-pairs (pairs (env-lookup *env*))
+  (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

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}
 };
 

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}
 };
 

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;

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;

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);

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 */
 };

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)))

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]

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

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))

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