JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

The break buffer, the inspector and the watch table show what a stopped program holds

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 08:37:15 +07:00
commit 6f0f4957f4
27 changed files with 1168 additions and 283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
TODO.org
View File

@ -1575,10 +1575,16 @@ Push was chosen partly because polling costs a compile, and that premise weakene
when the processes merged. The table-and-read design stands; whether it should stay when the processes merged. The table-and-read design stands; whether it should stay
pushed is open. pushed is open.
** TODO A watch over a struct or a slice ** DONE A watch over a struct or a slice
Scalars work today through four runtime entry points and need no compiler change. CLOSED: [2026-09-25]
A struct or a slice needs a compile-time walk over its type — one arm beside =(watch "name" v)= is a checker arm beside =print=, sharing its render context
=print=. with the emitter aimed at the watch slot, so any value watches as it prints. The
value is evaluated once, before the table is asked whether it is armed, so the
program behaves the same with or without a watch buffer open. Outside a dev
build, and always in the JS dialect, the backend drops everything but the
value's evaluation, so a release build makes no call. The =declare-c= scalar
entry points stay. See docs/BUILT.md, "The scalar entry points, and the
form for everything else".
** DONE Two ways to root a walk ** DONE Two ways to root a walk
The inspector takes a frame and a slot index as well as an expression. An index is The inspector takes a frame and a slot index as well as an expression. An index is
@ -1609,10 +1615,12 @@ The park used to drain the agent ring only when something had asked it to poll,
and a plain redefine does not, so every generation ran one re-run later than and a plain redefine does not, so every generation ran one re-run later than
whoever pressed the key expected. The drain happens in front of the exit now. whoever pressed the key expected. The drain happens in front of the exit now.
** TODO A dyn value from eval-expr never reaches the reply's value field ** DONE A dyn value from eval-expr never reaches the reply's value field
It renders to the program's own stdout and arrives on a later reply's output CLOSED: [2026-09-25]
instead. Where a dyn expression's value should surface is a question about the The renderer's emitter has a dyn entry: =println= keeps =flan_dyn_print= to
editor protocol. stdout, and the REPL's renders through =flan_dyn_emit_dev= into the value
buffer, so a dyn answer is the reply's =:value= on both backends. A dyn text is
quoted there as a typed string is. Rules out a dyn value arriving on =:output=.
** DONE Memory diagnostics on demand ** DONE Memory diagnostics on demand
CLOSED: [2026-09-20] CLOSED: [2026-09-20]
@ -1739,14 +1747,22 @@ form is evaluated again plainly.
Both were daemon ops with nothing calling them. One command shows the backtrace Both were daemon ops with nothing calling them. One command shows the backtrace
with the selected frame's locals. with the selected frame's locals.
** TODO Hex, binary and an address on a primitive in the inspector ** DONE Hex, binary and an address on a primitive in the inspector
The last item of the Emacs batch besides the break buffer, and independent of it. CLOSED: [2026-09-25]
Hex and binary were already drawn under every integer. The slot root's reply
now carries =:addr=, the address of the place it read, a field, element or
option payload down a path included, and the inspector shows it as =at 0x…=. A
data case's field and an expression root's value are not places and carry none,
rather than the address of a copy. A stack address is not offered to
=flan-inspect-address=, since the registry does not follow one.
** TODO A defclass is not on the definitions list as a type, and a sum's cases are not drawn ** DONE A defclass is not on the definitions list as a type, and a sum's cases are not drawn
A =defclass= is expanded away before the checker — a dyn map and a shape tag by CLOSED: [2026-09-25]
then — so there is no class table to read. A sum's cases are one symbol each and =defs= reads classes off the session's declarations, which still hold every
the daemon answers with the type's name only. =CFn= also wants adding to the type =defclass=, and lists each as kind =class= with its slots and location; its
rule. constructor is not listed again as a =fn=. Each data case is a =case= row named
=Type.Case=, drawn whenever =data= is, and the data row's signature lists its
cases. =CFn= is in =flan-mode='s type rule.
** CANCELLED A flycheck checker, and a structured JSON report ** CANCELLED A flycheck checker, and a structured JSON report
CLOSED: [2026-09-20] CLOSED: [2026-09-20]
@ -1829,9 +1845,13 @@ its slots in scope. The slots are already on the frame and already readable
(=flan_dev_frame_slot=); what is missing is checking an expression against that (=flan_dev_frame_slot=); what is missing is checking an expression against that
frame's names and types. frame's names and types.
** TODO The stack lists prelude frames ** DONE The stack lists prelude frames
=0: pause <prelude>:151:7= is the breakpoint the author wrote, not a step in CLOSED: [2026-09-25]
their program. Prelude frames want hiding by default, with a key to show them. A frame whose location is =<prelude>= is hidden by default, and a line in its
place counts the hidden run; =P= shows them. A hidden frame keeps its index,
because =locals= and the inspector are asked by it. The innermost frame is
shown even when it is the prelude's, unless the stop is =(pause)=, because it
is where the program stopped. Rules out renumbering the visible frames.
** TODO There is no stepper ** TODO There is no stepper
=(pause)= stops and offers restarts, frames, locals and the inspector, but =(pause)= stops and offers restarts, frames, locals and the inspector, but
@ -1864,10 +1884,13 @@ calls to the same function from one caller are indistinguishable in the stack.
Wants the caller storing its call site into the frame before the call, which is Wants the caller storing its call site into the frame before the call, which is
a field and a store on every dev-build call. a field and a store on every dev-build call.
** TODO The condition buffer cannot jump to the source ** DONE The condition buffer cannot jump to the source
It prints the source line and carets for the stop (=flan-cnr.el:197=) and lists CLOSED: [2026-09-25]
frames, but no key opens the file at that line. Wants RET-on-a-frame, or =M-.=, RET (and =v=) on a frame or on the stop's =at= line opens the file there; TAB
and =next-error= over the frame list. alone folds a frame's locals. The buffer is a =next-error= buffer, made current
when it opens, so =M-g M-n= walks the stop and then each frame with a file.
Refusals — the prelude, a relative path, a missing file — are one function
shared with =M-.=.
** TODO loop's bindings should be sequential, like let's ** TODO loop's bindings should be sequential, like let's
=check_loop= (=lib/check.ml:4741=) checks every initialiser before binding any, =check_loop= (=lib/check.ml:4741=) checks every initialiser before binding any,
@ -1894,10 +1917,12 @@ and a half-loaded file. =C-c C-k= is taken by the inspector.
so =next-error= works, but a minor mode installs no font-lock. Open: whether the so =next-error= works, but a minor mode installs no font-lock. Open: whether the
program's output should look different from the compiler's. program's output should look different from the compiler's.
** TODO compilation-mode steps over the notes ** DONE compilation-mode steps over the notes
Nothing sets the skip threshold, so =next-error= walks the errors and steps over CLOSED: [2026-09-25]
the notes, which are still parsed, coloured and clickable. Labelling them as The daemon buffer and the diagnostics buffer set =compilation-skip-threshold= to
warnings would make them navigable and is refused: a note is not a warning. 0 locally, so =next-error= stops on a note as well as an error. The user's own
default is left alone. Rules out relabelling a note as a warning to make it
navigable.
* Docs and the repository * Docs and the repository

60
docs/BUILT.md
View File

@ -5319,52 +5319,50 @@ So the cost of a watch call in a program nobody is debugging is **one relaxed lo
is the same number in a release build as in a dev one: `flan_dev.c` is linked into every build (`Build`, which says is the same number in a release build as in a dev one: `flan_dev.c` is linked into every build (`Build`, which says
why), so the symbols resolve either way and there is no second version of the file. why), so the symbols resolve either way and there is no second version of the file.
It is not *free*, and the distinction is worth keeping honest. Eliding the call entirely needs the compiler to know It is not *free*, and the distinction is worth keeping honest: a load and a branch per watched value per frame is the
the form, which is the `check.ml` arm below. A load and a branch per watched value per frame is the real number. real number for a scalar entry point, in either build. The `(watch ...)` form below costs that in a dev build and
nothing but its value's evaluation in any other, because the checker wraps the render in an `If` on
`flan_dev_watch_begin_n` and each backend lowers that `If` to its unit else branch when the build is not a dev one
(`Tast.is_watch_guard`). The checker does not know which build it is checking for, so the drop has to be the
backend's, the way the allocation registry's notes are. The JS dialect always drops it: there is no watch table there.
Measured on a 200-million-iteration loop at `-O2`: 0.53s with the call, 0.00s without it, the same as the loop with no
`watch` in it.
### Scalars work today; composites need a `check.ml` arm that was not built ### The scalar entry points, and the form for everything else
The four entry points a program can reach through `declare-c` are the whole feature for a scalar: Four entry points a program can reach through `declare-c` write a scalar:
```flan ```flan
(declare-c watch-i64 [name string x i64] i32 "flan_dev_watch_i64") (declare-c watch-i64 [name string x i64] i32 "flan_dev_watch_i64")
(watch-i64 "ticks" ticks) (watch-i64 "ticks" ticks)
``` ```
No arm in the checker, no new special form, nothing the compiler has to learn. They return `i32` rather than nothing They return `i32` rather than nothing for a blunt reason: `declare-c` refuses a void return outright — "which is not a
for a blunt reason: `declare-c` refuses a void return outright — "which is not a value C can carry", `shim.ml` — so a value C can carry", `shim.ml` — so a function a program can declare has to return something, and since it must, it
function a program can declare has to return something, and since it must, it returns the useful thing: 1 if the value returns the useful thing: 1 if the value was written, 0 if nobody is watching or the table is full.
was written, 0 if nobody is watching or the table is full.
A composite — a struct, a slice, a union — cannot be reached this way, and that is not a shortcoming of the four. A A composite — a struct, a slice, a union — cannot be reached that way. A Flan value carries no header, so nothing at run
Flan value carries no header, so nothing at run time can say what it is, and rendering one is a compile-time walk over time can say what it is, and rendering one is a compile-time walk over its *type*. **That is the same reason `C-x C-e`
its *type*. **That is the same reason `C-x C-e` renders in the thunk rather than marshalling anything**, and it is the renders in the thunk rather than marshalling anything**, and it is the layout decision's bill, paid in the same place.
layout decision's bill, paid in the same place.
**The missing piece is one arm in `check.ml`, and it was deliberately not written** — that file is held by another So `(watch "name" v)` is an arm in `check.ml`, beside `print`, and it is `print` with the emitter aimed elsewhere. The
lane. It sits beside `print` (`check.ml:3480`) and is the same shape as it: two share `render_ctx`; the watch emitter points each piece at `flan_dev_watch_emit*` rather than at `WriteStdout`, and a
dyn value at `flan_dyn_emit_watch`, the dyn printer with the watch slot as its sink. The walk is wrapped in
`flan_dev_watch_begin_n` — the name as bytes and a length, since that is how a Flan string crosses — and
`flan_dev_watch_end`, and runs only when `begin` answers that the table is armed and has room.
``` Two choices in it. The value is bound to a slot of the calling frame unless it is already a local or a global, because
| "watch" -> the walk names its argument once per field and a call would otherwise run once per field; and it is bound *before* the
arity loc name 2 args; (* a name and a value *) table is asked, so a side effect in the value happens whether or not anyone is watching — the program's behaviour does
(* a read, not a move — as print is, for the same reason: (watch "v" v) not depend on an editor window. A string watches quoted, as it renders inside a structure, because a table row is a
must not consume a Vec and make that its last showing *) value and an unquoted `5` could not be told from the number.
let n = check ctx (List.nth args 0) in (* must be String *)
let a = borrowed ctx target (fun () -> check ctx (List.nth args 1)) in
(* begin, the walk, end — with the emitter aimed at the four
flan_dev_watch_emit_* rather than at WriteStdout *)
Render.render { rc with emit = watch_emitter } 0 a
```
with `flan/watch-begin`, `flan/watch-end` and the four emit functions declared as externs the way `Session.externs` The daemon and the editor cannot tell which kind of caller filled the table.
already declares `flan_dev_emit*`. Nothing else has to move: `Render.render` is unchanged, the runtime side is built
and tested, and the daemon and the editor cannot tell which kind of caller filled the table.
~~That arm is also what **ghost text** is gated on.~~ **It was not, and ghost text is built without it** — see ~~That arm is also what **ghost text** is gated on.~~ **It was not, and ghost text is built without it** — see
"Ghost text finds its anchor in the buffer, not in the table" below. The claim was that values shown inline need a "Ghost text finds its anchor in the buffer, not in the table" below. The claim was that values shown inline need a
*place* and nothing in the table has one, so a source location would have to be carried per entry, so the call site *place* and nothing in the table has one, so a source location would have to be carried per entry, so the call site
would have to be generated. True of the table and false of the conclusion: the call site is in the buffer. The would have to be generated. True of the table and false of the conclusion: the call site is in the buffer.
composite renderer still wants the form, for its own reason, and it is the only one of the two that does.
## An error is a value, and there is more than one of them ## An error is a value, and there is more than one of them
@ -5651,7 +5649,7 @@ rather than a discovery.
A Flan struct is exactly its C layout. No header, no tag word — deliberately, and it is what makes a struct free and A Flan struct is exactly its C layout. No header, no tag word — deliberately, and it is what makes a struct free and
what makes the FFI work. The consequence is stated elsewhere in this file more than once: *a Flan value carries no what makes the FFI work. The consequence is stated elsewhere in this file more than once: *a Flan value carries no
header, so nothing at run time can say what it is*, which is why a rendering is a compile-time walk over a type and header, so nothing at run time can say what it is*, which is why a rendering is a compile-time walk over a type and
why `(watch "v" v)` cannot reach a composite without an arm in `check.ml`. why `(watch "v" v)` is an arm in `check.ml` rather than a function.
The allocation registry does not answer that question. It sidesteps it. **The allocator's caller knows the type at the The allocation registry does not answer that question. It sidesteps it. **The allocator's caller knows the type at the
moment it asks for memory**, and the compiler is standing right there, so a dev build writes it down: base address, moment it asks for memory**, and the compiler is standing right there, so a dev build writes it down: base address,

60
emacs/MANUAL.md
View File

