JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A condition type may name a parent and a handler for Error catches every built-in error, a signal passes one descriptor carrying its chain, name, sentence and site, and the break loop shows the sentence the runtime wrote

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 12:05:13 +07:00
parent 680c12e686
commit 73dfaacbc8
25 changed files with 812 additions and 237 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/main.ml
View File

@ -79,7 +79,7 @@ let summarise (d : Flan.Ast.decl) =
| Package n -> Printf.sprintf "package %s" n
| Import (a, p) -> Printf.sprintf "import %s %S" a p
| Defalias (n, _) -> Printf.sprintf "defalias %s" n
| Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
| Defstruct (n, fs, _) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
| Defdata (n, vs) -> Printf.sprintf "defdata %s (%d cases)" n (List.length vs)
| Defunion (n, ms) ->
Printf.sprintf "defunion %s (%d members)" n (List.length ms)
@ -401,7 +401,7 @@ let () =
List.filter_map
(fun (d : Flan.Ast.decl) ->
match d.Flan.Ast.d with
| Flan.Ast.Defstruct (n, fs) -> Some (n, fs)
| Flan.Ast.Defstruct (n, fs, _) -> Some (n, fs)
| _ -> None)
ds
in

2
conditions.org
View File

@ -10,7 +10,7 @@ Why it is shaped this way: [[file:spec-conditions.md][spec-conditions.md]]. Some
(signal c) ; (). Handler returns -> carry on. No handler -> no-op.
(error c) ; Never. Only a transfer gets past; else the program stops.
(handler-bind [(Type [c] body ...) ...] body ...) ; match by type, no hierarchy
(handler-bind [(Type [c] body ...) ...] body ...) ; match by type or a parent's
(restart-case BODY ; BODY and every clause have the same type = the form's
(name [p T ...] CLAUSE) ...)

11
emacs/flan-cnr.el
View File

