From 9a914404861292f585edc34d03f80e8045e66c9a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:43:24 +0700 Subject: [PATCH] C-c C-s installs a defn that stops before each form of its body, and the break buffer steps it with s and runs the rest of the call with c --- TODO.org | 12 ++-- emacs/MANUAL.md | 9 +++ emacs/flan-cnr.el | 64 +++++++++++++++++-- emacs/flan-mode.el | 3 + emacs/flan.el | 23 ++++++- emacs/test-flan-cider.el | 54 ++++++++++++++++ lib/ast.ml | 65 ++++++++++++++++++++ lib/dev.ml | 13 +++- lib/prelude.ml | 12 ++++ lib/session.ml | 20 +++++- test/test_dev.ml | 130 +++++++++++++++++++++++++++++++++++++++ 11 files changed, 385 insertions(+), 20 deletions(-) diff --git a/TODO.org b/TODO.org index 80f35745..fda1a4c8 100644 --- a/TODO.org +++ b/TODO.org @@ -2029,14 +2029,10 @@ 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. -** NEXT There is no stepper -Decided 2026-09-25: stepping happens inside a stopped frame, so the game loop and its clock are frozen, as under =(pause)=. -=(pause)= stops and offers restarts, frames, locals and the inspector, but -nothing advances a form at a time. CIDER instruments a form and steps the -instrumented copy; the equivalent here is a dev-build-only instrumented -redefinition, which the cell indirection already makes deliverable. Open: -whether stepping suspends the frame loop, and what it does to a game's clock. - +** DONE There is no stepper +CLOSED: [2026-09-25] +C-c C-s instruments a defn with a step point before each body form; no step +into a callee, no argument positions, and no value shown after a form. ** DONE A NaN cast says "does not fit", which reads as too big CLOSED: [2026-09-25] Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity, diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 34130ffa..3192aa39 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -236,6 +236,12 @@ breakpoint is just a condition nobody handled. hit it as many times as you like; an ordinary `C-c C-c` over the same form (or `C-c C-k` over the buffer) takes it off. +**Stepping.** `C-c C-s` installs the `defn` at point so that a call stops +before each form of its body. Each stop is a break like `(pause)`, and the +source of the form about to run is shown beside it. `s` goes to the next form, +`c` runs the rest of the call, and the next call steps again. `C-c C-c` over the +same form installs it plain. + `C-u C-x C-e` does the same for the expression before point: it stops *at* the expression instead of printing its value. That one does not stick, because there is no definition for it to stick to. `C-u C-c C-c` on a top-level form that is @@ -375,6 +381,9 @@ Keys in that buffer: | `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 | +| `e` | evaluate an expression in the frame at point; it sees that frame's locals | +| `s` | at a step, go to the next form | +| `c` | take `continue`: at a step, run the rest of the call | | `a` | abort | | `g` | read the program again | | `q` | close the buffer | diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 1c444758..45b8923a 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -63,6 +63,7 @@ ;;; Code: (require 'seq) +(require 'pulse) (require 'subr-x) (require 'flan-mode) @@ -170,6 +171,15 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the first place that can tell the difference. Named here rather than spelled at its use, because it is a fact about the prelude.") +(defconst flan-cnr-step "StepPoint" + "The condition the stepper's `(step-point)' signals, before each form of a +defn sent with `C-c C-s'. A stop like `(pause)', with `next' and `continue' +restarts: `s' takes the first and `c' the second.") + +(defun flan-cnr--stepping-p (state) + "Whether STATE is a stop of the stepper." + (equal (plist-get state :condition) flan-cnr-step)) + (defun flan-cnr--headline-fields (fields) "The condition's own numbers, folded into the headline. FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the @@ -229,7 +239,7 @@ indexing or the division itself, so it sits directly under the headline." ;; only thing that can be wrong here is the word for it. Calling a ;; breakpoint unhandled would be a small lie told at the top of the ;; one buffer that exists to say what happened. - (paused (equal name flan-cnr-breakpoint)) + (paused (member name (list flan-cnr-breakpoint flan-cnr-step))) (numbers (flan-cnr--headline-fields (plist-get state :fields)))) (insert (propertize name 'face (if paused 'warning 'error))) (when numbers (insert " — " numbers)) @@ -240,9 +250,11 @@ indexing or the division itself, so it sits directly under the headline." (let ((sentence (plist-get state :sentence))) (when sentence (insert sentence "\n"))) (insert (propertize - (if paused - "stopped at (pause); nothing has been unwound\n" - "unhandled; stopped where it erred, nothing unwound\n") + (cond + ((flan-cnr--stepping-p state) + "stepping: stopped before the form below; s steps to the next, c runs the rest of the call\n") + (paused "stopped at (pause); nothing has been unwound\n") + (t "unhandled; stopped where it erred, nothing unwound\n")) 'face 'shadow)) (flan-cnr--insert-site state)) (insert "\n") @@ -439,7 +451,8 @@ breakpoint the program's author wrote, not a step of the program." (if (and (not flan-cnr--show-prelude) (flan-cnr--prelude-frame-p fr) (or (> i 0) - (equal (plist-get state :condition) flan-cnr-breakpoint))) + (equal (plist-get state :condition) flan-cnr-breakpoint) + (flan-cnr--stepping-p state))) (setq hidden (1+ hidden)) (when (> hidden 0) (flan-cnr--insert-hidden hidden) @@ -574,7 +587,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 RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame a abort g refresh q quit\n" + "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame s step c continue 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 @@ -861,6 +874,41 @@ local of, and CODE is read from the minibuffer." v) (user-error "flan: %s" (or (plist-get r :message) "refused"))))) +(defun flan-cnr--take-named (name) + "Take the innermost restart called NAME, or refuse by name." + (let ((i (seq-position (plist-get flan-cnr--state :restarts) name))) + (unless i (user-error "flan: there is no %s restart at this stop" name)) + (flan-cnr--invoke i name))) + +(defun flan-cnr-step () + "Step to the next form: take the stepper's `next' restart." + (interactive) + (flan-cnr--take-named "next")) + +(defun flan-cnr-continue () + "Take the innermost `continue' restart. +At a stepper's stop it runs the rest of the call; at a `(pause)' it resumes." + (interactive) + (flan-cnr--take-named "continue")) + +(defun flan-cnr--step-site (state) + "Where a stepper's STATE stopped: the first frame that is not the prelude's." + (seq-some (lambda (fr) + (and (not (flan-cnr--prelude-frame-p fr)) + (plist-get fr :loc))) + (plist-get state :stack))) + +(defun flan-cnr--show-step-site (state) + "At a stepper's stop, show the form about to run in its source, highlighted. +The break buffer keeps the selection; the source is shown beside it." + (let ((loc (and (flan-cnr--stepping-p state) (flan-cnr--step-site state)))) + (when loc + (ignore-errors + (save-selected-window + (with-current-buffer (flan-visit-loc loc "the step") + (pulse-momentary-highlight-region + (point) (save-excursion (ignore-errors (forward-sexp)) (point))))))))) + (defun flan-cnr-refresh () "Ask the program again what it is offering." (interactive) @@ -920,6 +968,9 @@ anyone who would rather TAB always moved." ;; SLIME's `e': evaluate in the frame at point. (define-key map "e" #'flan-cnr-eval-in-frame) (define-key map "a" #'flan-cnr-abort) + ;; The stepper's two, CIDER's `c' and SLIME's `s' (`n' moves). + (define-key map "s" #'flan-cnr-step) + (define-key map "c" #'flan-cnr-continue) (define-key map "g" #'flan-cnr-refresh) (define-key map "q" #'quit-window) ;; Numbered, as SBCL's are, and for SBCL's reason: the names are not @@ -1162,6 +1213,7 @@ walk from a running program." ;; the program running again: see `flan--forget-break-stack'. (setq next-error-last-buffer buf)) (pop-to-buffer buf) + (flan-cnr--show-step-site (buffer-local-value 'flan-cnr--state buf)) buf))) (provide 'flan-cnr) diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 8785eebc..3c5b9080 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -87,6 +87,7 @@ ;; wiring they need. (autoload 'flan-inspect "flan-inspect" nil t) (autoload 'flan-cnr-show "flan-cnr" nil t) +(autoload 'flan-step-defun "flan" nil t) (autoload 'flan-doc "flan" nil t) (autoload 'flan "flan" nil t) (autoload 'flan-quit "flan" nil t) @@ -448,6 +449,8 @@ For `syntax-propertize-function'." ;; reads as the client being broken rather than as the key being free. (define-key map (kbd "C-M-x") #'flan-eval-defun) (define-key map (kbd "C-c C-k") #'flan-eval-buffer) + ;; The stepper: the defn at point, installed to stop before each form. + (define-key map (kbd "C-c C-s") #'flan-step-defun) (define-key map (kbd "C-x C-e") #'flan-eval-last-sexp) (define-key map (kbd "C-c C-z") #'flan-connect) (define-key map (kbd "C-c C-q") #'flan-disconnect) diff --git a/emacs/flan.el b/emacs/flan.el index 55c4a446..50ddbcdf 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -2590,7 +2590,7 @@ signature, listed in %s" (user-error "flan: %s%s" (or msg "rejected") (if loc (format " (%s)" loc) ""))))) -(defun flan--eval (code what &optional start end pause) +(defun flan--eval (code what &optional start end pause step) "Send CODE to the running program. WHAT names it for the echo area. START and END, when given, are the region it came from, flashed on success. PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the @@ -2605,7 +2605,8 @@ breakpoint is marked from the editor, without editing the buffer\"." (append (list :op "eval" :code code :file (or buffer-file-name "")) (when pause - (list :pause (flan--wire-position (car pause)))))))) + (list :pause (flan--wire-position (car pause)))) + (when step (list :step t)))))) ;; END as the place a value could go. Every caller of this sends a ;; declaration and declarations have no value, so this is the path that ;; stays open rather than one anybody takes today. @@ -2632,6 +2633,10 @@ breakpoint is marked from the editor, without editing the buffer\"." (cond ((and pause (plist-get reply :pause)) (flan--show-pause (car pause) (cdr pause))) + ;; An instrumented defn is marked whole, as a pause mark is, and an + ;; ordinary C-c C-c of it takes the mark down with the instrumentation. + ((and step start end (plist-get reply :step)) + (flan--show-pause start end)) ((and start end) (flan-clear-pause start end))) reply)) @@ -2913,6 +2918,20 @@ declaration for it to live in." ;; `flan--report' signals on a rejection. (pulse-momentary-highlight-region (car b) end)))))) +;;;###autoload +(defun flan-step-defun () + "Install the defn at point so that a call stops before each form of its body. +A stepper, CIDER's `C-u C-M-x': each stop is a break like `(pause)', with the +program and its clock frozen, and the break buffer shows the form about to +run. There `s' steps to the next form and `c' runs the rest of the call; the +next call steps again. `C-c C-c' on the defn installs it plain." + (interactive) + (let* ((b (flan--defun-bounds)) + (head (and (< (car b) (cdr b)) + (flan--declaration-head-at (car b) flan--defun-heads)))) + (unless head (user-error "flan: no defn at point to step through")) + (flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t))) + ;;;###autoload (defun flan-eval-buffer () "Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER. diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 2e850c1a..31407150 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1507,6 +1507,60 @@ would be overwritten. Look again and re-do the edit") (test-flan--check "`e' is the break buffer's own key" (eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame)))) +;; The stepper's stop: said as a step, the prelude's own frame hidden, and +;; `s' and `c' take its `next' and `continue' by index. +(let* ((asked nil) + (flan-cnr-request-function + (lambda (form) (push form asked) '(:status "ok")))) + (with-current-buffer (test-flan--cnr + (list :condition "StepPoint" + :restarts '("next" "continue" "continue") + :stack (list (list :fn "step-point" :loc ":250:3") + (list :fn "step" :loc "/s.flan:1:19")))) + (let ((text (buffer-string))) + (test-flan--check "a step's headline says it is stepping" + (string-match-p "stepping: stopped before the form" text)) + (test-flan--check "and the prelude's step-point frame is hidden" + (not (string-match-p "step-point" text)))) + (test-flan--check "the step site is the stepped frame's location" + (equal (flan-cnr--step-site flan-cnr--state) "/s.flan:1:19")) + (save-window-excursion (flan-cnr-step)) + (test-flan--check "`s' takes next" + (and (equal (plist-get (car asked) :op) "restart-at") + (equal (plist-get (car asked) :name) "next") + (= 0 (plist-get (car asked) :index))))) + (with-current-buffer (test-flan--cnr + (list :condition "StepPoint" + :restarts '("next" "continue" "continue"))) + (save-window-excursion (flan-cnr-continue)) + (test-flan--check "`c' takes the innermost continue" + (and (equal (plist-get (car asked) :name) "continue") + (= 1 (plist-get (car asked) :index))))) + (test-flan--check "`s' and `c' are the break buffer's own keys" + (and (eq (lookup-key flan-cnr-mode-map "s") #'flan-cnr-step) + (eq (lookup-key flan-cnr-mode-map "c") #'flan-cnr-continue)))) + +;; C-c C-s sends the defn at point for stepping and marks it. +(let ((sent nil)) + (with-temp-buffer + (flan-mode) + (insert "(defn step [] i64\n (set ticks 1)\n ticks)\n") + (goto-char (point-min)) + (forward-line 1) + (cl-letf (((symbol-function 'flan--request) + (lambda (form) (setq sent form) + '(:status "ok" :fns ("step") :names ("step") :step t))) + ((symbol-function 'flan-refresh-defs) #'ignore)) + (flan-step-defun)) + (test-flan--check "C-c C-s sends the defn with :step" + (and (equal (plist-get sent :op) "eval") + (plist-get sent :step) + (string-prefix-p "(defn step" (plist-get sent :code)))) + (test-flan--check "and marks it as instrumented" + (flan--pause-overlays)) + (test-flan--check "C-c C-s is flan-mode's key for it" + (eq (lookup-key flan-mode-map (kbd "C-c C-s")) #'flan-step-defun)))) + ;; `flan-cnr-show' refuses a running program by name rather than opening an ;; empty buffer. ;; The layout without the values: what a `layout' op alone would buy. The diff --git a/lib/ast.ml b/lib/ast.ml index bc5f0d67..362537c6 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -481,6 +481,71 @@ let map_children f (e : expr) : expr = let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc } +(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a + call stops before each form of its body, at any depth of body: the forms of + a [do], a [let], a loop, a [match] arm and each branch of an [if]. Not + inside an argument, an [fn] or a handler clause, which are not forms a + person reads as steps, and the last two are functions of their own. [None] + when there is no [defn] to instrument. + + A step is [(step-point)] from the prelude — [error] of a [StepPoint] under a + [restart-case], so the break loop takes it as it takes [(pause)], with the + game loop and its clock frozen. It answers whether to go on stepping: its + [next] restart says yes and its [continue] says no, and the answer is kept + in a local of the call, [flan~step], so [continue] runs the rest of this + call and the next call steps again. [~] cannot occur in a source symbol, so + the local is visibly the compiler's and hidden from the locals listing. *) +let step_flag = "flan~step" + +let step_point loc = + let v = { e = Var step_flag; loc } in + { e = + If (v, + { e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc }); + loc }, + None); + loc } + +let rec step_body (es : expr list) : expr list = + List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es + +and step_expr (e : expr) : expr = + let branch (x : expr) = + match x.e with + | Do _ -> step_expr x + | _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc } + in + match e.e with + | Do es -> { e with e = Do (step_body es) } + | Let (bs, es) -> { e with e = Let (bs, step_body es) } + | If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) } + | While (l, c, es) -> { e with e = While (l, c, step_body es) } + | Loop (bs, es) -> { e with e = Loop (bs, step_body es) } + | Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) } + | Match (sc, arms) -> + { e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) } + | _ -> e + +let instrument_step (ds : decl list) : decl list option = + let hit = ref false in + let ds = + List.map + (fun (d : decl) -> + match d.d with + | Defn f -> + hit := true; + let on = + { bname = step_flag; bty = None; + bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc } + in + { d with + d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody); + loc = d.dloc } ] } } + | _ -> d) + ds + in + if !hit then Some ds else None + (* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever starts at that position, or [None] when nothing does. diff --git a/lib/dev.ml b/lib/dev.ml index 562333ed..ca4c1aae 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1022,7 +1022,7 @@ let errors_reply (ds : Loc.diag list) = String.sub e 0 (String.length e - 1) ^ " " ^ String.concat " " (errors_field ds) ^ ")" -let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = +let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause = let now = liveness t in let parked_now = now = Parked in (* A park that is over takes its note with it: the long sentence below is @@ -1046,7 +1046,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = if now = Gone then error gone else match - Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now) + Session.eval ~origin ?base ?forms ?pause ~step ~running:(not parked_now) t.session code with | c when not c.Session.installs -> @@ -1109,6 +1109,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = | Some (l, c) -> [ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ] | None -> []) + @ (if step then [ ":step t" ] else []) @ install_note t ~parked:parked_now @ unpolled_note t ~parked:parked_now @ extra) @@ -4399,7 +4400,13 @@ let handle t req = let origin = match Wire.string_field req "file" with Some f -> f | None -> "" in - eval t ~code ~origin ~pause:(Wire.pos_field req "pause") + (* [:step t] instruments every defn sent for the stepper. *) + let step = + match Wire.field req "step" with + | Some { Form.v = Form.Sym "nil"; _ } | None -> false + | Some _ -> true + in + eval t ~code ~origin ~pause:(Wire.pos_field req "pause") ~step | None -> error "eval needs :code") | Some "eval-expr" -> (match Wire.string_field req "code" with diff --git a/lib/prelude.ml b/lib/prelude.ml index 904da3c9..e097d34e 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -240,6 +240,18 @@ let source = {flan| (defn pause [] () (restart-case (error (Pause {})) (continue [] (do)))) +;; The stepper's stop, which C-c C-s puts before each form of a defn's body +;; (Ast.instrument_step). It is (pause) with an answer: next goes on stepping +;; and continue runs the rest of the call, and the instrumented body keeps +;; that answer in a local of its own. Like Pause it is not under Error. +;; Named so a program's own step or Step is not what the instrumented body +;; calls. +(defstruct StepPoint []) + +(defn step-point [] bool + (restart-case (error (StepPoint {})) + (next [] :report "stop at the next form" true) + (continue [] :report "run the rest of this call" false))) ;; A seeded PRNG in Flan rather than libc's, because a grid hash is only a ;; regression test if the sequence is byte-identical on native and wasm32 diff --git a/lib/session.ml b/lib/session.ml index 286c6e38..59b81b99 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -787,7 +787,7 @@ let rerun t = t.live <- SM.empty file an [(import ...)] in them is resolved against, the session's own when absent: a file loaded from another directory names its packages from there. *) -let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : change = +let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = true) t src : change = let forms = match forms with Some f -> f | None -> Reader.read_all ~file:origin src in @@ -877,6 +877,15 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan fail loc "nothing to pause at line %d, column %d of the form sent" line col) in + (* [step]: every defn sent stops before each form of its body — see + [Ast.instrument_step]. After [qualify_decl] for the reason [pause] is. *) + let incoming = + if not step then incoming + else + match Ast.instrument_step incoming with + | Some ds -> ds + | None -> fail loc "there is no defn in the form sent to step through" + in (* A method declares a name of its own — that is what makes evaluating one twice a replacement and evaluating a new one an append, through the same kept/added logic every other declaration goes through. But no function is @@ -1504,6 +1513,15 @@ let shown_names (fn : Tast.fn) : string option array = Array.init n (fun i -> if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None) in + (* A name the compiler gave a local of its own, such as the stepper's + [flan~step], is hidden like an unnamed slot: [~] cannot be typed. *) + let raw = + Array.map + (function + | Some n when String.starts_with ~prefix:"flan~" n -> None + | x -> x) + raw + in let stripped = Array.map (Option.map strip_rebind) raw in let count name = Array.fold_left diff --git a/test/test_dev.ml b/test/test_dev.ml index dfc4a1fb..b781671e 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8759,6 +8759,136 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; + (* ── The stepper ───────────────────────────────────────────────── + [dev-pause.flan] calls [step] every 5ms. Sent with [:step t], a call + stops before each form of its body: first the (set ...), then, after + [next], the [ticks] it answers. [continue] runs the rest of the call, + and the next call steps again. A plain evaluation takes it out. Under + both backends, each with its own daemon. *) + let stepper ~llvm = + let what = if llvm then "llvm " else "x86 " in + let ssock = tmp (what ^ "step.sock") and sout = tmp (what ^ "step.out") in + (try Sys.remove ssock with Sys_error _ -> ()); + let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let spid = + Unix.create_process flan + (Array.append + [| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock |] + (if llvm then [| "--llvm" |] else [||])) + Unix.stdin sfd Unix.stderr + in + Unix.close sfd; + if not (listening ~pid:spid ssock) then + fail "%sstepper daemon %s" what !listen_why + else begin + let c = connect ssock in + let ask = request c in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in + let col sub = + let n = String.length sub in + let rec find i = + if String.equal (String.sub body i n) sub then i + 1 else find (i + 1) + in + find 0 + in + (* Where the stepped frame is: the frame of [step], whose location is + the step point's, which is the form about to run. *) + let at () = + match Wire.field (ask "(:op \"backtrace\")") "frames" with + | Some { Form.v = Form.List l; _ } -> + List.find_map + (fun (f : Form.t) -> + match f.Form.v with + | Form.List ({ Form.v = Form.Str "step"; _ } + :: { Form.v = Form.Str loc; _ } :: _) -> Some loc + | _ -> None) + l + | _ -> None + in + let stops_at sub = + let want = Printf.sprintf ":1:%d" (col sub) in + await (fun () -> + stopped (ask "(:op \"describe\")") + && (match at () with Some l -> contains_sub l want | None -> false)) + in + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstrumenting for the stepper: %s" what + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + if Wire.field r "step" = None then + fail "%san instrumented defn did not echo :step" what; + if not (stops_at "(set ticks") then + fail "%sthe stepper did not stop before the first form (at %s)" what + (Option.value ~default:"" (at ())) + else begin + (match Wire.string_field (ask "(:op \"describe\")") "condition" with + | Some "StepPoint" -> () + | c -> fail "%sa step stopped on %s" what (Option.value ~default:"" c)); + (* The stepper's own local is not one of the frame's. *) + let fr = ask "(:op \"locals\" :frame 1)" in + (match Wire.string_field fr "frame" with + | Some "step" -> + (match Wire.field fr "locals" with + | Some { Form.v = Form.List []; _ } | None -> () + | _ -> fail "%sthe stepper's flag is listed as a local" what) + | f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"" f)); + let r = ask "(:op \"restart\" :name \"next\")" in + if status r <> "ok" then + fail "%snext at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + if not (stops_at "ticks)") then + fail "%snext did not stop before the second form (at %s)" what + (Option.value ~default:"" (at ())); + let r = ask "(:op \"restart\" :name \"continue\")" in + if status r <> "ok" then + fail "%scontinue at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + (* The next call, 5ms on, steps again from the top. *) + if not (stops_at "(set ticks") then + fail "%sthe next call did not step again" what; + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstalling the plain defn: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + ignore (ask "(:op \"restart\" :name \"continue\")"); + if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then + fail "%sthe program did not resume from the last step" what; + let deadline = Unix.gettimeofday () +. 0.5 in + let rec run_on () = + if Unix.gettimeofday () > deadline then () + else if stopped (ask "(:op \"describe\")") then + fail "%sthe plain defn still steps" what + else begin + ignore (Unix.select [] [] [] 0.01); + run_on () + end + in + run_on () + end + end; + (try Unix.close c with Unix.Unix_error _ -> ()) + end; + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()); + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ] + in + stepper ~llvm:false; + stepper ~llvm:true; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" ()