@ -338,11 +338,13 @@ Keys in that buffer:
| Key | Does | | Key | Does |
|---|---| |---|---|
| `RET` | take the restart at point | | `RET` | take the restart at point; on a frame or on the `at` line, visit the source |
| `0`–`9` | take that restart by number | | `0`–`9` | take that restart by number |
| `TAB` / `n` | next restart | | `TAB` / `n` | next restart |
| `S-TAB` / `p` | previous | | `S-TAB` / `p` | previous |
| `f` | fold a stack frame open or closed | | `f` | fold a stack frame open or closed |
| `v` | visit the source of the frame at point |
| `P` | show or hide the prelude's frames |
| `i` | inspect the local or global at point | | `i` | inspect the local or global at point |
| `a` | abort | | `a` | abort |
| `g` | read the program again | | `g` | read the program again |
@ -372,6 +374,19 @@ takeable only when the program itself was already stopped — abandon the
evaluation and the program's own break comes back with them on offer. If the evaluation and the program's own break comes back with them on offer. If the
program was running, abandon and call the code again. program was running, abandon and call the code again.
**The stack.** Frames are numbered innermost first. A frame of a prelude
function — `pause` is one, so every breakpoint has one — is hidden, and a line
in its place says how many were hidden; `P` shows them. A hidden frame keeps
its number, so the numbers either side of it have a gap. The innermost frame is
where the program stopped, so it is shown even when it belongs to the prelude,
unless the stop is a `(pause)`.
A frame's location is where its function is written, and the `at` line under
the condition is the expression that stopped. `RET` on either opens that file
at that line. `next-error` (`M-g M-n`) walks the same list from any buffer
while the program is stopped: the stop first, then each frame outward, skipping
frames that have no file.
**`C-c C-M-b`** is the same choice as a quick one-key prompt, when you already **`C-c C-M-b`** is the same choice as a quick one-key prompt, when you already
know which restart you want and do not need the buffer. know which restart you want and do not need the buffer.
@ -449,7 +464,9 @@ drew. It reaches an **option's payload** and a **union case's fields**, which
have offsets but no accessor form to write. In exchange it needs a **stopped** have offsets but no accessor form to write. In exchange it needs a **stopped**
program, and it is refused — by name, with the reason — once the program program, and it is refused — by name, with the reason — once the program
resumes or if the frame's body was redefined since the frame was entered. It resumes or if the frame's body was redefined since the frame was entered. It
cannot start from an expression at all. cannot start from an expression at all. Because it reads a place in the stopped
frame, the buffer also shows where that place is stored, as `at 0x…` under the
value.
**An address** — `M-x flan-inspect-address`. A number, `#x7f…` or decimal, of **An address** — `M-x flan-inspect-address`. A number, `#x7f…` or decimal, of
the kind a debugger, a valgrind report or a C shim's `printf` hands you. There the kind a debugger, a valgrind report or a C shim's `printf` hands you. There
@ -666,19 +683,21 @@ closes it down, and killing the buffer does the same.
**The program decides what is shown.** There is no watch list to maintain, no **The program decides what is shown.** There is no watch list to maintain, no
per-variable registration, no place to type an expression. The program says per-variable registration, no place to type an expression. The program says
what it wants seen, from inside its own loop: what it wants seen, from inside its own loop, with `(watch "name" value)`:
```flan ```flan
(declare-c watch-i64 [name string x i64] i32 "flan_dev_watch_i64")
(declare-c watch-f64 [name string x f64] i32 "flan_dev_watch_f64")
(declare-c watch-str [name string s string] i32 "flan_dev_watch_str")
(defn step [] i64 (defn step [] i64
(set ticks (+ ticks 1)) (set ticks (+ ticks 1))
(watch-i64 "ticks" ticks) (watch "ticks" ticks)
(watch "player" player)
ticks) ticks)
``` ```
The value is rendered the way `print` renders it, so a struct, an array, a
slice, an option or a dyn value watches as it prints: `(Pos {.x 3 .y 1.5})`,
`[ 1 2 3]`. A string is quoted. The value is evaluated once whether or not a
watch buffer is open.
That is the whole of it. `C-c C-c` on `step` adds or removes a watched value That is the whole of it. `C-c C-c` on `step` adds or removes a watched value
the same way it changes anything else, so the watch list is edited in the place the same way it changes anything else, so the watch list is edited in the place
you were already looking. you were already looking.
@ -696,9 +715,11 @@ to see what the last frame held.
**What it costs when you are not watching.** Nothing writes the table until a **What it costs when you are not watching.** Nothing writes the table until a
watch buffer is open; `M-x flan-watch` tells the program somebody is looking watch buffer is open; `M-x flan-watch` tells the program somebody is looking
and closing it tells the program to stop. So a `watch-i64` call in a program and closing it tells the program to stop. So in a dev build a `watch` nobody is
nobody is debugging is a load and a branch that is not taken, in a release looking at costs a load and a branch that is not taken. In a release build
build as in a dev one. `watch` makes no call at all: the value is evaluated and nothing else happens.
A scalar entry point called through `declare-c` is an ordinary C call and costs
the load and the branch in either build.
**The limits.** The table holds **64 names**, and names past that are dropped **The limits.** The table holds **64 names**, and names past that are dropped
rather than being fatal — the buffer says how many, because a value that simply rather than being fatal — the buffer says how many, because a value that simply
@ -731,11 +752,18 @@ move again, so the two most useful of the five would go dead exactly when you
start playing. A whole number prints as one, because a spy on an array index start playing. A whole number prints as one, because a spy on an array index
reading `66.0000` sends you looking for a rounding bug that is not there. reading `66.0000` sends you looking for a rounding bug that is not there.
**Scalars only, so far.** `i64`, `u64`, `f64` and `string` have entry points; a **The scalar entry points.** `watch` is a form the compiler knows. The same
struct or a slice does not. That is not an oversight in the runtime — a Flan table is also reachable as plain C functions, one per scalar type, which a
value carries no header, so rendering one is a walk over its *type* at compile program declares like any other:
time, and a `(watch "hp" hp)` form in the compiler is what would do that walk.
It is not built. `flan-watch.el` says what it would need. ```flan
(declare-c watch-i64 [name string x i64] i32 "flan_dev_watch_i64")
(declare-c watch-f64 [name string x f64] i32 "flan_dev_watch_f64")
(declare-c watch-str [name string s string] i32 "flan_dev_watch_str")
```
Each returns 1 if the value was written and 0 if nobody is watching or the
table is full.
### Ghost text — the same values, inline ### Ghost text — the same values, inline

185
emacs/flan-cnr.el
View File