@ -233,6 +233,11 @@ indexing or the division itself, so it sits directly under the headline."
(insert (propertize name 'face (if paused 'warning 'error)))
(when numbers (insert " — " numbers))
(insert "\n")
;; The runtime's own sentence about it, when it wrote one: what the
;; fields below mean, or — for a trap, which has no fields — the whole of
;; what is known.
(let ((sentence (plist-get state :sentence)))
(when sentence (insert sentence "\n")))
(insert (propertize
(if paused
"stopped at (pause); nothing has been unwound\n"
@ -259,6 +264,10 @@ indexing or the division itself, so it sits directly under the headline."
(cond
((plist-get state :fields-empty)
" this condition has no fields\n")
;; A trap is not a struct. Its sentence, above, is what
;; there is to say about it.
((and (plist-get state :trap) (plist-get state :sentence))
" a trap carries no fields; the sentence above is what it refused\n")
(t (concat " not available — "
(or why (flan-cnr--why 'layout)) "\n")))
'face 'font-lock-comment-face))
@ -922,6 +931,8 @@ data and the fixture-driven tests can drive it without a socket."
;; has none, and then the headline simply has no line to point at.
:site (plist-get reply :site)
:source (plist-get reply :source)
;; The runtime's sentence about the stop, when it wrote one.
:sentence (plist-get reply :sentence)
;; FIELDS is either the rows themselves — the fixtures' shape — or
;; `flan-cnr-condition-fields''s plist of rows plus the one-sentence
;; reason the values half is missing.

22
emacs/test-flan-cider.el
View File

@ -1044,6 +1044,28 @@ would be overwritten. Look again and re-do the edit")
(test-flan--check "and the keys are shown" (and (string-match-p "TAB fold" text)
(string-match-p "P prelude frames" text))))
;; The runtime's sentence sits under the name. At a trap it is all there is:
;; a trap is not a struct, so the fields section says why it is empty rather
;; than that no struct has the name.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "ArithError"
:sentence "divide by zero: (/ 10 0)"
:restarts '("continue")))
(buffer-string))))
(test-flan--check "the runtime's sentence is under the condition's name"
(string-match-p "\\`ArithError\ndivide by zero: (/ 10 0)\n" text)))
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "DynType" :trap t
:sentence "dyn +: int and text, and + wants two numbers — (+ 3 \"hi\")"
:restarts nil))
(buffer-string))))
(test-flan--check "a trap's sentence is shown"
(string-match-p "and \\+ wants two numbers" text))
(test-flan--check "and its missing fields are not called a missing struct"
(string-match-p "a trap carries no fields" text)))
;; What a restart says beside its name: its `:report' sentence, the types it
;; takes, and where its clause is written — and `v' on the row visits that.
(let* ((buf (test-flan--cnr

7
lib/ast.ml
View File

@ -252,7 +252,10 @@ and decl_kind =
| Package of string
| Import of string * string (* alias, path *)
| Defalias of string * texpr
| Defstruct of string * field list
(* The third part is the parent a condition type names —
[(defstruct FileError :parent Error [...])] — and handler matching walks
that static chain. *)
| Defstruct of string * field list * texpr option
| Defdata of string * variant list
(* C's union: the members overlay one another at offset zero, the size is
the largest of them and the alignment the strictest. It carries the same
@ -379,7 +382,7 @@ let method_name (m : methd) = m.mgen ^ "@" ^ dispatch_text m.mkey
let declared_name (d : decl) =
match d.d with
| Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _)
| Defenum (n, _) | Defalias (n, _) | Defstruct (n, _, _) | Defdata (n, _)
| Defunion (n, _) | Defvar (n, _, _, _) | Defconst (n, _, _)
| Defclass (n, _) -> Some n
| Declare (fn, _) | DeclareC (fn, _) | Defn fn

108
lib/check.ml
View File

@ -93,6 +93,9 @@ type env = {
(* Enum name -> its members, in declaration order. A keyword at a call site
resolves against this and nothing else. *)
enums : (string, (string * int64) list) Hashtbl.t;
(* A condition type -> the parent it names, [(defstruct T :parent P ...)].
Handler matching walks this chain; see [condition_chain]. *)
parents : (string, string) Hashtbl.t;
(* Flan name -> the C symbol it is really called by. A foreign function is an
ordinary entry in [fns] as well; this only records how to name it. *)
externs : (string, string) Hashtbl.t;
@ -192,6 +195,7 @@ let new_env () = {
consts = Hashtbl.create 16;
locs = Hashtbl.create 16;
enums = Hashtbl.create 8;
parents = Hashtbl.create 8;
externs = Hashtbl.create 32;
extern_locs = Hashtbl.create 32;
fns = Hashtbl.create 32;
@ -2312,6 +2316,37 @@ let type_id name =
name;
!h
(* A condition type and every type it names as a parent, own first. The chain
is static: a signal site knows its condition's type, so the whole walk a
handler match makes is written into the site's descriptor, and the runtime
only compares numbers. [collect] has refused a cycle, but the walk stops at
one anyway rather than trusting that it ran. *)
let condition_chain env name =
let rec go seen n =
if List.mem n seen then List.rev seen
else
match Hashtbl.find_opt env.parents n with
| Some p -> go (n :: seen) p
| None -> List.rev (n :: seen)
in
go [] name
(* The sentence a handler for [Error] reads as the message, for the built-in
conditions the compiler itself signals. It has no values in it, because a
handler-case carries it past the frame that signalled; the fields carry
those. A program's own condition has none: its fields say what it is. The
runtime's own two, BoundsError and ArithError, are written in flan_rt.c. *)
let condition_message = function
| "StorageExhausted" -> "an allocator could not provide the memory asked of it"
| "FileError" -> "a file operation failed"
| "NoMethod" -> "no method answers this call"
| _ -> ""
let condition_desc env name =
{ Tast.cname = name;
cchain = List.map type_id (condition_chain env name);
cmessage = condition_message name }
(* How a restart's parameter list is spelled, and with it what the two ends of
an [invoke-restart] compare — spec-conditions.md §3's run-time check. A
restart is found by name on a dynamic stack, so neither end can see the
@ -3701,7 +3736,8 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
| Ast.Ssignal -> (Types.Unit, Tast.Ssignal)
| Ast.Serror -> (Types.Never, Tast.Serror)
in
expect ctx loc ~want (mk loc ty (Tast.Signal (kind, type_id name, c)))
expect ctx loc ~want
(mk loc ty (Tast.Signal (kind, condition_desc ctx.env name, c)))
| Ast.HandlerBind (clauses, body) -> check_handler_bind ctx ?want loc clauses body
| Ast.HandlerCase (body, clauses) -> check_handler_case ctx ?want loc body clauses
@ -6621,7 +6657,8 @@ and alloc_guard ctx loc (attempt : Tast.expr) =
in
let signal =
mk loc Types.Never
(Tast.Signal (Tast.Serror, type_id "StorageExhausted", cond))
(Tast.Signal (Tast.Serror, condition_desc ctx.env "StorageExhausted",
cond))
in
let attempt_then_signal =
mk loc Types.Unit
@ -6690,7 +6727,8 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
"flan_file_fail_reason" [] ])) ]))
in
let signal () =
mk loc Types.Never (Tast.Signal (Tast.Serror, type_id "FileError", cond))
mk loc Types.Never
(Tast.Signal (Tast.Serror, condition_desc ctx.env "FileError", cond))
in
(* One step of the attempt: run the runtime call, record whether it worked,
and signal if it did not. The last step a caller gives is what leaves [ok]
@ -10465,6 +10503,50 @@ let rec defconst_type_shaped env gname (v : Ast.expr) =
items
| _ -> ()
(* Every parent a struct names, now that every struct has its fields.
A parent has exactly [Error]'s two fields, [name string] and
[message string], and that is not a style rule: a handler that matched
through the link is handed the signal site's descriptor rather than the
condition, because the condition's layout is its own type's and the
handler's type is an ancestor's. The descriptor's first two fields are the
name and the sentence, so a parent shaped any other way would be read off
bytes that are not its fields. *)
let check_parents env =
let shaped n =
match Hashtbl.find_opt env.structs n with
| Some s ->
(match s.Tast.fields with
| [ { Tast.fname = "name"; fty = Types.String };
{ Tast.fname = "message"; fty = Types.String } ] -> true
| _ -> false)
| None -> false
in
Hashtbl.iter
(fun child parent ->
let loc =
Option.value (Hashtbl.find_opt env.locs child) ~default:Loc.unknown
in
if not (shaped parent) then
fail loc
"%s names %s as its parent, and %s has fields of its own. A \
handler for a parent is handed the name and the sentence of \
whatever it caught, not that condition's fields, so a parent has \
exactly [name string message string]. Give %s its own category \
with no field vector, (defstruct Category :parent Error), and \
name that as the parent"
child parent parent child;
(* A cycle is a chain with no root; the walk stops at the repeat. *)
let chain = condition_chain env child in
match Hashtbl.find_opt env.parents (List.nth chain (List.length chain - 1)) with
| Some back ->
fail loc
"%s's parents go round in a loop, %s -> %s, and a chain of parents \
has to end at a type with no parent, such as Error"
child (String.concat " -> " chain) back
| None -> ())
env.parents
let collect env (decls : Ast.decl list) =
(* One pass over every declaration kind before any of the others, because
the tables below are per-kind — structs, data types, aliases, enums, functions
@ -10511,7 +10593,7 @@ let collect env (decls : Ast.decl list) =
List.iter
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, _) ->
| Ast.Defstruct (n, _, _) ->
Hashtbl.replace env.locs n d.Ast.dloc;
Hashtbl.replace env.structs n { Tast.sname = n; fields = [] }
| Ast.Defdata (n, _) ->
@ -10687,10 +10769,25 @@ let collect env (decls : Ast.decl list) =
Hashtbl.replace env.externs fn.Ast.name csym;
Hashtbl.replace env.extern_locs fn.Ast.name loc
| Ast.Defalias _ -> ()
| Ast.Defstruct (n, fs) ->
| Ast.Defstruct (n, fs, parent) ->
let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in
if List.length (List.sort_uniq compare names) <> List.length names then
fail loc "%s declares the same field twice" n;
(* The parent is recorded here and its shape checked once every
struct has its fields, below, since it may be declared later. *)
(match parent with
| None -> Hashtbl.remove env.parents n
| Some t ->
(match resolve env t with
| Types.Named pn when Hashtbl.mem env.structs pn ->
if String.equal pn n then
fail t.Ast.tloc "%s cannot be its own parent" n;
Hashtbl.replace env.parents n pn
| pt ->
fail t.Ast.tloc
"%s names %s as its parent, and a parent is a condition \
struct, such as Error, the root every error descends from"
n (Types.to_string pt)));
let fields = List.map field fs in
(* Recorded before the refusal below rather than after it, because the
refusal asks [region_only], which walks this very declaration: a
@ -10885,6 +10982,7 @@ let collect env (decls : Ast.decl list) =
in
settle ();
List.iter (fun c -> ignore (infer c)) !pending;
check_parents env;
(* The paired declarations, handed back so that pass two checks the bodies of
the same functions whose signatures this pass registered. Pairing needs the
type names, which only this pass has; every pass after it needs the result,

2
lib/cimport.ml
View File

@ -1712,7 +1712,7 @@ let regenerate ~loc ~header:h ~flags ~(ds : Ast.decl list) ~config ~out =
let pick f = List.filter_map f ds in
let structs =
pick (fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None)
match d.Ast.d with Ast.Defstruct (n, fs, _) -> Some (n, fs) | _ -> None)
and enums =
pick (fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defenum (n, ms) -> Some (n, ms) | _ -> None)

15
lib/dev.ml
View File

@ -1789,6 +1789,19 @@ let site_fields t =
| None -> []
| Some text -> [ ":source " ^ Wire.quote text ])
(* The sentence the runtime wrote about the stop — "divide by zero: (/ 10 0)"
where the fields say op 0 — or nothing, for a program's own condition,
which says what it is in its fields, and for a (pause). A trap with no
struct behind it, DynType among them, has this and no fields at all. *)
let sentence_fields t =
match ask t "sentence" with
| exception Unix.Unix_error _ -> []
| text ->
let line = String.trim text in
if line = "" || line = "-" || (String.length line >= 4 && String.sub line 0 4 = "err ")
then []
else [ ":sentence " ^ Wire.quote line ]
let break t =
match liveness t with
| Gone -> error gone
@ -1863,7 +1876,7 @@ let break t =
program took on its own, and a list so long it was
truncated. *)
":trap " ^ (if trap then "t" else "nil") ]
@ site_fields t)
@ site_fields t @ sentence_fields t)
| Error m -> error ("the program refused to list its restarts: " ^ m))
(* [(:op "backtrace")] — the frames of a stopped program, innermost first.

59
lib/emit.ml
View File

@ -178,6 +178,17 @@ module Rt = struct
"loc", Ptr; "loclen", I64; "report", Ptr; "reportlen", I64;
"flags", I32 ] }
(* What a signal site says about its condition — the runtime's
[flan_condesc]. The first four fields are the prelude's [Error] laid out,
because a handler that matched through a parent link is handed this
rather than the condition. [chain] is the type ids from the condition's
own to its root; [loc] is the signal site. *)
let condesc =
{ sname = "condesc";
fields =
[ "name", Ptr; "namelen", I64; "message", Ptr; "messagelen", I64;
"chain", Ptr; "chainlen", I64; "loc", Ptr; "loclen", I64 ] }
(* The static description of a function, and the shadow-stack frame that
points at one. Dev builds only (runtime/flan_dev.c). *)
let fninfo =
@ -1653,6 +1664,33 @@ let fninfo m (fn : Tast.fn) ~nslots =
(Reach.ref_fingerprint ~is_global:(Hashtbl.mem m.globals) fn) ]));
id
(* A signal site's [%condesc], as a constant: the name and the sentence through
[string_bytes], because a handler may carry their addresses away (a
handler-case copies them out) and that is what keeps a module holding them
loaded; the chain and the site through [fi_bytes]'s counter, because
nothing reads them after the signal returns — the break loop copies the
site. *)
let condesc m (d : Tast.condesc) loc =
let nid, nlen = string_bytes m d.Tast.cname in
let mid, mlen = string_bytes m d.Tast.cmessage in
let lid, llen = fi_bytes m (Loc.to_string loc) in
let cid = Printf.sprintf "@\".cd.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant [%d x i32] [%s]\n" cid
(List.length d.Tast.cchain)
(String.concat ", "
(List.map (fun i -> Printf.sprintf "i32 %d" i) d.Tast.cchain)));
let id = Printf.sprintf "@\".cd.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private unnamed_addr constant %s\n" id
(Rt.ll_init Rt.condesc
[ nid; string_of_int nlen; mid; string_of_int mlen; cid;
string_of_int (List.length d.Tast.cchain); lid;
string_of_int llen ]));
id
(* ── Bounds checks ───────────────────────────────────────────────────── *)
(* A failure is a branch to a [noreturn] call and then [unreachable] — the same
@ -2291,21 +2329,20 @@ and value_at f (e : Tast.expr) : string =
| Tast.UnwrapSome v -> emit_unwrap f e.Tast.ty v
(* The condition crosses as a pointer: a handler runs while the signalling
frame is still alive, so there is nothing to copy and nothing to own. *)
| Tast.Signal (Tast.Ssignal, id, c) ->
| Tast.Signal (Tast.Ssignal, d, c) ->
let p = addr_rooted f c in
ins f "call void @flan_signal(i32 %d, ptr %s, ptr %s)" id p xfer_param;
let dp = condesc f.md d e.Tast.loc in
ins f "call void @flan_signal(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
guard f;
"zeroinitializer"
(* §2's diverging variant. [flan_error] does not return unless a handler
transferred, so the guard is the only way out and the fall-through is
unreachable. It cannot be marked noreturn for that reason — it does
return, on exactly one path. *)
| Tast.Signal (Tast.Serror, id, c) ->
| Tast.Signal (Tast.Serror, d, c) ->
let p = addr_rooted f c in
let name = struct_name_of c.Tast.ty in
let nid, nn = string_bytes f.md name in
ins f "call void @flan_error(i32 %d, ptr %s, ptr %s, ptr %s, i64 %d)"
id p xfer_param nid nn;
let dp = condesc f.md d e.Tast.loc in
ins f "call void @flan_error(ptr %s, ptr %s, ptr %s)" dp p xfer_param;
guard f;
term f "unreachable";
"zeroinitializer"
@ -4302,6 +4339,10 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
; lifted function that runs, and the environment that function is handed.
; Allocated on the establishing frame's stack.
|} ^ Rt.ll_type Rt.handler ^ {|
; What a signal site says about its condition: its name, the sentence a
; handler for a parent reads, the type ids from its own to its root, and the
; site. A constant per site; see [condesc].
|} ^ Rt.ll_type Rt.condesc ^ {|
; A restart frame: the one it displaced and the name it offers. There is no
; target field, because the frame's own address *is* the target — which makes
; a transfer's aim exact, and makes re-entering a restart-case work with
@ -4336,8 +4377,8 @@ declare void @flan_u64_to_bytes(i64, ptr, ptr)
declare void @flan_escape_bytes(ptr, i64, ptr)
declare void @flan_handler_push(ptr)
declare void @flan_handler_pop(ptr)
declare void @flan_signal(i32, ptr, ptr)
declare void @flan_error(i32, ptr, ptr, ptr, i64)
declare void @flan_signal(ptr, ptr, ptr)
declare void @flan_error(ptr, ptr, ptr)
declare void @flan_restart_push(ptr)
declare void @flan_restart_pop(ptr)
declare ptr @flan_find_restart(i32)

12
lib/load.ml
View File

@ -447,8 +447,9 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
Ast.Defconst (qualify alias n,
Option.map (rename_texpr owned alias) t,
rename_expr owned alias [] v)
| Ast.Defstruct (n, fs) ->
Ast.Defstruct (qualify alias n, List.map (rename_field owned alias) fs)
| Ast.Defstruct (n, fs, p) ->
Ast.Defstruct (qualify alias n, List.map (rename_field owned alias) fs,
Option.map (rename_texpr owned alias) p)
(* An untagged union imports exactly as a struct does, and for the reason
the data type above does not: it is a field list and a layout, with no
case table for the use site to resolve names against. The FFI is the
@ -853,7 +854,8 @@ let decl_uses acc (d : Ast.decl) =
match d.Ast.d with
| Ast.Package _ | Ast.Import _ | Ast.Defenum _ -> ()
| Ast.Defalias (_, t) -> texpr_uses acc t
| Ast.Defstruct (_, fs) | Ast.Defunion (_, fs) -> List.iter field fs
| Ast.Defstruct (_, fs, p) -> List.iter field fs; Option.iter (texpr_uses acc) p
| Ast.Defunion (_, fs) -> List.iter field fs
| Ast.Defdata (_, vs) ->
List.iter (fun (v : Ast.variant) -> List.iter field v.Ast.vfields) vs
| Ast.Defn f -> fn f
@ -1228,7 +1230,7 @@ let rec import ~seen ~open_ ~loc alias dir =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, _) -> Some n
| Ast.Defstruct (n, _, _) -> Some n
| _ -> None)
ds
and known_unions =
@ -1297,7 +1299,7 @@ let rec import ~seen ~open_ ~loc alias dir =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, fs) -> Some (n, fs, d.Ast.dloc)
| Ast.Defstruct (n, fs, _) -> Some (n, fs, d.Ast.dloc)
| _ -> None)
ds
in

