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
This commit is contained in:
Calvin Rose 2019-04-16 15:41:45 -04:00
parent 7527142549
commit 2d7df6b78e
13 changed files with 149 additions and 71 deletions

View File

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

View File

@ -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 \"<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*)
(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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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]

View File

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

View File

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

View File

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