@ -51,8 +51,9 @@
;; expand in place, TAB to fold, everything reachable from the keyboard, ;; expand in place, TAB to fold, everything reachable from the keyboard,
;; `q' to go. What was not taken from it is the cause chain — CIDER walks ;; `q' to go. What was not taken from it is the cause chain — CIDER walks
;; `ex-cause' because a JVM exception wraps another one, and a Flan condition ;; `ex-cause' because a JVM exception wraps another one, and a Flan condition
;; wraps nothing — and its filters, which exist because a JVM backtrace is ;; wraps nothing. Of its filters one was taken: the prelude's frames are
;; mostly frames nobody wrote. ;; hidden until `P' shows them, because `(pause)' is itself a prelude function
;; and its frame is the breakpoint, not a step of the program.
;; ;;
;; Everything this buffer cannot fill in is drawn as a section that says so, by ;; Everything this buffer cannot fill in is drawn as a section that says so, by
;; name, with what it would take. A missing section is indistinguishable from ;; name, with what it would take. A missing section is indistinguishable from
@ -65,6 +66,8 @@
(require 'subr-x) (require 'subr-x)
(declare-function flan--request "flan" (form)) (declare-function flan--request "flan" (form))
(declare-function flan-visit-loc "flan" (loc subject))
(declare-function flan--forget-break-stack "flan" ())
(declare-function flan-inspect "flan-inspect" (expr)) (declare-function flan-inspect "flan-inspect" (expr))
(declare-function flan-inspect-slot "flan-inspect" (frame slot name)) (declare-function flan-inspect-slot "flan-inspect" (frame slot name))
@ -147,6 +150,10 @@ so does a list long enough to have been truncated."
"The plist this buffer was last drawn from.") "The plist this buffer was last drawn from.")
(defvar-local flan-cnr--open nil (defvar-local flan-cnr--open nil
"Indices of the frames whose locals are showing.") "Indices of the frames whose locals are showing.")
(defvar-local flan-cnr--show-prelude nil
"Whether the stack section draws the prelude's own frames.
Nil by default: a prelude frame is library code the program called, most
often `pause' itself, and `P' shows them.")
(defun flan-cnr--unavailable (key) (defun flan-cnr--unavailable (key)
(propertize (concat " not available — " (flan-cnr--why key) "\n") (propertize (concat " not available — " (flan-cnr--why key) "\n")
@ -193,7 +200,8 @@ The frame lines below say where each call was; this is the only record of the
indexing or the division itself, so it sits directly under the headline." indexing or the division itself, so it sits directly under the headline."
(let ((site (plist-get state :site))) (let ((site (plist-get state :site)))
(when site (when site
(insert (propertize (format "at %s\n" site) 'face 'shadow)) (insert (propertize (format "at %s\n" site) 'face 'shadow
'flan-cnr-loc site 'mouse-face 'highlight))
(let ((source (plist-get state :source)) (let ((source (plist-get state :source))
(lc (flan-cnr--site-line-col site))) (lc (flan-cnr--site-line-col site)))
(when (and source lc) (when (and source lc)
@ -362,26 +370,68 @@ indexing or the division itself, so it sits directly under the headline."
(list 'flan-cnr-abort t 'mouse-face 'highlight)))) (list 'flan-cnr-abort t 'mouse-face 'highlight))))
(insert "\n")) (insert "\n"))
(defun flan-cnr--prelude-frame-p (fr)
"Whether FR is a frame of a prelude function.
The prelude is compiled into every program and its functions report their
location as `<prelude>:LINE:COL'. `(pause)' is one: the frame it pushes is the
breakpoint the program's author wrote, not a step of the program."
(let ((loc (plist-get fr :loc)))
(and (stringp loc) (string-prefix-p "<prelude>:" loc))))
(defun flan-cnr--insert-hidden (n)
"The line standing in for N consecutive prelude frames that are hidden."
(let ((start (point)))
(insert (propertize
(format " %d prelude frame%s hidden — P shows %s\n"
n (if (= n 1) "" "s") (if (= n 1) "it" "them"))
'face 'shadow))
(add-text-properties start (point)
(list 'flan-cnr-hidden t 'mouse-face 'highlight))))
(defun flan-cnr--insert-stack (state) (defun flan-cnr--insert-stack (state)
(flan-cnr--section "Stack (innermost first) — TAB folds a frame's locals:") (flan-cnr--section
"Stack (innermost first) — RET visits a frame's source, TAB folds its locals:")
(let ((frames (plist-get state :stack))) (let ((frames (plist-get state :stack)))
(if (null frames) (if (null frames)
(insert (flan-cnr--unavailable 'stack)) (insert (flan-cnr--unavailable 'stack))
(let ((i -1)) (let ((i -1) (hidden 0))
(dolist (fr frames) (dolist (fr frames)
(setq i (1+ i)) (setq i (1+ i))
(let ((start (point)) ;; A hidden frame keeps its number. The index is what `locals' and
(open (memq i flan-cnr--open))) ;; the inspector are asked by, so the frames either side of a hidden
(insert (format " %2d: %s %s%s\n" i ;; run are numbered with a gap, and the line in the gap says why.
(if open "v" ">") ;;
(propertize (or (plist-get fr :fn) "?") ;; The innermost frame is where the program stopped, so it is shown
'face 'font-lock-function-name-face) ;; even when it is the prelude's — unless the stop is `(pause)',
(if (plist-get fr :loc) ;; whose own frame is the breakpoint and not where anything failed.
(propertize (format " %s" (plist-get fr :loc)) (if (and (not flan-cnr--show-prelude)
'face 'shadow) (flan-cnr--prelude-frame-p fr)
""))) (or (> i 0)
(add-text-properties start (point) (equal (plist-get state :condition) flan-cnr-breakpoint)))
(list 'flan-cnr-frame i 'mouse-face 'highlight))) (setq hidden (1+ hidden))
(when (> hidden 0)
(flan-cnr--insert-hidden hidden)
(setq hidden 0))
(flan-cnr--insert-frame i fr)))
(when (> hidden 0) (flan-cnr--insert-hidden hidden)))))
(insert "\n"))
(defun flan-cnr--insert-frame (i fr)
"Draw frame I, FR, and its locals when it is open."
(let ((start (point))
(open (memq i flan-cnr--open)))
(insert (format " %2d: %s %s%s\n" i
(if open "v" ">")
(propertize (or (plist-get fr :fn) "?")
'face 'font-lock-function-name-face)
(if (plist-get fr :loc)
(propertize (format " %s" (plist-get fr :loc))
'face 'shadow)
"")))
(add-text-properties start (point)
(append (list 'flan-cnr-frame i 'mouse-face 'highlight)
(when (plist-get fr :loc)
(list 'flan-cnr-loc (plist-get fr :loc))))))
;; Collapsed by default. A stopped program has as many locals as it ;; Collapsed by default. A stopped program has as many locals as it
;; has frames, and all of them at once is the backtrace problem again ;; has frames, and all of them at once is the backtrace problem again
;; one level down. ;; one level down.
@ -413,8 +463,7 @@ indexing or the division itself, so it sits directly under the headline."
(add-text-properties (add-text-properties
start (point) start (point)
(list 'flan-cnr-inspect (list :slot i (nth 3 l) (nth 0 l)) (list 'flan-cnr-inspect (list :slot i (nth 3 l) (nth 0 l))
'mouse-face 'highlight))))))))))) 'mouse-face 'highlight))))))))
(insert "\n"))
(defun flan-cnr--insert-globals (state) (defun flan-cnr--insert-globals (state)
"Draw the globals the stopped stack reaches. "Draw the globals the stopped stack reaches.
@ -493,7 +542,7 @@ puts the likely culprit on top."
;; an entry is annotated with have to be on screen above it to read. ;; an entry is annotated with have to be on screen above it to read.
(flan-cnr--insert-globals state) (flan-cnr--insert-globals state)
(insert (propertize (insert (propertize
"RET/0-9 take a abort TAB fold a frame i inspect g refresh q quit\n" "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect a abort g refresh q quit\n"
'face 'shadow)) 'face 'shadow))
(goto-char (point-min)) (goto-char (point-min))
;; Point starts on the restart that abandons the evaluation, when there is ;; Point starts on the restart that abandons the evaluation, when there is
@ -535,9 +584,82 @@ puts the likely culprit on top."
((get-text-property (point) 'flan-cnr-restart) ((get-text-property (point) 'flan-cnr-restart)
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index) (flan-cnr--invoke (get-text-property (point) 'flan-cnr-index)
(get-text-property (point) 'flan-cnr-restart))) (get-text-property (point) 'flan-cnr-restart)))
((get-text-property (point) 'flan-cnr-frame) (flan-cnr-toggle-frame)) ((get-text-property (point) 'flan-cnr-hidden) (flan-cnr-toggle-prelude))
((or (get-text-property (point) 'flan-cnr-frame)
(get-text-property (point) 'flan-cnr-loc))
(flan-cnr-visit))
(t (user-error "flan: nothing to take on this line")))) (t (user-error "flan: nothing to take on this line"))))
(defun flan-cnr--loc-subject (pos)
"What the location at POS is the location of, for a refusal."
(let ((i (get-text-property pos 'flan-cnr-frame)))
(if i
(format "frame %d, %s," i
(or (plist-get (nth i (plist-get flan-cnr--state :stack)) :fn)
"?"))
"the stop")))
(defun flan-cnr-visit ()
"Visit the source of the frame, or of the stop, on this line.
A frame's location is where its function is written; the stop's is the
expression that stopped."
(interactive)
(let ((loc (get-text-property (point) 'flan-cnr-loc)))
(unless loc
(user-error
(if (get-text-property (point) 'flan-cnr-frame)
"flan: this frame has no location; the program did not report one"
"flan: point is not on a frame or on the stop")))
(flan-visit-loc loc (flan-cnr--loc-subject (point)))))
(defun flan-cnr-toggle-prelude ()
"Show or hide the prelude's frames in the stack section."
(interactive)
(setq flan-cnr--show-prelude (not flan-cnr--show-prelude))
(let ((line (line-number-at-pos)))
(flan-cnr--render flan-cnr--state)
(goto-char (point-min))
(forward-line (1- line)))
(message "flan: prelude frames %s"
(if flan-cnr--show-prelude "shown" "hidden")))
(defun flan-cnr--visitable-line-p (pos)
"Whether the line at POS carries a location `next-error' can visit.
A location in angle brackets, `<prelude>', names no file, so the walk steps
over it rather than stopping on a refusal."
(let ((loc (get-text-property pos 'flan-cnr-loc)))
(and loc (not (string-prefix-p "<" loc)))))
(defun flan-cnr-next-error (&optional n reset)
"The break buffer's `next-error-function': walk the stop and its frames.
Moves N lines that carry a visitable location, from the top when RESET, and
visits the source of the one it lands on."
(setq n (or n 1))
(let ((dir (if (< n 0) -1 1))
(left (abs n))
(found nil))
(save-excursion
(if reset (goto-char (point-min)) (beginning-of-line))
;; From the top, the first step lands on the first location rather than
;; the second; and a count of zero means the line point is on.
(when (and (or reset (zerop left)) (flan-cnr--visitable-line-p (point)))
(setq left (max 0 (1- left)) found (point)))
(while (and (> left 0) (zerop (forward-line dir)) (not (eobp)))
(when (flan-cnr--visitable-line-p (point))
(setq left (1- left) found (point)))))
(when (or (> left 0) (null found))
(user-error "flan: no more frames with a source location"))
(goto-char found)
(let ((win (get-buffer-window (current-buffer))))
(when win (set-window-point win found)))
(flan-visit-loc (get-text-property found 'flan-cnr-loc)
(flan-cnr--loc-subject found))))
(defun flan-cnr--forget ()
"The stack this buffer drew is gone; stop `next-error' walking it."
(when (eq next-error-last-buffer (current-buffer))
(setq next-error-last-buffer nil)))
(defun flan-cnr--invoke (index name) (defun flan-cnr--invoke (index name)
"Take restart INDEX, named NAME. "Take restart INDEX, named NAME.
By index, because the index is the identity — two frames can offer `retry' By index, because the index is the identity — two frames can offer `retry'
@ -553,6 +675,7 @@ different restart than the one it showed."
;; buffer says so and goes, rather than redrawing a state that is about ;; buffer says so and goes, rather than redrawing a state that is about
;; to stop being true. ;; to stop being true.
(progn (message "flan: %s — %s" name (or (plist-get r :note) "accepted")) (progn (message "flan: %s — %s" name (or (plist-get r :note) "accepted"))
(flan-cnr--forget)
(quit-window)) (quit-window))
(user-error "flan: %s" (or (plist-get r :message) "refused"))))) (user-error "flan: %s" (or (plist-get r :message) "refused")))))
@ -579,7 +702,9 @@ different restart than the one it showed."
(interactive) (interactive)
(let ((r (funcall flan-cnr-request-function '(:op "abort")))) (let ((r (funcall flan-cnr-request-function '(:op "abort"))))
(if (equal (plist-get r :status) "ok") (if (equal (plist-get r :status) "ok")
(progn (message "flan: %s" (or (plist-get r :note) "aborted")) (quit-window)) (progn (message "flan: %s" (or (plist-get r :note) "aborted"))
(flan-cnr--forget)
(quit-window))
(user-error "flan: %s" (or (plist-get r :message) "refused"))))) (user-error "flan: %s" (or (plist-get r :message) "refused")))))
(defun flan-cnr-toggle-frame () (defun flan-cnr-toggle-frame ()
@ -668,6 +793,8 @@ drawn from."
(get-text-property pos 'flan-cnr-shadowed) (get-text-property pos 'flan-cnr-shadowed)
(get-text-property pos 'flan-cnr-abort) (get-text-property pos 'flan-cnr-abort)
(get-text-property pos 'flan-cnr-frame) (get-text-property pos 'flan-cnr-frame)
(get-text-property pos 'flan-cnr-hidden)
(get-text-property pos 'flan-cnr-loc)
(get-text-property pos 'flan-cnr-inspect))) (get-text-property pos 'flan-cnr-inspect)))
(defun flan-cnr-tab () (defun flan-cnr-tab ()
@ -691,6 +818,8 @@ anyone who would rather TAB always moved."
(define-key map "n" #'flan-cnr-next) (define-key map "n" #'flan-cnr-next)
(define-key map "p" #'flan-cnr-previous) (define-key map "p" #'flan-cnr-previous)
(define-key map "f" #'flan-cnr-toggle-frame) (define-key map "f" #'flan-cnr-toggle-frame)
(define-key map "v" #'flan-cnr-visit)
(define-key map "P" #'flan-cnr-toggle-prelude)
(define-key map "i" #'flan-cnr-inspect) (define-key map "i" #'flan-cnr-inspect)
(define-key map "a" #'flan-cnr-abort) (define-key map "a" #'flan-cnr-abort)
(define-key map "g" #'flan-cnr-refresh) (define-key map "g" #'flan-cnr-refresh)
@ -722,7 +851,10 @@ anyone who would rather TAB always moved."
(define-derived-mode flan-cnr-mode special-mode "flan-break" (define-derived-mode flan-cnr-mode special-mode "flan-break"
"What a stopped Flan program is offering." "What a stopped Flan program is offering."
(setq buffer-read-only t)) (setq buffer-read-only t)
;; `next-error' walks the stop and then the frames, innermost first, the way
;; it walks a compiler's messages.
(setq-local next-error-function #'flan-cnr-next-error))
(defun flan-cnr-state-from-reply (reply &optional fields stack globals) (defun flan-cnr-state-from-reply (reply &optional fields stack globals)
"The buffer's state, out of a `break' REPLY. "The buffer's state, out of a `break' REPLY.
@ -932,7 +1064,12 @@ walk from a running program."
(flan-cnr-condition-fields (flan-cnr-condition-fields
(plist-get r :condition)) (plist-get r :condition))
(flan-cnr-backtrace) (flan-cnr-backtrace)
(flan-cnr-globals)))) (flan-cnr-globals)))
;; So `M-g M-n' from the source buffer walks this stack rather than
;; the last compilation's errors. Taken back when a restart or an
;; abort is accepted, here or from `flan.el', and when the poll sees
;; the program running again: see `flan--forget-break-stack'.
(setq next-error-last-buffer buf))
(pop-to-buffer buf) (pop-to-buffer buf)
buf))) buf)))

20
emacs/flan-inspect.el
View File

@ -426,6 +426,13 @@ an atom does not carry its type.")
Kept because it is the thing edit mode hands you: a Flan literal is what the Kept because it is the thing edit mode hands you: a Flan literal is what the
renderer writes, so the buffer you type into is the value's own spelling and renderer writes, so the buffer you type into is the value's own spelling and
not a second notation invented for editing it.") not a second notation invented for editing it.")
(defvar-local flan-inspect--addr nil
"Where the value on screen is stored, as a number, or nil.
The slot root answers with it, since it is reading a place in a stopped frame,
and so does the address root. An expression root's reply carries none: the
value it renders is the result of evaluating the expression, which is not
stored anywhere the program keeps.")
(defvar-local flan-inspect--at-stop nil (defvar-local flan-inspect--at-stop nil
"Which stop this buffer was drawn at, as the daemon numbered it. "Which stop this buffer was drawn at, as the daemon numbered it.
Nil where the reply did not say — only the slot root does, because only it Nil where the reply did not say — only the slot root does, because only it
@ -511,9 +518,10 @@ stated honestly — every Flan integer is rendered through i64."
('option (format "(some …)")) ('option (format "(some …)"))
(_ (plist-get node :text)))) (_ (plist-get node :text))))
(defun flan-inspect--render (root path node stack &optional declared) (defun flan-inspect--render (root path node stack &optional declared addr)
"Draw NODE, reached by ROOT walked by PATH, with STACK behind it. "Draw NODE, reached by ROOT walked by PATH, with STACK behind it.
DECLARED is the type the daemon named, when it named one." DECLARED is the type the daemon named, when it named one. ADDR is where the
value is stored, when the reply said."
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
(erase-buffer) (erase-buffer)
(insert (propertize (flan-inspect--root-label root path) (insert (propertize (flan-inspect--root-label root path)
@ -537,6 +545,10 @@ DECLARED is the type the daemon named, when it named one."
;; someone opened the inspector on a number *for*, and it is long. ;; someone opened the inspector on a number *for*, and it is long.
(let ((detail (flan-inspect--detail node))) (let ((detail (flan-inspect--detail node)))
(when detail (insert (propertize (concat detail "\n") 'face 'shadow)))) (when detail (insert (propertize (concat detail "\n") 'face 'shadow))))
;; Where it lives, in the base an address is read in. An address root
;; names its address in the line above already.
(when (and addr (not (eq (car-safe root) :addr)))
(insert (propertize (format "at 0x%X\n" addr) 'face 'shadow)))
;; The stack made visible. CIDER keeps it and does not show it; here it is ;; The stack made visible. CIDER keeps it and does not show it; here it is
;; the difference between a value and *which* value, and the thing that was ;; the difference between a value and *which* value, and the thing that was
;; typed at the root is often several steps back by now. ;; typed at the root is often several steps back by now.
@ -644,6 +656,7 @@ and whether that may be followed is the answer"))
"flan: the program answered without a value for %s" "flan: the program answered without a value for %s"
(flan-inspect--root-label root path))) (flan-inspect--root-label root path)))
:type (plist-get r :type) :type (plist-get r :type)
:addr (plist-get r :addr)
;; The stop the read happened at, where the reply carried one. It ;; The stop the read happened at, where the reply carried one. It
;; travels with the value rather than being asked for separately, ;; travels with the value rather than being asked for separately,
;; because asked separately it would be a second question about a ;; because asked separately it would be a second question about a
@ -663,6 +676,7 @@ and whether that may be followed is the answer"))
(setq flan-inspect--node (flan-inspect-parse flan-inspect--rendered)) (setq flan-inspect--node (flan-inspect-parse flan-inspect--rendered))
(setq flan-inspect--type (plist-get answer :type)) (setq flan-inspect--type (plist-get answer :type))
(setq flan-inspect--at-stop (plist-get answer :at-stop)) (setq flan-inspect--at-stop (plist-get answer :at-stop))
(setq flan-inspect--addr (plist-get answer :addr))
(setq flan-inspect--stack stack) (setq flan-inspect--stack stack)
(setq flan-inspect--editing nil) (setq flan-inspect--editing nil)
;; Put back what editing turned off, here and not in the two commands ;; Put back what editing turned off, here and not in the two commands
@ -673,7 +687,7 @@ and whether that may be followed is the answer"))
(setq buffer-read-only t) (setq buffer-read-only t)
(setq-local truncate-lines t) (setq-local truncate-lines t)
(flan-inspect--render root path flan-inspect--node stack (flan-inspect--render root path flan-inspect--node stack
flan-inspect--type)) flan-inspect--type flan-inspect--addr))
(display-buffer buf) (display-buffer buf)
buf)) buf))

7
emacs/flan-mode.el
View File

@ -235,8 +235,9 @@ reason and is the odd one — it is legal only as the last item of a `def' or a
("\\_<\\([a-zA-Z][a-zA-Z0-9!?*+=<>._-]*/\\)" 1 font-lock-type-face) ("\\_<\\([a-zA-Z][a-zA-Z0-9!?*+=<>._-]*/\\)" 1 font-lock-type-face)
;; The types the compiler knows without being told: every primitive in ;; The types the compiler knows without being told: every primitive in
;; `Types.primitive_names', plus the four applied ones the checker ;; `Types.primitive_names', plus the four applied ones the checker
;; resolves and the function type. `dyn' is lowercase on purpose — it is ;; resolves and the two function types, `Fn' and `CFn'. `dyn' is
;; a primitive beside `i64' and `bool', not a container over something. ;; lowercase on purpose — it is a primitive beside `i64' and `bool', not
;; a container over something.
;; `int' and `float' are builtin aliases for `i32' and `f32'. ;; `int' and `float' are builtin aliases for `i32' and `f32'.
;; ;;
;; `Unit' is deliberately absent, though `Types.primitive_names' has it. ;; `Unit' is deliberately absent, though `Types.primitive_names' has it.
@ -245,7 +246,7 @@ reason and is the odd one — it is legal only as the last item of a `def' or a
;; word outright — unit is spelled `()'. Drawing it as a valid type would ;; word outright — unit is spelled `()'. Drawing it as a valid type would
;; advertise a spelling the parser rejects, which is the same reason ;; advertise a spelling the parser rejects, which is the same reason
;; `find-restart' and `await' are left out of `flan--special'. ;; `find-restart' and `await' are left out of `flan--special'.
("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|string\\|dyn\\|int\\|float\\|Never\\|Allocator\\|Ptr\\|Option\\|Vec\\|Map\\|Fn\\)\\_>" ("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|string\\|dyn\\|int\\|float\\|Never\\|Allocator\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>"
. font-lock-type-face) . font-lock-type-face)
;; A type variable, `$t', which is what a generic `defn' names its ;; A type variable, `$t', which is what a generic `defn' names its
;; parameter types with and what `{:where (ordered? $t)}' constrains. ;; parameter types with and what `{:where (ordered? $t)}' constrains.

25
emacs/flan-watch.el
View File

@ -62,19 +62,17 @@
;; insert, because it diffs, so point and scroll survive a repaint instead of ;; insert, because it diffs, so point and scroll survive a repaint instead of
;; being yanked to the top five times a second. ;; being yanked to the top five times a second.
;; ;;
;; What a program writes today, with no compiler change: ;; What a program writes:
;;
;; (declare-c watch-i64 [name string x i64] i32 "flan_dev_watch_i64")
;; (declare-c watch-f64 [name string x f64] i32 "flan_dev_watch_f64")
;; ;;
;; (defn step [] i64 ;; (defn step [] i64
;; (set ticks (+ ticks 1)) ;; (set ticks (+ ticks 1))
;; (watch-i64 "ticks" ticks) ;; (watch "ticks" ticks)
;; (watch "player" player)
;; ticks) ;; ticks)
;; ;;
;; Scalars only, so far. A struct or a slice needs a compile-time walk over ;; `watch' renders any value the way `print' does — a struct, a slice, a dyn
;; its type — a `(watch "hp" hp)' form in the checker — and that is a file this ;; value — into the table. The scalar entry points underneath it,
;; change does not own. See docs/BUILT.md. ;; `flan_dev_watch_i64' and the rest, are reachable through `declare-c' too.
;;; Code: ;;; Code:
@ -118,11 +116,9 @@ was the only consumer and wrong the moment it was not.")
"The buffer's text for ROWS. OVERFLOW means some name found no slot." "The buffer's text for ROWS. OVERFLOW means some name found no slot."
(if (null rows) (if (null rows)
(concat "nothing is being watched\n\n" (concat "nothing is being watched\n\n"
"The program decides what is shown. Call into the watch table\n" "The program decides what is shown. Write into the watch table\n"
"from your own loop:\n\n" "from your own loop:\n\n"
" (declare-c watch-i64 [name string x i64] i32 \"flan_dev_watch_i64\")\n" " (watch \"ticks\" ticks)\n")
" ...\n"
" (watch-i64 \"ticks\" ticks)\n")
(let ((w (apply #'max (mapcar (lambda (r) (length (car r))) rows)))) (let ((w (apply #'max (mapcar (lambda (r) (length (car r))) rows))))
(concat (concat
(mapconcat (lambda (r) (mapconcat (lambda (r)
@ -172,9 +168,8 @@ was the only consumer and wrong the moment it was not.")
;; both are painted from the same reply, in `flan-watch--absorb'. ;; both are painted from the same reply, in `flan-watch--absorb'.
;; ;;
;; WHERE A VALUE ATTACHES. The table carries a name and a rendered string and ;; WHERE A VALUE ATTACHES. The table carries a name and a rendered string and
;; no source location, and it is not going to grow one here — that needs a ;; no source location. A location is not actually missing: `(watch "hp" hp)'
;; `(watch ...)' form in the checker, which is a file this does not own. But a ;; or `(watch-i64 "hp" hp)' is *in the buffer*,
;; location is not actually missing: `(watch-i64 "hp" hp)' is *in the buffer*,
;; and the name in the table is the string literal in it. So the anchor is ;; and the name in the table is the string literal in it. So the anchor is
;; found by searching the text rather than by being told, which costs one ;; found by searching the text rather than by being told, which costs one
;; regexp scan per displayed buffer per repaint and needs nothing new from the ;; regexp scan per displayed buffer per repaint and needs nothing new from the

133
emacs/flan.el
View File

@ -78,6 +78,15 @@
;; the commands here and requires nothing back. ;; the commands here and requires nothing back.
(require 'flan-mode) (require 'flan-mode)
(defun flan--navigable-notes ()
"Make `next-error' stop on a note as well as on an error, in this buffer.
A diagnostic's notes are `file:line:col: note: ...' lines, and `compile'
reads the word `note' as an info message. Its default
`compilation-skip-threshold' of 1 steps over info messages, so the second
location a diagnostic names was clickable but never reached by `next-error'.
Zero skips nothing. A note is not relabelled as a warning to get there."
(setq-local compilation-skip-threshold 0))
(defgroup flan nil (defgroup flan nil
"Talking to a running Flan program." "Talking to a running Flan program."
:group 'flan :group 'flan
@ -475,6 +484,7 @@ with it, and a rejected evaluation is a likely moment to *become* stopped."
(setq flan--stopped now) (setq flan--stopped now)
(unless (equal was now) (unless (equal was now)
(force-mode-line-update t) (force-mode-line-update t)
(unless now (flan--forget-break-stack))
;; Once, on the edge. A message every poll would bury whatever else the ;; Once, on the edge. A message every poll would bury whatever else the
;; echo area was saying, every second, for as long as the program sat ;; echo area was saying, every second, for as long as the program sat
;; there. ;; there.
@ -821,7 +831,8 @@ It builds the program first, which for a cold project is most of this."
;; program runs, and `compilation-mode' would claim it as the output of ;; program runs, and `compilation-mode' would claim it as the output of
;; one finished command — killing the process on a `recompile', among ;; one finished command — killing the process on a `recompile', among
;; other things it has no business doing to a live session. ;; other things it has no business doing to a live session.
(compilation-minor-mode 1)) (compilation-minor-mode 1)
(flan--navigable-notes))
(make-process (make-process
:name "flan-daemon" :buffer buf :name "flan-daemon" :buffer buf
:command args :command args
@ -1160,6 +1171,7 @@ apart, so a prompt cannot take a different restart than the one it showed."
(progn (progn
;; Accepted, not resumed — see `flan-restart'. ;; Accepted, not resumed — see `flan-restart'.
(setq flan--stopped nil) (setq flan--stopped nil)
(flan--forget-break-stack)
(force-mode-line-update t) (force-mode-line-update t)
(message "flan: %s — %s" name (or (plist-get r :note) "accepted"))) (message "flan: %s — %s" name (or (plist-get r :note) "accepted")))
(user-error "flan: %s" (or (plist-get r :message) "refused"))))) (user-error "flan: %s" (or (plist-get r :message) "refused")))))
@ -1181,6 +1193,7 @@ here for a name known in advance."
;; re-established by the next poll if the program is somehow still ;; re-established by the next poll if the program is somehow still
;; there. ;; there.
(setq flan--stopped nil) (setq flan--stopped nil)
(flan--forget-break-stack)
(force-mode-line-update t) (force-mode-line-update t)
(message "flan: %s — %s" name (message "flan: %s — %s" name
(or (plist-get r :note) "accepted"))) (or (plist-get r :note) "accepted")))
@ -1226,6 +1239,7 @@ nothing left to serve once it has gone."
(let ((r (flan--request '(:op "abort")))) (let ((r (flan--request '(:op "abort"))))
(if (equal (plist-get r :status) "ok") (if (equal (plist-get r :status) "ok")
(progn (setq flan--stopped nil) (progn (setq flan--stopped nil)
(flan--forget-break-stack)
(force-mode-line-update t) (force-mode-line-update t)
(message "flan: %s" (or (plist-get r :note) "aborted"))) (message "flan: %s" (or (plist-get r :note) "aborted")))
(user-error "flan: %s" (or (plist-get r :message) "refused"))))) (user-error "flan: %s" (or (plist-get r :message) "refused")))))
@ -1307,6 +1321,52 @@ than being told so."
(string-to-number (match-string 2 loc)) (string-to-number (match-string 2 loc))
(string-to-number (match-string 3 loc))))) (string-to-number (match-string 3 loc)))))
(defun flan--forget-break-stack ()
"Stop `next-error' walking the break buffer's stack.
The break buffer makes itself `next-error-last-buffer' while the program is
stopped. Once the program resumes or ends that stack is gone, and `M-g M-n'
from a source buffer must go back to the last compilation's errors rather
than visit frames that no longer exist."
(let ((buf (and (boundp 'flan-cnr-buffer)
(get-buffer (symbol-value 'flan-cnr-buffer)))))
(when (and buf (eq next-error-last-buffer buf))
(setq next-error-last-buffer nil))))
(defun flan--visitable-loc (loc subject)
"LOC as (FILE LINE COL) when FILE can be visited, or a `user-error'.
SUBJECT names what LOC is the location of, for the refusal. One set of
refusals for every place that jumps to a location the daemon sent: M-. on a
definition, and RET on a frame or on the stop in the break buffer."
(let ((parts (flan--parse-loc loc)))
(cond
((null parts)
(user-error "flan: the daemon gave %s an unreadable location: %s"
subject loc))
((string-match-p "\\`<.*>\\'" (nth 0 parts))
;; The prelude is a string inside the compiler (lib/prelude.ml) and
;; names itself <prelude>; anything in angle brackets is a placeholder
;; the frontend made up, not a path.
(user-error "flan: %s is defined in %s, which is not a file on disk"
subject (nth 0 parts)))
((not (file-name-absolute-p (nth 0 parts)))
;; The daemon makes its own source path absolute, so anything relative
;; arriving here came from somewhere that did not, and the directory it
;; is relative to is the daemon's, not this one's.
(user-error "flan: %s is at %s, relative to a directory this end does not know"
subject (nth 0 parts)))
((not (file-exists-p (nth 0 parts)))
(user-error "flan: %s is defined in %s, which is not a file on disk"
subject (nth 0 parts)))
(t parts))))
(defun flan-visit-loc (loc subject)
"Visit LOC in another window, refusing by `flan--visitable-loc's rules.
Returns the buffer visited."
(let ((parts (flan--visitable-loc loc subject)))
(find-file-other-window (nth 0 parts))
(goto-char (flan--position (nth 1 parts) (nth 2 parts)))
(current-buffer)))
(defun flan--position (line col) (defun flan--position (line col)
"Position of LINE and byte-column COL in the current buffer." "Position of LINE and byte-column COL in the current buffer."
(save-excursion (save-excursion
@ -1449,7 +1509,8 @@ no longer wrong."
;; should go there. The minor mode rather than deriving from ;; should go there. The minor mode rather than deriving from
;; `compilation-mode', because this buffer is not the output of a command ;; `compilation-mode', because this buffer is not the output of a command
;; that ran once. ;; that ran once.
(compilation-minor-mode 1)) (compilation-minor-mode 1)
(flan--navigable-notes))
(defvar-local flan--diagnostics-memory-start nil (defvar-local flan--diagnostics-memory-start nil
"Marker at the start of the memory section, or nil while there is none. "Marker at the start of the memory section, or nil while there is none.
@ -1804,8 +1865,9 @@ other, and KIND is what tells it apart where that matters.")
"Which kinds of name to colour by what the running program says they are. "Which kinds of name to colour by what the running program says they are.
A list of kinds drawn from `flan--dynamic-faces': `macro', `fn', `var', A list of kinds drawn from `flan--dynamic-faces': `macro', `fn', `var',
`const', `struct', `data', `union', `enum', `alias', `extern', `builtin'. `const', `struct', `data', `union', `enum', `alias', `class', `extern',
t draws all of them and nil draws none. `builtin'. t draws all of them and nil draws none. A data type's cases are
drawn when `data' is on the list.
The default is macros alone, which is the one kind a reader cannot work out The default is macros alone, which is the one kind a reader cannot work out
from the call itself — a macro does not evaluate its arguments, so the shape from the call itself — a macro does not evaluate its arguments, so the shape
@ -1870,7 +1932,11 @@ compiler has grown since, which is the point of asking rather than listing."
("data" . flan-type-face) ("data" . flan-type-face)
("union" . flan-type-face) ("union" . flan-type-face)
("enum" . flan-type-face) ("enum" . flan-type-face)
("alias" . flan-type-face)) ("alias" . flan-type-face)
;; A data type's case, `Shape.Rect', and a `defclass', which is a name
;; that constructs a value of that class.
("case" . flan-type-face)
("class" . flan-type-face))
"The face for each kind the `defs' op answers with. "The face for each kind the `defs' op answers with.
A kind not listed here is left undrawn rather than guessed at: the daemon is A kind not listed here is left undrawn rather than guessed at: the daemon is
allowed to grow the set, and a name drawn in the wrong colour says something allowed to grow the set, and a name drawn in the wrong colour says something
@ -1886,7 +1952,9 @@ The setting is written with symbols because that is what a user types; the
wire answers with strings." wire answers with strings."
(cond ((eq flan-font-lock-dynamically t) t) (cond ((eq flan-font-lock-dynamically t) t)
((null flan-font-lock-dynamically) nil) ((null flan-font-lock-dynamically) nil)
(t (and (memq (intern kind) flan-font-lock-dynamically) t)))) (t (and (memq (intern (if (equal kind "case") "data" kind))
flan-font-lock-dynamically)
t))))
(defvar flan--dynamic-face nil (defvar flan--dynamic-face nil
"The face `flan--dynamic-match' found, read by the font-lock rule after it.") "The face `flan--dynamic-match' found, read by the font-lock rule after it.")
@ -1927,10 +1995,10 @@ Leaves its face in `flan--dynamic-face' for the rule that calls this."
(let ((sym (match-string-no-properties 0))) (let ((sym (match-string-no-properties 0)))
(setq face (gethash sym flan--dynamic-table)) (setq face (gethash sym flan--dynamic-table))
;; A constructor is written `Type.Case', and a dot is a name character, ;; A constructor is written `Type.Case', and a dot is a name character,
;; so the whole thing is one symbol and no table could hold it — the ;; so the whole thing is one symbol. The daemon lists each case under
;; daemon answers with the type's name and knows nothing of the cases. ;; that full name, so the lookup above finds it. A dotted symbol it
;; The type half is drawn and the case half left alone, which is the ;; does not list, such as a case that does not exist, has only its
;; true statement: one of them is a name the program defines. ;; type half drawn.
(unless face (unless face
(let ((dot (string-search "." sym))) (let ((dot (string-search "." sym)))
(when (and dot (> dot 0)) (when (and dot (> dot 0))
@ -2004,10 +2072,11 @@ Called for its effect on one buffer; `flan--dynamic-sync' does every buffer."
(message "flan: %d names" (length flan--defs))) (message "flan: %d names" (length flan--defs)))
flan--defs) flan--defs)
(defconst flan--compiled-kinds '("fn" "macro") (defconst flan--compiled-kinds '("fn" "macro" "class")
"The kinds that have a body the compiler emitted code for. "The kinds that have a body the compiler emitted code for.
A macro is one: `Parse' desugars `(defmacro m [a] …)' into a `defn', so it is A macro is one: `Parse' desugars `(defmacro m [a] …)' into a `defn', so it is
compiled, installed and disassemblable exactly as a function is. It reaches compiled, installed and disassemblable exactly as a function is. So is a
class, whose name is its constructor `defn'. It reaches
this end as kind `macro' rather than as `fn' — that is the point of the kind this end as kind `macro' rather than as `fn' — that is the point of the kind
— and every list that offers \"a thing with a body\" has to say both words or — and every list that offers \"a thing with a body\" has to say both words or
it silently stops offering macros.") it silently stops offering macros.")
@ -2125,37 +2194,15 @@ in this program; C-c C-v describes it" (car d)))
(user-error "flan: %s is a %s, and the daemon reports no location for one" (user-error "flan: %s is a %s, and the daemon reports no location for one"
(car d) (nth 1 d))) (car d) (nth 1 d)))
(t (t
(let ((parts (flan--parse-loc (nth 3 d)))) (let ((parts (flan--visitable-loc (nth 3 d) (car d))))
(cond (list (xref-make
((null parts) (nth 2 d)
(user-error "flan: the daemon gave %s an unreadable location: %s" (xref-make-file-location
(car d) (nth 3 d))) (nth 0 parts) (nth 1 parts)
((string-match-p "\\`<.*>\\'" (nth 0 parts)) ;; A byte column, like every other one the daemon sends, but
;; The prelude is a string inside the compiler (lib/prelude.ml) and ;; a top-level definition starts at column 1 and anything
;; names itself <prelude>; anything in angle brackets is a ;; indenting it is ASCII, so the two agree here.
;; placeholder the frontend made up, not a path. (max 0 (1- (nth 2 parts)))))))))))
(user-error "flan: %s is defined in %s, which is not a file on disk"
(car d) (nth 0 parts)))
((not (file-name-absolute-p (nth 0 parts)))
;; The daemon makes its own source path absolute, so anything
;; relative arriving here came from somewhere that did not, and the
;; directory it is relative to is the daemon's, not this one's.
(user-error "flan: %s is at %s, relative to a directory this end does not know"
(car d) (nth 0 parts)))
((not (file-exists-p (nth 0 parts)))
;; The prelude is a string inside the compiler (lib/prelude.ml), so
;; its location names a file nobody can visit.
(user-error "flan: %s is defined in %s, which is not a file on disk"
(car d) (nth 0 parts)))
(t
(list (xref-make
(nth 2 d)
(xref-make-file-location
(nth 0 parts) (nth 1 parts)
;; A byte column, like every other one the daemon sends, but
;; a top-level definition starts at column 1 and anything
;; indenting it is ASCII, so the two agree here.
(max 0 (1- (nth 2 parts)))))))))))))
;;; Documentation ;;; Documentation

166
emacs/test-flan-cider.el
View File

@ -196,7 +196,20 @@
(let ((text (with-current-buffer (save-window-excursion (flan-inspect "flags")) (let ((text (with-current-buffer (save-window-excursion (flan-inspect "flags"))
(buffer-string)))) (buffer-string))))
(test-flan--check "a number opened on its own shows its bases" (test-flan--check "a number opened on its own shows its bases"
(string-match-p "0xFF 0b1111_1111" text)))) (string-match-p "0xFF 0b1111_1111" text))
(test-flan--check "an expression's value has no address line"
(not (string-match-p "^at 0x" text)))))
;; Where a slot's value is stored, which the slot root's reply carries: under
;; the value, in hex.
(let ((flan-inspect-request-function
(lambda (_) '(:status "ok" :type "i32" :value "7" :addr 140737488345360)))
(flan-inspect-buffer " *test-inspect*"))
(let ((text (with-current-buffer
(save-window-excursion (flan-inspect-slot 1 0 "n"))
(buffer-string))))
(test-flan--check "a slot's value says where it is stored"
(string-match-p "^at 0x7FFFFFFFD910$" text))))
(let ((flan-inspect-request-function (let ((flan-inspect-request-function
(lambda (_) '(:status "ok" :value "(Mask {.bits 255 .name \"all\"})"))) (lambda (_) '(:status "ok" :value "(Mask {.bits 255 .name \"all\"})")))
@ -1028,7 +1041,8 @@ would be overwritten. Look again and re-do the edit")
(test-flan--check "the stack says the program is running, not that it is unbuilt" (test-flan--check "the stack says the program is running, not that it is unbuilt"
(string-match-p "Stack.*\n not available.*running" (string-match-p "Stack.*\n not available.*running"
(substring text (string-match "--- Stack" text)))) (substring text (string-match "--- Stack" text))))
(test-flan--check "and the keys are shown" (string-match-p "TAB fold a frame" text))) (test-flan--check "and the keys are shown" (and (string-match-p "TAB fold" text)
(string-match-p "P prelude frames" text))))
;; A stopped program with nothing on offer between the error and the top. It ;; A stopped program with nothing on offer between the error and the top. It
;; is a real state — spec-conditions §2's `error' with no `restart-case' above ;; is a real state — spec-conditions §2's `error' with no `restart-case' above
@ -1229,6 +1243,129 @@ would be overwritten. Look again and re-do the edit")
(test-flan--check "and TAB again closes it" (test-flan--check "and TAB again closes it"
(not (string-match-p "i32 i = 7" (buffer-string)))))) (not (string-match-p "i32 i = 7" (buffer-string))))))
;; The prelude's frames, and the source behind a frame. `(pause)' is a prelude
;; function, so the innermost frame of every breakpoint is the prelude's own and
;; not a step of the program. It is hidden and keeps its number, because the
;; number is what `locals' and the inspector are asked by.
(let* ((dir (make-temp-file "flan-cnr-src" t))
(src (expand-file-name "game.flan" dir)))
(with-temp-file src
(insert "(defn tick [] ()\n (pause))\n\n(defn main [] ()\n (tick))\n"))
(let* ((state (list :condition "Pause" :restarts '("continue")
:site (format "%s:2:3" src) :source " (pause))"
:stack (list (list :fn "pause" :loc "<prelude>:151:7"
:fetched t :locals nil)
(list :fn "tick" :loc (format "%s:1:1" src)
:fetched t :locals nil)
(list :fn "main" :loc (format "%s:4:1" src)
:fetched t :locals nil))))
(buf (test-flan--cnr state)))
(with-current-buffer buf
(setq flan-cnr--show-prelude nil)
(flan-cnr--render state)
(let ((text (buffer-string)))
(test-flan--check "a prelude frame is hidden to begin with"
(not (string-match-p "0: > pause" text)))
(test-flan--check "and a line in its place says so"
(string-match-p "1 prelude frame hidden — P shows it" text))
(test-flan--check "the program's frames keep their numbers"
(and (string-match-p " 1: > tick" text)
(string-match-p " 2: > main" text))))
(goto-char (point-min))
(search-forward "prelude frame hidden")
(flan-cnr-take)
(test-flan--check "RET on that line shows the prelude frames"
(string-match-p " 0: > pause +<prelude>:151:7"
(buffer-string)))
(goto-char (point-min))
(search-forward " 0: > pause")
(let ((msg (test-flan--caught #'flan-cnr-visit)))
(test-flan--check "visiting a prelude frame refuses, naming the prelude"
(and msg (string-match-p "<prelude>, which is not a file" msg))))
(flan-cnr-toggle-prelude)
(test-flan--check "and P hides them again"
(not (string-match-p "0: > pause" (buffer-string))))
;; RET on a frame goes to where its function is written.
(goto-char (point-min))
(search-forward " 2: > main")
(save-window-excursion
(let ((visited (progn (flan-cnr-take) (current-buffer))))
(test-flan--check "RET on a frame visits its source"
(equal (buffer-file-name visited) src))
(test-flan--check "at the frame's line"
(= (line-number-at-pos) 4))
(kill-buffer visited)))
(test-flan--check "RET on a frame no longer folds it"
(not (memq 2 flan-cnr--open)))
;; next-error: the stop first, then each frame with a file behind it.
(test-flan--check "the break buffer is a next-error buffer"
(eq next-error-function #'flan-cnr-next-error))
(let ((lines nil))
(save-window-excursion
(with-current-buffer buf
(goto-char (point-min))
(dotimes (k 3)
(let ((b (flan-cnr-next-error 1 (zerop k))))
(push (with-current-buffer b (line-number-at-pos)) lines)
(set-buffer buf)))
(test-flan--check "and past the last frame it says so"
(test-flan--caught
(lambda () (flan-cnr-next-error 1))))
(flan-cnr-next-error -1)
(test-flan--check "and walks back"
(= (line-number-at-pos) 1))))
(test-flan--check "next-error walks the stop, then tick, then main"
(equal (nreverse lines) '(2 1 4))))
(let ((b (get-file-buffer src))) (when b (kill-buffer b))))
(delete-directory dir t)))
;; A stop raised inside a prelude function is shown where it stopped: the
;; innermost frame stays even though it is the prelude's, and the prelude
;; frames further out are still hidden. `(pause)' is the exception, above.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "BoundsError" :restarts nil
:stack (list (list :fn "sum" :loc "<prelude>:40:3")
(list :fn "fold" :loc "<prelude>:12:1")
(list :fn "main" :loc "/g.flan:3:1"))))
(buffer-string))))
(test-flan--check "a prelude frame that stopped is shown"
(string-match-p " 0: > sum" text))
(test-flan--check "and the prelude frames outside it are hidden"
(and (not (string-match-p " 1: > fold" text))
(string-match-p "1 prelude frame hidden" text))))
;; Once a restart or an abort is accepted the stack is gone, and `next-error'
;; from a source buffer must stop walking it.
(dolist (how '(restart abort))
(let* ((flan-cnr-request-function (lambda (_) '(:status "ok")))
(buf (test-flan--cnr (list :condition "Missing" :restarts '("retry")
:stack (list (list :fn "f" :loc "/x.flan:1:1"))))))
(setq next-error-last-buffer buf)
(with-current-buffer buf
(save-window-excursion
(if (eq how 'abort) (flan-cnr-abort)
(goto-char (point-min))
(search-forward "retry")
(flan-cnr-take))))
(test-flan--check (format "after the %s, next-error no longer walks the stack" how)
(null next-error-last-buffer))))
;; And the same when the program resumed some other way: the break buffer is
;; forgotten, and any other next-error buffer is left alone.
(let ((flan-cnr-buffer " *test-cnr*")
(other (get-buffer-create " *test-other-errors*")))
(setq next-error-last-buffer (get-buffer " *test-cnr*"))
(flan--forget-break-stack)
(test-flan--check "a resume forgets the break buffer as the next-error buffer"
(null next-error-last-buffer))
(setq next-error-last-buffer other)
(flan--forget-break-stack)
(test-flan--check "and leaves a compilation's alone"
(eq next-error-last-buffer other))
(setq next-error-last-buffer nil)
(kill-buffer other))
;; The two buffers meet, and this is the fixture the bug lived in. `i' used ;; The two buffers meet, and this is the fixture the bug lived in. `i' used
;; to send the local's *name* to be evaluated, which resolves wherever the ;; to send the local's *name* to be evaluated, which resolves wherever the
;; evaluator stands: right on the innermost frame by luck, and on any other ;; evaluator stands: right on the innermost frame by luck, and on any other
@ -1680,6 +1817,31 @@ stopped program, which is the case where it should fire."
(eq (key-binding (kbd k)) #'flan-macroexpand--not-source)) (eq (key-binding (kbd k)) #'flan-macroexpand--not-source))
'("C-c C-c" "C-c C-k" "C-x C-e")))) '("C-c C-c" "C-c C-k" "C-x C-e"))))
;; A diagnostic's note is a second `file:line:col:' line, labelled `note:'.
;; `compile' reads it as an info message, and next-error has to stop on it as
;; well as on the error above it, in both buffers that carry diagnostics.
(message "\nnext-error reaches a note")
(let ((flan-diagnostics-buffer " *test-flan-diag*"))
(with-current-buffer (get-buffer-create flan-diagnostics-buffer)
(flan-diagnostics-mode)
(let ((inhibit-read-only t))
(insert "a.flan:3:5: cannot add a bool to an i64\n"
" ^\n"
"a.flan:1:7: note: the bool was bound here\n"
" -\n"
"b.flan:9:2: the next error\n"))
(goto-char (point-min))
(compilation-next-error 1)
(test-flan--check "from the error, n lands on its note"
(looking-at "a.flan:1:7: note:"))
(compilation-next-error 1)
(test-flan--check "and then on the next error"
(looking-at "b.flan:9:2:"))
(test-flan--check "the threshold is this buffer's, not the user's setting"
(and (local-variable-p 'compilation-skip-threshold)
(eql (default-value 'compilation-skip-threshold) 1))))
(kill-buffer flan-diagnostics-buffer))
;; `flan-mode' itself — indentation, which is a function from text to text and ;; `flan-mode' itself — indentation, which is a function from text to text and
;; so belongs with the other fixture-driven checks rather than with anything ;; so belongs with the other fixture-driven checks rather than with anything
;; that needs a daemon. Loaded rather than run separately because ;; that needs a daemon. Loaded rather than run separately because

34
emacs/test-flan-mode.el
View File

@ -425,6 +425,8 @@
("(def v (Vec u8))" "Vec" font-lock-type-face "Vec") ("(def v (Vec u8))" "Vec" font-lock-type-face "Vec")
("(declare apply [(Fn [i64] i64)] i64)" "Fn" ("(declare apply [(Fn [i64] i64)] i64)" "Fn"
font-lock-type-face "Fn") font-lock-type-face "Fn")
("(declare call [(CFn [i64] i64)] i64)" "CFn"
font-lock-type-face "CFn")
("(defn seen? [k $t] bool 1)" "$t" font-lock-type-face ("(defn seen? [k $t] bool 1)" "$t" font-lock-type-face
"a type variable") "a type variable")
;; The package alias of a qualified name, `clojure-mode''s ;; The package alias of a qualified name, `clojure-mode''s
@ -483,7 +485,10 @@
("gravity" "const" "gravity f32" "" "") ("gravity" "const" "gravity f32" "" "")
("with-retry" "macro" "with-retry [args] Form" "" "") ("with-retry" "macro" "with-retry [args] Form" "" "")
("Pixel" "struct" "Pixel" "" "") ("Pixel" "struct" "Pixel" "" "")
("Shape" "data" "Shape" "" "") ("Shape" "data" "Shape [Empty (Dot [x f64 y f64])]" "" "")
("Shape.Empty" "case" "Shape.Empty" "" "")
("Shape.Dot" "case" "(Shape.Dot [x f64 y f64])" "" "")
("point" "class" "point [x y]" "sand.flan:20:1" "")
("Key" "enum" "Key" "" "") ("Key" "enum" "Key" "" "")
("sim/step" "fn" "sim/step [] ()" "sand.flan:9" "") ("sim/step" "fn" "sim/step [] ()" "sand.flan:9" "")
("a/draw" "fn" "a/draw [] ()" "" "") ("a/draw" "fn" "a/draw [] ()" "" "")
@ -570,17 +575,30 @@
(let ((flan--defs test-flan-mode--defs)) (let ((flan--defs test-flan-mode--defs))
(not (member "ticks" (flan--compiled-names))))) (not (member "ticks" (flan--compiled-names)))))
;; A constructor is `Type.Case' and is one symbol, so the type half is what ;; A constructor is `Type.Case' and is one symbol. The daemon lists each
;; the program can speak for and the case half is left alone. ;; case under that name, so the whole symbol is drawn, and it is drawn when
;; the data type is: a case is part of its type, not a kind to ask for apart.
(test-flan--check (test-flan--check
"a constructor's type half is drawn" "a constructor is drawn whole, case half included"
(let ((flan-font-lock-dynamically t)) (let ((flan-font-lock-dynamically '(data)))
(eq (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" "Shape") (eq (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" ".Dot")
'flan-type-face))) 'flan-type-face)))
(test-flan--check (test-flan--check
"and its case half is not" "and not when data types are not asked for"
(null (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" ".Dot"))) (null (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" "Shape.Dot")))
(test-flan--check
"a case the program does not have draws only its type half"
(let ((flan-font-lock-dynamically t))
(and (eq (test-flan-mode--dyn-face "(match s (Shape.Nope) 1)" "Shape")
'flan-type-face)
(null (test-flan-mode--dyn-face "(match s (Shape.Nope) 1)" ".Nope")))))
(test-flan--check
"a class the program defines is drawn when classes are asked for"
(let ((flan-font-lock-dynamically '(class)))
(eq (test-flan-mode--dyn-face "(point 1 2)" "point") 'flan-type-face)))
(test-flan--check (test-flan--check
"a name the program has never heard of is left alone" "a name the program has never heard of is left alone"

121
lib/check.ml
View File

@ -571,6 +571,26 @@ let fresh_slot ?name ctx ty =
ctx.slot_names <- name :: ctx.slot_names; ctx.slot_names <- name :: ctx.slot_names;
s s
(* The structural printer's context over this checker's tables, with the
pieces aimed wherever [emit] sends them. [print] and [watch] differ in the
emitter and in nothing else, and a second copy of this would be a second
answer to which types the walk knows. *)
let render_ctx ctx (emit : Render.emitter) : Render.ctx =
{ Render.structs = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.structs [];
datas = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.datas [];
unions = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.unions [];
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) ctx.env.enums [];
emit;
(* Neither [println] nor [watch] follows a pointer, and the allocation
registry does not change that. spec-memory.md fixes what it prints —
"Ptr and Handle print their address or identity rather than
recursively dereferencing" — and a printed line belongs to the program,
so it must read the same in a release build, where there is no registry
to ask. Following one is the *inspector's* move, and session.ml is where
that context is built. *)
ptrs = None;
alloc = (fun ty -> fresh_slot ctx ty) }
(* Shadowing is legal -- [(let [v 11] (let [v 22] ...))] is two slots, both (* Shadowing is legal -- [(let [v 11] (let [v 22] ...))] is two slots, both
named [v] -- and the debug info has nowhere to put the distinction. Every named [v] -- and the debug info has nowhere to put the distinction. Every
[!DILocalVariable] is scoped to the subprogram, because the typed IR has no [!DILocalVariable] is scoped to the subprogram, because the typed IR has no
@ -8618,25 +8638,10 @@ and named_call ?(qualified = false) ctx ~want loc name args =
(Tast.Prim (Tast.EscapeBytes, [ x ])))); (Tast.Prim (Tast.EscapeBytes, [ x ]))));
ei64 = (fun x -> write (conv Tast.I64ToBytes x)); ei64 = (fun x -> write (conv Tast.I64ToBytes x));
eu64 = (fun x -> write (conv Tast.U64ToBytes x)); eu64 = (fun x -> write (conv Tast.U64ToBytes x));
ef64 = (fun x -> write (conv Tast.F64ToBytes x)) } ef64 = (fun x -> write (conv Tast.F64ToBytes x));
in edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_print", [ x ]))) }
let rc =
{ Render.structs =
Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.structs [];
datas = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.datas [];
unions = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.unions [];
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) ctx.env.enums [];
emit = emitter;
(* [println] never follows a pointer, and the allocation registry does
not change that. spec-memory.md fixes what it prints — "Ptr and
Handle print their address or identity rather than recursively
dereferencing" — and a printed line belongs to the program, so it
must read the same in a release build, where there is no registry to
ask. Following one is the *inspector's* move, and session.ml is
where that context is built. *)
ptrs = None;
alloc = (fun ty -> fresh_slot ctx ty) }
in in
let rc = render_ctx ctx emitter in
let render_one a = let render_one a =
match a.Tast.ty with match a.Tast.ty with
| Types.String | Types.Slice (Types.Int Types.U8) -> | Types.String | Types.Slice (Types.Int Types.U8) ->
@ -8666,6 +8671,81 @@ and named_call ?(qualified = false) ctx ~want loc name args =
else [] else []
in in
expect ctx loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl))) expect ctx loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl)))
(* (watch "name" v) — v rendered into the dev watch table under the name.
The same walk as [print], with the pieces aimed at flan_dev.c's watch
slot instead of stdout, so a struct, a slice, an option or a dyn value
watches the way it prints.
The value is evaluated once, before the table is asked whether anyone is
looking, so a side effect in it happens whether or not a watch buffer is
open. The walk runs only when one is: [flan_dev_watch_begin_n] answers 0
when the table is not armed or is full, and the render is skipped.
Outside a dev build the backends drop the guarded [If] whole — see
[Tast.is_watch_guard] — so a release build evaluates the value and makes
no call at all. *)
| "watch" ->
arity ctx loc name 2 args;
let label = check ctx ~want:Types.String (List.hd args) in
let v = check ctx (List.nth args 1) in
if generic_ty v.Tast.ty then mk loc Types.Unit Tast.Unit
else begin
let unit_rt sym args = mk loc Types.Unit (Tast.Prim (Tast.Rt sym, args)) in
let bslice = Types.Slice (Types.Int Types.U8) in
let emitter : Render.emitter =
{ Render.ebytes = (fun x -> unit_rt "flan_dev_watch_emit" [ x ]);
estr = (fun x -> unit_rt "flan_dev_watch_emit_str" [ x ]);
ei64 = (fun x -> unit_rt "flan_dev_watch_emit_i64" [ x ]);
eu64 = (fun x -> unit_rt "flan_dev_watch_emit_u64" [ x ]);
ef64 = (fun x -> unit_rt "flan_dev_watch_emit_f64" [ x ]);
edyn = (fun x -> unit_rt "flan_dyn_emit_watch" [ x ]) }
in
(* A place is read where it stands; anything else is bound to a slot of
this frame first, so the walk — which names its argument once per
field — does not run it once per field. *)
let bind, value =
match v.Tast.e with
| Tast.Local _ | Tast.Global _ -> [], v
| _ ->
let s = fresh_slot ctx v.Tast.ty in
[ (s, v) ], mk loc v.Tast.ty (Tast.Local s)
in
let body =
match value.Tast.ty with
(* A string watches quoted, as it renders inside a structure: the
table's rows are values, and an unquoted one could not be told from
a number. *)
| Types.String ->
[ emitter.Render.estr (mk loc bslice (Tast.Prim (Tast.Bytes, [ value ]))) ]
| _ ->
Render.render
~refuse:(fun _loc t ->
Printf.sprintf
"%s has no rendering, so it cannot be watched — watch the \
values you want out of it instead"
(Types.to_string t))
(render_ctx ctx emitter) 0 value
in
let begin_ =
mk loc (Types.Int Types.I32)
(Tast.Prim (Tast.Rt Tast.watch_begin, [ label ]))
in
let zero = mk loc (Types.Int Types.I32) (Tast.Int (0L, Types.I32)) in
let open_ = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ begin_; zero ])) in
let guarded =
mk loc Types.Unit
(Tast.If
( open_,
mk loc Types.Unit
(Tast.Do (body @ [ unit_rt "flan_dev_watch_end" [] ])),
mk loc Types.Unit Tast.Unit ))
in
expect ctx loc ~want
(match bind with
| [] -> guarded
| _ -> mk loc Types.Unit (Tast.Let (bind, [ guarded ])))
end
| "exit" -> | "exit" ->
arity ctx loc name 1 args; arity ctx loc name 1 args;
prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ] prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ]
@ -9950,6 +10030,11 @@ let builtins : (string * string * string) list =
is a read, so it does not consume the value."); is a read, so it does not consume the value.");
("println", "println [T ...] ()", ("println", "println [T ...] ()",
"print, with a newline after it — (println) alone is the newline."); "print, with a newline after it — (println) alone is the newline.");
("watch", "watch [string T] ()",
"Writes the value, rendered as print renders it, into the dev session's \
watch table under the name, where M-x flan-watch shows it. Does nothing \
when no watch buffer is open. Outside a dev build it only evaluates \
the value.");
("exit", "exit [i32] never", ("exit", "exit [i32] never",
"Ends the process with this status. It has no value, so nothing written \ "Ends the process with this status. It has no value, so nothing written \
after it runs."); after it runs.");

89
lib/dev.ml
View File

@ -1415,6 +1415,21 @@ let defs t =
[M-.] on a prelude macro from "the prelude is not a file on disk" into a [M-.] on a prelude macro from "the prelude is not a file on disk" into a
shrug about the daemon having no location. *) shrug about the daemon having no location. *)
let macro_locs = Hashtbl.create 16 in let macro_locs = Hashtbl.create 16 in
(* The classes, off the session's declarations: [Classes.expand] turns a
[defclass] into its constructor [defn] before the checker runs, so the
class is not in [Tast.program] or the checker's environment, and the
declarations are the one place that still has it. Its constructor is
dropped from the [fn] rows for the macro rows' reason: one name, one row,
and [class] is what was written. *)
let classes =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defclass (n, slots) -> Some (n, List.map fst slots, d.Ast.dloc)
| _ -> None)
t.session.Session.decls
in
let class_names = List.map (fun (n, _, _) -> n) classes in
let fns = let fns =
List.filter_map List.filter_map
(fun (f : Tast.fn) -> (fun (f : Tast.fn) ->
@ -1425,6 +1440,7 @@ let defs t =
| None when List.mem f.Tast.name macro_names -> | None when List.mem f.Tast.name macro_names ->
Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc); Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc);
None None
| None when List.mem f.Tast.name class_names -> None
| None -> | None ->
Some Some
(entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f) (entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f)
@ -1519,9 +1535,53 @@ let defs t =
(fun name _ acc -> entry ~name ~kind ~sign:name ~loc:"" () :: acc) (fun name _ acc -> entry ~name ~kind ~sign:name ~loc:"" () :: acc)
tbl [] tbl []
in in
(* A data type's cases are names too: [Shape.Rect] is written at every
construction, and a [case] row is what lets an editor draw it and eldoc
show its fields. The data row's signature lists its cases in the order
and spelling of the [defdata]. *)
let case_sign label (v : Tast.variant) =
match v.Tast.vfields with
| [] -> label
| fs ->
Printf.sprintf "(%s [%s])" label
(String.concat " "
(List.map
(fun (f : Tast.field) ->
f.Tast.fname ^ " " ^ Types.to_string f.Tast.fty)
fs))
in
let datas =
Hashtbl.fold
(fun name (d : Tast.data) acc ->
let cases =
List.map
(fun (v : Tast.variant) ->
let full = name ^ "." ^ v.Tast.vname in
entry ~name:full ~kind:"case" ~sign:(case_sign full v)
~loc:"" ())
d.Tast.cases
in
entry ~name ~kind:"data"
~sign:
(Printf.sprintf "%s [%s]" name
(String.concat " "
(List.map (fun v -> case_sign v.Tast.vname v) d.Tast.cases)))
~loc:"" ()
:: cases
@ acc)
env.Check.datas []
in
let classes =
List.map
(fun (n, slots, loc) ->
entry ~name:n ~kind:"class"
~sign:(Printf.sprintf "%s [%s]" n (String.concat " " slots))
~loc:(Loc.to_string loc) ())
classes
in
List.sort compare List.sort compare
(of_table "struct" env.Check.structs (of_table "struct" env.Check.structs
@ of_table "data" env.Check.datas @ datas @ classes
@ of_table "union" env.Check.unions @ of_table "union" env.Check.unions
@ of_table "enum" env.Check.enums @ of_table "enum" env.Check.enums
@ of_table "alias" env.Check.aliases) @ of_table "alias" env.Check.aliases)
@ -2285,13 +2345,26 @@ let inspect t ~frame ~slot ~path =
| Ok (c, label, ty) -> | Ok (c, label, ty) ->
(match run_render_thunk t ~tag:"i" ~c with (match run_render_thunk t ~tag:"i" ~c with
| Error m -> error m | Error m -> error m
| Ok v -> | Ok out ->
(* One value and nothing else, so the whole of what came back is (* The address the value is stored at, on a line of its own, and
it — minus the trailing newline the renderer does not write then the value. See [Session.render_slot]. *)
here, because there is no second line to separate it from. *) let addr, v =
match String.index_opt out '\n' with
| Some i ->
( Int64.of_string_opt (String.sub out 0 i),
String.sub out (i + 1) (String.length out - i - 1) )
| None -> (None, out)
in
ok ok
[ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; ([ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label;
":type " ^ Wire.quote ty; ":value " ^ Wire.quote v; ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ]
@ (match addr with
(* Unsigned, as an address is: a user-space pointer is
positive as an i64 today, and printing it as the
unsigned number keeps that true if it ever is not. *)
| Some a -> [ Printf.sprintf ":addr %Lu" a ]
| None -> [])
@ [
(* Which stop this was read at, so that a write built from (* Which stop this was read at, so that a write built from
what is on the screen can name it and be refused if the what is on the screen can name it and be refused if the
program has been round the loop since. Nothing about the program has been round the loop since. Nothing about the
@ -2299,7 +2372,7 @@ let inspect t ~frame ~slot ~path =
moment at which it is true of what the reader is looking moment at which it is true of what the reader is looking
at, and an editor that asked for it separately would be at, and an editor that asked for it separately would be
asking a second time about a different instant. *) asking a second time about a different instant. *)
":at-stop " ^ string_of_int (Option.value ~default:0 (stop_gen t)) ])) ":at-stop " ^ string_of_int (Option.value ~default:0 (stop_gen t)) ])))
(* [(:op "set" :frame N :slot I :path (...) :edits (...) :at-stop G)] — the (* [(:op "set" :frame N :slot I :path (...) :edits (...) :at-stop G)] — the

14
lib/emit.ml
View File

@ -1865,6 +1865,9 @@ and value_at f (e : Tast.expr) : string =
bind_slot f slot) bind_slot f slot)
bs; bs;
block f body block f body
(* A (watch ...) outside a dev build: its else branch, which is unit. See
[Tast.is_watch_guard]. *)
| Tast.If (c, _, e') when (not f.md.dev) && Tast.is_watch_guard c -> value f e'
| Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e' | Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e'
| Tast.While (c, body, latch) -> emit_while f c body latch; "zeroinitializer" | Tast.While (c, body, latch) -> emit_while f c body latch; "zeroinitializer"
(* A plain branch, and then the block is dead — [term] closes it and [ins] (* A plain branch, and then the block is dead — [term] closes it and [ins]
@ -4025,6 +4028,17 @@ declare i64 @flan_dyn_at(i64, i64)
declare void @flan_dyn_set_at(i64, i64, i64) declare void @flan_dyn_set_at(i64, i64, i64)
declare void @flan_dyn_push(i64, i64) declare void @flan_dyn_push(i64, i64)
declare void @flan_dyn_print(i64) declare void @flan_dyn_print(i64)
declare void @flan_dyn_emit_dev(i64)
declare void @flan_dyn_emit_watch(i64)
; The watch table, which (watch "name" v) renders into. flan_dev.c is linked
; into every build, so these resolve in a release build too.
declare i32 @flan_dev_watch_begin_n(ptr, i64)
declare void @flan_dev_watch_emit(ptr, i64)
declare void @flan_dev_watch_emit_str(ptr, i64)
declare void @flan_dev_watch_emit_i64(i64)
declare void @flan_dev_watch_emit_u64(i64)
declare void @flan_dev_watch_emit_f64(double)
declare void @flan_dev_watch_end()
declare i64 @flan_dyn_need_i64(i64) declare i64 @flan_dyn_need_i64(i64)
declare double @flan_dyn_need_f64(i64) declare double @flan_dyn_need_f64(i64)
declare i32 @flan_dyn_need_bool(i64) declare i32 @flan_dyn_need_bool(i64)

3
lib/js.ml
View File

@ -1158,6 +1158,9 @@ and stmt f dest (e : Tast.expr) =
line f "%s = %s;" f.names.(slot) x) line f "%s = %s;" f.names.(slot) x)
binds; binds;
block f dest body block f dest body
(* A (watch ...): there is no watch table in the JS dialect, so only the
else branch, which is unit. See [Tast.is_watch_guard]. *)
| Tast.If (c, _, b) when Tast.is_watch_guard c -> stmt f dest b
| Tast.If (c, a, b) -> | Tast.If (c, a, b) ->
let cv = value f c in let cv = value f c in
line f "if (%s) {" cv; line f "if (%s) {" cv;

28
lib/render.ml
View File

@ -31,6 +31,10 @@ type emitter = {
ei64 : Tast.expr -> Tast.expr; ei64 : Tast.expr -> Tast.expr;
eu64 : Tast.expr -> Tast.expr; eu64 : Tast.expr -> Tast.expr;
ef64 : Tast.expr -> Tast.expr; ef64 : Tast.expr -> Tast.expr;
(* A dyn value, whole. The walk cannot take one apart — the tag is the
runtime's to read — so the runtime renders it, into the same place the
other four write to. *)
edyn : Tast.expr -> Tast.expr;
} }
(* What a walk is allowed to do with a pointer, and it is exactly two (* What a walk is allowed to do with a pointer, and it is exactly two
@ -93,7 +97,14 @@ let max_span = 8
let fail = Loc.fail let fail = Loc.fail
let rec render c depth (e : Tast.expr) : Tast.expr list = (* The refusal for a type the walk has no arm for, worded for the form that
asked. [print]'s is the default. *)
let print_refusal _loc t =
Printf.sprintf "no printer for %s — print the values you want out of it"
(Types.to_string t)
let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list =
let render c depth e = render ~refuse c depth e in
let loc = e.Tast.loc in let loc = e.Tast.loc in
let unit_ e = { Tast.e; ty = Types.Unit; loc } in let unit_ e = { Tast.e; ty = Types.Unit; loc } in
let cast t x = { Tast.e = Tast.Prim (Tast.Cast t, [ x ]); ty = t; loc } in let cast t x = { Tast.e = Tast.Prim (Tast.Cast t, [ x ]); ty = t; loc } in
@ -380,18 +391,11 @@ let rec render c depth (e : Tast.expr) : Tast.expr list =
Flan value carries no header and only the compiler knows what it is; a Flan value carries no header and only the compiler knows what it is; a
dyn value is the exact opposite — the runtime knows and the compiler dyn value is the exact opposite — the runtime knows and the compiler
does not — so the printing belongs on the side that can see the tag, and does not — so the printing belongs on the side that can see the tag, and
the walk hands the whole value over. the walk hands the whole value to [c.emit.edyn], which names the runtime
entry point that renders into this emitter's sink. *)
The cost is that it writes to stdout itself rather than through | Types.Dyn -> [ c.emit.edyn e ]
[c.emit], so a dyn printed at the REPL arrives on the program's output
and not in the REPL's buffer. Fixing that means an emit-shaped dyn
printer in the runtime — a second entry point taking the sink — and it
is not milestone 1's. *)
| Types.Dyn ->
[ unit_ (Tast.Prim (Tast.Rt "flan_dyn_print", [ e ])) ]
(* Reachable: [(println m)] on a Map. Everything else in [Types.t] has an (* Reachable: [(println m)] on a Map. Everything else in [Types.t] has an
arm above, and a [Var] never reaches a backend. So this names the fix arm above, and a [Var] never reaches a backend. So this names the fix
rather than only the refusal. *) rather than only the refusal. *)
| t -> | t ->
fail loc "no printer for %s — print the values you want out of it" fail loc "%s" (refuse loc t)
(Types.to_string t)

36
lib/session.ml
View File

@ -1140,7 +1140,13 @@ let dev_emitter : Render.emitter =
estr = call emit_str; estr = call emit_str;
ei64 = call emit_i64; ei64 = call emit_i64;
eu64 = call emit_u64; eu64 = call emit_u64;
ef64 = call emit_f64 } ef64 = call emit_f64;
(* Into the value buffer, not stdout: a dyn expression's value belongs in
the reply's value like any other. *)
edyn =
(fun x ->
{ Tast.e = Tast.Prim (Tast.Rt "flan_dyn_emit_dev", [ x ]);
ty = Types.Unit; loc = x.Tast.loc }) }
(* And what the REPL may do with a pointer, which [println] may not. See (* And what the REPL may do with a pointer, which [println] may not. See
render.ml's [pointers] for why the two sides differ. *) render.ml's [pointers] for why the two sides differ. *)
@ -1675,6 +1681,34 @@ let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
(match Render.render c 0 v with (match Render.render c 0 v with
| exception Loc.Error { Loc.dmsg = why; _ } -> Error (name ^ path_text path ^ ": " ^ why) | exception Loc.Error { Loc.dmsg = why; _ } -> Error (name ^ path_text path ^ ": " ^ why)
| parts -> | parts ->
(* Where the value lives, first and on a line of its own, when [v]
is a place in the stopped frame: its address is then the
storage the listing is reading. A data case's field is not a
place — [AddrOf] on it would answer the address of a copy — so
it has no address line. The caller splits the line off at the
first newline; a rendering has none, because [Render] quotes a
string's. *)
let parts =
if not (Emit.addr_is_place v) then parts
else
let addr =
{ Tast.e =
Tast.Prim
(Tast.Cast (Types.Int Types.I64),
[ { Tast.e = Tast.Prim (Tast.AddrOf, [ v ]);
ty = Types.Ptr v.Tast.ty; loc } ]);
ty = Types.Int Types.I64; loc }
in
let newline =
{ Tast.e =
Tast.Prim
(Tast.Bytes,
[ { Tast.e = Tast.Str "\n"; ty = Types.String; loc } ]);
ty = Types.Slice (Types.Int Types.U8); loc }
in
dev_emitter.Render.ei64 addr :: dev_emitter.Render.ebytes newline
:: parts
in
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
t.thunks <- t.thunks + 1; t.thunks <- t.thunks + 1;
let tname = Printf.sprintf "inspect/%d" t.thunks in let tname = Printf.sprintf "inspect/%d" t.thunks in

13
lib/tast.ml
View File

@ -437,6 +437,19 @@ type program = {
A lifted clause's body is not in here: it is a function of its own, and this A lifted clause's body is not in here: it is a function of its own, and this
walks one expression. A reader that wants it follows [hfn], the way [Reach] walks one expression. A reader that wants it follows [hfn], the way [Reach]
does. *) does. *)
(* The name [(watch ...)] asks the table under, and the test a backend uses to
recognise the [If] the checker wraps a watch's rendering in. The checker
does not know whether the build is a dev one; a backend does, and outside a
dev build it lowers the whole [If] to its else branch, which is unit — so a
release build keeps only the value's own evaluation, bound before the [If],
and makes no call into the runtime at all. *)
let watch_begin = "flan_dev_watch_begin_n"
let is_watch_guard (c : expr) =
match c.e with
| Prim (Ne, [ { e = Prim (Rt s, _); _ }; _ ]) -> String.equal s watch_begin
| _ -> false
let rec walk (f : expr -> unit) (e : expr) = let rec walk (f : expr -> unit) (e : expr) =
f e; f e;
let go = walk f in let go = walk f in

4
lib/x86.ml
View File

@ -1898,6 +1898,10 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
bind_slot f slot) bind_slot f slot)
bs; bs;
block f body dst t block f body dst t
(* A (watch ...) outside a dev build: its else branch, which is unit. See
[Tast.is_watch_guard]. *)
| Tast.If (c, _, b) when (not f.md.Emit.dev) && Tast.is_watch_guard c ->
lower f b dst
| Tast.If (c, a, b) -> | Tast.If (c, a, b) ->
let lelse = new_label f "else" and lend = new_label f "endif" in let lelse = new_label f "else" and lend = new_label f "endif" in
scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool); scoped f (fun () -> let cv = eval f c in load_loc f ~reg:rax cv Types.Bool);

38
runtime/flan_dev.c
View File

@ -566,10 +566,10 @@ static uint64_t watch_epoch;
* build — [flan_dev.c] is linked into both (see [Build], which says why) so the * build — [flan_dev.c] is linked into both (see [Build], which says why) so the
* symbols resolve either way and there is no second version of this file. * symbols resolve either way and there is no second version of this file.
* *
* What it is *not*: free. Eliding the call entirely needs the compiler to know * What it is *not*: free. A scalar entry point called through [declare-c]
* the form, which is a [check.ml] arm this does not have. A load and a branch * costs a load and a branch per watched value per frame, in both builds. The
* per watched value per frame is the honest number, and it is the same number * [(watch ...)] form costs that in a dev build only: outside one the backend
* in both builds rather than a dev-only tax. */ * drops its call, and what is left is the value's own evaluation. */
static int watch_on; static int watch_on;
void flan_dev_watch_enable(int on) { void flan_dev_watch_enable(int on) {
@ -639,6 +639,22 @@ int flan_dev_watch_begin(const char *name) {
return 1; return 1;
} }
/* [flan_dev_watch_begin] for a name that arrives as bytes and a length, which
* is how a Flan string crosses to the runtime: (watch "name" v) calls this.
* The name is copied to a NUL-terminated buffer on the stack, cut to what a
* slot holds, so nothing here allocates. */
int flan_dev_watch_begin_n(const uint8_t *name, int64_t len) {
/* The same first test [flan_dev_watch_begin] makes, ahead of the copy, so an
* unarmed table costs a load and a branch here too. */
if (!__atomic_load_n(&watch_on, __ATOMIC_RELAXED)) { watch_cur = NULL; return 0; }
char buf[WATCH_NAME];
size_t n = len < 0 ? 0 : (size_t)len;
if (n > WATCH_NAME - 1) n = WATCH_NAME - 1;
memcpy(buf, name, n);
buf[n] = '\0';
return flan_dev_watch_begin(buf);
}
void flan_dev_watch_emit(const uint8_t *bytes, int64_t len) { void flan_dev_watch_emit(const uint8_t *bytes, int64_t len) {
watch_slot *s = watch_cur; watch_slot *s = watch_cur;
if (s == NULL) return; if (s == NULL) return;
@ -703,14 +719,12 @@ void flan_dev_watch_end(void) {
* which is either nobody watching or a full table. A caller is free to ignore * which is either nobody watching or a full table. A caller is free to ignore
* it and normally does. * it and normally does.
* *
* A composite — a struct, a slice, a union — cannot be done this way, and that * A composite — a struct, a slice, a union — cannot be done this way: a Flan
* is not a shortcoming of these four: a Flan value carries no header, so * value carries no header, so nothing at run time can say what it is, and
* nothing at run time can say what it is, and rendering one is a compile-time * rendering one is a compile-time walk over its *type*. That is the
* walk over its *type*. The walk already exists — [Render.render] — and the * [(watch "hp" hp)] form in check.ml, which points [Render.render] at
* four [flan_dev_watch_emit_*] above are the emitter it would be pointed at, * [flan_dev_watch_begin_n], the [flan_dev_watch_emit_*] above and
* shaped exactly like the [print] arm's. What is missing is the * [flan_dev_watch_end]. */
* [(watch "hp" hp)] arm in check.ml that joins the two, which is a file this
* change does not own. docs/BUILT.md says what that arm is. */
int32_t flan_dev_watch_i64(const char *name, int64_t x) { int32_t flan_dev_watch_i64(const char *name, int64_t x) {
if (!flan_dev_watch_begin(name)) return 0; if (!flan_dev_watch_begin(name)) return 0;
flan_dev_watch_emit_i64(x); flan_dev_watch_emit_i64(x);

98
runtime/flan_dyn.c
View File

@ -48,6 +48,13 @@
* copies honest. */ * copies honest. */
void flan_write_stdout(const uint8_t *p, int64_t n); void flan_write_stdout(const uint8_t *p, int64_t n);
/* The two sinks in flan_dev.c a dyn value can be rendered into instead of
* stdout: an evaluated expression's value, and a watch slot. flan_dev.c is
* linked into every build, so these resolve whether or not the build is a dev
* one; the reference runs this way round so that flan_dev.c names nothing in
* this file and the dyn runtime stays droppable at the file level. */
void flan_dev_emit(const uint8_t *bytes, int64_t len);
void flan_dev_watch_emit(const uint8_t *bytes, int64_t len);
/* The one non-local exit a dyn operation can take. flan_rt.c's [rt_trap] is /* The one non-local exit a dyn operation can take. flan_rt.c's [rt_trap] is
* static, and re-implementing what it does — the break-loop hook, the flush, * static, and re-implementing what it does — the break-loop hook, the flush,
@ -462,7 +469,8 @@ static inline const char *tag_of(flan_dyn v) {
* One walk, two callers. [flan_dyn_print] writes to stdout through * One walk, two callers. [flan_dyn_print] writes to stdout through
* [flan_write_stdout], so a dyn print and a typed print interleave correctly * [flan_write_stdout], so a dyn print and a typed print interleave correctly
* in the one buffer; a trap message renders into a small buffer and puts the * in the one buffer; a trap message renders into a small buffer and puts the
* values in the sentence. * values in the sentence. [flan_dyn_emit_dev] and [flan_dyn_emit_watch] are
* the print walk aimed at flan_dev.c's buffers instead of stdout.
* *
* What it renders, per tag, is what typed [print] renders for the * What it renders, per tag, is what typed [print] renders for the
* corresponding type — captured from a running program rather than read off * corresponding type — captured from a running program rather than read off
@ -495,11 +503,17 @@ static inline const char *tag_of(flan_dyn v) {
#define PRINT_DEPTH 16 #define PRINT_DEPTH 16
static void emit(const char *s) { /* Where the rendering goes. stdout for [print], or one of flan_dev.c's
flan_write_stdout((const uint8_t *)s, (int64_t)strlen(s)); * buffers when the value is an evaluated expression's or a watched one: a
* value written to stdout arrives on the program's output rather than as the
* value the editor asked for. */
typedef void (*dyn_sink)(const uint8_t *p, int64_t n);
static void emit(dyn_sink w, const char *s) {
w((const uint8_t *)s, (int64_t)strlen(s));
} }
static void emit_n(const uint8_t *p, int64_t n) { flan_write_stdout(p, n); } static void emit_n(dyn_sink w, const uint8_t *p, int64_t n) { w(p, n); }
/* A text inside a structure, quoted and escaped. The same table as /* A text inside a structure, quoted and escaped. The same table as
* flan_rt.c's [flan_escape_char], which is where the typed side's printers — * flan_rt.c's [flan_escape_char], which is where the typed side's printers —
@ -514,28 +528,28 @@ static void emit_n(const uint8_t *p, int64_t n) { flan_write_stdout(p, n); }
* shares with the other side is the part that must not drift. If that table * shares with the other side is the part that must not drift. If that table
* changes, change this one. Streamed rather than built, so there is no buffer * changes, change this one. Streamed rather than built, so there is no buffer
* to overrun and no length to cap. */ * to overrun and no length to cap. */
static void emit_escaped(const uint8_t *p, int64_t n) { static void emit_escaped(dyn_sink w, const uint8_t *p, int64_t n) {
int64_t i; int64_t i;
emit("\""); emit(w, "\"");
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
unsigned char c = p[i]; unsigned char c = p[i];
switch (c) { switch (c) {
case '"': emit("\\\""); break; case '"': emit(w, "\\\""); break;
case '\\': emit("\\\\"); break; case '\\': emit(w, "\\\\"); break;
case '\n': emit("\\n"); break; case '\n': emit(w, "\\n"); break;
case '\t': emit("\\t"); break; case '\t': emit(w, "\\t"); break;
case '\r': emit("\\r"); break; case '\r': emit(w, "\\r"); break;
default: default:
if (c < 0x20) { if (c < 0x20) {
char b[5]; char b[5];
snprintf(b, sizeof b, "\\x%02x", c); snprintf(b, sizeof b, "\\x%02x", c);
emit(b); emit(w, b);
} else { } else {
emit_n(&c, 1); emit_n(w, &c, 1);
} }
} }
} }
emit("\""); emit(w, "\"");
} }
static int64_t dyn_int_value(flan_dyn v); /* forward: both int shapes */ static int64_t dyn_int_value(flan_dyn v); /* forward: both int shapes */
@ -554,20 +568,20 @@ static int64_t view_elem_size(int32_t elem);
static int64_t vecish_len(flan_obj *o); static int64_t vecish_len(flan_obj *o);
static flan_dyn vecish_at(flan_obj *o, int64_t i); static flan_dyn vecish_at(flan_obj *o, int64_t i);
static void render(flan_dyn v, int depth, int nested) { static void render(dyn_sink w, flan_dyn v, int depth, int nested) {
char buf[64]; char buf[64];
int32_t t = flan_dyn_tag(v); int32_t t = flan_dyn_tag(v);
if (depth > PRINT_DEPTH) { emit("..."); return; } if (depth > PRINT_DEPTH) { emit(w, "..."); return; }
switch (t) { switch (t) {
case FLAN_DYN_TAG_NIL: case FLAN_DYN_TAG_NIL:
emit("nil"); emit(w, "nil");
return; return;
case FLAN_DYN_TAG_BOOL: case FLAN_DYN_TAG_BOOL:
emit(dyn_payload(v) ? "true" : "false"); emit(w, dyn_payload(v) ? "true" : "false");
return; return;
case FLAN_DYN_TAG_INT: case FLAN_DYN_TAG_INT:
snprintf(buf, sizeof buf, "%lld", (long long)dyn_int_value(v)); snprintf(buf, sizeof buf, "%lld", (long long)dyn_int_value(v));
emit(buf); emit(w, buf);
return; return;
case FLAN_DYN_TAG_FLOAT: { case FLAN_DYN_TAG_FLOAT: {
double d; double d;
@ -576,21 +590,21 @@ static void render(flan_dyn v, int depth, int nested) {
* the comparison flan_rt.c and the prelude both use. */ * the comparison flan_rt.c and the prelude both use. */
if (d != d) snprintf(buf, sizeof buf, "nan"); if (d != d) snprintf(buf, sizeof buf, "nan");
else snprintf(buf, sizeof buf, "%g", d); else snprintf(buf, sizeof buf, "%g", d);
emit(buf); emit(w, buf);
return; return;
} }
case FLAN_DYN_TAG_TEXT: { case FLAN_DYN_TAG_TEXT: {
flan_obj *o = dyn_obj(v); flan_obj *o = dyn_obj(v);
if (nested) emit_escaped(obj_text_bytes(o), o->len); if (nested) emit_escaped(w, obj_text_bytes(o), o->len);
else emit_n(obj_text_bytes(o), o->len); else emit_n(w, obj_text_bytes(o), o->len);
return; return;
} }
/* A keyword prints with its colon, bare, at every depth: :a is its own /* A keyword prints with its colon, bare, at every depth: :a is its own
* spelling the way true is, and quoting it would make it a text. */ * spelling the way true is, and quoting it would make it a text. */
case FLAN_DYN_TAG_KEYWORD: { case FLAN_DYN_TAG_KEYWORD: {
kw_entry *k = dyn_kw(v); kw_entry *k = dyn_kw(v);
emit(":"); emit(w, ":");
emit_n(kw_bytes(k), k->len); emit_n(w, kw_bytes(k), k->len);
return; return;
} }
/* The map prints in edn's shape with the vec's spacing: a space before /* The map prints in edn's shape with the vec's spacing: a space before
@ -604,40 +618,48 @@ static void render(flan_dyn v, int depth, int nested) {
* for a record: #point{ :x 1 :y 2}. The tag is not an entry, so it is * for a record: #point{ :x 1 :y 2}. The tag is not an entry, so it is
* written here or it is not written at all. */ * written here or it is not written at all. */
if (o->u.v.klass != NULL) { if (o->u.v.klass != NULL) {
emit("#"); emit(w, "#");
emit_n(kw_bytes(o->u.v.klass), o->u.v.klass->len); emit_n(w, kw_bytes(o->u.v.klass), o->u.v.klass->len);
} }
emit("{"); emit(w, "{");
for (i = 0; i < o->len; i++) { for (i = 0; i < o->len; i++) {
emit(" "); emit(w, " ");
render(o->u.v.items[i * 2], depth + 1, 1); render(w, o->u.v.items[i * 2], depth + 1, 1);
emit(" "); emit(w, " ");
render(o->u.v.items[i * 2 + 1], depth + 1, 1); render(w, o->u.v.items[i * 2 + 1], depth + 1, 1);
} }
emit("}"); emit(w, "}");
return; return;
} }
default: { default: {
flan_obj *o = dyn_obj(v); flan_obj *o = dyn_obj(v);
int64_t i, n = o->kind == OBJ_VIEW ? view_len("print", o) : o->len; int64_t i, n = o->kind == OBJ_VIEW ? view_len("print", o) : o->len;
emit("["); emit(w, "[");
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
emit(" "); emit(w, " ");
if (o->kind == OBJ_VIEW) if (o->kind == OBJ_VIEW)
render(view_box(o->u.view.elem, render(w, view_box(o->u.view.elem,
(const uint8_t *)view_base(o) (const uint8_t *)view_base(o)
+ i * view_elem_size(o->u.view.elem)), + i * view_elem_size(o->u.view.elem)),
depth + 1, 1); depth + 1, 1);
else else
render(o->u.v.items[i], depth + 1, 1); render(w, o->u.v.items[i], depth + 1, 1);
} }
emit("]"); emit(w, "]");
return; return;
} }
} }
} }
void flan_dyn_print(flan_dyn v) { render(v, 0, 0); } void flan_dyn_print(flan_dyn v) { render(flan_write_stdout, v, 0, 0); }
/* The same rendering into an evaluated expression's value, and into the watch
* slot [flan_dev_watch_begin] opened. lib/render.ml's dyn arm calls these on
* the inspecting side and [flan_dyn_print] on [println]'s. A text is quoted
* even at the top, because the typed side's renderer quotes a string there:
* the value "5" and the value 5 must not read alike. */
void flan_dyn_emit_dev(flan_dyn v) { render(flan_dev_emit, v, 0, 1); }
void flan_dyn_emit_watch(flan_dyn v) { render(flan_dev_watch_emit, v, 0, 1); }
/* The same walk into a buffer, for a trap's sentence. Bounded and truncated /* The same walk into a buffer, for a trap's sentence. Bounded and truncated
* rather than allocating: a trap is the one moment when allocating would be a * rather than allocating: a trap is the one moment when allocating would be a

4
runtime/flan_dyn.h
View File

@ -186,6 +186,10 @@ flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k);
/* Structural, and per type it renders what typed [print] renders. Never /* Structural, and per type it renders what typed [print] renders. Never
* traps: every tag has a rendering, including nil. */ * traps: every tag has a rendering, including nil. */
void flan_dyn_print(flan_dyn v); void flan_dyn_print(flan_dyn v);
/* The same rendering, into flan_dev.c's evaluated-value buffer and into the
* open watch slot rather than stdout. A text is quoted at the top as well. */
void flan_dyn_emit_dev(flan_dyn v);
void flan_dyn_emit_watch(flan_dyn v);
/* ── The typed boundary ──────────────────────────────────────────────── /* ── The typed boundary ────────────────────────────────────────────────
* *

18
test/programs/dev-watch.flan
View File

@ -1,10 +1,8 @@
;;;; A program that pushes values into the watch table from its own loop. ;;;; A program that pushes values into the watch table from its own loop.
;;;; ;;;;
;;;; The point of the case is that this needs no compiler change: the watch ;;;; Two ways in. A scalar reaches the watch entry points as ordinary C
;;;; entry points are ordinary C functions, so a program reaches them through ;;;; functions, through [declare-c]. A struct, a slice or anything else goes
;;;; [declare-c] the same way it reaches anything else in the runtime. That is ;;;; through the [(watch "name" v)] form, which renders it the way print does.
;;;; deliberate — a [(watch "hp" hp)] form would be an arm in the checker, and
;;;; a scalar does not need one.
;;;; ;;;;
;;;; The values are written every iteration and are *not* read back from here. ;;;; The values are written every iteration and are *not* read back from here.
;;;; What reads them is the daemon's [watch] op, over the agent, while this ;;;; What reads them is the daemon's [watch] op, over the agent, while this
@ -22,6 +20,8 @@
(defonce ticks i64) (defonce ticks i64)
(defstruct Pos [x i32 y f64])
(defn loop-cells [] i32 (defn loop-cells [] i32
(let [i 0] (let [i 0]
(while (< i 8) (while (< i 8)
@ -37,6 +37,14 @@
(watch-i64 "ticks" ticks) (watch-i64 "ticks" ticks)
(watch-f64 "half" (/ (f64 ticks) 2.0)) (watch-f64 "half" (/ (f64 ticks) 2.0))
(watch-str "label" "sand") (watch-str "label" "sand")
;; The form: a struct, a slice, and a scalar through the same form.
(watch "pos" (Pos {.x 3 .y 1.5}))
(watch "row" [1 2 3])
(watch "t2" (* ticks 2))
;; A dyn value renders through the dyn printer into the slot, and a string
;; through the form is quoted.
(watch "d" {:a 1})
(watch "s" "x")
;; A hot inner loop, and the value *varies* across it — which is what makes ;; A hot inner loop, and the value *varies* across it — which is what makes
;; the row a test of the accumulator rather than of the plumbing. A slot that ;; the row a test of the accumulator rather than of the plumbing. A slot that
;; only kept [last] would report 21 and no range; n, min and max are each ;; only kept [last] would report 21 and no range; n, min and max are each

27
test/programs/watch-release.flan Normal file
View File

@ -0,0 +1,27 @@
;;;; (watch "name" v) in a build with no dev session behind it.
;;;;
;;;; Outside a dev build a watch makes no call into the runtime: the program
;;;; must compile, link and print exactly what it prints without them. The value
;;;; is still evaluated once, which the counter shows.
(defstruct Pos [x i32 y f64])
(defonce calls i64)
(defn bump [] i64
(set calls (+ calls 1))
calls)
(defn main [] i32
(let [p (Pos {.x 3 .y 1.5})
xs [1 2 3]
d {:a 1}]
(watch "pos" p)
(watch "xs" xs)
(watch "slice" (slice xs 0 2))
(watch "dyn" d)
(watch "label" "sand")
(watch "bump" (bump))
(watch "bump" (bump))
(println (.x p) calls))
0)

25
test/test_acceptance.ml
View File

@ -4411,6 +4411,31 @@ level "1"
"programs/dyn-class.flan" dyn_class_out; "programs/dyn-class.flan" dyn_class_out;
outputs ~x86:true "dyn: classes and dispatch, --x86" outputs ~x86:true "dyn: classes and dispatch, --x86"
"programs/dyn-class.flan" dyn_class_out; "programs/dyn-class.flan" dyn_class_out;
(* (watch "name" v) with nothing arming the table: a struct, an array, a
slice, a dyn map and a string all compile against flan_dev.c's watch
entry points on both backends, write nothing, and evaluate the value
once — [calls] is 2 after two watched calls to [bump]. *)
outputs "watch: a release build" "programs/watch-release.flan" "3 2\n";
outputs ~opt:"-O0" "watch: a release build, -O0"
"programs/watch-release.flan" "3 2\n";
outputs ~x86:true "watch: a release build, --x86"
"programs/watch-release.flan" "3 2\n";
(* And a release build makes no call into the watch table at all: the
backend drops the guarded render, so the only cost left is the value's
own evaluation. A dev build keeps the call. *)
(let p =
Reader.read_file "programs/watch-release.flan" |> Parse.program
|> Check.program
in
let call = "call i32 @flan_dev_watch_begin_n(" in
if contains (Emit.program p) call then begin
incr failures;
print_endline "FAIL watch: a release build still calls the watch table"
end;
if not (contains (Emit.program ~dev:true p) call) then begin
incr failures;
print_endline "FAIL watch: a dev build lost its call to the watch table"
end);
(* ── Per-type descriptors, M2 item 2 ───────────────────────────── (* ── Per-type descriptors, M2 item 2 ─────────────────────────────
The first program anywhere with a dyn field in a struct, which was a The first program anywhere with a dyn field in a struct, which was a
refusal until the descriptors landed. It matters at all three rows refusal until the descriptors landed. It matters at all three rows

152
test/test_dev.ml
View File

@ -1385,7 +1385,9 @@ let () =
(* The site, on LLVM: an arith trap publishes its loc around the (* The site, on LLVM: an arith trap publishes its loc around the
hook exactly as a bounds trap does. *) hook exactly as a bounds trap does. *)
(match Wire.string_field (ask "(:op \"break\")") "site" with (match Wire.string_field (ask "(:op \"break\")") "site" with
| Some site when contains_sub site "dev-break.flan:" -> () (* Absolute, because the break buffer opens the file it names and
an editor is not in this process's working directory. *)
| Some site when contains_sub site "dev-break.flan:" && site.[0] = '/' -> ()
| Some site -> fail "the arith site points at %s" site | Some site -> fail "the arith site points at %s" site
| None -> fail "a division by zero carries no :site"); | None -> fail "a division by zero carries no :site");
let r = ask "(:op \"restart\" :name \"use-zero\")" in let r = ask "(:op \"restart\" :name \"use-zero\")" in
@ -2288,6 +2290,33 @@ let () =
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "the inspect program never stopped" fail "the inspect program never stopped"
else begin else begin
(* A data type's cases are on [defs] under their full names, and the
type's own row lists them in the order the [defdata] does. *)
(let r = ask "(:op \"defs\")" in
let row name =
match Wire.field r "defs" with
| Some { Form.v = Form.List entries; _ } ->
List.find_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
({ Form.v = Form.Str n; _ } :: { Form.v = Form.Str k; _ }
:: { Form.v = Form.Str s; _ } :: _)
when String.equal n name -> Some (k, s)
| _ -> None)
entries
| _ -> None
in
let want name kind sign =
match row name with
| Some (k, s) when k = kind && s = sign -> ()
| Some (k, s) -> fail "%s is on defs as (%s %S)" name k s
| None -> fail "defs did not mention %s" name
in
want "Shape" "data"
"Shape [Empty (Dot [x f64 y f64]) (Rect [w i32 h i32])]";
want "Shape.Empty" "case" "Shape.Empty";
want "Shape.Rect" "case" "(Shape.Rect [w i32 h i32])");
(* The slot travels by index and the index comes off the listing, (* The slot travels by index and the index comes off the listing,
which is the fourth element of each entry. Reading it here rather which is the fourth element of each entry. Reading it here rather
than writing 0 exercises the field the editor depends on, and keeps than writing 0 exercises the field the editor depends on, and keeps
@ -2357,6 +2386,47 @@ let () =
want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})"; want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})";
want "box" "(some \"x\")" "f32" "4.5"; want "box" "(some \"x\")" "f32" "4.5";
want "s" "(\"Shape.Rect.w\")" "i32" "3"; want "s" "(\"Shape.Rect.w\")" "i32" "3";
(* Where each value is stored. The struct and its first field share
an address and the second field is one f32 further on, so the
number is the layout's and not a label. *)
(match slot_of listing "mark" with
| None -> ()
| Some slot ->
let addr path =
match Wire.field (inspect ~path slot) "addr" with
| Some { Form.v = Form.Int a; _ } -> Some a
| _ -> None
in
(match addr "()", addr "(\"x\")", addr "(\"y\")" with
| Some m, Some x, Some y ->
if m <> x then
fail "mark is at %Ld and its first field at %Ld" m x;
if Int64.sub y x <> 4L then
fail "mark.y is %Ld bytes past mark.x, not 4" (Int64.sub y x)
| _ -> fail "inspect on a slot answered with no :addr"));
(let addr name path =
match slot_of listing name with
| None -> None
| Some slot ->
(match Wire.field (inspect ~path slot) "addr" with
| Some { Form.v = Form.Int a; _ } -> Some a
| _ -> None)
in
(* An element is its index's worth of elements past the first. *)
(match addr "xs" "()", addr "xs" "(1)" with
| Some a, Some b when Int64.sub b a = 4L -> ()
| a, b ->
fail "xs[1] is not one i32 past xs: %s, %s"
(Option.fold ~none:"none" ~some:Int64.to_string a)
(Option.fold ~none:"none" ~some:Int64.to_string b));
(* An option's payload is inside the option's own storage. *)
(match addr "box" "()", addr "box" "(some)" with
| Some a, Some b when b > a && Int64.sub b a < 16L -> ()
| _ -> fail "box's payload is not inside box's storage");
(* A data case's field has no accessor place to take the address
of, and says nothing rather than a copy's address. *)
if addr "s" "(\"Shape.Rect.w\")" <> None then
fail "a data case's field answered with an address");
(* Emacs prints an empty list as `nil' and has no other spelling for (* Emacs prints an empty list as `nil' and has no other spelling for
one, so a client in that language cannot send `()'. *) one, so a client in that language cannot send `()'. *)
(match slot_of listing "mark" with (match slot_of listing "mark" with
@ -3879,6 +3949,28 @@ let () =
| Some "\"sand\"" -> () | Some "\"sand\"" -> ()
| Some v -> fail "watch rendered a string as %s, unquoted" v | Some v -> fail "watch rendered a string as %s, unquoted" v
| None -> fail "watch lost the string"); | None -> fail "watch lost the string");
(* The (watch ...) form: a struct and a slice, rendered by the same
walk print uses, and a scalar through the same form. *)
(match List.assoc_opt "pos" t with
| Some "(Pos {.x 3 .y 1.5})" -> ()
| Some v -> fail "watch rendered a struct as %s" v
| None -> fail "the (watch ...) form never wrote a struct");
(match List.assoc_opt "row" t with
| Some "[ 1 2 3]" -> ()
| Some v -> fail "watch rendered a slice as %s" v
| None -> fail "the (watch ...) form never wrote a slice");
(match List.assoc_opt "t2" t with
| Some v when int_of_string_opt v <> None -> ()
| Some v -> fail "watch rendered a computed i64 as %s" v
| None -> fail "the (watch ...) form never wrote a scalar");
(match List.assoc_opt "d" t with
| Some "{ :a 1}" -> ()
| Some v -> fail "watch rendered a dyn map as %s" v
| None -> fail "the (watch ...) form never wrote a dyn value");
(match List.assoc_opt "s" t with
| Some "\"x\"" -> ()
| Some v -> fail "the (watch ...) form rendered a string as %s" v
| None -> fail "the (watch ...) form never wrote a string");
(* The accumulator, which is the other half of the watch and the (* The accumulator, which is the other half of the watch and the
half a scalar row cannot stand in for. [loop-cells] samples "cell" half a scalar row cannot stand in for. [loop-cells] samples "cell"
eight times per step at 0, 3, ... 21, so the row has to show a eight times per step at 0, 3, ... 21, so the row has to show a
@ -5853,12 +5945,11 @@ let () =
| Some { Form.v = Form.Sym "t"; _ } -> true | Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false | _ -> false
in in
(* What the expression answered, wherever it came back: a dyn value (* A dyn value is rendered into the reply's [:value], as a typed
is rendered into the reply's output rather than into [:value], one is, on both backends, and a dyn text is quoted there as a
and which of the two carries it is not what is under test. *) typed string is. *)
let answer r = let answer r =
Option.value ~default:"" (Wire.string_field r "value") Option.value ~default:"" (Wire.string_field r "value")
^ Option.value ~default:"" (Wire.string_field r "output")
in in
let read () = let read () =
answer answer
@ -5877,7 +5968,7 @@ let () =
if not (await ~ms:20000 parked) then if not (await ~ms:20000 parked) then
fail "the dyn-global program (--%s) never parked" backend fail "the dyn-global program (--%s) never parked" backend
else begin else begin
if not (contains_sub (read ()) "kept") then if read () <> "\"kept\"" then
fail "--%s: the global was not readable before any thunk ran: %S" fail "--%s: the global was not readable before any thunk ran: %S"
backend (read ()); backend (read ());
for cycle = 1 to 3 do for cycle = 1 to 3 do
@ -6069,13 +6160,11 @@ let () =
if not (printed "counter 45") then if not (printed "counter 45") then
fail "the defonce beside the edited def lost its value: %S" fail "the defonce beside the edited def lost its value: %S"
(Buffer.contents output); (Buffer.contents output);
(* Read back rather than only printed, [counter]'s reason. A dyn (* Read back rather than only printed, [counter]'s reason. [c] is a
renders through the program's printer — its reply carries the text dyn, and its value arrives in [:value] like a typed one's. *)
in [:output] and an empty [:value] — so the cast is what turns the
answer into a value the reply can hold. *)
(let r = (let r =
request c request c
"(:op \"eval-expr\" :code \"(i64 c)\" :file \"programs/dev-rerun.flan\")" "(:op \"eval-expr\" :code \"c\" :file \"programs/dev-rerun.flan\")"
in in
match Wire.string_field r "value" with match Wire.string_field r "value" with
| Some "10" -> () | Some "10" -> ()
@ -6518,13 +6607,9 @@ let () =
"(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")" "(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")"
code) code)
in in
(* Every answer is compared inside the expression rather than read out (* Most answers are compared inside the expression, which keeps each
of it. A generic answers a dyn, and a dyn value is rendered to the row about dispatch rather than about rendering; the row after the
program's own stdout rather than into the reply's :value — it does first ask reads a dyn answer straight out of :value.
reach a later reply's :output, which is how the dyn-global rows
below read one, but the flush is the next reply's and not this one's.
Asking the running program whether the answer is 12 puts a typed
value in :value and takes the timing out of the test.
The first ask is retried: the agent's thread is let go only after the The first ask is retried: the agent's thread is let go only after the
socket is bound, so an early ask is a race with the startup and not a socket is bound, so an early ask is a race with the startup and not a
@ -6539,6 +6624,37 @@ let () =
else begin else begin
if !answered <> "1" then if !answered <> "1" then
fail "the method the program was built with answered %S" !answered; fail "the method the program was built with answered %S" !answered;
(* A generic answers a dyn, and its value is in this reply's :value
and not on the program's stdout. *)
(let r = ask "(area (point 3 4))" in
if value r <> "12" then
fail "a dyn answer did not reach :value (%S, output %S)" (value r)
(Option.value ~default:"" (Wire.string_field r "output")));
(* A class is on [defs] as a class, with its slots and where it is
written, and its constructor is not listed a second time as a fn. *)
(let r = request c "(:op \"defs\")" in
match Wire.field r "defs" with
| Some { Form.v = Form.List entries; _ } ->
let rows name =
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
({ Form.v = Form.Str n; _ } :: { Form.v = Form.Str k; _ }
:: { Form.v = Form.Str s; _ }
:: { Form.v = Form.Str l; _ } :: _)
when String.equal n name -> Some (k, s, l)
| _ -> None)
entries
in
(match rows "point" with
| [ ("class", "point [x y]", loc) ]
when String.length loc > 0 && loc.[0] = '/' -> ()
| rs ->
fail "point is on defs as %s"
(String.concat "; "
(List.map (fun (k, s, l) -> k ^ " " ^ s ^ " " ^ l) rs)))
| _ -> fail "defs did not answer with a list");
(* A circle has no method yet, so the dispatch misses and the generic (* A circle has no method yet, so the dispatch misses and the generic
signals NoMethod — the answer a program handles, spelled here as signals NoMethod — the answer a program handles, spelled here as
the thing that makes the next step's success mean something. *) the thing that makes the next step's success mean something. *)

11
test/test_flan.ml
View File

@ -5747,6 +5747,17 @@ let () =
Printf.printf "FAIL %s\n wanted: %s (no printer for)\n got: %s (%s)\n" Printf.printf "FAIL %s\n wanted: %s (no printer for)\n got: %s (%s)\n"
name "<test>:1:43" got dmsg name "<test>:1:43" got dmsg
end); end);
(* The same refusal from watch is worded for watch, not for print. *)
(let name = "an unwatchable value is refused in watch's own words" in
match checked "(defn f [m (Map i32 i32)] () (watch \"m\" m))" with
| _ ->
incr failures;
Printf.printf "FAIL %s: expected a type error\n" name
| exception Loc.Error { Loc.dmsg; _ } ->
if not (contains dmsg "cannot be watched") || contains dmsg "print" then begin
incr failures;
Printf.printf "FAIL %s\n got: %s\n" name dmsg
end);
(* A predicate a body relies on has to be carried by every signature between (* A predicate a body relies on has to be carried by every signature between
it and the call site, or the refusal moves into code the caller did not it and the call site, or the refusal moves into code the caller did not

3
test/test_sanitize.ml
View File

@ -213,6 +213,9 @@ let corpus =
immortal and is not a collector object. If that reasoning is wrong, immortal and is not a collector object. If that reasoning is wrong,
50000 instances past the one-megabyte floor is where ASan says so. *) 50000 instances past the one-megabyte floor is where ASan says so. *)
"programs/dyn-class.flan", []; "programs/dyn-class.flan", [];
(* (watch ...) outside a dev build: every value is bound to a slot and
evaluated, and nothing else about the form is emitted. *)
"programs/watch-release.flan", [];
(* nil <-> None at (Option T), M2 queue item 4: an Option's tag is read (* nil <-> None at (Option T), M2 queue item 4: an Option's tag is read
with a raw [Field] the surface language never writes (check.ml's with a raw [Field] the surface language never writes (check.ml's
[box_option]/[unbox_option], the same access Render's structural [box_option]/[unbox_option], the same access Render's structural