20
lib/parse.ml
View File

@ -1333,10 +1333,26 @@ let rec decl (f : Form.t) : Ast.decl =
| [ n; t ] -> mk (Ast.Defalias (dname n, texpr t))
| _ -> fail f "defalias is (defalias Name Type)")
(* A parent comes before the fields, where Common Lisp's define-condition
puts its supertypes. With no field vector the struct is a category: it
has the fields every parent has, which are the root [Error]'s, so a
handler for it reads the name and the sentence of whatever matched. *)
| List ({ v = Sym "defstruct"; _ } :: args) ->
(match args with
| [ n; { v = Vec fs; _ } ] -> mk (Ast.Defstruct (dname n, fields f fs))
| _ -> fail f "defstruct is (defstruct Name [field Type ...])")
| [ n; { v = Vec fs; _ } ] ->
mk (Ast.Defstruct (dname n, fields f fs, None))
| [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] ->
mk (Ast.Defstruct (dname n, fields f fs, Some (texpr p)))
| [ n; { v = Kw "parent"; _ }; p ] ->
let str name =
{ Ast.fname = name; fty = { Ast.t = Ast.Tname "string"; tloc = f.loc };
floc = f.loc }
in
mk (Ast.Defstruct (dname n, [ str "name"; str "message" ], Some (texpr p)))
| _ ->
fail f
"defstruct is (defstruct Name [field Type ...]), or with a parent \
(defstruct Name :parent Parent [field Type ...])")
| List ({ v = Sym "defdata"; _ } :: args) ->
(match args with

52
lib/prelude.ml
View File

@ -43,6 +43,25 @@
the printer it was being forced through was the wrong one. *)
let source = {flan|
;; The root every built-in error descends from. A condition type names its
;; parent where it is declared — (defstruct FileError :parent Error [...]) —
;; and a handler for a type answers every condition below it, so one handler
;; for Error catches any error:
;;
;; (handler-case (run) [(Error [e] (println (.name e)) (println (.message e)))])
;;
;; A handler that matched through a parent is handed the condition's name and
;; a sentence saying what went wrong, not the condition's own fields: the
;; handler's type is the parent's, and the fields are the child's. That is
;; why a parent has exactly these two fields, and why a type declared with a
;; parent and no field vector — a category, (defstruct Category :parent
;; Error) — gets them. The sentence has no values in it; a handler for the
;; condition's own type reads those from its fields. A program's own
;; condition has an empty sentence, since its fields say what it is.
;;
;; (pause) and warnings are not under Error: a breakpoint is not a failure.
(defstruct Error [name string message string])
;; The condition every allocating operation signals when the allocator cannot
;; satisfy a request — spec-memory.md, "Allocation failure". It is here rather
;; than built by the checker because it is an ordinary value struct and the
@ -54,7 +73,7 @@ let source = {flan|
;; allocator's address, which is its identity — the same thing the epoch hangs
;; off — so a handler can tell which region ran out. Rendering happens in the
;; handler or the break loop, where a working allocator is known.
(defstruct StorageExhausted [bytes i64 align i64 allocator i64])
(defstruct StorageExhausted :parent Error [bytes i64 align i64 allocator i64])
;; What an out-of-range index signals. Same shape as StorageExhausted and for
;; the same reasons: fixed numeric fields, no rendered message, nothing that
@ -92,7 +111,7 @@ let source = {flan|
;; being pushed here. That is plan.org's "restarts go at the resync point,
;; once", with allocation and file failure as the named exceptions and this on
;; the default side of the rule.
(defstruct BoundsError [low i64 high i64 length i64])
(defstruct BoundsError :parent Error [low i64 high i64 length i64])
;; What an arithmetic operation with no answer signals. Three situations, and
;; until now none of them had a defined behaviour: a divide or remainder by
@ -116,18 +135,17 @@ let source = {flan|
;; fields are a C struct that has to agree with this one field for field**,
;; the same hand-kept agreement flan_bounds_cond keeps with BoundsError.
;;
;; `op` is a small integer and not a keyword, exactly as FileError's `op` is,
;; because the field is filled in from C and a keyword is not a thing that
;; exists there. The codes:
;; `op` is an ArithOp, an i32 at run time, which is what lets the runtime fill
;; it in from C; the members' numbers are flan_rt.c's FLAN_ARITH_* codes:
;;
;; 0 (/ a 0) 1 (% a 0)
;; 2 (/ min -1) 3 (% min -1)
;; 4 a float to integer cast whose value does not fit
;; 5 a float to integer cast of NaN
;; 6 a float to integer cast of an infinity
;; :div-zero (/ a 0) :rem-zero (% a 0)
;; :div-overflow (/ min -1) :rem-overflow (% min -1)
;; :cast-range a float to integer cast whose value does not fit
;; :cast-nan a float to integer cast of NaN
;; :cast-inf a float to integer cast of an infinity
;;
;; `lhs` and `rhs` are the two operands for codes 0 through 3 and the
;; destination type's representable range for codes 4 through 6 — the violated condition
;; `lhs` and `rhs` are the two operands for the first four and the
;; destination type's representable range for the casts — the violated condition
;; written as a range, which is what flan_slice_promise_error already does
;; with BoundsError's fields. Two meanings over two fields rather than two
;; condition types, so that a handler writes one clause and not five. The
@ -152,7 +170,11 @@ let source = {flan|
;; division by zero is the restart the program already established, a frame
;; loop's `continue`, which is reachable from a handler without anything being
;; pushed here.
(defstruct ArithError [op i32 lhs i64 rhs i64])
(defenum ArithOp
[div-zero 0 rem-zero 1 div-overflow 2 rem-overflow 3
cast-range 4 cast-nan 5 cast-inf 6])
(defstruct ArithError :parent Error [op ArithOp lhs i64 rhs i64])
;; What a generic function signals when no method answers. `generic` is the
;; name written at the defgeneric or defmulti, and `value` is what the
@ -174,7 +196,7 @@ let source = {flan|
;;
;; No restart is established at the miss, which is BoundsError's decision
;; taken for BoundsError's reason -- see the note above it.
(defstruct NoMethod [generic string value dyn])
(defstruct NoMethod :parent Error [generic string value dyn])
;; A breakpoint. (pause) stops the program where it stands and hands it to the
;; break loop, with the whole stack under it readable — C-c C-b lists the
@ -1961,7 +1983,7 @@ let source = {flan|
;; parent link, not class inheritance", decides on is the
;; answer to that, and it is not built; when it is, these reasons can become
;; types without any call site changing.
(defstruct FileError [path string op i32 reason i32])
(defstruct FileError :parent Error [path string op i32 reason i32])
(defconst file-op-read i32 0)
(defconst file-op-write i32 1)

2
lib/shim.ml
View File

@ -135,7 +135,7 @@ let scan (decls : Ast.decl list) =
List.iter
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defstruct (n, fs) -> Hashtbl.replace env.structs n fs
| Ast.Defstruct (n, fs, _) -> Hashtbl.replace env.structs n fs
| Ast.Defenum (n, _) -> Hashtbl.replace env.enums n ()
| Ast.Defdata (n, _) -> Hashtbl.replace env.datas n ()
| Ast.Defunion (n, _) -> Hashtbl.replace env.unions n ()

8
lib/tast.ml
View File

@ -218,7 +218,7 @@ and expr_kind =
nothing here alters control flow. [HandlerBind] pushes one frame per
clause, runs its body, and pops them; each clause was lifted into its own
function by the checker, so what is left is the frame and the call. *)
| Signal of sigkind * int * expr (* how, the type id, the condition *)
| Signal of sigkind * condesc * expr (* how, what, the condition *)
| Handled of hframe list * expr list
(* The transfer, spec-conditions.md §3–§6. [RestartCase] pushes one frame per
clause, runs its body, and pops them; if a transfer arrives naming one of
@ -275,6 +275,12 @@ and fnref = Flanfn of string | Rtfn of string | Fnval of string
and sigkind = Ssignal | Serror
(* What a signal site says about its condition, which the backends write out
as a constant the runtime's [flan_condesc] reads: the type's name, the type
ids from its own to its root ([Check.condition_chain]), and the sentence a
handler for a parent reads as the message. *)
and condesc = { cname : string; cchain : int list; cmessage : string }
and place =
| Plocal of int
| Pglobal of string

37
lib/x86.ml
View File

@ -1056,6 +1056,32 @@ let fninfo f (fn : Tast.fn) ~nslots =
fn) ]));
l
(* A signal site's [flan_condesc], [emit.ml]'s [condesc] spelled for this
backend: the name and the sentence through [string_const], which counts
them, because a handler may carry their addresses away; the chain and the
site through [fi_bytes], because nothing reads them after the signal
returns. In [.data.rel.ro] for [fninfo]'s reason: it holds addresses. *)
let condesc f (d : Tast.condesc) loc =
let nlbl = string_const f d.Tast.cname in
let mlbl = string_const f d.Tast.cmessage in
let llbl, llen = fi_bytes f (Loc.to_string loc) in
let clbl = rodata_label f in
Buffer.add_string f.rodata
(Printf.sprintf "\t.align 4\n%s:\n%s" clbl
(String.concat ""
(List.map (fun i -> Printf.sprintf "\t.long\t%d\n" i) d.Tast.cchain)));
let l = rodata_label f in
Buffer.add_string f.rodata
(Printf.sprintf
"\t.section\t.data.rel.ro,\"aw\"\n\t.align 8\n%s:\n%s\t.section\t.rodata\n"
l
(Emit.Rt.asm_init Emit.Rt.condesc
[ nlbl; string_of_int (String.length d.Tast.cname); mlbl;
string_of_int (String.length d.Tast.cmessage); clbl;
string_of_int (List.length d.Tast.cchain); llbl;
string_of_int llen ]));
l
(* The store that says "this slot is bound now", and it is the address rather
than a flag for [emit.ml]'s reason: the reader needs the address anyway, so
one store carries both facts, and a slot the control flow has not reached
@ -1920,11 +1946,11 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
| Tast.Match (scrut, arms) -> emit_match f scrut arms dst t
(* The condition crosses as a pointer: a handler runs while the signalling
frame is still alive, so there is nothing to copy and nothing to own. *)
| Tast.Signal (Tast.Ssignal, id, c) ->
| Tast.Signal (Tast.Ssignal, d, c) ->
scoped f (fun () ->
let l = lvalue_rooted f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
lea f.b ~dst:rdi ~mm:(Sym (condesc f d e.Tast.loc, 0));
chan_into f ~reg:rdx;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_signal";
@ -1932,15 +1958,12 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
(* §2's diverging variant. [flan_error] does not return unless a handler
transferred, so the guard is the only way out and the fall-through is
[ud2] — where [emit.ml] writes [unreachable]. *)
| Tast.Signal (Tast.Serror, id, c) ->
| Tast.Signal (Tast.Serror, d, c) ->
scoped f (fun () ->
let l = lvalue_rooted f c in
addr_into f ~reg:rsi l;
imm_into f ~reg:rdi (Int64.of_int id);
lea f.b ~dst:rdi ~mm:(Sym (condesc f d e.Tast.loc, 0));
chan_into f ~reg:rdx;
let name =
match c.Tast.ty with Types.Named n -> n | _ -> "a condition" in
str_args f ~preg:rcx ~nreg:r8 name;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_error";
guard f;

50
runtime/flan_dyn.c
View File

@ -62,6 +62,9 @@ void flan_dev_watch_emit(const uint8_t *bytes, int64_t len);
* program die where it stands", which that file went to some trouble to have
* only one of. So flan_rt.c exports a thin wrapper and this calls it. */
_Noreturn void flan_trap(const uint8_t *name, int64_t namelen);
/* A trap's sentence, printed after its site and kept for the break loop, which
* shows it beside the trap's name (flan_rt.c). */
void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...);
/* Growing a Vec through a dyn view borrows flan_rt.c's own growth: doubling,
* allocator adoption and the epoch check all live in [flan_vec_push], and
@ -803,9 +806,9 @@ static void say(char *buf, int64_t cap, flan_dyn v) {
* which without reading the sentence twice — and because the break loop lists
* them by name. */
/* Where the operation was written, printed as flan_rt.c's traps print it: the
* GNU "file:line:col: " prefix, so `next-error` walks to the dyn failure the
* same way it walks to a bounds failure. The pair is what an emitted string
/* Where the operation was written, printed as flan_rt.c's traps print it
* ([flan_say] writes both): the GNU "file:line:col: " prefix, so `next-error`
* walks to the dyn failure the same way it walks to a bounds failure. The pair is what an emitted string
* literal already is — a pointer and a length, not a C string — and the
* emitter hands it over exactly as [flan_dyn_cast_kind]'s site does.
*
@ -814,10 +817,6 @@ static void say(char *buf, int64_t cap, flan_dyn v) {
* given a site (everything but the arithmetic, the ordering, [at], [set-at]
* and [push]) pass NULL, and so does test/dyn_ops.c, which calls the runtime
* directly and has no source position to offer. */
static void trap_where(const uint8_t *loc, int64_t loclen) {
if (loc != NULL && loclen > 0)
fprintf(stderr, "%.*s: ", (int)loclen, (const char *)loc);
}
static _Noreturn void trap2(const uint8_t *loc, int64_t loclen,
const char *name, int64_t namelen, const char *op,
@ -825,10 +824,8 @@ static _Noreturn void trap2(const uint8_t *loc, int64_t loclen,
char sa[SAY_MAX], sb[SAY_MAX];
say(sa, SAY_MAX, a);
say(sb, SAY_MAX, b);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr, "dyn %s: %s and %s, and %s — (%s %s %s)\n", op, tag_of(a),
tag_of(b), why, op, sa, sb);
flan_say(loc, loclen, "dyn %s: %s and %s, and %s — (%s %s %s)", op,
tag_of(a), tag_of(b), why, op, sa, sb);
flan_trap((const uint8_t *)name, namelen);
}
@ -837,9 +834,8 @@ static _Noreturn void trap1(const uint8_t *loc, int64_t loclen,
const char *why, flan_dyn a) {
char sa[SAY_MAX];
say(sa, SAY_MAX, a);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr, "dyn %s: %s, and %s — (%s %s)\n", op, tag_of(a), why, op, sa);
flan_say(loc, loclen, "dyn %s: %s, and %s — (%s %s)", op, tag_of(a), why, op,
sa);
flan_trap((const uint8_t *)name, namelen);
}
@ -852,11 +848,9 @@ static _Noreturn void trap_range(const uint8_t *loc, int64_t loclen,
int64_t len) {
char sv[SAY_MAX];
say(sv, SAY_MAX, v);
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr,
"dyn %s: index %lld is out of bounds for %s of length %lld — %s\n",
op, (long long)i, tag_of(v), (long long)len, sv);
flan_say(loc, loclen,
"dyn %s: index %lld is out of bounds for %s of length %lld — %s", op,
(long long)i, tag_of(v), (long long)len, sv);
flan_trap((const uint8_t *)"DynRange", 8);
}
@ -927,11 +921,9 @@ void flan_gc_collect(void) {
* NULL, which prints no prefix. */
static _Noreturn void trap_oom(const uint8_t *loc, int64_t loclen,
int64_t want) {
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr,
"dyn heap: %lld bytes could not be allocated, with %lld live\n",
(long long)want, (long long)gc_bytes);
flan_say(loc, loclen,
"dyn heap: %lld bytes could not be allocated, with %lld live",
(long long)want, (long long)gc_bytes);
flan_trap((const uint8_t *)"DynHeap", 7);
}
@ -1985,12 +1977,10 @@ static void view_vec_check(const uint8_t *loc, int64_t loclen, const char *op,
if (h->alloc) {
flan_dyn_alloc_hdr *a = (flan_dyn_alloc_hdr *)h->alloc;
if ((int64_t)a->epoch != h->epoch) {
fflush(stdout);
trap_where(loc, loclen);
fprintf(stderr,
"dyn %s: this view's container's allocator was released — the "
"Vec was made at epoch %lld and the allocator is at %lld now\n",
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
flan_say(loc, loclen,
"dyn %s: this view's container's allocator was released — the "
"Vec was made at epoch %lld and the allocator is at %lld now",
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
flan_trap((const uint8_t *)"DynRange", 8);
}
}

419
runtime/flan_rt.c
View File

@ -11,6 +11,7 @@
* on x86-64 and silently does not on wasm32.
*/
#include <stdarg.h>
#include <stdint.h>
#include <stddef.h>
#include <stdio.h>
@ -63,6 +64,44 @@ void flan_handler_pop(flan_handler *h) {
handlers = h->prev;
}
/* What a signal site says about its condition: Emit.Rt.condesc, field for
* field, which both backends lay out from one list. A compiled signal points
* at a constant; the runtime's own conditions build one on the failing
* frame's stack.
*
* The first four fields are laid out as the prelude's
* (defstruct Error [name string message string]), and that is the point of
* their order: a handler that matched through a parent link is handed *this*
* rather than the condition, because the condition's layout is its own type's
* and the handler's type is an ancestor's. A parent is a type with exactly
* Error's fields — the checker refuses any other — so every such handler reads
* the name and the sentence and nothing it could misread.
*
* [message] is a sentence with no values in it, and static: a handler-case
* copies the view out before the signalling frame is unwound, so the bytes it
* points at must outlive that frame. The sentence with the values in it is the
* break loop's, below. [chain] is the type ids from the condition's own type
* to its root, own first. */
typedef struct flan_condesc {
const uint8_t *name;
int64_t namelen;
const uint8_t *message;
int64_t messagelen;
const uint32_t *chain;
int64_t chainlen;
const uint8_t *loc;
int64_t loclen;
} flan_condesc;
/* 1 when a handler for [type_id] answers the condition by its own type, 2
* when it answers through a parent link, 0 when it does not answer. */
static int flan_handles(uint32_t type_id, const flan_condesc *d) {
if (d->chainlen > 0 && d->chain[0] == type_id) return 1;
for (int64_t i = 1; i < d->chainlen; i++)
if (d->chain[i] == type_id) return 2;
return 0;
}
/* [xfer] is the signalling function's own end of the transfer channel
* (spec-conditions.md §6), threaded through so that a handler invoking a
* restart can write its target into it. That makes this C frame transparent to
@ -72,12 +111,16 @@ void flan_handler_pop(flan_handler *h) {
*
* A handler that transfers stops the walk. The remaining handlers are for a
* signal that is still looking for someone; this one has been answered. */
void flan_signal(uint32_t type_id, void *condition, void *xfer) {
for (flan_handler *h = handlers; h != NULL; h = h->prev)
if (h->type_id == type_id) {
h->fn(condition, xfer, h->env);
void flan_signal(const flan_condesc *d, void *condition, void *xfer) {
for (flan_handler *h = handlers; h != NULL; h = h->prev) {
int how = flan_handles(h->type_id, d);
if (how) {
/* A parent's handler reads the name and the sentence; see
* flan_condesc. */
h->fn(how == 1 ? condition : (void *)d, xfer, h->env);
if (*(void **)xfer != NULL) return;
}
}
}
/* A restart stack, the same shape and for the same reasons. What a transfer
@ -233,6 +276,10 @@ void flan_rt_init(int32_t argc, char **argv) {
* is not [fflush(stdout)]. */
static _Noreturn void rt_die(void);
static void rt_flush_out(void);
/* And the sentence a stop is told with; see "What the break loop is told
* about a stop" below. */
static void rt_sentence(const char *fmt, ...);
static void rt_print_sentence(const uint8_t *loc, int64_t loclen);
/* The one malloc in this file that is not an allocator's, because the argument
* vector belongs to the process rather than to any region a Flan program named.
@ -602,11 +649,17 @@ static _Noreturn void rt_die(void) {
_exit(134);
}
/* The sentence each bounds failure is told with — to stderr when nothing
* answered, and to the break loop before it is asked. */
static void bounds_sentence(int64_t idx, int64_t len) {
rt_sentence("index %lld is out of bounds for length %lld", (long long)idx,
(long long)len);
}
_Noreturn void flan_bounds_fail(const uint8_t *loc, int64_t loclen,
int64_t idx, int64_t len) {
rt_flush_out();
fprintf(stderr, "%.*s: index %lld is out of bounds for length %lld\n",
(int)loclen, (const char *)loc, (long long)idx, (long long)len);
bounds_sentence(idx, len);
rt_print_sentence(loc, loclen);
rt_die();
}
@ -695,6 +748,74 @@ _Noreturn void flan_trap(const uint8_t *name, int64_t namelen) {
rt_trap(name, namelen);
}
/* ── What the break loop is told about a stop ─────────────────────────
*
* Where the expression that stopped is written, and the sentence the runtime
* wrote about it — the loc every checked site already passes, and the words
* it prints to stderr. The frame chain says where each *call* was; the site
* is the only record of the `at` or the division itself, and the sentence is
* what the condition's fields mean ("this value does not fit the integer type
* it is cast to" rather than op 4 and two bounds).
*
* Set immediately before a break hook or a trap hook runs and cleared when a
* break hook returns, so the agent's snapshot (taken on entry to the break
* loop, on this same thread) reads them while they are true, and consumes
* them so that a break nested inside that one cannot inherit them. NULL and
* empty outside that window, which is the honest answer for a stop that has
* nothing to point at. */
const uint8_t *flan_break_site;
int64_t flan_break_site_len;
char flan_break_sentence[512];
int64_t flan_break_sentence_len;
static void rt_sentencev(const char *fmt, va_list ap) {
int n = vsnprintf(flan_break_sentence, sizeof flan_break_sentence, fmt, ap);
if (n < 0) n = 0;
if (n >= (int)sizeof flan_break_sentence)
n = (int)sizeof flan_break_sentence - 1;
flan_break_sentence_len = n;
}
static void rt_sentence(const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
rt_sentencev(fmt, ap);
va_end(ap);
}
static void rt_break_clear(void) {
flan_break_site = NULL;
flan_break_site_len = 0;
flan_break_sentence_len = 0;
}
/* The sentence already formatted, to stderr, after the site. */
static void rt_print_sentence(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
if (loc != NULL && loclen > 0)
fprintf(stderr, "%.*s: ", (int)loclen, (const char *)loc);
fprintf(stderr, "%.*s\n", (int)flan_break_sentence_len,
flan_break_sentence);
}
/* A trap's sentence: formatted once, printed where it always was, and left
* for the trap hook with the site beside it. [loc] may be NULL. Exported for
* flan_dyn.c, whose traps are this kind and must be told the same way. */
void flan_sayv(const uint8_t *loc, int64_t loclen, const char *fmt,
va_list ap) {
rt_sentencev(fmt, ap);
rt_print_sentence(loc, loclen);
flan_break_site = loc;
flan_break_site_len = loc != NULL ? loclen : 0;
}
void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
flan_sayv(loc, loclen, fmt, ap);
va_end(ap);
}
/* Must agree with Check.type_id, byte for byte, or a name typed at the break
* loop matches nothing. FNV-1a over the name, 32 bits. */
static uint32_t flan_name_id(const uint8_t *s, int64_t n) {
@ -772,19 +893,29 @@ void flan_restart_pop_c(void *frame) {
* with the one in use. TODO.org, "The break loop's display pass", records the
* choice by index that left it with no caller. Now there is no function. */
void flan_error(uint32_t type_id, void *condition, void *xfer,
const uint8_t *name, int64_t namelen) {
flan_signal(type_id, condition, xfer);
void flan_error(const flan_condesc *d, void *condition, void *xfer) {
flan_signal(d, condition, xfer);
if (*(void **)xfer != NULL) return;
/* Nothing handled it. In a dev build that is a place to stand, not the end
* of the program — which is the whole of §2 and the reason it is worth
* having. */
* having. The site is the (error ...) itself, and the sentence is the
* condition's static one, or none: a program's own condition says what it
* is in its fields. */
if (flan_break_hook != NULL) {
flan_break_hook(name, namelen, condition, xfer);
flan_break_site = d->loclen > 0 ? d->loc : NULL;
flan_break_site_len = d->loclen;
rt_sentence("%.*s", (int)d->messagelen, (const char *)d->message);
flan_break_hook(d->name, d->namelen, condition, xfer);
rt_break_clear();
if (*(void **)xfer != NULL) return;
}
rt_flush_out();
fprintf(stderr, "unhandled %.*s\n", (int)namelen, (const char *)name);
if (d->messagelen > 0)
rt_sentence("unhandled %.*s: %.*s", (int)d->namelen,
(const char *)d->name, (int)d->messagelen,
(const char *)d->message);
else
rt_sentence("unhandled %.*s", (int)d->namelen, (const char *)d->name);
rt_print_sentence(d->loc, d->loclen);
rt_die();
}
@ -795,9 +926,8 @@ void flan_error(uint32_t type_id, void *condition, void *xfer,
* process, so that the stack that offered no such name can be read. */
_Noreturn void flan_restart_fail(const uint8_t *loc, int64_t loclen,
const uint8_t *name, int64_t namelen) {
rt_flush_out();
fprintf(stderr, "%.*s: no restart named %.*s is active\n",
(int)loclen, (const char *)loc, (int)namelen, (const char *)name);
flan_say(loc, loclen, "no restart named %.*s is active", (int)namelen,
(const char *)name);
rt_trap((const uint8_t *)"NoSuchRestart", 13);
}
@ -810,10 +940,9 @@ _Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen,
const uint8_t *name, int64_t namelen,
const uint8_t *want, int64_t wantlen,
const uint8_t *got, int64_t gotlen) {
rt_flush_out();
fprintf(stderr, "%.*s: restart %.*s takes %.*s, given %.*s\n",
(int)loclen, (const char *)loc, (int)namelen, (const char *)name,
(int)wantlen, (const char *)want, (int)gotlen, (const char *)got);
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s", (int)namelen,
(const char *)name, (int)wantlen, (const char *)want, (int)gotlen,
(const char *)got);
rt_trap((const uint8_t *)"RestartArity", 12);
}
@ -825,12 +954,8 @@ _Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen,
_Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen,
const uint8_t *name, int64_t namelen,
const uint8_t *want, int64_t wantlen) {
rt_flush_out();
fprintf(stderr,
"%.*s: restart %.*s takes %.*s, and none was supplied — a restart "
"with parameters cannot be taken from the break loop yet\n",
(int)loclen, (const char *)loc, (int)namelen, (const char *)name,
(int)wantlen, (const char *)want);
flan_say(loc, loclen, "restart %.*s takes %.*s, and none was supplied",
(int)namelen, (const char *)name, (int)wantlen, (const char *)want);
rt_trap((const uint8_t *)"RestartUnarmed", 14);
}
@ -840,19 +965,19 @@ _Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen,
* lexical case is refused by the checker; this is the one that reaches a
* function through a call, where nothing static could see it. */
_Noreturn void flan_transfer_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: a defer invoked a restart, which a defer may not do\n",
(int)loclen, (const char *)loc);
flan_say(loc, loclen, "a defer invoked a restart, which a defer may not do");
rt_trap((const uint8_t *)"TransferFromDefer", 17);
}
static void slice_sentence(int64_t lo, int64_t hi, int64_t len) {
rt_sentence("slice [%lld %lld) is out of bounds for length %lld",
(long long)lo, (long long)hi, (long long)len);
}
_Noreturn void flan_slice_fail(const uint8_t *loc, int64_t loclen,
int64_t lo, int64_t hi, int64_t len) {
rt_flush_out();
fprintf(stderr, "%.*s: slice [%lld %lld) is out of bounds for length %lld\n",
(int)loclen, (const char *)loc, (long long)lo, (long long)hi,
(long long)len);
slice_sentence(lo, hi, len);
rt_print_sentence(loc, loclen);
rt_die();
}
@ -900,51 +1025,78 @@ typedef struct { int64_t low, high, length; } flan_bounds_cond;
static const uint8_t flan_bounds_name[] = "BoundsError";
#define FLAN_BOUNDS_NAMELEN 11
/* Where the expression that trapped is written — the loc every checked site
* already passes for its unhandled message, published for the break hook.
* The frame chain says where each *call* was; this is the only record of the
* `at` or the division itself, which is the line a person wants pointed at.
*
* Set immediately before the hook runs and cleared when it returns, so the
* agent's snapshot (taken on entry to the break loop, on this same thread)
* reads it while it is true and a later break through [flan_error] — a user
* (error ...), which carries no loc — cannot inherit a stale one. NULL
* outside that window, and NULL is the honest answer for a signal that has
* no expression to point at. */
const uint8_t *flan_break_site;
int64_t flan_break_site_len;
/* The root every built-in error descends from, and the parent link the two
* conditions this file signals itself carry. Must agree with the prelude's
* (defstruct BoundsError :parent Error ...) — the same hand-kept agreement
* flan_name_id has with Check.type_id. */
static const uint8_t flan_error_name[] = "Error";
#define FLAN_ERROR_NAMELEN 5
/* Returns nonzero if something transferred, in which case the caller returns
* and its caller's guard carries the transfer out. */
static int flan_bounds_signal(const uint8_t *loc, int64_t loclen, void *xfer,
int64_t low, int64_t high, int64_t len) {
flan_bounds_cond c;
uint32_t id = flan_name_id(flan_bounds_name, FLAN_BOUNDS_NAMELEN);
c.low = low;
c.high = high;
c.length = len;
flan_signal(id, &c, xfer);
if (*(void **)xfer != NULL) return 1;
/* A descriptor for one of the runtime's own conditions, on the caller's
* stack; [chain] is the caller's too, two entries long. */
static void rt_condesc(flan_condesc *d, uint32_t chain[2], const uint8_t *name,
int64_t namelen, const char *message,
const uint8_t *loc, int64_t loclen) {
chain[0] = flan_name_id(name, namelen);
chain[1] = flan_name_id(flan_error_name, FLAN_ERROR_NAMELEN);
d->name = name;
d->namelen = namelen;
d->message = (const uint8_t *)message;
d->messagelen = (int64_t)strlen(message);
d->chain = chain;
d->chainlen = 2;
d->loc = loc;
d->loclen = loclen;
}
/* With nothing answering [d], stand in the break loop with the site and the
* sentence, which the caller has formatted after the walk and before this —
* after, because a handler the walk ran may have stopped on something of its
* own and written over it. Returns nonzero if the break loop transferred, in
* which case the caller returns and its caller's guard carries the transfer
* out. */
static int rt_error_break(const flan_condesc *d, void *condition, void *xfer) {
if (flan_break_hook != NULL) {
flan_break_site = loc;
flan_break_site_len = loclen;
flan_break_hook(flan_bounds_name, FLAN_BOUNDS_NAMELEN, &c, xfer);
flan_break_site = NULL;
flan_break_site_len = 0;
if (*(void **)xfer != NULL) return 1;
flan_break_site = d->loc;
flan_break_site_len = d->loclen;
flan_break_hook(d->name, d->namelen, condition, xfer);
if (*(void **)xfer != NULL) { rt_break_clear(); return 1; }
}
return 0;
}
/* Which of the three sentences a BoundsError is told with. */
enum { BOUNDS_AT, BOUNDS_SLICE, BOUNDS_PROMISE };
static void promise_sentence(int64_t n);
static int flan_bounds_signal(const uint8_t *loc, int64_t loclen, void *xfer,
int kind, int64_t low, int64_t high,
int64_t len) {
flan_bounds_cond c;
flan_condesc d;
uint32_t chain[2];
c.low = low;
c.high = high;
c.length = len;
rt_condesc(&d, chain, flan_bounds_name, FLAN_BOUNDS_NAMELEN,
"an index or a range is out of bounds", loc, loclen);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return 1;
if (kind == BOUNDS_AT) bounds_sentence(low, len);
else if (kind == BOUNDS_SLICE) slice_sentence(low, high, len);
else promise_sentence(high);
return rt_error_break(&d, &c, xfer);
}
void flan_bounds_error(const uint8_t *loc, int64_t loclen, int64_t idx,
int64_t len, void *xfer) {
if (flan_bounds_signal(loc, loclen, xfer, idx, idx, len)) return;
if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_AT, idx, idx, len)) return;
flan_bounds_fail(loc, loclen, idx, len);
}
void flan_slice_error(const uint8_t *loc, int64_t loclen, int64_t lo,
int64_t hi, int64_t len, void *xfer) {
if (flan_bounds_signal(loc, loclen, xfer, lo, hi, len)) return;
if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_SLICE, lo, hi, len)) return;
flan_slice_fail(loc, loclen, lo, hi, len);
}
@ -973,19 +1125,21 @@ void flan_slice_error(const uint8_t *loc, int64_t loclen, int64_t lo,
* violated condition written as a range, which is what those fields can carry.
* Deliberately not (0, n, n) — that reads as a range in bounds, and a handler
* testing high <= length would wave the failure through. */
static void promise_sentence(int64_t n) {
rt_sentence("slice-from-ptr was promised %lld elements behind the pointer, "
"and a count is never negative", (long long)n);
}
_Noreturn void flan_slice_promise_fail(const uint8_t *loc, int64_t loclen,
int64_t n) {
rt_flush_out();
fprintf(stderr,
"%.*s: slice-from-ptr was promised %lld elements behind the "
"pointer, and a count is never negative\n",
(int)loclen, (const char *)loc, (long long)n);
promise_sentence(n);
rt_print_sentence(loc, loclen);
rt_die();
}
void flan_slice_promise_error(const uint8_t *loc, int64_t loclen, int64_t n,
void *xfer) {
if (flan_bounds_signal(loc, loclen, xfer, 0, n, 0)) return;
if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_PROMISE, 0, n, 0)) return;
flan_slice_promise_fail(loc, loclen, n);
}
@ -1042,20 +1196,16 @@ typedef struct { int32_t op; int64_t lhs, rhs; } flan_arith_cond;
static const uint8_t flan_arith_name[] = "ArithError";
#define FLAN_ARITH_NAMELEN 10
/* The sentence each code gets when nothing answered. It is separate from the
* struct because the condition deliberately carries no rendered message:
* formatting is the unhandled path's job, and this is the unhandled path. */
static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op,
int64_t lhs, int64_t rhs) {
rt_flush_out();
/* The sentence each code gets, with its values in it — for the break loop
* and for stderr when nothing answered. Separate from the struct because the
* condition deliberately carries no rendered message. */
static void arith_sentence(int32_t op, int64_t lhs, int64_t rhs) {
switch (op) {
case FLAN_ARITH_DIV_ZERO:
fprintf(stderr, "%.*s: divide by zero: (/ %lld 0)\n", (int)loclen,
(const char *)loc, (long long)lhs);
rt_sentence("divide by zero: (/ %lld 0)", (long long)lhs);
break;
case FLAN_ARITH_REM_ZERO:
fprintf(stderr, "%.*s: remainder by zero: (%% %lld 0)\n", (int)loclen,
(const char *)loc, (long long)lhs);
rt_sentence("remainder by zero: (%% %lld 0)", (long long)lhs);
break;
/* Worth its own sentence rather than sharing the word "overflow", because
* the reader who hits it has probably never had to think about this case:
@ -1063,62 +1213,71 @@ static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op,
* overflows, and it overshoots by exactly one. */
case FLAN_ARITH_DIV_OVERFLOW:
case FLAN_ARITH_REM_OVERFLOW:
fprintf(stderr,
"%.*s: (%s %lld %lld) overflows — the quotient is one past the "
"largest value the type holds\n",
(int)loclen, (const char *)loc,
op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs,
(long long)rhs);
rt_sentence("(%s %lld %lld) overflows — the quotient is one past the "
"largest value the type holds",
op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs,
(long long)rhs);
break;
/* NaN and the infinities did not overshoot the range: no integer is
* their value, whatever the type. Saying "does not fit" reads as too big. */
case FLAN_ARITH_CAST_NAN:
fprintf(stderr,
"%.*s: this value is NaN, which has no integer value to cast to\n",
(int)loclen, (const char *)loc);
rt_sentence("this value is NaN, which has no integer value to cast to");
break;
case FLAN_ARITH_CAST_INF:
fprintf(stderr,
"%.*s: this value is infinite, which has no integer value to cast "
"to\n",
(int)loclen, (const char *)loc);
rt_sentence("this value is infinite, which has no integer value to cast "
"to");
break;
/* An unsigned type's range starts at zero and a signed one's below it, so
* the lower bound says how to read the upper one: u64's is all ones. */
default:
if (lhs == 0)
fprintf(stderr,
"%.*s: this value does not fit the integer type it is cast to, "
"which holds [0 %llu]\n",
(int)loclen, (const char *)loc, (unsigned long long)rhs);
rt_sentence("this value does not fit the integer type it is cast to, "
"which holds [0 %llu]", (unsigned long long)rhs);
else
fprintf(stderr,
"%.*s: this value does not fit the integer type it is cast to, "
"which holds [%lld %lld]\n",
(int)loclen, (const char *)loc, (long long)lhs, (long long)rhs);
rt_sentence("this value does not fit the integer type it is cast to, "
"which holds [%lld %lld]", (long long)lhs, (long long)rhs);
break;
}
rt_die();
}
/* The same, with no values in it: what a handler for Error reads as the
* message. Static, because a handler-case carries it past the frame that
* signalled. */
static const char *arith_message(int32_t op) {
switch (op) {
case FLAN_ARITH_DIV_ZERO: return "divide by zero";
case FLAN_ARITH_REM_ZERO: return "remainder by zero";
case FLAN_ARITH_DIV_OVERFLOW:
return "a division overflows: the quotient is one past the largest value "
"the type holds";
case FLAN_ARITH_REM_OVERFLOW:
return "a remainder overflows: the quotient is one past the largest value "
"the type holds";
case FLAN_ARITH_CAST_NAN:
return "a NaN has no integer value to cast to";
case FLAN_ARITH_CAST_INF:
return "an infinity has no integer value to cast to";
default:
return "a value does not fit the integer type it is cast to";
}
}
void flan_arith_error(const uint8_t *loc, int64_t loclen, int32_t op,
int64_t lhs, int64_t rhs, void *xfer) {
flan_arith_cond c;
uint32_t id = flan_name_id(flan_arith_name, FLAN_ARITH_NAMELEN);
flan_condesc d;
uint32_t chain[2];
c.op = op;
c.lhs = lhs;
c.rhs = rhs;
flan_signal(id, &c, xfer);
rt_condesc(&d, chain, flan_arith_name, FLAN_ARITH_NAMELEN, arith_message(op),
loc, loclen);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return;
if (flan_break_hook != NULL) {
flan_break_site = loc;
flan_break_site_len = loclen;
flan_break_hook(flan_arith_name, FLAN_ARITH_NAMELEN, &c, xfer);
flan_break_site = NULL;
flan_break_site_len = 0;
if (*(void **)xfer != NULL) return;
}
flan_arith_fail(loc, loclen, op, lhs, rhs);
arith_sentence(op, lhs, rhs);
if (rt_error_break(&d, &c, xfer)) return;
rt_print_sentence(loc, loclen);
rt_die();
}
/* ── Allocators, spec-memory.md ────────────────────────────────────────
@ -1548,10 +1707,9 @@ flan_allocator *flan_arena_new(int64_t cap) {
static void *flan_destroyed_proc(flan_allocator *a, int32_t mode, void *p,
int64_t old_size, int64_t size, int64_t align) {
(void)a; (void)mode; (void)p; (void)old_size; (void)size; (void)align;
rt_flush_out();
fprintf(stderr,
"this allocator was destroyed by arena-destroy, so nothing can be "
"allocated from it or released through it\n");
flan_say(NULL, 0,
"this allocator was destroyed by arena-destroy, so nothing can be "
"allocated from it or released through it");
rt_trap((const uint8_t *)"DestroyedAllocator", 18);
}
@ -1630,20 +1788,15 @@ void flan_alloc_free_all(flan_allocator *a, const uint8_t *loc, int64_t loclen)
}
_Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: this allocator is null — a zeroed Allocator was never given "
"one\n",
(int)loclen, (const char *)loc);
flan_say(loc, loclen,
"this allocator is null — a zeroed Allocator was never given one");
rt_trap((const uint8_t *)"NullAllocator", 13);
}
_Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: this allocator does not offer free-all — it has no region "
"to release\n",
(int)loclen, (const char *)loc);
flan_say(loc, loclen,
"this allocator does not offer free-all — it has no region to "
"release");
rt_trap((const uint8_t *)"NoFreeAll", 9);
}
@ -1942,7 +2095,8 @@ void *flan_vec_at(flan_vec *v, int32_t i, int64_t size, const uint8_t *loc,
/* The same unsigned comparison the fixed-array bounds check uses: a negative
* index sign-extends to a huge unsigned and is caught by the one test. */
if ((uint64_t)(int64_t)i >= (uint64_t)v->len) {
if (flan_bounds_signal(loc, loclen, xfer, (int64_t)i, (int64_t)i, v->len))
if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_AT, (int64_t)i, (int64_t)i,
v->len))
return NULL;
flan_vec_bounds_fail(loc, loclen, (int64_t)i, v->len);
}
@ -1960,7 +2114,8 @@ void flan_vec_as_slice(flan_vec *v, void *out, int32_t lo, int32_t hi,
/* Both ends, because both are what went wrong — the fixed-array slice
* check reports the same pair. [out] is left untouched on the transfer
* path; the caller's guard branches before it reads the slice. */
if (flan_bounds_signal(loc, loclen, xfer, l, h, v->len)) return;
if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_SLICE, l, h, v->len))
return;
flan_vec_bounds_fail(loc, loclen, l, v->len);
}
s.p = (uint8_t *)v->ptr + l * size;

