diff --git a/TODO.org b/TODO.org index 84f0b97c..3ea45b08 100644 --- a/TODO.org +++ b/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 :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 == 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 diff --git a/docs/BUILT.md b/docs/BUILT.md index de16a5f7..3f845741 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -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, diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index e08994ed..ad0def76 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -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 diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index dea14019..5bc4e1f7 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -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 `: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 ":" 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, `', 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))) diff --git a/emacs/flan-inspect.el b/emacs/flan-inspect.el index be5c8be2..32ab9302 100644 --- a/emacs/flan-inspect.el +++ b/emacs/flan-inspect.el @@ -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)) diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 578c4c70..2319497c 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -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. diff --git a/emacs/flan-watch.el b/emacs/flan-watch.el index b73cb1f0..3b013653 100644 --- a/emacs/flan-watch.el +++ b/emacs/flan-watch.el @@ -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 diff --git a/emacs/flan.el b/emacs/flan.el index b6e6cd18..2efbfd6c 100644 --- a/emacs/flan.el +++ b/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 ; 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 ; 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 diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index a13ead5d..84a93172 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -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 ":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 +: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 ", 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 ":40:3") + (list :fn "fold" :loc ":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 diff --git a/emacs/test-flan-mode.el b/emacs/test-flan-mode.el index 4727dacd..e7e2f887 100644 --- a/emacs/test-flan-mode.el +++ b/emacs/test-flan-mode.el @@ -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" diff --git a/lib/check.ml b/lib/check.ml index 1383ce91..a127a542 100644 --- a/lib/check.ml +++ b/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."); diff --git a/lib/dev.ml b/lib/dev.ml index 0ae23018..e123a58b 100644 --- a/lib/dev.ml +++ b/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 diff --git a/lib/emit.ml b/lib/emit.ml index f6af7bbc..c4d380e9 100644 --- a/lib/emit.ml +++ b/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) diff --git a/lib/js.ml b/lib/js.ml index ae5fe71d..c687f59b 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -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; diff --git a/lib/render.ml b/lib/render.ml index 1e3d3348..f1cb9667 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -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) diff --git a/lib/session.ml b/lib/session.ml index b54592e2..ed0d7860 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -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 = "") 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 diff --git a/lib/tast.ml b/lib/tast.ml index deec3a91..7f1aa9af 100644 --- a/lib/tast.ml +++ b/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 diff --git a/lib/x86.ml b/lib/x86.ml index 387b4bb4..c546b4e5 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -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); diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index fbedac8a..503e91b2 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -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); diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 101ce84c..9c67b115 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -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 diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index d200f6d4..eea4c87f 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -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 ──────────────────────────────────────────────── * diff --git a/test/programs/dev-watch.flan b/test/programs/dev-watch.flan index b92ec5dc..5c65e201 100644 --- a/test/programs/dev-watch.flan +++ b/test/programs/dev-watch.flan @@ -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 diff --git a/test/programs/watch-release.flan b/test/programs/watch-release.flan new file mode 100644 index 00000000..8814723a --- /dev/null +++ b/test/programs/watch-release.flan @@ -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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index e8ea4157..2e7b708b 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -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 diff --git a/test/test_dev.ml b/test/test_dev.ml index fe2e9d6d..28c6c6cc 100644 --- a/test/test_dev.ml +++ b/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. *) diff --git a/test/test_flan.ml b/test/test_flan.ml index 04f993e8..3c606aef 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5747,6 +5747,17 @@ let () = Printf.printf "FAIL %s\n wanted: %s (no printer for)\n got: %s (%s)\n" name ":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 diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index d760a961..50e5767f 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -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