A generic's name disassembles to each of its copies, and completion knows the name

This commit is contained in:
Joseph Ferano 2026-09-25 12:01:06 +07:00
commit 5e9be2150f
6 changed files with 495 additions and 51 deletions

View File

@ -1080,6 +1080,10 @@ should not pay for identity and metadata. Not implemented.
function nosuch" twice at the same place and counts 2 errors — once from the
abstract pass and once from the instantiation.
** TODO A type variable is printed without its $
=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort
expects [t] here, found [3 i32]" where the source wrote =[$t]=.
** DONE Two refusals suggested something that does not compile
CLOSED: [2026-09-25]
=vec-new= and =map-new= with no type no longer say "or give the binding a type";
@ -1931,6 +1935,11 @@ C-x C-e thunk triggered. Needs reproducing under load and fixing.
* Editor
** TODO C-c C-l on a generic needs a session to find its copies
The lowering view compiles the file, but only the daemon's =defs= says which
functions are a generic's copies, so with no session a generic's name shows
nothing. Needs a way to ask the compiler for a file's copies of a name.
** DONE The syntax table and the font-lock lists are read off the parser
CLOSED: [2026-09-21]
The special-form list is the heads the parser dispatches on, the builtin list is

View File

@ -415,6 +415,40 @@ looks like."
(buffer-substring-no-properties beg (line-beginning-position 2))
(buffer-substring-no-properties beg (point-max)))))))
(defun flan-lower--copies (name)
"The names of the copies of generic NAME the connected program has, or nil.
A generic has no code under its own name: each type it is called at makes a
copy named for the types, `selection-sort-i32'. The daemon lists the generic
with its signature as written, `$' and all, and lists each copy with the
generic's own location -- which is what tells a copy from an unrelated
function that happens to share the prefix, `sort-bytes' beside `sort'."
(let ((g (assoc name flan--defs)))
(when (and g (string-match-p "\\$" (nth 2 g)))
(let ((prefix (concat name "-")))
(sort (mapcar #'car
(seq-filter
(lambda (d)
(and (string-prefix-p prefix (car d))
(equal (nth 1 d) "fn")
(equal (nth 3 d) (nth 3 g))))
flan--defs))
#'string<)))))
(defun flan-lower--fetch-copies (section name)
"SECTION for each copy of generic NAME, each under a line naming it, or nil.
The copies are the session's, and the file may call the generic at fewer
types than the session does; a copy the file does not make is named as such
rather than left out."
(let ((copies (flan-lower--copies name)))
(and copies
(mapconcat
(lambda (c)
(format ";; %s\n%s" c
(or (funcall flan-lower-fetch-function
section flan-lower--file c flan-lower--flags)
"not made by this file: nothing in it calls at these types\n")))
copies "\n"))))
(defun flan-lower--gather (sections)
"Fetch each of SECTIONS into `flan-lower--texts', replacing what was there.
One section's failure is that section's text and not the buffer's: `llc' can
@ -425,6 +459,7 @@ altogether would be the wrong answer to that."
(or (funcall flan-lower-fetch-function
s flan-lower--file flan-lower--name
flan-lower--flags)
(flan-lower--fetch-copies s flan-lower--name)
(format "nothing for `%s' here\n" flan-lower--name))
(error (concat (error-message-string err) "\n")))))
(setf (alist-get s flan-lower--texts) text))))

View File