7
spec-conditions.md
View File

@ -4,8 +4,11 @@ Status: **frozen** for the six hard cases below. Everything not listed here is
still open, but nothing in the implementation may depend on the unlisted parts.
Four operators: `handler-bind`, `handler-case`, `restart-case`, `invoke-restart`.
No condition class hierarchy — condition types are structs, matching is by type
plus an optional predicate.
No condition class hierarchy — condition types are structs, matching is by type,
and a type may name one parent (`(defstruct FileError :parent Error [...])`), so
a handler for a type answers every condition below it in that static chain. A
handler matched through a parent is handed the condition's name and sentence
(the root `Error`'s two fields), not the condition's own fields.
## 1. `signal` returns `()`

2
test/programs/arith-condition.flan
View File

@ -47,7 +47,7 @@
(defonce frames i64)
(defonce skipped i64)
(defonce cleaned i64)
(defonce op i32)
(defonce op ArithOp)
(defonce lhs i64)
(defonce rhs i64)

59
test/programs/condition-parents.flan Normal file
View File

@ -0,0 +1,59 @@
;;;; A condition type names its parent, and a handler for a type answers every
;;;; condition below it. Error is the root every built-in error descends from,
;;;; so one handler for it catches a bad index, an arithmetic failure and a
;;;; program's own error alike — and is handed the name and the runtime's
;;;; sentence, not the fields, since its type is the parent's.
;; A category: a parent with no field vector, which gets Error's two fields.
(defstruct IoError :parent Error)
(defstruct DiskFull :parent IoError [free i64])
;; A condition with no parent is matched by its own type and nothing else.
(defstruct Loner [n i32])
(defonce zero i64)
(defonce grid [4 i32])
(defn risky [n i32] i32
(cond
(= n 0) (i32 (/ 10 zero))
(= n 1) (at grid (+ n 5))
(= n 2) (do (error (DiskFull {.free 7})) 0)
:else n))
;; The catch-all. The clause runs after the unwind, so the name and the
;; sentence it prints are copies that outlived the frame that signalled.
(defn guarded [n i32] i32
(handler-case (risky n)
[(Error [e]
(println (.name e))
(println (.message e))
-1)]))
(defn main [] i32
(println (guarded 0))
(println (guarded 1))
(println (guarded 2))
(println (guarded 3))
;; A handler for the middle of the chain.
(println (handler-case (risky 2) [(IoError [e] (println (.name e)) -2)]))
;; A handler for the condition's own type still reads its fields, and is
;; the innermost, so it answers first.
(println
(handler-case
(handler-case (risky 2) [(DiskFull [d] (i32 (.free d)))])
[(Error [_e] -3)]))
;; A non-unwinding handler for Error sees the same two fields while the
;; signalling frame is alive, and the handler for ArithError inside it
;; reads the op as the enum it is.
(println
(handler-case
(handler-bind [(Error [e] (println (.message e)))]
(handler-bind [(ArithError [a] (println (= (.op a) :div-zero)))]
(risky 0)))
[(ArithError [_a] -4)]))
;; A condition outside the chain is not an Error.
(println
(handler-case
(handler-case (do (error (Loner {.n 1})) 0) [(Error [_e] -5)])
[(Loner [l] (.n l))]))
0)

11
test/programs/dev-trap-dyn.flan Normal file
View File

@ -0,0 +1,11 @@
;;;; A dyn type mismatch is a trap, with no struct behind it: what it refused
;;;; is the sentence the runtime wrote, which the break loop carries to the
;;;; editor in place of fields.
(import agent "vendor:agent")
(defn add [x dyn y dyn] dyn (+ x y))
(defn main [] i32
(agent/start "/tmp/flan-dev-trap-dyn-fallback.sock")
(add 3 "hi")
0)

17
test/test_acceptance.ml
View File

@ -2799,6 +2799,23 @@ let () =
outputs ~dev:true "arithmetic with no answer is a condition, dev"
"programs/arith-condition.flan" arith_cond_out;
(* A handler for a parent answers every condition below it, and is handed
the name and the sentence rather than the fields. The empty line is
DiskFull's sentence: a program's own condition says what it is in its
fields. *)
let parents_out =
"ArithError\ndivide by zero\n-1\n\
BoundsError\nan index or a range is out of bounds\n-1\n\
DiskFull\n\n-1\n3\nDiskFull\n-2\n7\n\
true\ndivide by zero\n-4\n1\n"
in
outputs "conditions have a parent link" "programs/condition-parents.flan"
parents_out;
outputs ~x86:true "conditions have a parent link, --x86"
"programs/condition-parents.flan" parents_out;
outputs ~dev:true "conditions have a parent link, dev"
"programs/condition-parents.flan" parents_out;
(* And the half that finishes that thought. bounds-condition.flan's last
line is `10 99 12 13` — an abandoned frame's leftovers — and a restart
undoes none of it, because a restart is not a transaction

57
test/test_dev.ml
View File

@ -1383,13 +1383,14 @@ let () =
l
| _ -> []
in
(* op 0 is FLAN_ARITH_DIV_ZERO; lhs is the dividend and rhs the
divisor, which is the pair the unhandled message prints. Each
read at its own offset, so an i32 followed by two i64s is the
layout both ends have to agree on. *)
(* op is ArithOp, an i32 at run time, and 0 is :div-zero; lhs is the
dividend and rhs the divisor, which is the pair the unhandled
message prints. Each read at its own offset, so an i32 followed
by two i64s is the layout both ends have to agree on. *)
if
fields
<> [ ("op", "i32", "0"); ("lhs", "i64", "1"); ("rhs", "i64", "0") ]
<> [ ("op", "ArithOp", ":div-zero"); ("lhs", "i64", "1");
("rhs", "i64", "0") ]
then
fail "ArithError's rendered fields: %s"
(String.concat ", "
@ -1403,6 +1404,12 @@ let () =
| Some site when contains_sub site "dev-break.flan:" && site.[0] = '/' -> ()
| Some site -> fail "the arith site points at %s" site
| None -> fail "a division by zero carries no :site");
(* And the runtime's sentence, which says what op 0 and the two
operands mean. *)
(match Wire.string_field (ask "(:op \"break\")") "sentence" with
| Some "divide by zero: (/ 1 0)" -> ()
| Some s -> fail "the arith sentence is %S" s
| None -> fail "a division by zero carries no :sentence");
let r = ask "(:op \"restart\" :name \"use-zero\")" in
if status r <> "ok" then
fail "resuming past a division by zero: %s"
@ -1660,12 +1667,14 @@ let () =
in
if status r <> "error" then
fail "an expression that stopped inside the bounds break answered anyway";
(* Its site is its own (error ...), in the evaluated buffer. *)
(let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break inside the bounds break: %s" (status r)
else
match Wire.string_field r "site" with
| None -> ()
| Some site -> fail "the inner break inherited the trap's site: %s" site);
| Some site when contains_sub site "/tmp/buf.flan:" -> ()
| Some site -> fail "the inner break inherited the trap's site: %s" site
| None -> fail "the inner break's (error ...) carried no site");
let r = ask "(:op \"restart\" :name \"back\")" in
if status r <> "ok" then
fail "resuming the inner break: %s"
@ -1674,7 +1683,10 @@ let () =
if not
(await (fun () ->
let r = ask "(:op \"break\")" in
status r = "ok" && Wire.string_field r "site" <> None))
status r = "ok"
&& (match Wire.string_field r "site" with
| Some site -> contains_sub site "dev-break-bounds.flan:"
| None -> false)))
then fail "the outer bounds break lost its site after the inner one";
(* And the payoff: taking it resumes, which is the difference between a
stop you can recover from and a dead session. *)
@ -1792,7 +1804,8 @@ let () =
standalone half of the same claim is test_acceptance.ml's
free-all-refused, which still exits 134: nothing installs the hook in a
program that did not import the agent. *)
let trap_park ?(refault = false) ?(trapping = "") what prog cond restarts =
let trap_park ?(refault = false) ?(trapping = "") ?(sentence = "") what prog
cond restarts =
let tsock = tmp (prog ^ ".sock") and tout = tmp (prog ^ ".out") in
(try Sys.remove tsock with Sys_error _ -> ());
let tfd =
@ -1855,6 +1868,12 @@ let () =
like it had been unwound. *)
let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break at the %s trap: %s" what (status r);
(* A trap has no fields; what it refused is its sentence. *)
if sentence <> "" then
(match Wire.string_field r "sentence" with
| Some s when contains_sub s sentence -> ()
| Some s -> fail "the %s trap's sentence is %S" what s
| None -> fail "the %s trap carried no :sentence" what);
(match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ } ->
let names =
@ -2032,9 +2051,13 @@ let () =
end
end
in
trap_park "free-all" "dev-trap-free-all.flan" "NoFreeAll" [ "continue" ];
trap_park ~trapping:"(do (free-all nowhere) 0)" "null allocator"
trap_park ~sentence:"does not offer free-all" "free-all"
"dev-trap-free-all.flan" "NoFreeAll" [ "continue" ];
trap_park ~sentence:"this allocator is null"
~trapping:"(do (free-all nowhere) 0)" "null allocator"
"dev-trap-null-alloc.flan" "NullAllocator" [];
trap_park ~sentence:"dyn +: int and text"
"dyn type" "dev-trap-dyn.flan" "DynType" [];
(* And the one that used to be a silent death rather than an exit code:
SIGSEGV. The author's dogfooding session sorted (bytes "INSERTIONSORT")
in place — the old aliasing bytes — and the session vanished without a
@ -5786,13 +5809,13 @@ let () =
{ Form.v = Form.Str "i32"; _ };
{ Form.v = Form.Str "7"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "x86 condition did not render (Boom {.why 7})");
(* And a user [error] carries no site — there is no trapping
expression behind it — which is the same answer LLVM gives. Said
rather than left untested: the site is absent here for a reason,
not because this backend cannot produce one. *)
(* And a user [error] carries its own site, the (error ...) in
[look], which is the same answer LLVM gives: the descriptor the
signal passes holds it on both backends. *)
(match Wire.string_field (request c "(:op \"break\")") "site" with
| None -> ()
| Some site -> fail "an x86 user error carried a site: %s" site);
| Some site when contains_sub site "dev-locals.flan:" -> ()
| Some site -> fail "an x86 user error's site is %s" site
| None -> fail "an x86 user error carried no site");
if status r <> "ok" then fail "x86 backtrace: %s" (said r)
else
(match frames with

30
test/test_flan.ml
View File

@ -3307,6 +3307,30 @@ let () =
(* The rule the blanket one could not express, both ways round. A loop
wholly inside a restart-case body keeps its local break; a break that
would *leave* the restart-case is refused, and says so. *)
(* A condition's parent. A parent has exactly Error's two fields, because a
handler for it is handed the name and the sentence and not the fields. *)
accepts "a condition may name Error as its parent"
"(defstruct Oops :parent Error [n i32]) (defn f [] () (error (Oops {.n 1})))";
accepts "a category with no field vector gets Error's fields"
"(defstruct Io :parent Error) (defstruct Full :parent Io [n i32]) \
(defn f [e Io] string (.message e))";
accepts "the suggested category spelling compiles"
"(defstruct Category :parent Error)";
rejects_check "a parent with fields of its own is refused"
"(defstruct Oops :parent Error [n i32]) (defstruct Worse :parent Oops [m i32])"
~needle:"Worse names Oops as its parent, and Oops has fields of its own";
rejects_check "a parent that is not a struct is refused"
"(defstruct Oops :parent i32 [n i32])"
~needle:"a parent is a condition struct";
rejects_check "a condition cannot be its own parent"
"(defstruct Oops :parent Oops)" ~needle:"cannot be its own parent";
rejects_check "a chain of parents that loops is refused"
"(defstruct A :parent B) (defstruct B :parent A)"
~needle:"a chain of parents has to end";
parse_rejects "a parent comes before the fields"
"(defstruct Oops [n i32] :parent Error)"
~needle:"(defstruct Name :parent Parent [field Type ...])";
(* SBCL's placement for a clause's report: after the parameters. *)
accepts "a restart clause may carry a :report sentence"
"(defn f [] i64 (restart-case 1 (retry [] :report \"Try again\" (do) 2)))";
@ -4248,7 +4272,7 @@ let () =
let known_structs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None)
match d.Ast.d with Ast.Defstruct (n, _, _) -> Some n | _ -> None)
ds
and known_unions =
List.filter_map
@ -4341,7 +4365,7 @@ let () =
let known_structs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None)
match d.Ast.d with Ast.Defstruct (n, _, _) -> Some n | _ -> None)
fixture_ds
and known_unions =
List.filter_map
@ -4513,7 +4537,7 @@ let () =
let structs_of ds =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None)
match d.Ast.d with Ast.Defstruct (n, fs, _) -> Some (n, fs) | _ -> None)
ds
in
check "a defstruct that matches the header is not reported"

