The break window evaluates in a frame and steps through a function, and C-c C-c reports every error in the form
# Conflicts: # test/test_dev.ml
This commit is contained in:
commit
fc6e2f7dfb
37
TODO.org
37
TODO.org
@ -1977,15 +1977,6 @@ maps bind =q=, and the diagnostics map binds =RET= and =q=, so those keys are
|
||||
the mode's own and behave the same under Evil. Every key a mode does not bind
|
||||
itself, including the rest of =special-mode-map=, stays Evil's.
|
||||
|
||||
** NEXT Eval in the frame, from the break loop
|
||||
Decided 2026-09-25: SLIME's eval-in-frame, as described.
|
||||
An expression is evaluated at a frame boundary, so it sees globals and not the
|
||||
stopped frame's locals — which are the values anyone stopped there wants. Wants
|
||||
SLIME's eval-in-frame: pick a frame, and the expression is checked and run with
|
||||
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.
|
||||
|
||||
** DONE The stack lists prelude frames
|
||||
CLOSED: [2026-09-25]
|
||||
A frame whose location is =<prelude>= is hidden by default, and a line in its
|
||||
@ -1994,14 +1985,15 @@ 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 C-c C-c reports one error, not every error in the form
|
||||
CLOSED: [2026-09-25]
|
||||
Every error at any depth: a refused subexpression stands as a Never that fits
|
||||
any want, and what it causes is left unsaid. Rules out stopping at a statement boundary.
|
||||
|
||||
** 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,
|
||||
@ -2024,23 +2016,10 @@ rebinds all at once. No other form had the gap: =let= was already sequential,
|
||||
=dotimes= binds one name, and =fn=, =defn=, =match= and the handler and restart
|
||||
clauses bind parameters with no initialisers.
|
||||
|
||||
** NEXT C-c C-c reports one error, not every error in the form
|
||||
Decided 2026-09-25: every error in the form, at any depth. A failed subexpression takes an error type that fits any want, so checking continues around it and the errors it would cause are not reported — Rust's, TypeScript's and Elm's shape. Rules out stopping at a statement boundary.
|
||||
Whole-file paths use =Check.program_all= and report every bad declaration. The
|
||||
daemon asks for the sink off (=lib/loc.ml:185=) and gets one exception, so a
|
||||
function with three bad expressions takes three round trips. The sink is
|
||||
per-phase; making it per-form would need a resync point inside a body.
|
||||
|
||||
** DONE A session should start before a program compiles
|
||||
CLOSED: [2026-09-25]
|
||||
A file with no =main= starts on a stub =main= that returns and parks; =load-file= (=C-c C-k=, already its key — the inspector stays on =C-c C-i=) keeps what compiles and lists the rest. Rules out =flan dev= with no file at all, and =--two-process= on a file with no =main=.
|
||||
|
||||
** NEXT The daemon buffer is navigable but not coloured
|
||||
Decided 2026-09-25: errors, warnings and notes take compilation-mode's faces, and the program's own output takes a face of its own so it reads apart from the compiler's.
|
||||
=*flan*= is all plain text. =compilation-minor-mode= is on (=emacs/flan.el:822=)
|
||||
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.
|
||||
|
||||
** DONE compilation-mode steps over the notes
|
||||
CLOSED: [2026-09-25]
|
||||
The daemon buffer and the diagnostics buffer set =compilation-skip-threshold= to
|
||||
|
||||
@ -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 |
|
||||
@ -1186,6 +1195,7 @@ Use `C-c C-g` if you need frames.
|
||||
| `C-u C-c C-c` | ...and stop at the form point is inside (`C-u C-u`: on entry) |
|
||||
| `C-M-x` | the same as `C-c C-c`, on the binding SLIME and CIDER use |
|
||||
| `C-c C-k` | load the whole buffer, as one module; what does not compile is listed |
|
||||
| `C-c C-s` | install the defn at point to stop before each form of its body |
|
||||
| `C-x C-e` | the form before point, evaluated — or installed, if it is a declaration |
|
||||
| `C-u C-x C-e` | ...and stop at it instead of showing its value |
|
||||
| `C-c C-z` | connect (finds `.flan-dev.sock` upward) |
|
||||
|
||||
@ -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 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
|
||||
@ -833,6 +846,69 @@ drawn from."
|
||||
(`(:expr ,expr) (flan-inspect expr))
|
||||
(_ (user-error "flan: this line carries no root the inspector knows")))))
|
||||
|
||||
(defun flan-cnr--frame-at-point ()
|
||||
"The index of the frame point is on, or on a local of, or nil."
|
||||
(or (get-text-property (point) 'flan-cnr-frame)
|
||||
(pcase (get-text-property (point) 'flan-cnr-inspect)
|
||||
(`(:slot ,frame . ,_) frame))))
|
||||
|
||||
(defun flan-cnr-eval-in-frame (frame code)
|
||||
"Evaluate CODE in stopped FRAME, SLIME's eval-in-frame, and show the value.
|
||||
CODE sees FRAME's locals as well as the globals, and a `set' of a local
|
||||
changes the frame. Interactively FRAME is the one point is on, or on a
|
||||
local of, and CODE is read from the minibuffer."
|
||||
(interactive
|
||||
(let ((frame (flan-cnr--frame-at-point)))
|
||||
(unless frame
|
||||
(user-error "flan: point is not on a frame — e evaluates in the frame point is on"))
|
||||
(list frame (read-string (format "Eval in frame %d: " frame)))))
|
||||
(let ((r (funcall flan-cnr-request-function
|
||||
(list :op "eval-expr" :frame frame :code code))))
|
||||
(if (equal (plist-get r :status) "ok")
|
||||
(let ((v (or (plist-get r :value) (plist-get r :note) "")))
|
||||
;; A set may have changed what an open frame shows, so each is
|
||||
;; asked again the next time it is opened.
|
||||
(dolist (fr (plist-get flan-cnr--state :stack))
|
||||
(when (consp fr) (plist-put fr :fetched nil)))
|
||||
(message "=> %s" v)
|
||||
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)
|
||||
@ -889,7 +965,12 @@ anyone who would rather TAB always moved."
|
||||
(define-key map "v" #'flan-cnr-visit)
|
||||
(define-key map "P" #'flan-cnr-toggle-prelude)
|
||||
(define-key map "i" #'flan-cnr-inspect)
|
||||
;; 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
|
||||
@ -1132,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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -412,6 +412,34 @@ nil keeps everything."
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-region (point-min) (line-beginning-position)))))))
|
||||
|
||||
(defface flan-output-face '((t :inherit font-lock-string-face))
|
||||
"Face for the running program's own output in the daemon's buffer.
|
||||
It sets that output apart from what the compiler and the daemon say, whose
|
||||
errors, warnings and notes take `compilation-mode''s faces."
|
||||
:group 'flan)
|
||||
|
||||
(defun flan--daemon-buffer-setup ()
|
||||
"Make the current buffer the daemon's log: navigable and coloured.
|
||||
The daemon writes a diagnostic as `file:line:col: message', the shape
|
||||
`compilation-minor-mode' already reads, so it only has to be switched on.
|
||||
The minor mode adds its font-lock rules but turns nothing on, and a process
|
||||
buffer is in `fundamental-mode', which global font-lock skips; so font-lock
|
||||
is switched on here, first, or the rules would never be drawn."
|
||||
(font-lock-mode 1)
|
||||
;; A log, not source: a quote the program printed opens no string.
|
||||
(setq-local font-lock-keywords-only t)
|
||||
;; Only the compiler's own shape, `file:line:col:', is a diagnostic here.
|
||||
;; compile.el's other rules are for a build log: one of them draws any
|
||||
;; line starting `word:' as a program name, which is every `score: 10'
|
||||
;; the program prints.
|
||||
(setq-local compilation-mode-font-lock-keywords nil)
|
||||
(setq-local compilation-error-regexp-alist
|
||||
'(("^\\([^ \t\n:][^\t\n:]*\\):\\([0-9]+\\):\\([0-9]+\\): \
|
||||
\\(?:\\(warning\\)\\|\\(note\\|info\\)\\)?"
|
||||
1 2 3 (4 . 5))))
|
||||
(compilation-minor-mode 1)
|
||||
(flan--navigable-notes))
|
||||
|
||||
(defun flan--append-output (text)
|
||||
"Append TEXT, the running program's own output, where it can be read.
|
||||
Two places. The daemon's log always gets it, so output lands somewhere
|
||||
@ -423,7 +451,13 @@ open, above its prompt, which is where whoever is typing there is looking."
|
||||
(inhibit-read-only t))
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(insert text))
|
||||
;; Marked as it is inserted, because nothing in the text says whose
|
||||
;; it is. A line the program prints in the diagnostic shape is
|
||||
;; still read as one by `compilation-minor-mode', and takes its
|
||||
;; face. `face' for a buffer with font-lock off, `font-lock-face'
|
||||
;; so fontification does not strip it.
|
||||
(insert (propertize text 'face 'flan-output-face
|
||||
'font-lock-face 'flan-output-face)))
|
||||
(flan--trim-lines)
|
||||
;; Follow the tail only for someone who was already at it; a reader
|
||||
;; scrolled back is reading something.
|
||||
@ -893,8 +927,7 @@ 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)
|
||||
(flan--navigable-notes))
|
||||
(flan--daemon-buffer-setup))
|
||||
(make-process
|
||||
:name "flan-daemon" :buffer buf
|
||||
:command args
|
||||
@ -2566,7 +2599,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
|
||||
@ -2582,11 +2615,20 @@ breakpoint is marked from the editor, without editing the buffer\"."
|
||||
(list :op "eval" :code code :file (or buffer-file-name "<buffer>")
|
||||
:syntax (flan--syntax))
|
||||
(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.
|
||||
(flan--report reply what end)
|
||||
;;
|
||||
;; A form with several errors is refused with all of them under
|
||||
;; `:errors'; `flan--report' marks and signals the first, and the rest
|
||||
;; are marked beside it before the signal leaves, as `C-c C-k' does.
|
||||
(condition-case err
|
||||
(flan--report reply what end)
|
||||
(user-error
|
||||
(flan--report-load-errors (cdr (plist-get reply :errors)) t)
|
||||
(signal (car err) (cdr err))))
|
||||
;; `flan--report' signals on a rejection, so reaching here means it
|
||||
;; landed. Flashing the text that was sent answers "which form did that
|
||||
;; take?" — the question the echo area cannot, because point may be nowhere
|
||||
@ -2601,6 +2643,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))
|
||||
|
||||
@ -2893,6 +2939,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.
|
||||
|
||||
@ -1477,6 +1477,114 @@ would be overwritten. Look again and re-do the edit")
|
||||
(test-flan--check "nothing is evaluated as an expression"
|
||||
(null (plist-get (car asked) :code))))))
|
||||
|
||||
;; `e' evaluates in the frame point is on, or on a local of: the request
|
||||
;; names that frame, and the value comes back to the echo area.
|
||||
(let* ((asked nil)
|
||||
(flan-cnr-request-function
|
||||
(lambda (form) (push form asked) '(:status "ok" :value "8"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry")
|
||||
:stack (list (list :fn "g" :fetched t
|
||||
:locals '(("b" "i64" "1" 4)))
|
||||
(list :fn "f" :fetched t
|
||||
:locals '(("n" "i64" "7" 0))))))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: > f")
|
||||
(flan-cnr-toggle-frame)
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: v f")
|
||||
(search-forward "i64 n")
|
||||
(let ((said (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ n 1)"))
|
||||
((symbol-function 'message)
|
||||
(lambda (fmt &rest args) (apply #'format fmt args))))
|
||||
(call-interactively #'flan-cnr-eval-in-frame))))
|
||||
(test-flan--check "`e' on a local evaluates in that local's frame"
|
||||
(and (equal (plist-get (car asked) :op) "eval-expr")
|
||||
(= 1 (plist-get (car asked) :frame))
|
||||
(equal (plist-get (car asked) :code) "(+ n 1)")))
|
||||
(test-flan--check "and answers the value"
|
||||
(equal said "8")))
|
||||
(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 "<prelude>: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))))
|
||||
|
||||
;; Every key flan-mode binds has a row in the manual's key reference.
|
||||
(let ((text (with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name "MANUAL.md"
|
||||
(file-name-directory (locate-library "flan-mode"))))
|
||||
(buffer-string)))
|
||||
(missing nil))
|
||||
(map-keymap
|
||||
(lambda (k d)
|
||||
(when (and (eq k ?\C-c) (keymapp d))
|
||||
(map-keymap
|
||||
(lambda (k2 d2)
|
||||
(when (commandp d2)
|
||||
(let ((desc (replace-regexp-in-string
|
||||
"RET" "C-m"
|
||||
(replace-regexp-in-string
|
||||
"TAB" "C-i" (key-description (vector k k2))))))
|
||||
(unless (string-match-p (regexp-quote (format "| `%s` |" desc)) text)
|
||||
(push desc missing)))))
|
||||
d)))
|
||||
flan-mode-map)
|
||||
(test-flan--check (format "every C-c key has a row in the manual (missing %s)" missing)
|
||||
(null missing)))
|
||||
|
||||
;; 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
|
||||
|
||||
@ -533,6 +533,43 @@ already rely on it — so nothing here is a stand-in for the real thing."
|
||||
;; The session is not poisoned by that: a good form still lands.
|
||||
(flan--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form")
|
||||
|
||||
;; The daemon's buffer is coloured: the compiler's errors, warnings and
|
||||
;; notes take compilation's faces and the program's own output takes
|
||||
;; `flan-output-face'. Checked on `font-lock-face', which is what
|
||||
;; fontification writes; batch Emacs cannot turn `font-lock-mode' on, so
|
||||
;; nothing here aliases it to `face'.
|
||||
(let ((flan-daemon-buffer " *flan-colour-test*"))
|
||||
(with-current-buffer (get-buffer-create flan-daemon-buffer)
|
||||
(insert "flan dev: built x.flan in 3ms\n"
|
||||
"/tmp/a.flan:2:8: expected i32, found string\n"
|
||||
"/tmp/a.flan:3:1: warning: w\n"
|
||||
"/tmp/a.flan:4:1: note: n\n")
|
||||
(flan--daemon-buffer-setup)
|
||||
(flan--append-output "said hi\nscore: 10\n")
|
||||
(font-lock-ensure)
|
||||
(let ((face-on (lambda (text)
|
||||
(goto-char (point-min))
|
||||
(search-forward text)
|
||||
(get-text-property (match-beginning 0) 'font-lock-face))))
|
||||
(test-flan--check
|
||||
"the daemon's buffer draws an error, a warning and a note in compilation's faces"
|
||||
(and (memq 'compilation-error (ensure-list (funcall face-on "a.flan:2")))
|
||||
(memq 'compilation-warning (ensure-list (funcall face-on "a.flan:3")))
|
||||
(memq 'compilation-info (ensure-list (funcall face-on "a.flan:4")))))
|
||||
(test-flan--check
|
||||
"the program's output takes its own face"
|
||||
(eq (funcall face-on "said") 'flan-output-face))
|
||||
(test-flan--check
|
||||
"a line of output shaped `word:' is not drawn as a program name"
|
||||
(progn (goto-char (point-min)) (search-forward "score")
|
||||
(and (null (get-text-property (match-beginning 0) 'face))
|
||||
(eq (get-text-property (match-beginning 0) 'font-lock-face)
|
||||
'flan-output-face))))
|
||||
(test-flan--check
|
||||
"the daemon's own line is left plain"
|
||||
(null (funcall face-on "flan dev:")))))
|
||||
(kill-buffer flan-daemon-buffer))
|
||||
|
||||
;; The program's own output arrives on replies and lands in the daemon's
|
||||
;; buffer — no REPL is open yet, and the log is the fallback that makes a
|
||||
;; println never depend on one.
|
||||
|
||||
65
lib/ast.ml
65
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.
|
||||
|
||||
|
||||
266
lib/check.ml
266
lib/check.ml
@ -211,6 +211,19 @@ type env = {
|
||||
the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan
|
||||
name a program calls. *)
|
||||
tracks : (string, Shim.track) Hashtbl.t;
|
||||
(* Recovery: checking goes on past a refused subexpression. See [check].
|
||||
[recovering] is on only while a whole-file or session check is collecting
|
||||
every error; [recovered] is what it found, newest first; [poison] counts
|
||||
failed subexpressions and reads of what they were bound to, which is how
|
||||
an error caused by an earlier one is told apart and left unsaid.
|
||||
[speculating] turns recovery off inside a trial, whose refusal is an
|
||||
answer the caller acts on; [guard_next] turns it off for the one next
|
||||
[check], whose own refusal a caller re-words. *)
|
||||
mutable recovering : bool;
|
||||
mutable recovered : Loc.diag list;
|
||||
mutable poison : int;
|
||||
mutable speculating : int;
|
||||
mutable guard_next : bool;
|
||||
}
|
||||
|
||||
let new_env () = {
|
||||
@ -243,6 +256,11 @@ let new_env () = {
|
||||
in_field = false;
|
||||
classes = Hashtbl.create 8;
|
||||
tracks = Hashtbl.create 16;
|
||||
recovering = false;
|
||||
recovered = [];
|
||||
poison = 0;
|
||||
speculating = 0;
|
||||
guard_next = false;
|
||||
}
|
||||
|
||||
(* Where a named type was declared, and what it has, as a note.
|
||||
@ -3527,6 +3545,63 @@ let hash_ty = Types.Int Types.U64
|
||||
Each caller calls it again rather than sharing one value: [slots] and
|
||||
[slot_tys] are counted up per frame, and two frames that shared a context
|
||||
would share a slot counter. *)
|
||||
(* What a refused subexpression stands as while recovering. [Zero] of [Never]
|
||||
is a value nothing else builds, so it is recognisable; see [check]. *)
|
||||
let poison loc = { Tast.e = Tast.Zero Types.Never; ty = Types.Never; loc }
|
||||
|
||||
(* A poison, or a read of a local one was bound to. *)
|
||||
let is_poison (r : Tast.expr) =
|
||||
Types.equal r.Tast.ty Types.Never
|
||||
&& (match r.Tast.e with Tast.Zero Types.Never | Tast.Local _ -> true | _ -> false)
|
||||
|
||||
let record_recovered env (d : Loc.diag) =
|
||||
let same (x : Loc.diag) = x.Loc.dloc = d.Loc.dloc && String.equal x.Loc.dmsg d.Loc.dmsg in
|
||||
if not (List.exists same env.recovered) then env.recovered <- d :: env.recovered
|
||||
|
||||
(* [f] with recovery off, for a check whose refusal is an answer: a trial, a
|
||||
probe, a fallback that re-checks. *)
|
||||
let speculate env f =
|
||||
env.speculating <- env.speculating + 1;
|
||||
Fun.protect ~finally:(fun () -> env.speculating <- env.speculating - 1) f
|
||||
|
||||
(* A refusal a caller has re-worded: recorded and stood in for while
|
||||
recovering, raised otherwise. The [check] it re-words was [guarded], so its
|
||||
own refusal came here rather than being recorded in its first wording. *)
|
||||
let refuse_or_poison env loc (d : Loc.diag) =
|
||||
if env.recovering && env.speculating = 0 then begin
|
||||
record_recovered env d;
|
||||
env.poison <- env.poison + 1;
|
||||
poison loc
|
||||
end
|
||||
else raise (Loc.Error d)
|
||||
|
||||
(* [f], a declaration's body, with recovery on when [on]. Everything it
|
||||
recorded is raised as [Loc.Errors] at the end, together with whatever
|
||||
refusal ended it, so nothing checked with a poison in it is ever returned. *)
|
||||
let with_recovery env ~on f =
|
||||
if not on then f ()
|
||||
else begin
|
||||
let saved = (env.recovering, env.recovered, env.poison) in
|
||||
let restore () =
|
||||
let r, d, p = saved in
|
||||
env.recovering <- r; env.recovered <- d; env.poison <- p
|
||||
in
|
||||
env.recovering <- true; env.recovered <- []; env.poison <- 0;
|
||||
match f () with
|
||||
| x ->
|
||||
let found = List.rev env.recovered in
|
||||
restore ();
|
||||
if found = [] then x else raise (Loc.Errors found)
|
||||
| exception Loc.Error d ->
|
||||
let found = List.rev env.recovered in
|
||||
restore ();
|
||||
(* Raised past the end of the body after something in it already
|
||||
failed: a return that does not fit, a value that is missing, both of
|
||||
them what the failure left behind. *)
|
||||
if found = [] then raise (Loc.Error d) else raise (Loc.Errors found)
|
||||
| exception e -> restore (); raise e
|
||||
end
|
||||
|
||||
let invented_ctx env ret =
|
||||
{ env; ret; slots = 0; slot_tys = []; slot_names = []; scope = [];
|
||||
defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false;
|
||||
@ -4152,7 +4227,67 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) =
|
||||
(* Every expression goes through here, and [check_value] is the one that
|
||||
knows the forms. What this adds is [refuse_owned_copy], asked of whatever
|
||||
came back unless the form was checked as the target of a place. *)
|
||||
(* Recovery, when [env.recovering] is on: a subexpression that is refused is
|
||||
recorded and stands as a [poison] of type [Never], which fits any want, so
|
||||
checking carries on around it and every error in a body is reported. What
|
||||
an earlier failure causes is not reported: an error raised by a node one of
|
||||
whose subexpressions failed, or with [Never] wanted, is dropped, as long as
|
||||
something has been recorded. That last condition keeps a poison from ever
|
||||
reaching a backend unreported — a scope with a poison in it always ends in
|
||||
a raise (see [with_recovery]). *)
|
||||
let rec check ctx ?want (e : Ast.expr) : Tast.expr =
|
||||
let env = ctx.env in
|
||||
let guarded = env.guard_next in
|
||||
env.guard_next <- false;
|
||||
if (not env.recovering) || env.speculating > 0 || guarded then
|
||||
check_plain ctx ?want e
|
||||
else begin
|
||||
let seen = env.poison in
|
||||
let caused () =
|
||||
env.recovered <> []
|
||||
&& (env.poison > seen || want = Some Types.Never)
|
||||
in
|
||||
match check_plain ctx ?want e with
|
||||
| r ->
|
||||
if is_poison r then env.poison <- env.poison + 1;
|
||||
r
|
||||
| exception Loc.Error d ->
|
||||
if not (caused ()) then begin
|
||||
record_recovered env d;
|
||||
(* A call refused as a whole — the wrong number of arguments, say —
|
||||
never checked its arguments, and a mistake inside one is still a
|
||||
mistake. They are checked on their own, with no expectation, so
|
||||
only what no expectation could change is kept: a name that is not
|
||||
there. *)
|
||||
match e.Ast.e with
|
||||
| Ast.Call (_, args) -> recheck_args ctx args
|
||||
| _ -> ()
|
||||
end;
|
||||
env.poison <- env.poison + 1;
|
||||
poison e.Ast.loc
|
||||
(* A checker arm that was never written for a [Never] operand may fail
|
||||
some other way over one. Only then, and only as a consequence. *)
|
||||
| exception (Not_found | Invalid_argument _ | Failure _ | Assert_failure _
|
||||
| Match_failure _) when caused () ->
|
||||
env.poison <- env.poison + 1;
|
||||
poison e.Ast.loc
|
||||
end
|
||||
|
||||
and recheck_args ctx (args : Ast.expr list) =
|
||||
let env = ctx.env in
|
||||
let before = env.recovered in
|
||||
List.iter (fun a -> ignore (check ctx a)) args;
|
||||
let rec fresh l = if l == before then [] else match l with [] -> [] | d :: r -> d :: fresh r in
|
||||
let kept =
|
||||
List.filter
|
||||
(fun (d : Loc.diag) ->
|
||||
String.starts_with ~prefix:"check/unknown-" d.Loc.kind
|
||||
|| String.equal d.Loc.kind "check/private")
|
||||
(fresh env.recovered)
|
||||
in
|
||||
env.recovered <- kept @ before
|
||||
|
||||
and check_plain ctx ?want (e : Ast.expr) : Tast.expr =
|
||||
let place = ctx.place_ok in
|
||||
ctx.place_ok <- false;
|
||||
let r = check_value ctx ?want e in
|
||||
@ -5566,6 +5701,9 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body =
|
||||
let want = Option.map (resolve ctx.env) b.Ast.bty in
|
||||
let v = check ctx ?want b.Ast.bval in
|
||||
(match v.Tast.ty with
|
||||
(* A refused initialiser, already reported: the name is bound to
|
||||
the poison so that what follows is still checked. *)
|
||||
| Types.Never when is_poison v -> ()
|
||||
| Types.Unit | Types.Never ->
|
||||
fail b.Ast.bloc "%s would be bound to %s, which is not a value"
|
||||
b.Ast.bname (Types.to_string v.Tast.ty)
|
||||
@ -5796,6 +5934,9 @@ and check_loop ctx ?want loc bs body =
|
||||
(fun (n, v) ->
|
||||
let v = check ctx v in
|
||||
(match v.Tast.ty with
|
||||
(* A refused initialiser, already reported: the name is bound to
|
||||
the poison so that what follows is still checked. *)
|
||||
| Types.Never when is_poison v -> ()
|
||||
| Types.Unit | Types.Never ->
|
||||
fail v.Tast.loc "%s would be bound to %s, which is not a value" n
|
||||
(Types.to_string v.Tast.ty)
|
||||
@ -5969,7 +6110,10 @@ and check_recur ctx ~tail loc args =
|
||||
accident. *)
|
||||
and check_truthy ctx c =
|
||||
let loc = c.Ast.loc in
|
||||
match check ctx c with
|
||||
(* Speculative, because a refusal here is answered by asking again at
|
||||
[bool]; and that second ask is guarded, because its refusal is re-worded
|
||||
below. Recovery sees each refusal once, in its final words. *)
|
||||
match speculate ctx.env (fun () -> check ctx c) with
|
||||
| c0 when c0.Tast.ty = Types.Dyn ->
|
||||
widen loc Types.Bool (rt loc (Types.Int Types.I32) "flan_dyn_truthy" [ c0 ])
|
||||
| c0 when Types.fits ~expected:Types.Bool ~actual:c0.Tast.ty -> c0
|
||||
@ -5995,10 +6139,11 @@ and check_truthy ctx c =
|
||||
Anything more complicated than a name gets the operator and no
|
||||
template: a reconstructed expression would be a guess at code the
|
||||
reader can see for themselves. *)
|
||||
(match check ctx ~want:Types.Bool c with
|
||||
(ctx.env.guard_next <- true;
|
||||
match check ctx ~want:Types.Bool c with
|
||||
| c1 -> c1
|
||||
| exception Loc.Error d when not (String.equal d.Loc.kind "check/type-mismatch") ->
|
||||
raise (Loc.Error d)
|
||||
refuse_or_poison ctx.env loc d
|
||||
| exception Loc.Error _ ->
|
||||
let how =
|
||||
let zero = match c0.Tast.ty with Types.Float _ -> "0.0" | _ -> "0" in
|
||||
@ -6010,9 +6155,11 @@ and check_truthy ctx c =
|
||||
| _, true -> Printf.sprintf " — test it against %s with !=" zero
|
||||
| _ -> ""
|
||||
in
|
||||
Loc.failk "check/condition-not-bool" loc
|
||||
"a condition is a bool or a dyn, and this is %s%s"
|
||||
(Types.to_string c0.Tast.ty) how)
|
||||
(try
|
||||
Loc.failk "check/condition-not-bool" loc
|
||||
"a condition is a bool or a dyn, and this is %s%s"
|
||||
(Types.to_string c0.Tast.ty) how
|
||||
with Loc.Error d -> refuse_or_poison ctx.env loc d))
|
||||
| exception Loc.Error _ -> check ctx ~want:Types.Bool c
|
||||
|
||||
and check_if ctx ?(tail = false) ?want loc c t e =
|
||||
@ -6080,15 +6227,23 @@ and check_if ctx ?(tail = false) ?want loc c t e =
|
||||
location; and with an expectation in hand both arms are checked against
|
||||
it rather than against each other, so nothing here runs. *)
|
||||
let e =
|
||||
match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with
|
||||
let reworded = want = None && and_sentinel e in
|
||||
match
|
||||
branch ctx (fun () ->
|
||||
in_tail (fun () ->
|
||||
if reworded then ctx.env.guard_next <- true;
|
||||
check ctx ?want:ewant e))
|
||||
with
|
||||
| v -> v
|
||||
| exception Loc.Error d
|
||||
when want = None && and_sentinel e
|
||||
&& String.equal d.Loc.kind "check/type-mismatch" ->
|
||||
Loc.failk "check/shortcircuit-operand" t.Tast.loc
|
||||
"an and answers false or its last operand, so the two have to be \
|
||||
one type — this operand is %s, and false is a bool"
|
||||
(Types.to_string t.Tast.ty)
|
||||
when reworded && String.equal d.Loc.kind "check/type-mismatch" ->
|
||||
(try
|
||||
Loc.failk "check/shortcircuit-operand" t.Tast.loc
|
||||
"an and answers false or its last operand, so the two have to be \
|
||||
one type — this operand is %s, and false is a bool"
|
||||
(Types.to_string t.Tast.ty)
|
||||
with Loc.Error d -> refuse_or_poison ctx.env e.Ast.loc d)
|
||||
| exception Loc.Error d when reworded -> refuse_or_poison ctx.env e.Ast.loc d
|
||||
in
|
||||
let t, e =
|
||||
match free_join, Types.const_join t.Tast.ty e.Tast.ty with
|
||||
@ -6190,16 +6345,19 @@ and positional_struct ctx ~want loc name args =
|
||||
let fields =
|
||||
map2_lr
|
||||
(fun (f : Tast.field) (a : Ast.expr) ->
|
||||
ctx.env.guard_next <- true;
|
||||
try check ctx ~want:f.Tast.fty a with
|
||||
| Loc.Error d when d.Loc.dloc = a.Ast.loc ->
|
||||
Loc.raise_diag
|
||||
{ d with
|
||||
Loc.notes =
|
||||
d.Loc.notes
|
||||
@ [ Loc.note a.Ast.loc
|
||||
(Printf.sprintf "this is %s's field .%s" name
|
||||
f.Tast.fname) ]
|
||||
@ note })
|
||||
refuse_or_poison ctx.env a.Ast.loc
|
||||
(Loc.sort_notes
|
||||
{ d with
|
||||
Loc.notes =
|
||||
d.Loc.notes
|
||||
@ [ Loc.note a.Ast.loc
|
||||
(Printf.sprintf "this is %s's field .%s" name
|
||||
f.Tast.fname) ]
|
||||
@ note })
|
||||
| Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d)
|
||||
fields args
|
||||
in
|
||||
expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields)))
|
||||
@ -6642,6 +6800,8 @@ and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a =
|
||||
that finds nothing. *)
|
||||
and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a =
|
||||
fun ctx items d ->
|
||||
(* Every check here only looks for a better sentence for [d]. *)
|
||||
speculate ctx.env @@ fun () ->
|
||||
match items with
|
||||
| [] -> raise (Loc.Error d)
|
||||
| first :: rest ->
|
||||
@ -6841,7 +7001,7 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) =
|
||||
dyn — a dyn becomes a %s where a %s is passed, returned or stored"
|
||||
tn tn tn
|
||||
| None ->
|
||||
(match check ctx ~want:ty v with
|
||||
(match speculate ctx.env (fun () -> check ctx ~want:ty v) with
|
||||
| _ ->
|
||||
fail v.Ast.loc
|
||||
"the checks a value as %s and does not convert one, and this is \
|
||||
@ -7367,6 +7527,7 @@ and ordinal n =
|
||||
points at the wrong form. The rekind is what stops a nested call from being
|
||||
named twice: once enriched, it is no longer the kind this looks for. *)
|
||||
and check_arg ctx name i (want : Types.t) (a : Ast.expr) =
|
||||
ctx.env.guard_next <- true;
|
||||
match check ctx ~want a with
|
||||
| e -> e
|
||||
| exception Loc.Error d
|
||||
@ -7382,9 +7543,10 @@ and check_arg ctx name i (want : Types.t) (a : Ast.expr) =
|
||||
name which p.Ast.fname (Types.to_string want)) ]
|
||||
| _ -> []
|
||||
in
|
||||
Loc.raise_diag
|
||||
refuse_or_poison ctx.env a.Ast.loc
|
||||
(Loc.diag ~kind:"check/argument-type" ~notes a.Ast.loc
|
||||
(Printf.sprintf "%s — this is the %s argument of %s" d.Loc.dmsg which name))
|
||||
| exception Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d
|
||||
|
||||
and fields_named env n : Tast.structure option =
|
||||
match Hashtbl.find_opt env.structs n with
|
||||
@ -10723,6 +10885,16 @@ and ordinary_call ctx ~want loc name args =
|
||||
lifted body captures it by value and then calls the copy. [peek_outer]
|
||||
rather than [capture] in the guard, because a guard must not take a copy
|
||||
on its way to deciding what a form means. *)
|
||||
(* A local bound to a refused initialiser's stand-in, called: the refusal
|
||||
is already reported, so the call stands in too, its arguments still
|
||||
checked. *)
|
||||
| _ when ctx.env.recovering
|
||||
&& (match lookup ctx name with
|
||||
| Some b -> Types.equal b.bty Types.Never
|
||||
| None -> false) ->
|
||||
List.iter (fun a -> ignore (check ctx a)) args;
|
||||
ctx.env.poison <- ctx.env.poison + 1;
|
||||
poison loc
|
||||
| _ when (match lookup ctx name with
|
||||
| Some b -> callable_ty b.bty
|
||||
| None ->
|
||||
@ -11454,7 +11626,9 @@ and instantiate env loc gname vars subst cparams cret =
|
||||
env.tvpreds <- saved_preds; env.chain <- saved_chain
|
||||
in
|
||||
let tfn =
|
||||
match !check_fn_ref env { fn with Ast.name = sym } with
|
||||
(* Without recovery: a copy that does not check is refused whole, at
|
||||
the call that asked for it, as it always was. *)
|
||||
match speculate env (fun () -> !check_fn_ref env { fn with Ast.name = sym }) with
|
||||
| tfn -> restore (); tfn
|
||||
| exception e ->
|
||||
restore ();
|
||||
@ -11577,7 +11751,7 @@ and trial ctx f =
|
||||
outer_what; caught; place_ok; envslot; parent = _;
|
||||
in_frames; loops; tail; in_defer;
|
||||
owner = _ } = ctx in
|
||||
match f () with
|
||||
match speculate ctx.env f with
|
||||
| r -> Ok r
|
||||
| exception Loc.Error d ->
|
||||
ctx.slots <- slots; ctx.slot_tys <- slot_tys;
|
||||
@ -12657,7 +12831,7 @@ let collect env (decls : Ast.decl list) =
|
||||
let left =
|
||||
List.filter
|
||||
(fun ((n, _) as c) ->
|
||||
match infer c with
|
||||
match speculate env (fun () -> infer c) with
|
||||
| ty -> Hashtbl.replace env.globals n (ty, true); false
|
||||
| exception Loc.Error _ -> true)
|
||||
!pending
|
||||
@ -13981,7 +14155,7 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
in
|
||||
(match f () with
|
||||
| x -> x
|
||||
| exception (Loc.Error d as e) ->
|
||||
| exception ((Loc.Error d | Loc.Errors (d :: _)) as e) ->
|
||||
if ok env name d then begin
|
||||
Hashtbl.filter_map_inplace
|
||||
(fun g r ->
|
||||
@ -14062,7 +14236,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
| Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name ->
|
||||
ignore
|
||||
(Loc.caught s (fun () ->
|
||||
tolerant fn.Ast.name (fun () -> Some (check_generic env fn))))
|
||||
tolerant fn.Ast.name (fun () ->
|
||||
with_recovery env ~on:keep_going (fun () ->
|
||||
Some (check_generic env fn)))))
|
||||
| _ -> ())
|
||||
decls;
|
||||
let globals =
|
||||
@ -14070,9 +14246,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
(fun (d : Ast.decl) ->
|
||||
Option.join
|
||||
(Loc.caught s (fun () ->
|
||||
let checked () =
|
||||
with_recovery env ~on:keep_going (fun () -> check_global env d)
|
||||
in
|
||||
match Ast.declared_name d with
|
||||
| Some n -> tolerant n (fun () -> check_global env d)
|
||||
| None -> check_global env d)))
|
||||
| Some n -> tolerant n checked
|
||||
| None -> checked ())))
|
||||
decls
|
||||
in
|
||||
let fns =
|
||||
@ -14085,7 +14264,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
| Ast.Defn fn ->
|
||||
Option.join
|
||||
(Loc.caught s (fun () ->
|
||||
tolerant fn.Ast.name (fun () -> Some (check_fn env fn))))
|
||||
tolerant fn.Ast.name (fun () ->
|
||||
with_recovery env ~on:keep_going (fun () ->
|
||||
Some (check_fn env fn)))))
|
||||
| _ -> None)
|
||||
decls
|
||||
in
|
||||
@ -14144,8 +14325,8 @@ let program_with_env (decls : Ast.decl list) : Tast.program * env =
|
||||
(** The same, with [tolerate] deciding which body failures leave a
|
||||
declaration out rather than refuse it — see [build_program]. The names
|
||||
left out come back beside the program; nothing else about it changes. *)
|
||||
let program_tolerant ~tolerate (decls : Ast.decl list) =
|
||||
build_program ~keep_going:false ~tolerate decls
|
||||
let program_tolerant ?(keep_going = false) ~tolerate (decls : Ast.decl list) =
|
||||
build_program ~keep_going ~tolerate decls
|
||||
|
||||
let program (decls : Ast.decl list) : Tast.program =
|
||||
let p, _, _ = build_program ~keep_going:false decls in
|
||||
@ -14263,6 +14444,25 @@ let expressions env (es : (Types.t option * Ast.expr) list) :
|
||||
(ts, Array.of_list (List.rev ctx.slot_tys),
|
||||
Array.of_list (List.rev ctx.slot_names))
|
||||
|
||||
(* One expression checked with [scope]'s names already bound, in order, so a
|
||||
later entry shadows an earlier one of the same name: evaluating in a stopped
|
||||
frame, whose locals the expression may name. Each is bound to a slot of the
|
||||
expression's own frame, and which slot is answered beside the name, so the
|
||||
caller can point every use of it at the stopped frame's storage instead
|
||||
([Tast.rewrite_locals]). *)
|
||||
let expression_in_scope env ~(scope : (string * Types.t * bool) list)
|
||||
(e : Ast.expr) :
|
||||
Tast.expr * Types.t array * string option array * (string * int) list =
|
||||
let ctx = invented_ctx env Types.Unit in
|
||||
let bound =
|
||||
List.map
|
||||
(fun (name, ty, assignable) -> (name, bind ctx name ty ~assignable))
|
||||
scope
|
||||
in
|
||||
let t = expect ctx e.Ast.loc ~want:None (check ctx e) in
|
||||
(t, Array.of_list (List.rev ctx.slot_tys),
|
||||
Array.of_list (List.rev ctx.slot_names), bound)
|
||||
|
||||
(* The one-expression case, which is every caller but the write verb. *)
|
||||
let expression env ?want (e : Ast.expr) :
|
||||
Tast.expr * Types.t array * string option array =
|
||||
|
||||
156
lib/dev.ml
156
lib/dev.ml
@ -1033,7 +1033,32 @@ let stale_field (ss : Session.stale list) =
|
||||
(if x.Session.running then " :running t" else ""))
|
||||
ss) ]
|
||||
|
||||
let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
(* Every refusal a check found, one plist each: beside what a load installed,
|
||||
or beside the first of them when a form sent had several. *)
|
||||
let errors_field (ds : Loc.diag list) =
|
||||
match ds with
|
||||
| [] -> []
|
||||
| ds ->
|
||||
[ ":errors "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (d : Loc.diag) ->
|
||||
Printf.sprintf "(:loc %s :message %s)"
|
||||
(Wire.quote (Loc.to_string d.Loc.dloc))
|
||||
(Wire.quote d.Loc.dmsg))
|
||||
ds) ]
|
||||
|
||||
(* A refusal with several diagnostics: the first where every refusal puts its
|
||||
message, all of them under [:errors]. *)
|
||||
let errors_reply (ds : Loc.diag list) =
|
||||
match ds with
|
||||
| [] -> error "nothing was refused"
|
||||
| d :: _ ->
|
||||
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
|
||||
String.sub e 0 (String.length e - 1)
|
||||
^ " " ^ String.concat " " (errors_field ds) ^ ")"
|
||||
|
||||
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
|
||||
@ -1075,7 +1100,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
else 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 ->
|
||||
@ -1138,6 +1163,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)
|
||||
@ -1156,20 +1182,9 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
||||
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
|
||||
Session.restore t.session before;
|
||||
error ~loc:(Loc.to_string l) msg
|
||||
|
||||
(* The refusals a load answered beside what it installed, one plist each. *)
|
||||
let errors_field (ds : Loc.diag list) =
|
||||
match ds with
|
||||
| [] -> []
|
||||
| ds ->
|
||||
[ ":errors "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (d : Loc.diag) ->
|
||||
Printf.sprintf "(:loc %s :message %s)"
|
||||
(Wire.quote (Loc.to_string d.Loc.dloc))
|
||||
(Wire.quote d.Loc.dmsg))
|
||||
ds) ]
|
||||
| exception Loc.Errors ds ->
|
||||
Session.restore t.session before;
|
||||
errors_reply ds
|
||||
|
||||
(* C-c C-k: a whole file into the running session, SBCL's [load]. [eval] with
|
||||
one difference — a form that does not compile is left out and listed
|
||||
@ -1197,16 +1212,9 @@ let load_file t ~code ~origin =
|
||||
(match Session.pruned check forms with
|
||||
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
|
||||
error ~loc:(Loc.to_string l) msg
|
||||
| exception Loc.Errors ({ Loc.dloc = l; dmsg = msg; _ } :: _ as ds) ->
|
||||
let e = error ~loc:(Loc.to_string l) msg in
|
||||
String.sub e 0 (String.length e - 1)
|
||||
^ " " ^ String.concat " " (errors_field ds) ^ ")"
|
||||
| exception Loc.Errors ds -> errors_reply ds
|
||||
| (), kept, errs ->
|
||||
if errs <> [] && kept = [] then
|
||||
let d = List.hd errs in
|
||||
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
|
||||
String.sub e 0 (String.length e - 1)
|
||||
^ " " ^ String.concat " " (errors_field errs) ^ ")"
|
||||
if errs <> [] && kept = [] then errors_reply errs
|
||||
else
|
||||
eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin
|
||||
~pause:None)
|
||||
@ -1247,7 +1255,7 @@ let load_file t ~code ~origin =
|
||||
state to spawn it beside; the price is that eval races the application and
|
||||
the race is documented as the programmer's problem. There is no race to
|
||||
document here, because there is nothing running to race. *)
|
||||
let eval_expr t ~code ~origin ~pause =
|
||||
let eval_expr_at t ~code ~origin ~pause ~at =
|
||||
match liveness t with
|
||||
| Gone -> error gone
|
||||
| Live | Parked ->
|
||||
@ -1263,7 +1271,7 @@ let eval_expr t ~code ~origin ~pause =
|
||||
let had =
|
||||
List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns
|
||||
in
|
||||
match Session.eval_expr ~origin ~pause t.session code with
|
||||
match Session.eval_expr ~origin ~pause ?frame:(Option.map snd at) t.session code with
|
||||
| c ->
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
(* This expression's number among those the agent has queued: an
|
||||
@ -1288,6 +1296,18 @@ let eval_expr t ~code ~origin ~pause =
|
||||
itself says whose it is — see [settled] below. *)
|
||||
let entered = state t in
|
||||
let entered_gen = stop_gen t in
|
||||
(* In a frame the thunk is addressed to one stop, and the agent drops it,
|
||||
and counts the drop, if that stop has ended by the time it is
|
||||
claimed. Read before the build, which is when that usually happens. *)
|
||||
let refused_before = if at = None then None else refusals t in
|
||||
let dropped () =
|
||||
match refused_before with
|
||||
| None -> None
|
||||
| Some (before, _) ->
|
||||
(match refusals t with
|
||||
| Some (now, why) when now > before -> Some why
|
||||
| _ -> None)
|
||||
in
|
||||
t.n <- t.n + 1;
|
||||
let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in
|
||||
(* A generic called at a new type makes a copy that is defined in this
|
||||
@ -1306,7 +1326,14 @@ let eval_expr t ~code ~origin ~pause =
|
||||
in
|
||||
(match build_module c ~debug:t.session.Session.debug ~out with
|
||||
| _ ->
|
||||
(match deliver t out with
|
||||
(match
|
||||
(* In a frame, only at the stop the frame was read at: the thunk
|
||||
reads that frame's slots by address, and after a resume they
|
||||
are somebody else's storage. *)
|
||||
match at with
|
||||
| Some (gen, _) -> deliver_at_stop t ~gen out
|
||||
| None -> deliver t out
|
||||
with
|
||||
| "ok" ->
|
||||
if copies <> [] then begin
|
||||
t.gen <- t.gen + 1;
|
||||
@ -1464,6 +1491,9 @@ let eval_expr t ~code ~origin ~pause =
|
||||
| Some answer ->
|
||||
(match value () with Some v -> `Value v | None -> answer)
|
||||
| None ->
|
||||
match dropped () with
|
||||
| Some why -> `Dropped why
|
||||
| None ->
|
||||
if ms <= 0 then `Timeout
|
||||
else begin
|
||||
ignore (Unix.select [] [] [] 0.005);
|
||||
@ -1528,6 +1558,7 @@ let eval_expr t ~code ~origin ~pause =
|
||||
left over, which is the shape it was always about: a program
|
||||
that is running, is not parked, and produced nothing in five
|
||||
seconds. *)
|
||||
| `Dropped why -> error why
|
||||
| `Timeout ->
|
||||
if liveness t = Parked then
|
||||
error
|
||||
@ -2468,6 +2499,40 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
|
||||
name name)
|
||||
else Ok (name, fn)))
|
||||
|
||||
(* [:frame N] on [eval-expr] is SLIME's eval-in-frame: the expression sees
|
||||
that stopped frame's locals — see [Session.in_frame]. The frame is checked
|
||||
the way [locals] and [inspect] check it, and the thunk is delivered at this
|
||||
stop only. *)
|
||||
let eval_expr ?frame ?at_stop t ~code ~origin ~pause =
|
||||
match frame with
|
||||
| None -> eval_expr_at t ~code ~origin ~pause ~at:None
|
||||
| Some index ->
|
||||
(match stopped_frame t ~frame:index ~what:"an expression in a frame" with
|
||||
| Error m -> error m
|
||||
| Ok (_, fn) ->
|
||||
(match stop_gen t with
|
||||
| None | Some 0 ->
|
||||
error
|
||||
"the program resumed while this was being asked; there is no frame \
|
||||
to evaluate in any more"
|
||||
| Some gen ->
|
||||
(* A frame with no slots has no locals to bind, and the program
|
||||
has no table to answer for it: the expression sees globals. *)
|
||||
let bound =
|
||||
if Array.length fn.Tast.slots = 0 then Ok []
|
||||
else bound_slots t ~frame:index
|
||||
in
|
||||
(* [at_stop] is the stop the editor drew the frame at. It is not
|
||||
checked here: the agent refuses a thunk addressed to a stop that
|
||||
is over, and says so. *)
|
||||
let gen = Option.value ~default:gen at_stop in
|
||||
(match bound with
|
||||
| Error m ->
|
||||
error ("the program refused to say which slots are bound: " ^ m)
|
||||
| Ok bound ->
|
||||
eval_expr_at t ~code ~origin ~pause
|
||||
~at:(Some (gen, (index, fn, bound))))))
|
||||
|
||||
(* [(:op "locals" :frame N)] — what a stopped frame's named locals hold.
|
||||
|
||||
The half of a break loop that the author actually wanted, and the reason
|
||||
@ -4490,7 +4555,13 @@ and handle_op t req =
|
||||
let origin =
|
||||
match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
|
||||
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
|
||||
@ -4508,7 +4579,8 @@ and handle_op t req =
|
||||
| Some { Form.v = Form.Sym "nil"; _ } | None -> false
|
||||
| Some _ -> true
|
||||
in
|
||||
eval_expr t ~code ~origin ~pause
|
||||
eval_expr ?frame:(Wire.int_field req "frame")
|
||||
?at_stop:(Wire.int_field req "at-stop") t ~code ~origin ~pause
|
||||
| None -> error "eval-expr needs :code")
|
||||
(* [:all], absent or [nil] being false and anything else true — the spelling
|
||||
[:pause], [:on] and [:reset] already use. One step is the default because
|
||||
@ -5299,19 +5371,21 @@ let need_main ~file (session : Session.t) =
|
||||
|
||||
(* The agent's C, in every program [flan dev] builds, whether or not the source
|
||||
imports the package: its constructor binds the socket before [main], so a
|
||||
file that never mentions the agent can still be reached from the editor. A
|
||||
program that imports it already has it, and is left alone — two copies
|
||||
would collide at the link. A release build is not built here and is not
|
||||
affected. *)
|
||||
file that never mentions the agent can still be reached from the editor.
|
||||
|
||||
Always this compiler's own copy, in place of any the program vendors. The
|
||||
agent is the daemon's other half — the stack it snapshots and the verbs it
|
||||
answers are what this file reads — and a program outside this repository
|
||||
carries whatever copy of vendor/agent it was given, however old. An old one
|
||||
builds and answers, and then puts every frame at its function's own line,
|
||||
because it predates the call-site record, so the stepper never moves. One
|
||||
copy and not two: two would collide at the link. A release build is not
|
||||
built here. *)
|
||||
let with_agent ~dir csrcs lflags =
|
||||
let c = Filename.concat dir "flan_agent.c" in
|
||||
write_file c Runtime_src.agent_source;
|
||||
let csrcs =
|
||||
if List.exists (fun c -> Filename.basename c = "flan_agent.c") csrcs then
|
||||
csrcs
|
||||
else begin
|
||||
let c = Filename.concat dir "flan_agent.c" in
|
||||
write_file c Runtime_src.agent_source;
|
||||
csrcs @ [ c ]
|
||||
end
|
||||
List.filter (fun x -> Filename.basename x <> "flan_agent.c") csrcs @ [ c ]
|
||||
in
|
||||
let lflags =
|
||||
lflags
|
||||
|
||||
@ -205,6 +205,7 @@ let caught s f =
|
||||
match f () with
|
||||
| x -> Some x
|
||||
| exception Error d -> s.found <- d :: s.found; None
|
||||
| exception Errors ds -> s.found <- List.rev_append ds s.found; None
|
||||
|
||||
(** Raise everything found, in the order it was found, or return if the pass
|
||||
was clean. *)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -805,7 +805,7 @@ let rehost t =
|
||||
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 = "<eval>") ?base ?forms ?pause ?(running = true) t src : change =
|
||||
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = true) t src : change =
|
||||
let forms =
|
||||
match forms with Some f -> f | None -> Source.read_code ~file:origin src
|
||||
in
|
||||
@ -895,6 +895,15 @@ let eval ?(origin = "<eval>") ?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
|
||||
@ -986,8 +995,13 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
|
||||
&& List.exists stale_site b.sites)
|
||||
t.built
|
||||
in
|
||||
(* Every error in the form sent, not the first: [keep_going] checks past a
|
||||
refused subexpression (see [Check.check]). One error is still raised as
|
||||
[Loc.Error], which is what every caller of one form expects. *)
|
||||
let program, env, tolerated =
|
||||
Check.program_tolerant ~tolerate:stale_owner decls
|
||||
match Check.program_tolerant ~keep_going:true ~tolerate:stale_owner decls with
|
||||
| r -> r
|
||||
| exception Loc.Errors [ d ] -> raise (Loc.Error d)
|
||||
in
|
||||
let program =
|
||||
if tolerated = [] then program
|
||||
@ -1517,6 +1531,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
|
||||
@ -2525,7 +2548,68 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
|
||||
sticks — a thunk is built and thrown away, so the mark lasts exactly one
|
||||
evaluation, which is the truthful thing for an expression that has no
|
||||
declaration to live in. *)
|
||||
let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
|
||||
(* [frame] is SLIME's eval-in-frame: a stopped frame's index, the function it
|
||||
is running and which of its slots were bound when it stopped. The
|
||||
expression is then checked with that frame's named locals in scope — the
|
||||
innermost of two of one name winning, as it does in the source — and every
|
||||
use of one reads or writes the frame's own storage through [flan/dev-slot],
|
||||
so a [set] changes the frame and a vec is not copied. A local not bound
|
||||
yet is refused where it is named: its address is null. *)
|
||||
let in_frame t ~frame:(index, (fn : Tast.fn), bound) (parsed : Ast.expr) =
|
||||
let n = Array.length fn.Tast.slots in
|
||||
let nparams = List.length fn.Tast.params in
|
||||
let named =
|
||||
List.filter_map
|
||||
(fun i ->
|
||||
match if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None with
|
||||
| Some raw -> Some (i, strip_rebind raw)
|
||||
| None -> None)
|
||||
(List.init n Fun.id)
|
||||
in
|
||||
(* Unbound first, so that of two slots one name the bound one shadows. *)
|
||||
let order =
|
||||
List.filter (fun (i, _) -> not (List.mem i bound)) named
|
||||
@ List.filter (fun (i, _) -> List.mem i bound) named
|
||||
in
|
||||
let scope =
|
||||
List.map (fun (i, name) -> (name, fn.Tast.slots.(i), i >= nparams)) order
|
||||
in
|
||||
let checked, base, bnames, syn = Check.expression_in_scope t.env ~scope parsed in
|
||||
let table = List.map2 (fun (i, name) (_, j) -> (j, (i, name))) order syn in
|
||||
let idx loc k =
|
||||
{ Tast.e = Tast.Int (Int64.of_int k, Types.I64); ty = Types.Int Types.I64; loc }
|
||||
in
|
||||
let pointer i loc =
|
||||
let ty = fn.Tast.slots.(i) in
|
||||
{ Tast.e =
|
||||
Tast.Prim
|
||||
(Tast.Cast (Types.Ptr (Types.Mut, ty)),
|
||||
[ { Tast.e = Tast.Call ("flan/dev-slot", [ idx loc index; idx loc i ]);
|
||||
ty = Types.Ptr (Types.Mut, Types.Int Types.U8); loc } ]);
|
||||
ty = Types.Ptr (Types.Mut, ty); loc }
|
||||
in
|
||||
let checked =
|
||||
Tast.rewrite_locals
|
||||
(fun j loc ->
|
||||
match List.assoc_opt j table with
|
||||
| None -> None
|
||||
| Some (i, name) when not (List.mem i bound) ->
|
||||
fail loc
|
||||
"%s is not bound yet where the program stopped, so there is no \
|
||||
value to read" name
|
||||
| Some (i, _) -> Some (pointer i loc))
|
||||
checked
|
||||
in
|
||||
(* The slots the frame's names were bound to are read through the pointer
|
||||
now, never directly; a byte keeps each from costing its type's size. *)
|
||||
let base =
|
||||
Array.mapi (fun j ty -> if List.mem_assoc j table then Types.Int Types.U8 else ty) base
|
||||
and bnames =
|
||||
Array.mapi (fun j nm -> if List.mem_assoc j table then None else nm) bnames
|
||||
in
|
||||
(checked, base, bnames)
|
||||
|
||||
let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
|
||||
let form =
|
||||
match Source.read_code ~expr:true ~file:origin src with
|
||||
| [ f ] -> f
|
||||
@ -2574,7 +2658,11 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
|
||||
and the host has no cell for. *)
|
||||
let mark = Check.instance_mark t.env in
|
||||
let lmark = Check.lifted_mark t.env in
|
||||
let checked, base, bnames = Check.expression t.env parsed in
|
||||
let checked, base, bnames =
|
||||
match frame with
|
||||
| None -> Check.expression t.env parsed
|
||||
| Some frame -> in_frame t ~frame parsed
|
||||
in
|
||||
let fresh = Check.instances_since t.env mark in
|
||||
let lifted = Check.lifted_since t.env lmark in
|
||||
(* The thunk's frame starts at whatever [Check.expression] needed and grows
|
||||
|
||||
59
lib/tast.ml
59
lib/tast.ml
@ -506,6 +506,65 @@ and walk_place f (p : place) =
|
||||
| Pfield (t, _) | Pderef t -> walk f t
|
||||
| Pindex (t, idx) -> walk f t; List.iter (walk f) idx
|
||||
|
||||
(* [e] with every read, store and address of a local slot [f] answers for
|
||||
replaced: a read of slot [i] by [Deref p], its place by [Pderef p], where
|
||||
[f i loc] is [Some p], a pointer to where the value really lives. The one
|
||||
caller is evaluating in a stopped frame, whose locals are the other frame's
|
||||
slots reached by address. Slots [f] answers [None] for are left alone, and
|
||||
so is every binder: only the slots [f] names are replaced, and none of them
|
||||
is bound inside [e]. *)
|
||||
let rec rewrite_locals (f : int -> Loc.t -> expr option) (e : expr) : expr =
|
||||
let go = rewrite_locals f in
|
||||
let gos = List.map go in
|
||||
let kind =
|
||||
match e.e with
|
||||
| Local i ->
|
||||
(match f i e.loc with Some p -> Deref p | None -> e.e)
|
||||
| Int _ | Float _ | Bool _ | Str _ | Unit | Zero _ | Uninit _ | Global _
|
||||
| None_ | FnAddr _ | Break _ | Continue _ -> e.e
|
||||
| Fill (t, b) -> Fill (t, go b)
|
||||
| DeadBeef (t, b) -> DeadBeef (t, go b)
|
||||
| Prim (p, es) -> Prim (p, gos es)
|
||||
| Call (n, es) -> Call (n, gos es)
|
||||
| Do es -> Do (gos es)
|
||||
| Make (n, es) -> Make (n, gos es)
|
||||
| MakeCase (d, c, es) -> MakeCase (d, c, gos es)
|
||||
| Arr es -> Arr (gos es)
|
||||
| InvokeRestart (a, b, es, c, d, l) -> InvokeRestart (a, b, gos es, c, d, l)
|
||||
| CallPtr (c, es) -> CallPtr (go c, gos es)
|
||||
| Let (bs, body) -> Let (List.map (fun (s, v) -> (s, go v)) bs, gos body)
|
||||
| If (a, b, c) -> If (go a, go b, go c)
|
||||
| While (c, body, latch) -> While (go c, gos body, gos latch)
|
||||
| Return v -> Return (Option.map go v)
|
||||
| Set (p, v) -> Set (rewrite_place f e.loc p, go v)
|
||||
| Addr p -> Addr (rewrite_place f e.loc p)
|
||||
| Field (t, i) -> Field (go t, i)
|
||||
| Deref t -> Deref (go t)
|
||||
| CaseField (t, c, i) -> CaseField (go t, c, i)
|
||||
| Some_ t -> Some_ (go t)
|
||||
| UnwrapSome t -> UnwrapSome (go t)
|
||||
| Signal (k, d, t) -> Signal (k, d, go t)
|
||||
| Closure (r, t) -> Closure (r, go t)
|
||||
| Thicken (n, t) -> Thicken (n, go t)
|
||||
| Match (sc, arms) ->
|
||||
Match (go sc, List.map (fun a -> { a with abody = gos a.abody }) arms)
|
||||
| Handled (hs, body) ->
|
||||
Handled
|
||||
(List.map (fun h -> { h with henv = Option.map go h.henv }) hs, gos body)
|
||||
| RestartCase (cs, body) ->
|
||||
RestartCase (List.map (fun c -> { c with rbody = gos c.rbody }) cs, go body)
|
||||
| WithAlloc (a, body) -> WithAlloc (go a, gos body)
|
||||
in
|
||||
{ e with e = kind }
|
||||
|
||||
and rewrite_place f loc (p : place) : place =
|
||||
match p with
|
||||
| Plocal i -> (match f i loc with Some ptr -> Pderef ptr | None -> p)
|
||||
| Pglobal _ -> p
|
||||
| Pfield (t, i) -> Pfield (rewrite_locals f t, i)
|
||||
| Pderef t -> Pderef (rewrite_locals f t)
|
||||
| Pindex (t, idx) -> Pindex (rewrite_locals f t, List.map (rewrite_locals f) idx)
|
||||
|
||||
(* ── What the object image can hold ─────────────────────────────────── *)
|
||||
|
||||
(* Whether an initialiser is a value a linker can write into the program's
|
||||
|
||||
187
test/test_dev.ml
187
test/test_dev.ml
@ -127,6 +127,166 @@ let status r =
|
||||
|
||||
let contains_sub = Test_support.contains
|
||||
|
||||
(* The stepper, against a running program whose [step] is dev-pause.flan's
|
||||
and dev-repl.flan's: sent with [:step t], a call stops before each form of
|
||||
its body — the (set ...), then after [next] the [ticks] it answers.
|
||||
[continue] runs the rest of the call and the next call steps again, and a
|
||||
plain evaluation takes it out. Run in a daemon of each backend that another
|
||||
block already started, so it costs no build of its own. *)
|
||||
let stepper_checks ~what ask =
|
||||
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:"<none>" (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:"<none>" 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:"<none>" 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:"<none>" (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
|
||||
|
||||
(* Eval-in-frame against dev-locals.flan's [look], stopped at its (error ...):
|
||||
the expression sees that frame's locals, the inner of two [label]s wins, a
|
||||
[set] writes the frame's own storage, and a local not bound yet is refused
|
||||
by name. [ask] sends one request. Run under each backend. *)
|
||||
let eval_in_frame_checks ~backend ask =
|
||||
let value code =
|
||||
let r =
|
||||
ask (Printf.sprintf "(:op \"eval-expr\" :frame 0 :code %S)" code)
|
||||
in
|
||||
if status r = "ok" then Ok (Option.value ~default:"" (Wire.string_field r "value"))
|
||||
else Error (Option.value ~default:(status r) (Wire.string_field r "message"))
|
||||
in
|
||||
let expect code want =
|
||||
match value code with
|
||||
| Ok v when v = want -> ()
|
||||
| Ok v -> fail "%s eval-in-frame %s answered %S, wanted %S" backend code v want
|
||||
| Error m -> fail "%s eval-in-frame %s: %s" backend code m
|
||||
in
|
||||
expect "(+ n 1)" "4";
|
||||
expect "(.y p)" "2.5";
|
||||
expect "label" "\"inner\"";
|
||||
expect "(do (set flag false) flag)" "false";
|
||||
(match
|
||||
Wire.field (ask "(:op \"locals\" :frame 0)") "locals"
|
||||
with
|
||||
| Some { Form.v = Form.List rows; _ } ->
|
||||
if not
|
||||
(List.exists
|
||||
(fun (e : Form.t) ->
|
||||
match e.Form.v with
|
||||
| Form.List ({ Form.v = Form.Str "flag"; _ } :: _
|
||||
:: { Form.v = Form.Str "false"; _ } :: _) -> true
|
||||
| _ -> false)
|
||||
rows)
|
||||
then fail "%s eval-in-frame: a set did not reach the frame" backend
|
||||
| _ -> fail "%s eval-in-frame: no locals after the set" backend);
|
||||
expect "(do (set flag true) flag)" "true";
|
||||
(match value "(+ after 1)" with
|
||||
| Error m when contains_sub m "after is not bound yet" -> ()
|
||||
| Error m -> fail "%s eval-in-frame of an unbound local said %s" backend m
|
||||
| Ok v -> fail "%s eval-in-frame read an unbound local as %s" backend v);
|
||||
(match value "(+ n \"x\")" with
|
||||
| Error _ -> ()
|
||||
| Ok v -> fail "%s eval-in-frame accepted a type error: %s" backend v);
|
||||
(* Addressed to a stop that is over: the agent drops it, and the reply says
|
||||
why at once rather than timing out. *)
|
||||
let t0 = Unix.gettimeofday () in
|
||||
let r = ask "(:op \"eval-expr\" :frame 0 :at-stop 999999 :code \"n\")" in
|
||||
let m = Option.value ~default:"" (Wire.string_field r "message") in
|
||||
if status r = "ok" then fail "%s eval-in-frame ran at a stop that is over" backend
|
||||
else if not (contains_sub m "resumed" || contains_sub m "stopped again") then
|
||||
fail "%s eval-in-frame at a stop that is over said %s" backend m
|
||||
else if Unix.gettimeofday () -. t0 > 4.0 then
|
||||
fail "%s eval-in-frame at a stop that is over waited out the clock" backend
|
||||
|
||||
(* ── The one verb whose reply races the process it ends ─────────────── *)
|
||||
|
||||
(* [abort] is answered twice over, and the two answers are not ordered. On the
|
||||
@ -194,7 +354,21 @@ let () =
|
||||
explain and is quoted as it stands. *)
|
||||
let other = Dev.refusal ~parked:true "err flan.abi.x86: the module is x86" in
|
||||
if not (contains_sub other "flan.abi.x86") then
|
||||
fail "a parked program's other refusals were rewritten too: %S" other
|
||||
fail "a parked program's other refusals were rewritten too: %S" other;
|
||||
(* The agent is always this compiler's, never the copy a program vendors:
|
||||
an old copy answers every frame at its function's own line. *)
|
||||
let dir = tmp "agent-dir" in
|
||||
(try Unix.mkdir dir 0o700 with Unix.Unix_error _ -> ());
|
||||
let csrcs, _ =
|
||||
Dev.with_agent ~dir [ "/far/vendor/agent/flan_agent.c"; "/far/x.c" ] []
|
||||
in
|
||||
let own = Filename.concat dir "flan_agent.c" in
|
||||
if csrcs <> [ "/far/x.c"; own ] then
|
||||
fail "a vendored agent was linked in place of the compiler's: %s"
|
||||
(String.concat " " csrcs)
|
||||
else if In_channel.with_open_bin own In_channel.input_all
|
||||
<> Runtime_src.agent_source then
|
||||
fail "the agent linked is not the compiler's own"
|
||||
|
||||
(* A daemon's death is reported by the signal's name. [WSIGNALED] carries
|
||||
OCaml's own numbering, in which SIGTERM is -11, and a SIGTERM printed as
|
||||
@ -2324,6 +2498,7 @@ let () =
|
||||
(String.concat ", "
|
||||
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused")))
|
||||
end;
|
||||
eval_in_frame_checks ~backend:"llvm" ask;
|
||||
(* A frame whose every slot the compiler invented is not an error and
|
||||
is not an empty answer either: it says which it is. *)
|
||||
let r = ask "(:op \"locals\" :frame 1)" in
|
||||
@ -4372,6 +4547,7 @@ let () =
|
||||
end
|
||||
else begin
|
||||
let c = connect sigsock in
|
||||
stepper_checks ~what:"llvm " (request c);
|
||||
let stopped r =
|
||||
match Wire.field r "stopped" with
|
||||
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||
@ -4836,6 +5012,13 @@ let () =
|
||||
if not (List.exists (String.equal "continue") names) then
|
||||
fail "a break at (pause) offers %s, wanted continue among them"
|
||||
(String.concat ", " names);
|
||||
(* [step] has no slots at all, so there is nothing to bind and no
|
||||
table for the program to answer from: an expression evaluated
|
||||
in its frame sees the globals. Frame 0 is [pause]'s own. *)
|
||||
(let r = ask "(:op \"eval-expr\" :frame 1 :code \"(+ ticks 0)\")" in
|
||||
if status r <> "ok" then
|
||||
fail "eval-in-frame of a frame with no slots: %s"
|
||||
(Option.value ~default:(status r) (Wire.string_field r "message")));
|
||||
|
||||
(* The second claim, and the one this block exists for. A plain
|
||||
re-evaluation of the same form replaces the stored declaration
|
||||
@ -4881,6 +5064,7 @@ let () =
|
||||
end
|
||||
end
|
||||
end;
|
||||
stepper_checks ~what:"x86 " ask;
|
||||
|
||||
(* The other way a thunk reaches a [(pause)], and the one no flag asks
|
||||
for: an ordinary [C-x C-e] over an expression that calls a body
|
||||
@ -6285,6 +6469,7 @@ let () =
|
||||
(String.concat ", "
|
||||
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused")))
|
||||
end;
|
||||
eval_in_frame_checks ~backend:"x86" (request c);
|
||||
(* One slot by index, which is the inspector's own root rather than
|
||||
[locals]' listing, and an aggregate for it: an x86 frame passes every
|
||||
aggregate by pointer, so a struct is where a recorded address could
|
||||
|
||||
@ -1772,4 +1772,60 @@ let () =
|
||||
| _ -> fail "a package's bare name resolved from the program's own file"
|
||||
| exception Loc.Error _ -> ());
|
||||
|
||||
(* ── Every error in the form sent ───────────────────────────────────
|
||||
A refused subexpression stands as a value that fits anywhere, so the
|
||||
check goes on past it: three bad expressions are three errors, one three
|
||||
levels down is still found, and what a failure causes is not reported. *)
|
||||
(let errors src =
|
||||
let t, _ = Session.create ~file:"programs/reload.flan" () in
|
||||
match Session.eval t src with
|
||||
| _ -> fail "a form with errors was accepted: %s" src; []
|
||||
| exception Loc.Error d -> [ d ]
|
||||
| exception Loc.Errors ds -> ds
|
||||
in
|
||||
let msgs ds = String.concat " | " (List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds) in
|
||||
let three =
|
||||
errors
|
||||
"(defn three [] i64 (println (+ 1 \"a\")) (println (nope 2)) (+ 3 \"c\"))"
|
||||
in
|
||||
if List.length three <> 3 then
|
||||
fail "three bad expressions gave %d errors: %s" (List.length three) (msgs three);
|
||||
let deep =
|
||||
errors
|
||||
"(defn deep [] i64 (+ 1 \"a\") (if true (let [x (do (println (nope 2)) 1)] x) 0))"
|
||||
in
|
||||
if List.length deep <> 2 || not (has (msgs deep) "nope") then
|
||||
fail "an error three levels down was not reported: %s" (msgs deep);
|
||||
(* The failed call poisons the let's [x]; the field read of it and the sum
|
||||
it flows into are consequences, and are not said. *)
|
||||
let caused =
|
||||
errors "(defn caused [] i64 (let [x (nope 1)] (+ (.foo x) (+ x 1))))"
|
||||
in
|
||||
if List.length caused <> 1 || not (has (msgs caused) "nope") then
|
||||
fail "a failure's consequences were reported: %s" (msgs caused);
|
||||
(* A local bound to a refused initialiser and then called is the same
|
||||
consequence: no "unknown function p". *)
|
||||
let called = errors "(defn called [] i64 (let [p (nope 1)] (p 3)))" in
|
||||
if List.length called <> 1 then
|
||||
fail "calling a local bound to a failure was reported: %s" (msgs called);
|
||||
(* A call refused for its argument count still has its arguments checked. *)
|
||||
let arity =
|
||||
errors "(defn arity [] i64 (bump (nope2) 7 8))"
|
||||
in
|
||||
if List.length arity <> 2 || not (has (msgs arity) "nope2") then
|
||||
fail "an error inside a miscounted call was not reported: %s" (msgs arity);
|
||||
(* And the whole-file path: fn-no-type.flan has one mistake, reported once. *)
|
||||
(match Front.checked ~all:true "programs/fn-no-type.flan" with
|
||||
| _ -> fail "fn-no-type.flan checked"
|
||||
| exception Loc.Error _ -> ()
|
||||
| exception Loc.Errors ds ->
|
||||
if List.length ds <> 1 then
|
||||
fail "fn-no-type.flan gave %d errors: %s" (List.length ds) (msgs ds));
|
||||
(* One error is the [Loc.Error] every caller of one form expects. *)
|
||||
let t, _ = Session.create ~file:"programs/reload.flan" () in
|
||||
(match Session.eval t "(defn one [] i64 (nope 1))" with
|
||||
| _ -> fail "an unknown function was accepted"
|
||||
| exception Loc.Error _ -> ()
|
||||
| exception Loc.Errors _ -> fail "one error came as a list"));
|
||||
|
||||
Test_support.report ~label:"session" ()
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user