@ -3029,36 +3029,72 @@ tail of exactly one packaged name, because a buffer inside a package writes
(let ((inhibit-read-only t))
(erase-buffer)
(flan-disassembly-mode)
(let ((start (point)))
(insert (format "; %s for %s\n"
(if ir "LLVM IR" "disassembly") full))
(put-text-property start (point) 'face 'font-lock-comment-face))
(flan-disassemble--header "signature" (plist-get r :signature))
(flan-disassemble--header "source" (plist-get r :loc))
(flan-disassemble--header
"generation"
(let ((g (plist-get r :generation)))
(if (and (numberp g) (zerop g))
"0 (the build the program was launched from)"
(format "%s" g))))
(flan-disassemble--header "object" (plist-get r :object))
(flan-disassemble--header "showing" (plist-get r :basis))
(when (plist-get r :note)
(flan-disassemble--header "note" (plist-get r :note)))
(insert "\n")
(let ((start (point)))
(insert (plist-get r :text))
;; The source lines the daemon placed in the listing, and the
;; headings in the IR, are `;' comments; shown as comments so the
;; code between them reads as the code.
(save-excursion
(goto-char start)
(while (re-search-forward "^[ \t]*;.*$" nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-comment-face))))
(flan-disassemble--render r (if ir "LLVM IR" "disassembly"))
(goto-char (point-min))))
(display-buffer flan-disassembly-buffer)))
(defun flan-disassemble--comment (text)
"Insert TEXT as a line drawn as a comment."
(let ((start (point)))
(insert text "\n")
(put-text-property start (point) 'face 'font-lock-comment-face)))
(defun flan-disassemble--render (r what)
"Insert the reply R into the current buffer; WHAT names the view.
A generic has no code of its own, only a copy per type it was called at.
The daemon answers its name with that copy's listing when there is one, and
with `:copies', one listing each, when there are several; each is headed by
the types its variables were bound to."
(let ((copies (plist-get r :copies)))
(if copies
(progn
(flan-disassemble--comment
(format "; %s for %s, one copy per type it is called at"
what (plist-get r :name)))
(flan-disassemble--header "signature" (plist-get r :signature))
(dolist (c copies)
(insert "\n")
(flan-disassemble--comment
(format ";; %s at %s" (plist-get c :generic) (plist-get c :types)))
(if (plist-get c :refused)
(progn
(flan-disassemble--header "signature" (plist-get c :signature))
(flan-disassemble--header "no listing" (plist-get c :refused)))
(flan-disassemble--listing c))))
(flan-disassemble--comment
(if (plist-get r :generic)
(format "; %s for %s at %s" what (plist-get r :generic)
(plist-get r :types))
(format "; %s for %s" what (plist-get r :name))))
(flan-disassemble--listing r))))
(defun flan-disassemble--listing (r)
"Insert one function's headers and listing out of the reply R."
(flan-disassemble--header "signature" (plist-get r :signature))
(flan-disassemble--header "source" (plist-get r :loc))
(flan-disassemble--header
"generation"
(let ((g (plist-get r :generation)))
(if (and (numberp g) (zerop g))
"0 (the build the program was launched from)"
(format "%s" g))))
(flan-disassemble--header "object" (plist-get r :object))
(flan-disassemble--header "showing" (plist-get r :basis))
(when (plist-get r :note)
(flan-disassemble--header "note" (plist-get r :note)))
(insert "\n")
(let ((start (point)))
(insert (plist-get r :text))
(unless (bolp) (insert "\n"))
;; The source lines the daemon placed in the listing, and the headings in
;; the IR, are `;' comments; shown as comments so the code between them
;; reads as the code.
(save-excursion
(goto-char start)
(while (re-search-forward "^[ \t]*;.*$" nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-comment-face)))))
;;;###autoload
(defun flan-disassemble-ir (name)
"Show the LLVM IR NAME's installed body was built from.

View File

@ -1822,6 +1822,44 @@ already rely on it — so nothing here is a stand-in for the real thing."
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "not a function" raised))))
;; A generic has no code under its own name, only a copy per type it is
;; called at, so its name is answered with those: refused while there are
;; none, and one listing per copy, each headed by its types, once there
;; are several. Sent from a file that is not the program's.
(let ((file (concat socket3 "-sorts.flan")))
(flan--request
(list :op "eval" :file file
:code "(defn selection-sort [xs [$t]] ()
{:where (ordered? $t)}
(dotimes [i (length xs)]
(let [m i]
(dotimes [j (length xs)]
(when (< (at xs j) (at xs m)) (set m j)))
(swap xs i m))))"))
(test-flan--check "a generic nothing calls yet is refused, saying why"
(let ((raised nil))
(condition-case err (flan-disassemble "selection-sort" t)
(user-error (setq raised (error-message-string err))))
(and raised
(string-match-p "is generic" raised)
(string-match-p "no code has been made" raised))))
(flan--request
(list :op "eval" :file file
:code "(defn use-sort [] ()
(let [a [3 1 2]] (selection-sort (slice a 0 3)))
(let [b [3.0 1.0]] (selection-sort (slice b 0 2))))"))
(flan-disassemble "selection-sort" t)
(with-current-buffer flan-disassembly-buffer
(let ((text (buffer-string)))
(test-flan--check "a generic's IR is shown copy by copy"
(and (string-match-p "\\`; LLVM IR for selection-sort, one copy" text)
(string-match-p "^;; selection-sort at \\$t = i32$" text)
(string-match-p "^;; selection-sort at \\$t = f64$" text)
(string-match-p "^define .*flan\\.selection-sort-i32" text)
(string-match-p "^define .*flan\\.selection-sort-f64" text)))
(test-flan--check "each copy names the file the generic was sent from"
(string-match-p (regexp-quote file) text)))))
(flan-quit)
(ignore-errors (delete-file socket3)))
@ -1841,6 +1879,30 @@ already rely on it — so nothing here is a stand-in for the real thing."
;; anything being shut at all. `invisible-p' is the predicate that means
;; what it says, and it means it whether outline folded with an overlay or
;; with a text property.
;;
;; A generic is compiled only as its copies, so its own name finds nothing
;; and each copy is shown under a line naming it. A function that merely
;; shares the prefix and was written elsewhere is not a copy.
(with-temp-buffer
(let ((flan--defs
'(("sort" "fn" "sort [[$t]] ()" "<prelude>:331:7" "")
("sort-i32" "fn" "sort-i32 [[i32]] ()" "<prelude>:331:7" "")
("sort-f64" "fn" "sort-f64 [[f64]] ()" "<prelude>:331:7" "")
("sort-bytes" "fn" "sort-bytes [[[u8]]] ()" "<prelude>:1595:7" "")))
(flan-lower-fetch-function
(lambda (section _file name _flags)
(unless (equal name "sort") (format "%s of %s\n" section name))))
(flan-lower--file "x.flan")
(flan-lower--name "sort")
(flan-lower--flags nil)
(flan-lower--texts nil))
(flan-lower--gather '(ir))
(let ((text (alist-get 'ir flan-lower--texts)))
(test-flan--check "a generic's lowering is each of its copies, named"
(and (string-match-p "^;; sort-f64\nir of sort-f64$" text)
(string-match-p "^;; sort-i32\nir of sort-i32$" text)
(not (string-match-p "sort-bytes" text)))))))
(let* ((flan-lower--state (copy-alist flan-lower--state))
(flan-lower-fetch-function
(lambda (section _file name _flags)

View File

@ -649,6 +649,59 @@ let host_loc t name =
| Some f -> Loc.to_string f.Tast.floc
| None -> ""
(* A generic is never a [Tast.fn]: the checker keeps it as the AST it was
written as, and each type it is called at makes an ordinary copy under a
name of its own ([selection-sort-i32]). So a by-name op asked for the name
that was written finds nothing in the program, and these are how it gets
from that name to what the program does hold. *)
(* Its signature as written, [$] and all — [Types.to_string] prints a variable
bare, and [[t]] is not how anyone wrote it. *)
let generic_signature t name =
match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with
| None -> None
| Some (vars, params, ret) ->
let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in
let show ty = Types.to_string (Check.subst_ty dollar ty) in
Some
(Printf.sprintf "%s [%s] %s" name
(String.concat " " (List.map show params)) (show ret))
(* The copies of generic [name] the program holds, each with the types its
variables were bound to, spelled [$t = i32]. Read off the program: a copy
a [C-x C-e] made is kept in it, and [eval_expr] records the thunk's module
as that copy's owner, since no other module defines it. *)
let generic_copies t name =
let env = t.session.Session.env in
match Hashtbl.find_opt env.Check.gsigs name with
| None -> []
| Some (vars, params, ret) ->
List.filter_map
(fun (f : Tast.fn) ->
if f.Tast.fparent <> None then None
else
match Check.instantiation_origin env f.Tast.name with
| Some (g, ps) when String.equal g name ->
let subst = ref [] in
if List.length ps = List.length params then
ignore
(List.for_all2 (Check.bind_ty ~widen:true subst) params ps
&& Check.bind_ty subst ret f.Tast.ret);
let bound =
List.map
(fun v ->
match List.assoc_opt v !subst with
| Some ty -> Printf.sprintf "$%s = %s" v (Types.to_string ty)
| None -> "$" ^ v)
vars
in
Some (f, String.concat ", " bound)
| _ -> None)
t.session.Session.program.Tast.fns
(* By the types, alphabetically — [f64] before [i32] — so a listing asked
for twice is in the same order whatever order the copies were made in. *)
|> List.sort (fun (_, a) (_, b) -> String.compare a b)
(* ── Ops ───────────────────────────────────────────────────────────── *)
(* Every reply is a plist with a :status, so an editor can dispatch on one key
@ -1046,6 +1099,9 @@ let eval_expr t ~code ~origin ~pause =
the same instantiation would list it as already there. *)
let held = Session.held t.session in
let refused msg = Session.restore t.session held; error msg in
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
| c ->
let before = match result t with Some (g, _) -> g | None -> 0L in
@ -1077,10 +1133,32 @@ let eval_expr t ~code ~origin ~pause =
let entered_gen = stop_gen t 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
thunk's module and in no other, so this module is where [disassemble]
has to look for it — and its IR is kept for the reason [eval] keeps
a module's. *)
let ll =
Filename.concat t.dir (Printf.sprintf "e%d%s" t.n (module_ext c))
in
write_file ll c.Session.ir;
let copies =
List.filter_map
(fun (f : Tast.fn) ->
if List.mem f.Tast.name had then None else Some f.Tast.name)
t.session.Session.program.Tast.fns
in
(match build_module c ~debug:t.session.Session.debug ~out with
| _ ->
(match deliver t out with
| "ok" ->
if copies <> [] then begin
t.gen <- t.gen + 1;
List.iter
(fun n ->
Hashtbl.replace t.owners n
{ ogen = t.gen; oso = out; oll = ll; oloc = fn_loc t n })
copies
end;
(* Strictly after the delivery, and that ordering is the whole of
it: the sleeper is woken to look at a ring, so waking it before
the module is in one buys an empty poll and a five-second wait.
@ -1644,10 +1722,27 @@ let defs t =
(fun (name, sign, doc) -> entry ~name ~kind:"builtin" ~sign ~loc:"" ~doc ())
Check.builtins
in
(* A generic by the name it was written under. The program holds only its
copies, so without these rows the name an author typed was the one name
completion, eldoc and [M-.] had never heard of. Kind [fn], because it is
one to every reader of this list: it is called, jumped to, and
disassembled — the last through [disassemble], which answers a generic's
name with its copies. *)
let generics =
Hashtbl.fold
(fun name (g : Ast.fn) acc ->
entry ~name ~kind:"fn"
~sign:(Option.value ~default:name (generic_signature t name))
~loc:(Loc.to_string g.Ast.nloc) ()
:: acc)
t.session.Session.env.Check.generics []
|> List.sort compare
in
ok
[ ":defs "
^ Wire.list
(fns @ macros @ types @ globals @ externs @ prelude_macros @ builtins)
(fns @ generics @ macros @ types @ globals @ externs @ prelude_macros
@ builtins)
]
(* [(:op "layout" :type T)] — a struct's fields and their types.
@ -3757,22 +3852,9 @@ let kind_of t name =
then Some "an extern"
else None
let disassemble t ~name ~form =
if form <> "ir" && form <> "asm" then
error
(Printf.sprintf
"unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
else
match find_fn t name with
| None ->
(match kind_of t name with
| Some k ->
error
(Printf.sprintf
"%s is %s, not a function: there is no generated code to show for it"
name k)
| None -> error (Printf.sprintf "no function named %s in this session" name))
| Some f ->
(* The fields of one function's listing, or why there is none. [name] is the
symbol the code was built under, which for a generic's copy is the copy's. *)
let disassemble_fn t ~name ~form (f : Tast.fn) =
let o, why = basis t name in
let common =
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
@ -3793,7 +3875,7 @@ let disassemble t ~name ~form =
it cannot answer rather than failing at the text of an answer it was
never going to find. *)
if form = "ir" && t.session.Session.x86 then
error
Error
"this session was compiled by the x86 dev backend, so there is no \
LLVM IR to show — the listing it produced is assembly. C-c C-a \
disassembles the object, which works here; for the IR view, restart \
@ -3803,13 +3885,13 @@ let disassemble t ~name ~form =
| text ->
(match ir_of ~ir:text name with
| Some body ->
ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
Ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
| None ->
error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
Error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
| exception Sys_error m ->
error ("the IR this body was built from is gone: " ^ m)
Error ("the IR this body was built from is gone: " ^ m)
else if not (Sys.file_exists o.oso) then
error ("the object this body was linked into is gone: " ^ o.oso)
Error ("the object this body was linked into is gone: " ^ o.oso)
else
(* The kept source is what the source lines come from: the assembly's
map on x86, the [.ll]'s headings for an LLVM line table. Missing is
@ -3837,12 +3919,75 @@ let disassemble t ~name ~form =
"source interleaving needs line tables, which an LLVM \
session has only when started with flan dev --llvm --debug" ]
in
ok
Ok
(common
@ [ ":object " ^ Wire.quote o.oso ]
@ note
@ [ ":text " ^ Wire.quote text ])
| Error m -> error m
| Error m -> Error m
(* A generic's name answers with its copies: one is shown as any function is,
with [:generic] and [:types] beside it, and several come back as
[:copies], a list of those replies, one per type it was called at. *)
let disassemble t ~name ~form =
if form <> "ir" && form <> "asm" then
error
(Printf.sprintf
"unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
else
match find_fn t name with
| Some f ->
(match disassemble_fn t ~name ~form f with
| Ok fields -> ok fields
| Error m -> error m)
| None when Check.is_generic t.session.Session.env name ->
let sign = Option.value ~default:name (generic_signature t name) in
let copy ((f : Tast.fn), bound) =
Result.map
(fun fields ->
fields
@ [ ":generic " ^ Wire.quote name; ":types " ^ Wire.quote bound ])
(disassemble_fn t ~name:f.Tast.name ~form f)
in
(match generic_copies t name with
| [] ->
error
(Printf.sprintf
"%s is generic — %s — and nothing in this session calls it \
yet, so no code has been made for it. Each type it is called \
at gets its own compiled copy: evaluate a function that calls \
it, then disassemble %s again"
name sign name)
| [ c ] ->
(match copy c with Ok fields -> ok fields | Error m -> error m)
| cs ->
(* One copy that cannot be shown is that copy's entry, named with
the reason, and not the whole reply: the others still have code
to read. *)
let entry (((f : Tast.fn), bound) as c) =
match copy c with
| Ok fields -> Wire.list fields
| Error m ->
Wire.list
[ ":name " ^ Wire.quote f.Tast.name;
":signature " ^ Wire.quote (signature_of_fn f);
":loc " ^ Wire.quote (fn_loc t f.Tast.name);
":generic " ^ Wire.quote name; ":types " ^ Wire.quote bound;
":refused " ^ Wire.quote m ]
in
ok
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
":generic " ^ Wire.quote name;
":signature " ^ Wire.quote sign;
":copies " ^ Wire.list (List.map entry cs) ])
| None ->
(match kind_of t name with
| Some k ->
error
(Printf.sprintf
"%s is %s, not a function: there is no generated code to show for it"
name k)
| None -> error (Printf.sprintf "no function named %s in this session" name))
(* ── The watch table ───────────────────────────────────────────────── *)

View File

@ -3290,6 +3290,161 @@ let () =
(* ── Disassembly ───────────────────────────────────────────────── *)
(* A generic is compiled only as its copies, one per type it is called at,
so its own name has to be answered with those — the name the author
typed is the one the program never holds. Sent from a file that is not
the program's, which is how the report came in. Run against a daemon
of each backend, with the view each one has. *)
let generic_disassembly c ~backend ~form =
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let file = "/tmp/flan-devtest-sorts.flan" in
let eval code =
request c
(Printf.sprintf "(:op \"eval\" :code %s :file %s)" (Wire.quote code)
(Wire.quote file))
in
let ask () =
request c
(Printf.sprintf
"(:op \"disassemble\" :name \"selection-sort\" :form %S)" form)
in
let r =
eval
"(defn selection-sort [xs [$t]] ()\n {:where (ordered? $t)}\n \
(dotimes [i (length xs)]\n (let [m i]\n (dotimes [j \
(length xs)]\n (when (< (at xs j) (at xs m)) (set m j)))\n \
(swap xs i m))))"
in
if status r <> "ok" then fail "%s: sending a generic: %s" backend (said r)
else begin
let r = ask () in
if status r <> "error" then
fail "%s: a generic nothing calls was disassembled" backend
else if not (contains_sub (said r) "is generic")
|| not (contains_sub (said r) "[[$t]]")
|| not (contains_sub (said r) "evaluate a function that calls it")
then fail "%s: a generic nothing calls is refused for the wrong reason: %s"
backend (said r);
let r = request c "(:op \"defs\")" in
(match Wire.field r "defs" with
| Some { Form.v = Form.List rows; _ } ->
let row =
List.find_opt
(fun (d : Form.t) ->
match d.Form.v with
| Form.List ({ Form.v = Form.Str "selection-sort"; _ } :: _) ->
true
| _ -> false)
rows
in
(match row with
| Some { Form.v = Form.List [ _; { Form.v = Form.Str "fn"; _ };
{ Form.v = Form.Str sign; _ };
{ Form.v = Form.Str loc; _ }; _ ]; _ }
->
if sign <> "selection-sort [[$t]] ()" then
fail "%s: the generic's signature is not as written: %s" backend sign;
if loc <> file ^ ":1:7" then
fail "%s: the generic's location is not where it was sent from: %s"
backend loc
| _ -> fail "%s: defs does not list the generic by its name" backend)
| _ -> fail "%s: defs answered no list" backend);
let r =
eval
"(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3))))"
in
if status r <> "ok" then fail "%s: calling the generic at i32: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with one copy: %s" backend (said r)
else begin
if Wire.string_field r "name" <> Some "selection-sort-i32" then
fail "%s: the one copy is not the one shown" backend;
if Wire.string_field r "types" <> Some "$t = i32" then
fail "%s: the one copy does not say its types" backend;
if Wire.string_field r "loc" <> Some (file ^ ":1:7") then
fail "%s: the one copy does not name the file it came from: %s"
backend (Option.value ~default:"" (Wire.string_field r "loc"));
if not (contains_sub
(Option.value ~default:"" (Wire.string_field r "text"))
(if form = "ir" then "flan.selection-sort-i32" else "ret"))
then fail "%s: the one copy's listing is not its code" backend
end
end;
let r =
eval
"(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3)))\n \
(let [b [3.0 1.0]] (selection-sort (slice b 0 2))))"
in
if status r <> "ok" then fail "%s: calling the generic at f64: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with two copies: %s" backend (said r)
else
match Wire.field r "copies" with
| Some { Form.v = Form.List [ a; b ]; _ } ->
let types f =
Option.value ~default:"" (Wire.string_field f "types")
in
if types a <> "$t = f64" || types b <> "$t = i32" then
fail "%s: the copies are not headed by their types: %s, %s"
backend (types a) (types b);
List.iter
(fun f ->
let name = Option.value ~default:"" (Wire.string_field f "name") in
let text = Option.value ~default:"" (Wire.string_field f "text") in
if form = "ir" && not (contains_sub text ("flan." ^ name)) then
fail "%s: the copy %s shows some other code" backend name;
if text = "" then fail "%s: the copy %s has no listing" backend name)
[ a; b ]
| _ -> fail "%s: two copies did not come back as two" backend
end;
(* A copy made by an evaluated expression is defined only in that
expression's module, which is where its code has to be read from —
and the copies made before it are still shown beside it. *)
let r =
request c
"(:op \"eval-expr\" :code \"(selection-sort (slice [(i64 3) (i64 1)] 0 2))\")"
in
if status r <> "ok" then
fail "%s: calling the generic at i64 from an expression: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with a copy an expression made: %s" backend (said r)
else
match Wire.field r "copies" with
| Some { Form.v = Form.List [ _; _; _ ] as l; _ } ->
let l = match l with Form.List l -> l | _ -> [] in
List.iter
(fun f ->
let name = Option.value ~default:"" (Wire.string_field f "name") in
match Wire.string_field f "refused" with
| Some m -> fail "%s: the copy %s has no listing: %s" backend name m
| None ->
let text = Option.value ~default:"" (Wire.string_field f "text") in
if form = "ir" && not (contains_sub text ("flan." ^ name)) then
fail "%s: the copy %s shows some other code" backend name;
if text = "" then fail "%s: the copy %s has no listing" backend name)
l;
(match
List.find_opt
(fun f -> Wire.string_field f "types" = Some "$t = i64") l
with
| Some f ->
(match Wire.string_field f "object" with
| Some o when String.starts_with ~prefix:"e" (Filename.basename o) -> ()
| o ->
fail "%s: the expression's copy is not read from its module: %s"
backend (Option.value ~default:"" o))
| None -> fail "%s: the expression's copy is not listed" backend)
| _ -> fail "%s: three copies did not come back as three" backend
end
end
in
(* A third daemon, over a program that keeps running, because the two
claims here are about *which* module owns a name and what the answer is
allowed to say it means — and both change the moment a body is
@ -3457,6 +3612,7 @@ let () =
"\"ir\" or";
refused "a request with no name" "(:op \"disassemble\" :form \"asm\")"
"needs :name";
generic_disassembly c ~backend:"llvm" ~form:"ir";
(* A stopped program has not thereby failed to install. The commonest way
to stop is to install a body and have it error, so the one thing the
@ -3738,6 +3894,7 @@ let () =
fail "annotate: the delivered wind's positions are not the buffer's:\n%s"
(text r)
end;
generic_disassembly c ~backend:"x86" ~form:"asm";
ignore (request c "(:op \"close\")");
Unix.close c;
if not