36
vendor/agent/flan_agent.c vendored
View File

@ -331,6 +331,10 @@ extern void flan_restart_take(void *frame, void *xfer);
* thread the trap stopped. */
extern const uint8_t *flan_break_site;
extern int64_t flan_break_site_len;
/* And the sentence the runtime wrote about the stop — what the condition's
* fields mean, or what a trap with no fields refused — under the same rule. */
extern char flan_break_sentence[];
extern int64_t flan_break_sentence_len;
/* A restart frame with no Flan function under it, which is what the boundary
* below is made of. The storage belongs to flan_rt.c for the reason the
* shadow-stack frame's shape does: the struct is declared in one file. */
@ -559,6 +563,10 @@ typedef struct {
* Empty for a stop with no site — a user (error ...), a (pause). */
int32_t sitelen;
char site[512];
/* The runtime's sentence about the stop, copied and consumed with the
* site. Empty for a stop whose condition says what it is in its fields. */
int32_t sentencelen;
char sentence[512];
} snapshot;
/* One per nested break loop, because an inner break must not answer with the
@ -672,6 +680,18 @@ static int snap_push(int resumable, void *cond) {
flan_break_site = NULL;
flan_break_site_len = 0;
}
s->sentencelen = 0;
if (flan_break_sentence_len > 0) {
int64_t k = flan_break_sentence_len;
if (k > (int64_t)sizeof s->sentence) k = (int64_t)sizeof s->sentence;
memcpy(s->sentence, flan_break_sentence, (size_t)k);
/* One line on the wire: a newline in it would end the reply early. */
for (int64_t i = 0; i < k; i++)
if (s->sentence[i] == '\n' || s->sentence[i] == '\r')
s->sentence[i] = ' ';
s->sentencelen = (int32_t)k;
flan_break_sentence_len = 0;
}
s->total = n;
s->used = 0;
s->tused = 0;
@ -911,6 +931,10 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
* when none of it can be taken — and because the same names come back
* from a `restarts' query, and the terminal and the socket must not be
* describing two different programs. */
/* The runtime's sentence, under the name. A trap has printed its own
* already, just above; a signalled condition has not. */
if (s->resumable && s->sentencelen > 0)
fprintf(stderr, " %.*s\n", (int)s->sentencelen, s->sentence);
if (!s->resumable)
fprintf(stderr,
" nothing here can be resumed into; read the frame, then fix "
@ -1298,6 +1322,18 @@ static void handle_line(char *line, sink *o) {
reply(o, "\n");
return;
}
/* The runtime's sentence about the stop, on one line, or [-] for a stop
* that has none: a program's own condition, which says what it is in its
* fields, and a (pause). */
if (strcmp(line, "sentence") == 0) {
if (!(atomic_load(&depth) > 0)) { reply(o, "err not stopped\n"); return; }
snapshot *s = snap_top();
if (s == NULL) { reply(o, "err no snapshot\n"); return; }
if (s->sentencelen > 0) emit(o, s->sentence, (size_t)s->sentencelen);
else reply(o, "-");
reply(o, "\n");
return;
}
/* One line per restart, innermost first: the index it is taken by, a flag
* for whether it can be taken at all, and the name. The index leads
* because it is the identity - two frames can offer [retry] and only one