The break buffer, the inspector and the watch table show what a stopped program holds
This commit is contained in:
commit
6f0f4957f4
77
TODO.org
77
TODO.org
@ -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
|
||||
pushed is open.
|
||||
|
||||
** TODO A watch over a struct or a slice
|
||||
Scalars work today through four runtime entry points and need no compiler change.
|
||||
A struct or a slice needs a compile-time walk over its type — one arm beside
|
||||
=print=.
|
||||
** DONE A watch over a struct or a slice
|
||||
CLOSED: [2026-09-25]
|
||||
=(watch "name" v)= is a checker arm beside =print=, sharing its render context
|
||||
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
|
||||
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
|
||||
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
|
||||
It renders to the program's own stdout and arrives on a later reply's output
|
||||
instead. Where a dyn expression's value should surface is a question about the
|
||||
editor protocol.
|
||||
** DONE A dyn value from eval-expr never reaches the reply's value field
|
||||
CLOSED: [2026-09-25]
|
||||
The renderer's emitter has a dyn entry: =println= keeps =flan_dyn_print= to
|
||||
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
|
||||
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
|
||||
with the selected frame's locals.
|
||||
|
||||
** TODO 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.
|
||||
** DONE Hex, binary and an address on a primitive in the inspector
|
||||
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
|
||||
A =defclass= is expanded away before the checker — a dyn map and a shape tag by
|
||||
then — so there is no class table to read. A sum's cases are one symbol each and
|
||||
the daemon answers with the type's name only. =CFn= also wants adding to the type
|
||||
rule.
|
||||
** DONE A defclass is not on the definitions list as a type, and a sum's cases are not drawn
|
||||
CLOSED: [2026-09-25]
|
||||
=defs= reads classes off the session's declarations, which still hold every
|
||||
=defclass=, and lists each as kind =class= with its slots and location; its
|
||||
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
|
||||
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
|
||||
frame's names and types.
|
||||
|
||||
** TODO The stack lists prelude frames
|
||||
=0: pause <prelude>:151:7= is the breakpoint the author wrote, not a step in
|
||||
their program. Prelude frames want hiding by default, with a key to show them.
|
||||
** DONE The stack lists prelude frames
|
||||
CLOSED: [2026-09-25]
|
||||
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
|
||||
=(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
|
||||
a field and a store on every dev-build call.
|
||||
|
||||
** TODO The condition buffer cannot jump to the source
|
||||
It prints the source line and carets for the stop (=flan-cnr.el:197=) and lists
|
||||
frames, but no key opens the file at that line. Wants RET-on-a-frame, or =M-.=,
|
||||
and =next-error= over the frame list.
|
||||
** DONE The condition buffer cannot jump to the source
|
||||
CLOSED: [2026-09-25]
|
||||
RET (and =v=) on a frame or on the stop's =at= line opens the file there; TAB
|
||||
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
|
||||
=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
|
||||
program's output should look different from the compiler's.
|
||||
|
||||
** TODO compilation-mode steps over the notes
|
||||
Nothing sets the skip threshold, so =next-error= walks the errors and steps over
|
||||
the notes, which are still parsed, coloured and clickable. Labelling them as
|
||||
warnings would make them navigable and is refused: a note is not a warning.
|
||||
** DONE compilation-mode steps over the notes
|
||||
CLOSED: [2026-09-25]
|
||||
The daemon buffer and the diagnostics buffer set =compilation-skip-threshold= to
|
||||
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
|
||||
|
||||
|
||||
@ -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
|
||||
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
|
||||
the form, which is the `check.ml` arm below. A load and a branch per watched value per frame is the real number.
|
||||
It is not *free*, and the distinction is worth keeping honest: a load and a branch per watched value per frame is the
|
||||
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
|
||||
(declare-c watch-i64 [name string x i64] i32 "flan_dev_watch_i64")
|
||||
(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
|
||||
for a blunt reason: `declare-c` refuses a void return outright — "which is not a value C can carry", `shim.ml` — so a
|
||||
function a program can declare has to return something, and since it must, it returns the useful thing: 1 if the value
|
||||
was written, 0 if nobody is watching or the table is full.
|
||||
They return `i32` rather than nothing for a blunt reason: `declare-c` refuses a void return outright — "which is not a
|
||||
value C can carry", `shim.ml` — so a function a program can declare has to return something, and since it must, it
|
||||
returns the useful thing: 1 if the value 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
|
||||
Flan value carries no header, so nothing at run 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` renders in the thunk rather than marshalling anything**, and it is the
|
||||
layout decision's bill, paid in the same place.
|
||||
A composite — a struct, a slice, a union — cannot be reached that way. A Flan value carries no header, so nothing at run
|
||||
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`
|
||||
renders in the thunk rather than marshalling anything**, and it is the 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
|
||||
lane. It sits beside `print` (`check.ml:3480`) and is the same shape as it:
|
||||
So `(watch "name" v)` is an arm in `check.ml`, beside `print`, and it is `print` with the emitter aimed elsewhere. The
|
||||
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.
|
||||
|
||||
```
|
||||
| "watch" ->
|
||||
arity loc name 2 args; (* a name and a value *)
|
||||
(* a read, not a move — as print is, for the same reason: (watch "v" v)
|
||||
must not consume a Vec and make that its last showing *)
|
||||
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
|
||||
```
|
||||
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
|
||||
the walk names its argument once per field and a call would otherwise run once per field; and it is bound *before* the
|
||||
table is asked, so a side effect in the value happens whether or not anyone is watching — the program's behaviour does
|
||||
not depend on an editor window. A string watches quoted, as it renders inside a structure, because a table row is a
|
||||
value and an unquoted `5` could not be told from the number.
|
||||
|
||||
with `flan/watch-begin`, `flan/watch-end` and the four emit functions declared as externs the way `Session.externs`
|
||||
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.
|
||||
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
|
||||
"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
|
||||
would have to be generated. True of the table and false of the conclusion: the call site is in the buffer. The
|
||||
composite renderer still wants the form, for its own reason, and it is the only one of the two that does.
|
||||
would have to be generated. True of the table and false of the conclusion: the call site is in the buffer.
|
||||
|
||||
## 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
|
||||
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
|
||||
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
|
||||
moment it asks for memory**, and the compiler is standing right there, so a dev build writes it down: base address,
|
||||
|
||||
@ -338,11 +338,13 @@ Keys in that buffer:
|
||||
|
||||
| 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 |
|
||||
| `TAB` / `n` | next restart |
|
||||
| `S-TAB` / `p` | previous |
|
||||
| `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 |
|
||||
| `a` | abort |
|
||||
| `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
|
||||
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
|
||||
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**
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
(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
|
||||
(set ticks (+ ticks 1))
|
||||
(watch-i64 "ticks" ticks)
|
||||
(watch "ticks" ticks)
|
||||
(watch "player" player)
|
||||
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
|
||||
the same way it changes anything else, so the watch list is edited in the place
|
||||
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
|
||||
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
|
||||
nobody is debugging is a load and a branch that is not taken, in a release
|
||||
build as in a dev one.
|
||||
and closing it tells the program to stop. So in a dev build a `watch` nobody is
|
||||
looking at costs a load and a branch that is not taken. In a release build
|
||||
`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
|
||||
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
|
||||
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
|
||||
struct or a slice does not. That is not an oversight in the runtime — a Flan
|
||||
value carries no header, so rendering one is a walk over its *type* at compile
|
||||
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.
|
||||
**The scalar entry points.** `watch` is a form the compiler knows. The same
|
||||
table is also reachable as plain C functions, one per scalar type, which a
|
||||
program declares like any other:
|
||||
|
||||
```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
|
||||
|
||||
|
||||
@ -51,8 +51,9 @@
|
||||
;; 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
|
||||
;; `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
|
||||
;; mostly frames nobody wrote.
|
||||
;; wraps nothing. Of its filters one was taken: the prelude's frames are
|
||||
;; 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
|
||||
;; name, with what it would take. A missing section is indistinguishable from
|
||||
@ -65,6 +66,8 @@
|
||||
(require 'subr-x)
|
||||
|
||||
(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-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.")
|
||||
(defvar-local flan-cnr--open nil
|
||||
"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)
|
||||
(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."
|
||||
(let ((site (plist-get state :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))
|
||||
(lc (flan-cnr--site-line-col site)))
|
||||
(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))))
|
||||
(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)
|
||||
(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)))
|
||||
(if (null frames)
|
||||
(insert (flan-cnr--unavailable 'stack))
|
||||
(let ((i -1))
|
||||
(let ((i -1) (hidden 0))
|
||||
(dolist (fr frames)
|
||||
(setq i (1+ i))
|
||||
(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)
|
||||
(list 'flan-cnr-frame i 'mouse-face 'highlight)))
|
||||
;; A hidden frame keeps its number. The index is what `locals' and
|
||||
;; the inspector are asked by, so the frames either side of a hidden
|
||||
;; run are numbered with a gap, and the line in the gap says why.
|
||||
;;
|
||||
;; The innermost frame is where the program stopped, so it is shown
|
||||
;; even when it is the prelude's — unless the stop is `(pause)',
|
||||
;; whose own frame is the breakpoint and not where anything failed.
|
||||
(if (and (not flan-cnr--show-prelude)
|
||||
(flan-cnr--prelude-frame-p fr)
|
||||
(or (> i 0)
|
||||
(equal (plist-get state :condition) flan-cnr-breakpoint)))
|
||||
(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
|
||||
;; has frames, and all of them at once is the backtrace problem again
|
||||
;; one level down.
|
||||
@ -413,8 +463,7 @@ indexing or the division itself, so it sits directly under the headline."
|
||||
(add-text-properties
|
||||
start (point)
|
||||
(list 'flan-cnr-inspect (list :slot i (nth 3 l) (nth 0 l))
|
||||
'mouse-face 'highlight)))))))))))
|
||||
(insert "\n"))
|
||||
'mouse-face 'highlight))))))))
|
||||
|
||||
(defun flan-cnr--insert-globals (state)
|
||||
"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.
|
||||
(flan-cnr--insert-globals state)
|
||||
(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))
|
||||
(goto-char (point-min))
|
||||
;; 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)
|
||||
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index)
|
||||
(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"))))
|
||||
|
||||
(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)
|
||||
"Take restart INDEX, named NAME.
|
||||
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
|
||||
;; to stop being true.
|
||||
(progn (message "flan: %s — %s" name (or (plist-get r :note) "accepted"))
|
||||
(flan-cnr--forget)
|
||||
(quit-window))
|
||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
||||
|
||||
@ -579,7 +702,9 @@ different restart than the one it showed."
|
||||
(interactive)
|
||||
(let ((r (funcall flan-cnr-request-function '(:op "abort"))))
|
||||
(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")))))
|
||||
|
||||
(defun flan-cnr-toggle-frame ()
|
||||
@ -668,6 +793,8 @@ drawn from."
|
||||
(get-text-property pos 'flan-cnr-shadowed)
|
||||
(get-text-property pos 'flan-cnr-abort)
|
||||
(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)))
|
||||
|
||||
(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 "p" #'flan-cnr-previous)
|
||||
(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 "a" #'flan-cnr-abort)
|
||||
(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"
|
||||
"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)
|
||||
"The buffer's state, out of a `break' REPLY.
|
||||
@ -932,7 +1064,12 @@ walk from a running program."
|
||||
(flan-cnr-condition-fields
|
||||
(plist-get r :condition))
|
||||
(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)
|
||||
buf)))
|
||||
|
||||
|
||||
@ -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
|
||||
renderer writes, so the buffer you type into is the value's own spelling and
|
||||
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
|
||||
"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
|
||||
@ -511,9 +518,10 @@ stated honestly — every Flan integer is rendered through i64."
|
||||
('option (format "(some …)"))
|
||||
(_ (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.
|
||||
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))
|
||||
(erase-buffer)
|
||||
(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.
|
||||
(let ((detail (flan-inspect--detail node)))
|
||||
(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 difference between a value and *which* value, and the thing that was
|
||||
;; 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-inspect--root-label root path)))
|
||||
:type (plist-get r :type)
|
||||
:addr (plist-get r :addr)
|
||||
;; The stop the read happened at, where the reply carried one. It
|
||||
;; travels with the value rather than being asked for separately,
|
||||
;; 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--type (plist-get answer :type))
|
||||
(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--editing nil)
|
||||
;; 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-local truncate-lines t)
|
||||
(flan-inspect--render root path flan-inspect--node stack
|
||||
flan-inspect--type))
|
||||
flan-inspect--type flan-inspect--addr))
|
||||
(display-buffer buf)
|
||||
buf))
|
||||
|
||||
|
||||
@ -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)
|
||||
;; The types the compiler knows without being told: every primitive in
|
||||
;; `Types.primitive_names', plus the four applied ones the checker
|
||||
;; resolves and the function type. `dyn' is lowercase on purpose — it is
|
||||
;; a primitive beside `i64' and `bool', not a container over something.
|
||||
;; resolves and the two function types, `Fn' and `CFn'. `dyn' is
|
||||
;; 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'.
|
||||
;;
|
||||
;; `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
|
||||
;; advertise a spelling the parser rejects, which is the same reason
|
||||
;; `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)
|
||||
;; A type variable, `$t', which is what a generic `defn' names its
|
||||
;; parameter types with and what `{:where (ordered? $t)}' constrains.
|
||||
|
||||
@ -62,19 +62,17 @@
|
||||
;; insert, because it diffs, so point and scroll survive a repaint instead of
|
||||
;; being yanked to the top five times a second.
|
||||
;;
|
||||
;; What a program writes today, with no compiler change:
|
||||
;;
|
||||
;; (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")
|
||||
;; What a program writes:
|
||||
;;
|
||||
;; (defn step [] i64
|
||||
;; (set ticks (+ ticks 1))
|
||||
;; (watch-i64 "ticks" ticks)
|
||||
;; (watch "ticks" ticks)
|
||||
;; (watch "player" player)
|
||||
;; ticks)
|
||||
;;
|
||||
;; Scalars only, so far. A struct or a slice needs a compile-time walk over
|
||||
;; its type — a `(watch "hp" hp)' form in the checker — and that is a file this
|
||||
;; change does not own. See docs/BUILT.md.
|
||||
;; `watch' renders any value the way `print' does — a struct, a slice, a dyn
|
||||
;; value — into the table. The scalar entry points underneath it,
|
||||
;; `flan_dev_watch_i64' and the rest, are reachable through `declare-c' too.
|
||||
|
||||
;;; 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."
|
||||
(if (null rows)
|
||||
(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"
|
||||
" (declare-c watch-i64 [name string x i64] i32 \"flan_dev_watch_i64\")\n"
|
||||
" ...\n"
|
||||
" (watch-i64 \"ticks\" ticks)\n")
|
||||
" (watch \"ticks\" ticks)\n")
|
||||
(let ((w (apply #'max (mapcar (lambda (r) (length (car r))) rows))))
|
||||
(concat
|
||||
(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'.
|
||||
;;
|
||||
;; 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
|
||||
;; `(watch ...)' form in the checker, which is a file this does not own. But a
|
||||
;; location is not actually missing: `(watch-i64 "hp" hp)' is *in the buffer*,
|
||||
;; no source location. A location is not actually missing: `(watch "hp" hp)'
|
||||
;; or `(watch-i64 "hp" hp)' is *in the buffer*,
|
||||
;; 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
|
||||
;; regexp scan per displayed buffer per repaint and needs nothing new from the
|
||||
|
||||
133
emacs/flan.el
133
emacs/flan.el
@ -78,6 +78,15 @@
|
||||
;; the commands here and requires nothing back.
|
||||
(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
|
||||
"Talking to a running Flan program."
|
||||
:group 'flan
|
||||
@ -475,6 +484,7 @@ with it, and a rejected evaluation is a likely moment to *become* stopped."
|
||||
(setq flan--stopped now)
|
||||
(unless (equal was now)
|
||||
(force-mode-line-update t)
|
||||
(unless now (flan--forget-break-stack))
|
||||
;; 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
|
||||
;; 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
|
||||
;; one finished command — killing the process on a `recompile', among
|
||||
;; other things it has no business doing to a live session.
|
||||
(compilation-minor-mode 1))
|
||||
(compilation-minor-mode 1)
|
||||
(flan--navigable-notes))
|
||||
(make-process
|
||||
:name "flan-daemon" :buffer buf
|
||||
:command args
|
||||
@ -1160,6 +1171,7 @@ apart, so a prompt cannot take a different restart than the one it showed."
|
||||
(progn
|
||||
;; Accepted, not resumed — see `flan-restart'.
|
||||
(setq flan--stopped nil)
|
||||
(flan--forget-break-stack)
|
||||
(force-mode-line-update t)
|
||||
(message "flan: %s — %s" name (or (plist-get r :note) "accepted")))
|
||||
(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
|
||||
;; there.
|
||||
(setq flan--stopped nil)
|
||||
(flan--forget-break-stack)
|
||||
(force-mode-line-update t)
|
||||
(message "flan: %s — %s" name
|
||||
(or (plist-get r :note) "accepted")))
|
||||
@ -1226,6 +1239,7 @@ nothing left to serve once it has gone."
|
||||
(let ((r (flan--request '(:op "abort"))))
|
||||
(if (equal (plist-get r :status) "ok")
|
||||
(progn (setq flan--stopped nil)
|
||||
(flan--forget-break-stack)
|
||||
(force-mode-line-update t)
|
||||
(message "flan: %s" (or (plist-get r :note) "aborted")))
|
||||
(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 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)
|
||||
"Position of LINE and byte-column COL in the current buffer."
|
||||
(save-excursion
|
||||
@ -1449,7 +1509,8 @@ no longer wrong."
|
||||
;; should go there. The minor mode rather than deriving from
|
||||
;; `compilation-mode', because this buffer is not the output of a command
|
||||
;; that ran once.
|
||||
(compilation-minor-mode 1))
|
||||
(compilation-minor-mode 1)
|
||||
(flan--navigable-notes))
|
||||
|
||||
(defvar-local flan--diagnostics-memory-start nil
|
||||
"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.
|
||||
|
||||
A list of kinds drawn from `flan--dynamic-faces': `macro', `fn', `var',
|
||||
`const', `struct', `data', `union', `enum', `alias', `extern', `builtin'.
|
||||
t draws all of them and nil draws none.
|
||||
`const', `struct', `data', `union', `enum', `alias', `class', `extern',
|
||||
`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
|
||||
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)
|
||||
("union" . 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.
|
||||
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
|
||||
@ -1886,7 +1952,9 @@ The setting is written with symbols because that is what a user types; the
|
||||
wire answers with strings."
|
||||
(cond ((eq flan-font-lock-dynamically t) t)
|
||||
((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
|
||||
"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)))
|
||||
(setq face (gethash sym flan--dynamic-table))
|
||||
;; 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
|
||||
;; daemon answers with the type's name and knows nothing of the cases.
|
||||
;; The type half is drawn and the case half left alone, which is the
|
||||
;; true statement: one of them is a name the program defines.
|
||||
;; so the whole thing is one symbol. The daemon lists each case under
|
||||
;; that full name, so the lookup above finds it. A dotted symbol it
|
||||
;; does not list, such as a case that does not exist, has only its
|
||||
;; type half drawn.
|
||||
(unless face
|
||||
(let ((dot (string-search "." sym)))
|
||||
(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)))
|
||||
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.
|
||||
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
|
||||
— and every list that offers \"a thing with a body\" has to say both words or
|
||||
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"
|
||||
(car d) (nth 1 d)))
|
||||
(t
|
||||
(let ((parts (flan--parse-loc (nth 3 d))))
|
||||
(cond
|
||||
((null parts)
|
||||
(user-error "flan: the daemon gave %s an unreadable location: %s"
|
||||
(car d) (nth 3 d)))
|
||||
((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"
|
||||
(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)))))))))))))
|
||||
(let ((parts (flan--visitable-loc (nth 3 d) (car d))))
|
||||
(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
|
||||
|
||||
|
||||
@ -196,7 +196,20 @@
|
||||
(let ((text (with-current-buffer (save-window-excursion (flan-inspect "flags"))
|
||||
(buffer-string))))
|
||||
(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
|
||||
(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"
|
||||
(string-match-p "Stack.*\n not available.*running"
|
||||
(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
|
||||
;; 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"
|
||||
(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
|
||||
;; 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
|
||||
@ -1680,6 +1817,31 @@ stopped program, which is the case where it should fire."
|
||||
(eq (key-binding (kbd k)) #'flan-macroexpand--not-source))
|
||||
'("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
|
||||
;; so belongs with the other fixture-driven checks rather than with anything
|
||||
;; that needs a daemon. Loaded rather than run separately because
|
||||
|
||||
@ -425,6 +425,8 @@
|
||||
("(def v (Vec u8))" "Vec" font-lock-type-face "Vec")
|
||||
("(declare apply [(Fn [i64] i64)] i64)" "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
|
||||
"a type variable")
|
||||
;; The package alias of a qualified name, `clojure-mode''s
|
||||
@ -483,7 +485,10 @@
|
||||
("gravity" "const" "gravity f32" "" "")
|
||||
("with-retry" "macro" "with-retry [args] Form" "" "")
|
||||
("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" "" "")
|
||||
("sim/step" "fn" "sim/step [] ()" "sand.flan:9" "")
|
||||
("a/draw" "fn" "a/draw [] ()" "" "")
|
||||
@ -570,17 +575,30 @@
|
||||
(let ((flan--defs test-flan-mode--defs))
|
||||
(not (member "ticks" (flan--compiled-names)))))
|
||||
|
||||
;; A constructor is `Type.Case' and is one symbol, so the type half is what
|
||||
;; the program can speak for and the case half is left alone.
|
||||
;; A constructor is `Type.Case' and is one symbol. The daemon lists each
|
||||
;; 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
|
||||
"a constructor's type half is drawn"
|
||||
(let ((flan-font-lock-dynamically t))
|
||||
(eq (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" "Shape")
|
||||
"a constructor is drawn whole, case half included"
|
||||
(let ((flan-font-lock-dynamically '(data)))
|
||||
(eq (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" ".Dot")
|
||||
'flan-type-face)))
|
||||
|
||||
(test-flan--check
|
||||
"and its case half is not"
|
||||
(null (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" ".Dot")))
|
||||
"and not when data types are not asked for"
|
||||
(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
|
||||
"a name the program has never heard of is left alone"
|
||||
|
||||
121
lib/check.ml
121
lib/check.ml
@ -571,6 +571,26 @@ let fresh_slot ?name ctx ty =
|
||||
ctx.slot_names <- name :: ctx.slot_names;
|
||||
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
|
||||
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
|
||||
@ -8618,25 +8638,10 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
||||
(Tast.Prim (Tast.EscapeBytes, [ x ]))));
|
||||
ei64 = (fun x -> write (conv Tast.I64ToBytes x));
|
||||
eu64 = (fun x -> write (conv Tast.U64ToBytes x));
|
||||
ef64 = (fun x -> write (conv Tast.F64ToBytes x)) }
|
||||
in
|
||||
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) }
|
||||
ef64 = (fun x -> write (conv Tast.F64ToBytes x));
|
||||
edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_print", [ x ]))) }
|
||||
in
|
||||
let rc = render_ctx ctx emitter in
|
||||
let render_one a =
|
||||
match a.Tast.ty with
|
||||
| Types.String | Types.Slice (Types.Int Types.U8) ->
|
||||
@ -8666,6 +8671,81 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
||||
else []
|
||||
in
|
||||
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" ->
|
||||
arity ctx loc name 1 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.");
|
||||
("println", "println [T ...] ()",
|
||||
"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",
|
||||
"Ends the process with this status. It has no value, so nothing written \
|
||||
after it runs.");
|
||||
|
||||
89
lib/dev.ml
89
lib/dev.ml
@ -1415,6 +1415,21 @@ let defs t =
|
||||
[M-.] on a prelude macro from "the prelude is not a file on disk" into a
|
||||
shrug about the daemon having no location. *)
|
||||
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 =
|
||||
List.filter_map
|
||||
(fun (f : Tast.fn) ->
|
||||
@ -1425,6 +1440,7 @@ let defs t =
|
||||
| None when List.mem f.Tast.name macro_names ->
|
||||
Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc);
|
||||
None
|
||||
| None when List.mem f.Tast.name class_names -> None
|
||||
| None ->
|
||||
Some
|
||||
(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)
|
||||
tbl []
|
||||
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
|
||||
(of_table "struct" env.Check.structs
|
||||
@ of_table "data" env.Check.datas
|
||||
@ datas @ classes
|
||||
@ of_table "union" env.Check.unions
|
||||
@ of_table "enum" env.Check.enums
|
||||
@ of_table "alias" env.Check.aliases)
|
||||
@ -2285,13 +2345,26 @@ let inspect t ~frame ~slot ~path =
|
||||
| Ok (c, label, ty) ->
|
||||
(match run_render_thunk t ~tag:"i" ~c with
|
||||
| Error m -> error m
|
||||
| Ok v ->
|
||||
(* One value and nothing else, so the whole of what came back is
|
||||
it — minus the trailing newline the renderer does not write
|
||||
here, because there is no second line to separate it from. *)
|
||||
| Ok out ->
|
||||
(* The address the value is stored at, on a line of its own, and
|
||||
then the value. See [Session.render_slot]. *)
|
||||
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
|
||||
[ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label;
|
||||
":type " ^ Wire.quote ty; ":value " ^ Wire.quote v;
|
||||
([ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label;
|
||||
":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
|
||||
what is on the screen can name it and be refused if 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
|
||||
at, and an editor that asked for it separately would be
|
||||
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
|
||||
|
||||
14
lib/emit.ml
14
lib/emit.ml
@ -1865,6 +1865,9 @@ and value_at f (e : Tast.expr) : string =
|
||||
bind_slot f slot)
|
||||
bs;
|
||||
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.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]
|
||||
@ -4025,6 +4028,17 @@ declare i64 @flan_dyn_at(i64, i64)
|
||||
declare void @flan_dyn_set_at(i64, i64, i64)
|
||||
declare void @flan_dyn_push(i64, 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 double @flan_dyn_need_f64(i64)
|
||||
declare i32 @flan_dyn_need_bool(i64)
|
||||
|
||||
@ -1158,6 +1158,9 @@ and stmt f dest (e : Tast.expr) =
|
||||
line f "%s = %s;" f.names.(slot) x)
|
||||
binds;
|
||||
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) ->
|
||||
let cv = value f c in
|
||||
line f "if (%s) {" cv;
|
||||
|
||||
@ -31,6 +31,10 @@ type emitter = {
|
||||
ei64 : Tast.expr -> Tast.expr;
|
||||
eu64 : 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
|
||||
@ -93,7 +97,14 @@ let max_span = 8
|
||||
|
||||
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 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
|
||||
@ -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
|
||||
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
|
||||
the walk hands the whole value over.
|
||||
|
||||
The cost is that it writes to stdout itself rather than through
|
||||
[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 ])) ]
|
||||
the walk hands the whole value to [c.emit.edyn], which names the runtime
|
||||
entry point that renders into this emitter's sink. *)
|
||||
| Types.Dyn -> [ c.emit.edyn e ]
|
||||
(* 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
|
||||
rather than only the refusal. *)
|
||||
| t ->
|
||||
fail loc "no printer for %s — print the values you want out of it"
|
||||
(Types.to_string t)
|
||||
fail loc "%s" (refuse loc t)
|
||||
|
||||
@ -1140,7 +1140,13 @@ let dev_emitter : Render.emitter =
|
||||
estr = call emit_str;
|
||||
ei64 = call emit_i64;
|
||||
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
|
||||
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
|
||||
| exception Loc.Error { Loc.dmsg = why; _ } -> Error (name ^ path_text path ^ ": " ^ why)
|
||||
| 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
|
||||
t.thunks <- t.thunks + 1;
|
||||
let tname = Printf.sprintf "inspect/%d" t.thunks in
|
||||
|
||||
13
lib/tast.ml
13
lib/tast.ml
@ -437,6 +437,19 @@ type program = {
|
||||
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]
|
||||
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) =
|
||||
f e;
|
||||
let go = walk f in
|
||||
|
||||
@ -1898,6 +1898,10 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
|
||||
bind_slot f slot)
|
||||
bs;
|
||||
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) ->
|
||||
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);
|
||||
|
||||
@ -566,10 +566,10 @@ static uint64_t watch_epoch;
|
||||
* 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.
|
||||
*
|
||||
* What it is *not*: free. Eliding the call entirely needs the compiler to know
|
||||
* the form, which is a [check.ml] arm this does not have. A load and a branch
|
||||
* per watched value per frame is the honest number, and it is the same number
|
||||
* in both builds rather than a dev-only tax. */
|
||||
* What it is *not*: free. A scalar entry point called through [declare-c]
|
||||
* costs a load and a branch per watched value per frame, in both builds. The
|
||||
* [(watch ...)] form costs that in a dev build only: outside one the backend
|
||||
* drops its call, and what is left is the value's own evaluation. */
|
||||
static int watch_on;
|
||||
|
||||
void flan_dev_watch_enable(int on) {
|
||||
@ -639,6 +639,22 @@ int flan_dev_watch_begin(const char *name) {
|
||||
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) {
|
||||
watch_slot *s = watch_cur;
|
||||
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
|
||||
* it and normally does.
|
||||
*
|
||||
* A composite — a struct, a slice, a union — cannot be done this way, and that
|
||||
* is not a shortcoming of these four: a Flan value carries no header, so
|
||||
* nothing at run time can say what it is, and rendering one is a compile-time
|
||||
* walk over its *type*. The walk already exists — [Render.render] — and the
|
||||
* four [flan_dev_watch_emit_*] above are the emitter it would be pointed at,
|
||||
* shaped exactly like the [print] arm's. What is missing is the
|
||||
* [(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. */
|
||||
* A composite — a struct, a slice, a union — cannot be done this way: a Flan
|
||||
* value carries no header, so nothing at run time can say what it is, and
|
||||
* rendering one is a compile-time walk over its *type*. That is the
|
||||
* [(watch "hp" hp)] form in check.ml, which points [Render.render] at
|
||||
* [flan_dev_watch_begin_n], the [flan_dev_watch_emit_*] above and
|
||||
* [flan_dev_watch_end]. */
|
||||
int32_t flan_dev_watch_i64(const char *name, int64_t x) {
|
||||
if (!flan_dev_watch_begin(name)) return 0;
|
||||
flan_dev_watch_emit_i64(x);
|
||||
|
||||
@ -48,6 +48,13 @@
|
||||
* copies honest. */
|
||||
|
||||
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
|
||||
* 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
|
||||
* [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
|
||||
* 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
|
||||
* 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
|
||||
|
||||
static void emit(const char *s) {
|
||||
flan_write_stdout((const uint8_t *)s, (int64_t)strlen(s));
|
||||
/* Where the rendering goes. stdout for [print], or one of flan_dev.c'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
|
||||
* 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
|
||||
* changes, change this one. Streamed rather than built, so there is no buffer
|
||||
* 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;
|
||||
emit("\"");
|
||||
emit(w, "\"");
|
||||
for (i = 0; i < n; i++) {
|
||||
unsigned char c = p[i];
|
||||
switch (c) {
|
||||
case '"': emit("\\\""); break;
|
||||
case '\\': emit("\\\\"); break;
|
||||
case '\n': emit("\\n"); break;
|
||||
case '\t': emit("\\t"); break;
|
||||
case '\r': emit("\\r"); break;
|
||||
case '"': emit(w, "\\\""); break;
|
||||
case '\\': emit(w, "\\\\"); break;
|
||||
case '\n': emit(w, "\\n"); break;
|
||||
case '\t': emit(w, "\\t"); break;
|
||||
case '\r': emit(w, "\\r"); break;
|
||||
default:
|
||||
if (c < 0x20) {
|
||||
char b[5];
|
||||
snprintf(b, sizeof b, "\\x%02x", c);
|
||||
emit(b);
|
||||
emit(w, b);
|
||||
} 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 */
|
||||
@ -554,20 +568,20 @@ static int64_t view_elem_size(int32_t elem);
|
||||
static int64_t vecish_len(flan_obj *o);
|
||||
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];
|
||||
int32_t t = flan_dyn_tag(v);
|
||||
if (depth > PRINT_DEPTH) { emit("..."); return; }
|
||||
if (depth > PRINT_DEPTH) { emit(w, "..."); return; }
|
||||
switch (t) {
|
||||
case FLAN_DYN_TAG_NIL:
|
||||
emit("nil");
|
||||
emit(w, "nil");
|
||||
return;
|
||||
case FLAN_DYN_TAG_BOOL:
|
||||
emit(dyn_payload(v) ? "true" : "false");
|
||||
emit(w, dyn_payload(v) ? "true" : "false");
|
||||
return;
|
||||
case FLAN_DYN_TAG_INT:
|
||||
snprintf(buf, sizeof buf, "%lld", (long long)dyn_int_value(v));
|
||||
emit(buf);
|
||||
emit(w, buf);
|
||||
return;
|
||||
case FLAN_DYN_TAG_FLOAT: {
|
||||
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. */
|
||||
if (d != d) snprintf(buf, sizeof buf, "nan");
|
||||
else snprintf(buf, sizeof buf, "%g", d);
|
||||
emit(buf);
|
||||
emit(w, buf);
|
||||
return;
|
||||
}
|
||||
case FLAN_DYN_TAG_TEXT: {
|
||||
flan_obj *o = dyn_obj(v);
|
||||
if (nested) emit_escaped(obj_text_bytes(o), o->len);
|
||||
else emit_n(obj_text_bytes(o), o->len);
|
||||
if (nested) emit_escaped(w, obj_text_bytes(o), o->len);
|
||||
else emit_n(w, obj_text_bytes(o), o->len);
|
||||
return;
|
||||
}
|
||||
/* 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. */
|
||||
case FLAN_DYN_TAG_KEYWORD: {
|
||||
kw_entry *k = dyn_kw(v);
|
||||
emit(":");
|
||||
emit_n(kw_bytes(k), k->len);
|
||||
emit(w, ":");
|
||||
emit_n(w, kw_bytes(k), k->len);
|
||||
return;
|
||||
}
|
||||
/* 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
|
||||
* written here or it is not written at all. */
|
||||
if (o->u.v.klass != NULL) {
|
||||
emit("#");
|
||||
emit_n(kw_bytes(o->u.v.klass), o->u.v.klass->len);
|
||||
emit(w, "#");
|
||||
emit_n(w, kw_bytes(o->u.v.klass), o->u.v.klass->len);
|
||||
}
|
||||
emit("{");
|
||||
emit(w, "{");
|
||||
for (i = 0; i < o->len; i++) {
|
||||
emit(" ");
|
||||
render(o->u.v.items[i * 2], depth + 1, 1);
|
||||
emit(" ");
|
||||
render(o->u.v.items[i * 2 + 1], depth + 1, 1);
|
||||
emit(w, " ");
|
||||
render(w, o->u.v.items[i * 2], depth + 1, 1);
|
||||
emit(w, " ");
|
||||
render(w, o->u.v.items[i * 2 + 1], depth + 1, 1);
|
||||
}
|
||||
emit("}");
|
||||
emit(w, "}");
|
||||
return;
|
||||
}
|
||||
default: {
|
||||
flan_obj *o = dyn_obj(v);
|
||||
int64_t i, n = o->kind == OBJ_VIEW ? view_len("print", o) : o->len;
|
||||
emit("[");
|
||||
emit(w, "[");
|
||||
for (i = 0; i < n; i++) {
|
||||
emit(" ");
|
||||
emit(w, " ");
|
||||
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)
|
||||
+ i * view_elem_size(o->u.view.elem)),
|
||||
depth + 1, 1);
|
||||
else
|
||||
render(o->u.v.items[i], depth + 1, 1);
|
||||
render(w, o->u.v.items[i], depth + 1, 1);
|
||||
}
|
||||
emit("]");
|
||||
emit(w, "]");
|
||||
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
|
||||
* rather than allocating: a trap is the one moment when allocating would be a
|
||||
|
||||
@ -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
|
||||
* traps: every tag has a rendering, including nil. */
|
||||
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 ────────────────────────────────────────────────
|
||||
*
|
||||
|
||||
@ -1,10 +1,8 @@
|
||||
;;;; 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
|
||||
;;;; entry points are ordinary C functions, so a program reaches them through
|
||||
;;;; [declare-c] the same way it reaches anything else in the runtime. That is
|
||||
;;;; deliberate — a [(watch "hp" hp)] form would be an arm in the checker, and
|
||||
;;;; a scalar does not need one.
|
||||
;;;; Two ways in. A scalar reaches the watch entry points as ordinary C
|
||||
;;;; functions, through [declare-c]. A struct, a slice or anything else goes
|
||||
;;;; through the [(watch "name" v)] form, which renders it the way print does.
|
||||
;;;;
|
||||
;;;; 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
|
||||
@ -22,6 +20,8 @@
|
||||
|
||||
(defonce ticks i64)
|
||||
|
||||
(defstruct Pos [x i32 y f64])
|
||||
|
||||
(defn loop-cells [] i32
|
||||
(let [i 0]
|
||||
(while (< i 8)
|
||||
@ -37,6 +37,14 @@
|
||||
(watch-i64 "ticks" ticks)
|
||||
(watch-f64 "half" (/ (f64 ticks) 2.0))
|
||||
(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
|
||||
;; 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
|
||||
|
||||
27
test/programs/watch-release.flan
Normal file
27
test/programs/watch-release.flan
Normal 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)
|
||||
@ -4411,6 +4411,31 @@ level "1"
|
||||
"programs/dyn-class.flan" dyn_class_out;
|
||||
outputs ~x86:true "dyn: classes and dispatch, --x86"
|
||||
"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 ─────────────────────────────
|
||||
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
|
||||
|
||||
152
test/test_dev.ml
152
test/test_dev.ml
@ -1385,7 +1385,9 @@ let () =
|
||||
(* The site, on LLVM: an arith trap publishes its loc around the
|
||||
hook exactly as a bounds trap does. *)
|
||||
(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
|
||||
| None -> fail "a division by zero carries no :site");
|
||||
let r = ask "(:op \"restart\" :name \"use-zero\")" in
|
||||
@ -2288,6 +2290,33 @@ let () =
|
||||
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
||||
fail "the inspect program never stopped"
|
||||
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,
|
||||
which is the fourth element of each entry. Reading it here rather
|
||||
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 \"x\")" "f32" "4.5";
|
||||
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
|
||||
one, so a client in that language cannot send `()'. *)
|
||||
(match slot_of listing "mark" with
|
||||
@ -3879,6 +3949,28 @@ let () =
|
||||
| Some "\"sand\"" -> ()
|
||||
| Some v -> fail "watch rendered a string as %s, unquoted" v
|
||||
| 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
|
||||
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
|
||||
@ -5853,12 +5945,11 @@ let () =
|
||||
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||
| _ -> false
|
||||
in
|
||||
(* What the expression answered, wherever it came back: a dyn value
|
||||
is rendered into the reply's output rather than into [:value],
|
||||
and which of the two carries it is not what is under test. *)
|
||||
(* A dyn value is rendered into the reply's [:value], as a typed
|
||||
one is, on both backends, and a dyn text is quoted there as a
|
||||
typed string is. *)
|
||||
let answer r =
|
||||
Option.value ~default:"" (Wire.string_field r "value")
|
||||
^ Option.value ~default:"" (Wire.string_field r "output")
|
||||
in
|
||||
let read () =
|
||||
answer
|
||||
@ -5877,7 +5968,7 @@ let () =
|
||||
if not (await ~ms:20000 parked) then
|
||||
fail "the dyn-global program (--%s) never parked" backend
|
||||
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"
|
||||
backend (read ());
|
||||
for cycle = 1 to 3 do
|
||||
@ -6069,13 +6160,11 @@ let () =
|
||||
if not (printed "counter 45") then
|
||||
fail "the defonce beside the edited def lost its value: %S"
|
||||
(Buffer.contents output);
|
||||
(* Read back rather than only printed, [counter]'s reason. A dyn
|
||||
renders through the program's printer — its reply carries the text
|
||||
in [:output] and an empty [:value] — so the cast is what turns the
|
||||
answer into a value the reply can hold. *)
|
||||
(* Read back rather than only printed, [counter]'s reason. [c] is a
|
||||
dyn, and its value arrives in [:value] like a typed one's. *)
|
||||
(let r =
|
||||
request c
|
||||
"(:op \"eval-expr\" :code \"(i64 c)\" :file \"programs/dev-rerun.flan\")"
|
||||
"(:op \"eval-expr\" :code \"c\" :file \"programs/dev-rerun.flan\")"
|
||||
in
|
||||
match Wire.string_field r "value" with
|
||||
| Some "10" -> ()
|
||||
@ -6518,13 +6607,9 @@ let () =
|
||||
"(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")"
|
||||
code)
|
||||
in
|
||||
(* Every answer is compared inside the expression rather than read out
|
||||
of it. A generic answers a dyn, and a dyn value is rendered to the
|
||||
program's own stdout rather than into the reply's :value — it does
|
||||
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.
|
||||
(* Most answers are compared inside the expression, which keeps each
|
||||
row about dispatch rather than about rendering; the row after the
|
||||
first ask reads a dyn answer straight out of :value.
|
||||
|
||||
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
|
||||
@ -6539,6 +6624,37 @@ let () =
|
||||
else begin
|
||||
if !answered <> "1" then
|
||||
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
|
||||
signals NoMethod — the answer a program handles, spelled here as
|
||||
the thing that makes the next step's success mean something. *)
|
||||
|
||||
@ -5747,6 +5747,17 @@ let () =
|
||||
Printf.printf "FAIL %s\n wanted: %s (no printer for)\n got: %s (%s)\n"
|
||||
name "<test>:1:43" got dmsg
|
||||
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
|
||||
it and the call site, or the refusal moves into code the caller did not
|
||||
|
||||
@ -213,6 +213,9 @@ let corpus =
|
||||
immortal and is not a collector object. If that reasoning is wrong,
|
||||
50000 instances past the one-megabyte floor is where ASan says so. *)
|
||||
"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
|
||||
with a raw [Field] the surface language never writes (check.ml's
|
||||
[box_option]/[unbox_option], the same access Render's structural
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user