diff --git a/TODO.org b/TODO.org index 867e46b1..72d9a41b 100644 --- a/TODO.org +++ b/TODO.org @@ -630,12 +630,6 @@ generic binding — saying =$= marks a type variable and naming the bare spelling. A =defn= parameter was already refused, as a type in a name slot. -** NEXT A container parameter the function grows is warned at -Decided 2026-09-25: Odin's behaviour stays — a Vec or Map passed by value is a -copy of its header, so growth inside the callee does not reach the caller. A -parameter the function grows (push, put, reserve, anything that can reallocate) -gets a warning at the parameter suggesting (Ptr ...). - ** CANCELLED not= as a spelling of != CLOSED: [2026-09-25] One spelling for one operation; != stays, and not= is refused with a suggestion @@ -680,14 +674,6 @@ A machine-type target needs =numeric?=; an enum target needs =integer?=; by what it claims, not by the set it happens to denote this week — which is why =ordered?= is refused even though every type it admits today converts. -** NEXT There is now no generic enum to integer conversion -Decided 2026-09-25: build =enum?= as described. -Recorded as a loss. The one spelling that worked did so by not asking about the -operand at all, so removing it was still right. =enum?= is the eventual answer — -it would entail =ordered?= and =equal?= and not =numeric?=, so the cast rule -becomes a disjunction and the refusal has to name whichever the reader meant. Each -part of that is a decision and the author has not been asked. - ** DONE The Ptr and union arms of the fill boundary are relaxable CLOSED: [2026-09-25] A =Ptr= may be byte-filled, and an untagged union is filled over its whole @@ -856,34 +842,12 @@ CLOSED: [2026-09-20] typed conditions stay strict =bool=. =and= and =or= hand back the operand that decided them, Clojure's rule, through a desugaring that evaluates each test once. -** NEXT A bool arm and a dyn arm joining as dyn -Decided 2026-09-25: they join as =dyn=, the =bool= boxed — Clojure's rule, so =(or false (box "s"))= answers ="s"=. -With both arms of a desugared =and=/=or= holding real values, a non-bool =dyn= on -the losing side meets the strict =bool= boundary and traps — -=(or false (box "s"))= is the case. Whether a =bool= arm and a =dyn= arm should -join as =dyn= is the author's call and is not settled. - -** NEXT A truthiness failure re-runs the whole failing subtree -Decided 2026-09-25: fix it without changing any message — the retry reuses what the first pass settled for each subtree (memoised by node), so nested =not= is linear. Test with a deep nest that must fail fast and with the existing message tests unchanged. -The retry exists to keep a refused literal's message unchanged and re-runs the -subtree rather than the leaf, which is exponential in nested =not= depth on a -program that does not type-check. Moot for anything that compiles; only the -daemon's half-typed recompiles could feel it. A cheaper retry was tried and -shelved because it changes which literal gets the nicer message. - ** DONE and's last operand gets a misdirected caret CLOSED: [2026-09-25] Already fixed by 3672da2, which blames the arm that is not a compiler temp; the caret is on the last operand and =test/test_flan.ml= asserts its column. Rules out relabelling the else arm, a bool sentinel, and inverting the condition. -** NEXT Signature pairing's cold-rebuild edge -Decided 2026-09-25: the type takes precedence, as today. The warning is at the parameter site: where a name in a parameter vector is read as a program-declared type but could also have been read as a parameter name, the parameter vector gets a warning naming the type and where it is declared. -Whether a parameter vector reads as one annotated parameter or two dyn ones -depends on what type names exist, so adding a type can silently re-pair an -existing signature between compiles. A changed-pairing warning was proposed and -not queued. - ** DONE A typed container crosses into dyn as a view, and only from permanent storage CLOSED: [2026-09-20] The descriptor is pointer, length and element type — a slice plus the piece a @@ -1006,13 +970,10 @@ at all, which is what the diagnosis predicted. A =map= that *changes* the elemen type is the one shape that did not come with them: one copy per ordered pair of types rather than per type. -** NEXT CFn in a struct or a fixed array -Decided 2026-09-25: allowed. A call through a null =CFn= is a named runtime condition on both backends, and parks in a dev build. -A zeroed function value is a null pointer, so a function value is refused in any -position zero-initialisation would conjure one — =CFn= included. An =(Option -(CFn ...))= field is already legal. A table of function pointers is exactly what -=CFn= is for, and the objection is about zero-initialisation rather than about -capture. +** DONE CFn in a struct or a fixed array +CLOSED: [2026-09-25] +A zeroed =CFn= is admitted everywhere and a call through a null one signals +=NullCall= before its arguments run. =(Fn ...)= stays refused in those positions. ** DONE Structural compatibility is identical layout Same fields, same types, same order, so structural compatibility is "the same @@ -1655,12 +1616,6 @@ a defcustom. The agent keeps the condition pointer beside its name and a verb hands it back, so the editor can render the condition's own fields rather than only its class. -** NEXT The type identity of a local is not qualified -Decided 2026-09-25: a local's type prints package-qualified in the break buffer and the inspector, as a field's and a condition's already do. -Settled for conditions and for structs, because =Load= qualifies every declaration -at import. Still open for locals, where the debug information gives a bare name and -nothing qualifies it. - ** NEXT The render-thunk-per-inspection design Decided 2026-09-25: the inspector reads a value through the type layouts the compiler records, with no compile per inspection, which lets it hold a value. An inspection still compiles a thunk per request. A redesign rather than a @@ -1930,21 +1885,6 @@ CLOSED: [2026-09-25] =put= on an instance still checks a declared slot's type and still inserts an undeclared key; only =set= refuses one, since a slot it writes has to exist. -** NEXT update: change a place by applying a function to it -Decided 2026-09-25: every place evaluates each of its subexpressions once, C's compound-assignment rule, which also fixes =++= and =--=; =update= is built on that. Rules out refusing side effects in a place. -=(set (.velocity g) (inc (.velocity g)))= names the place twice. Clojure's -=update= would be a macro over the same two steps, for a struct field and a -class slot alike. - -Blocked on the double-evaluation question, which =++=, =--= and any -compound assignment share: =(update (at grid (next-index) c) inc)= evaluates -=(next-index)= twice, and a place with a side effect is then wrong rather than -slow. Either places get a general single-evaluation rule — bind every -subexpression of a place to a temp once, which is what C's compound assignment -does — or the language says a place must be side-effect free and refuses -otherwise. The first is the real fix and it is a change to how every place -lowers, not to one macro. - ** TODO A session eval reported (CFn [] ()) does not cross into dyn yet At =sand.flan:46:20=, the =:pause= in =(when (get state :pause) (return))=, where =state= is a =defclass= instance with a =pause= slot. =(CFn [] ())= is diff --git a/docs/BUILT.md b/docs/BUILT.md index 2a4071b0..5a8a18b8 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -3890,7 +3890,7 @@ before this landed, so `macro-unless.flan` is a test written after the feature. ### The line between a special form and a macro A form the prelude itself relies on is built into the parser: `cond`, `when` and `dotimes`. A form only programs use -is a prelude macro: `inc`, `++`, `into`, `unless`, `until` and `comment`. The reason is `Macro.reduce`: a prelude +is a prelude macro: `inc`, `++`, `update`, `into`, `unless`, `until` and `comment`. The reason is `Macro.reduce`: a prelude function that calls a macro is left out of the module that runs macros, so a form the prelude's own functions use cannot be a macro without taking those functions away from every macro body. `until` peels an optional leading label and answers `(while :label (not test) body ...)`. @@ -4339,8 +4339,9 @@ implemented. refusal's witness now runs. The escape refusal that replaced it is gone too; see "Escape: only an escaping closure's environment is the collector's".* - **An `fn` with nothing to say what it takes** (`fn-no-type.flan`), above. -- **A position that would zero one** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element, - `(zeroed)`. ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which +- **A position that would zero an `(Fn ...)`** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element, + `(zeroed)`. A `(CFn ...)` is admitted in all four: every call through one tests for null and signals `NullCall` + (`fn-cfn-table.flan`). ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which is the one kind of zero that is not a value the type can have** — every other type's zero is one: `0`, `false`, an empty slice, `None`, a union's first case. A parameter, a return type and a `let` binding are not on the list because none of them is ever conjured, and an `(Option (Fn ...))` is not either, because a `None`'s tag is what diff --git a/lib/check.ml b/lib/check.ml index f0c7d623..aede389e 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -891,18 +891,24 @@ let no_such_rand name = Odin's [where] clause is the same shape ([core/slice/slice.odin:289] is [where intrinsics.type_is_ordered(T)]) with forty-one predicates against - these five. There is no [copyable?] any more and no Odin counterpart + these six. There is no [copyable?] any more and no Odin counterpart either: Odin has no move semantics, and since the repeal neither does this language, so [$T] never has to answer the question. - [integer?] is the narrowest of the five and exists because [numeric?] was + [integer?] is the narrowest numeric bound and exists because [numeric?] was one type too wide for a family of bodies: an integer body under [numeric?] is instantiated at f32 and f64 too, and (if (< x 0) (- 0 x) x) at -0.0 is the wrong abs while %, the bitwise operators and the shifts have no float meaning at all. A function that can be generalized should not need a variant per numeric type, and [integer?] is what lets the integer-only - ones say exactly what they need. *) -let predicate_names = [ "ordered?"; "equal?"; "hashable?"; "numeric?"; "integer?" ] + ones say exactly what they need. + + [enum?] admits exactly the enums. It entails [ordered?] and [equal?] and + not [numeric?]: an enum compares, and it converts to a number, but it is + not one — no arithmetic, no literal. It is what licenses the generic + enum-to-number conversion, beside [numeric?]. *) +let predicate_names = + [ "ordered?"; "equal?"; "hashable?"; "numeric?"; "integer?"; "enum?" ] (* ── What a type owns, transitively ──────────────────────────────────── The one structural ownership question that survived the repeal, because it @@ -1041,6 +1047,7 @@ let pred_holds p (t : Types.t) = | "hashable?" -> Types.keyable t | "numeric?" -> Types.is_numeric t | "integer?" -> Types.is_integer t + | "enum?" -> (match t with Types.Enum _ -> true | _ -> false) | _ -> false (* What one declared predicate *also* gives you. These are entailments over @@ -1053,8 +1060,8 @@ let pred_holds p (t : Types.t) = let pred_entails ~declared ~wanted = String.equal declared wanted || match wanted, declared with - | "ordered?", ("numeric?" | "integer?") -> true - | "equal?", ("numeric?" | "ordered?" | "integer?") -> true + | "ordered?", ("numeric?" | "integer?" | "enum?") -> true + | "equal?", ("numeric?" | "ordered?" | "integer?" | "enum?") -> true (* Every integer type is a number, so [integer?] gives a body everything [numeric?] does — the arithmetic, the written 0, the untyped integer literal — on top of the operations only it admits. The reverse is @@ -1145,12 +1152,19 @@ let fn_sig (t : Types.t) = let callable_ty t = fn_sig t <> None +(* A (CFn ...) is not on the list: it is one code address, and every call + through one tests for null and signals NullCall (see [Emit.null_check]), so + a zeroed one is an empty slot rather than a crash. That is what lets a table + of function pointers be a struct or a fixed array. An (Fn ...) stays + refused: a call through one is not tested, and (Option (Fn ...)) is the + field that holds one. *) let rec no_zeroed_fn loc what (t : Types.t) = match t with - | Types.Fn _ | Types.CFn _ -> + | Types.Fn _ -> fail loc "%s cannot be %s — it would be zeroed, and a zeroed function value is a \ - null pointer. Pass it as a parameter, or hold it in a let" + null pointer. Pass it as a parameter, hold it in a let, or store a \ + (CFn ...) if it captures nothing" what (Types.to_string t) | Types.Array (_, e) -> no_zeroed_fn loc what e | _ -> () @@ -1635,9 +1649,37 @@ let dyn_param_or_typo env n loc = parameters are lowercase" n -let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) - : Ast.field list = - let is_type_name env n = is_type_name env n || also n in +(* The pairings a parameter vector owes to a type the program declares under + a name that is also a legal parameter name — a lowercase one, since a + capitalised name is refused as a parameter. [(defn f [p point] ...)] is one + parameter while [point] is a type and two dyn ones the moment it is not, + so adding or removing the type re-pairs the signature with no edit to it. + The type still wins; this is the warning at the parameter, filled by + [pair_decls] and printed by [build_program] with the other warnings. *) +let pairing_warnings : Loc.diag list ref = ref [] + +let pair_params ?(also = fun _ -> false) ?(declared = fun _ -> None) + ?(hide = fun _ -> false) env (items : Ast.pitem list) : Ast.field list = + let is_type_name env n = (is_type_name env n && not (hide n)) || also n in + let warn_pairing n t tloc = + let bare = + match String.rindex_opt t '/' with + | Some i -> String.sub t (i + 1) (String.length t - i - 1) + | None -> t + in + match declared t with + | Some (what, (at : Loc.t)) + when bare <> "" && bare.[0] >= 'a' && bare.[0] <= 'z' -> + pairing_warnings := + Loc.diag ~kind:"check/parameter-reads-a-type" tloc + (Printf.sprintf + "[%s %s] is one parameter %s of type %s, the %s declared at %s, \ + and not two dyn parameters. If two were meant, give the second \ + a name no type has" + n t n t what (Loc.to_string at)) + :: !pairing_warnings + | _ -> () + in let dyn loc = { Ast.t = Ast.Tname "dyn"; tloc = loc } in let rec go = function | [] -> [] @@ -1653,6 +1695,7 @@ let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) | Ast.Pname (n, loc) :: Ast.Ptype t :: rest -> { Ast.fname = n; fty = t; floc = loc } :: go rest | Ast.Pname (n, loc) :: Ast.Pname (t, tloc) :: rest when is_type_name env t -> + warn_pairing n t tloc; { Ast.fname = n; fty = { Ast.t = Ast.Tname t; tloc }; floc = loc } :: go rest (* The slot after this one is not a type, so this one is a parameter with no type written — unless the slot after it only *looks* unlike a type @@ -1782,13 +1825,42 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = match d.Ast.d with Ast.Defclass (n, _) -> Some n | _ -> None) decls in - let fn (f : Ast.fn) = + (* The types the program declares, with what kind and where, for + [pair_params]'s warning. The prelude's are left out: its names are the + language's, not a declaration the reader made. *) + let types = Hashtbl.create 16 in + List.iter + (fun (d : Ast.decl) -> + let add n what = + if d.Ast.dloc.Loc.file <> Prelude.file + && not (List.mem n Types.primitive_names) then + Hashtbl.replace types n (what, d.Ast.dloc) + in + match d.Ast.d with + | Ast.Defstruct (n, _, _) -> add n "struct" + | Ast.Defenum (n, _) -> add n "enum" + | Ast.Defalias (n, _) -> add n "alias" + | Ast.Defdata (n, _) -> add n "data type" + | Ast.Defunion (n, _) -> add n "union" + | _ -> ()) + decls; + pairing_warnings := []; + (* A prelude signature is paired against the prelude's types alone: a + program's type named [t] must not turn the prelude's parameter [t] into + a type. *) + let fn ~prelude (f : Ast.fn) = match f.Ast.praw with | None -> f - | Some items -> { f with Ast.params = pair_params env items; praw = None } + | Some items -> + let hide n = prelude && Hashtbl.mem types n in + { f with + Ast.params = + pair_params ~hide ~declared:(Hashtbl.find_opt types) env items; + praw = None } in List.map (fun (d : Ast.decl) -> + let prelude = String.equal d.Ast.dloc.Loc.file Prelude.file in match d.Ast.d with (* A class's slot vector is paired here and nowhere earlier, for the reason a [defn]'s is, and its constructor is written from the @@ -1802,9 +1874,9 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = (f.Ast.fname, slot_of env ~classes n f.Ast.fname f.Ast.fty)) slots); Classes.constructor n slots d.Ast.dloc - | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } - | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn f, c) } - | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn f, c) } + | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn ~prelude f) } + | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn ~prelude f, c) } + | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn ~prelude f, c) } | _ -> d) decls @@ -2447,6 +2519,49 @@ and const_steps ro (ty : Types.t) n = let const_copy env (e : Types.t) = if owning env e || holds_dyn env e then None else Some "(clone v)" +(* Whether (clone x) accepts a value of this type — the same arms the clone + builtin takes: a Vec or a Map whose elements own nothing, or a slice whose + elements neither own storage nor hold a dyn. *) +let clone_accepts env (t : Types.t) = + match t with + | Types.Vec _ | Types.Map _ -> not (region_only env t) + | Types.Slice (_, e) -> not (owning env e || holds_dyn env e) + | _ -> false + +(* The end of clone's refusal for a container of owning elements. Pushing + the elements themselves into a second container would copy their headers + and share their blocks, so the advice is a copy of each element where + clone takes one, and otherwise that there is no copy to make. *) +let insert_copies env (t : Types.t) = + let elem = + match t with + | Types.Vec e | Types.Slice (_, e) | Types.Map (_, e) -> Some e + | _ -> None + in + match elem with + | Some e when clone_accepts env e -> + "Build a second container and push a (clone x) of each element into it" + | Some e -> + Printf.sprintf + "Nothing copies what a %s owns either, so read the elements where they \ + are" + (Types.to_string e) + | None -> "Build a second container and insert into it" + +(* A call written back out as source, for a fix that has to repeat what the + reader wrote: names, integers and calls of those. Anything else is [None] + and the caller says the fix in words. *) +let rec spell_form (a : Ast.expr) = + match a.Ast.e with + | Ast.Var v -> Some v + | Ast.Int n -> Some (Int64.to_string n) + | Ast.UInt (_, s) -> Some s + | Ast.Call (f, args) -> + let parts = List.map spell_form (f :: args) in + if List.mem None parts then None + else Some ("(" ^ String.concat " " (List.filter_map Fun.id parts) ^ ")") + | _ -> None + (* A store through a read-only view: a [[const T]] or a (Ptr const T). *) let refuse_const_place env loc (view : Types.t) = match view with @@ -4227,6 +4342,101 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) = (* Every expression goes through here, and [check_value] is the one that knows the forms. What this adds is [refuse_owned_copy], asked of whatever came back unless the form was checked as the target of a place. *) + +(* The conditions [check_truthy] has refused, each with the body it was + checked in and its diagnostic, for as long as the outermost call is on the + stack — see [check_truthy]. Physical identity on both, since a generic's + body is the same syntax checked again at another type. *) +let truthy_failed : + (Ast.expr * (string * binding) list * Types.t * Loc.diag) list ref = ref [] + +(* Whether two scopes bind the same names at the same types, which is what a + refusal under them can depend on — the slots are fresh on every pass. A + memo keyed on less would replay a refusal after a retry changed a type. *) +let same_scope (a : (string * binding) list) (b : (string * binding) list) = + a == b + || List.equal + (fun (n, (x : binding)) (m, (y : binding)) -> + String.equal n m && Types.equal x.bty y.bty) + a b +let truthy_depth = ref 0 + +(* The same for an [if], keyed on its condition and the expectation: + an [if] whose else arm is tried on its own terms first (see [check_if]) + would otherwise be re-checked, refused, by the trial of every [if] above + it — the square of a refused or/and chain's length. *) +let if_failed : + (Loc.t, + Ast.expr * ((string * binding) list * Types.t) * Types.t option * Loc.diag) + Hashtbl.t = + Hashtbl.create 16 +let if_depth = ref 0 + + +(* A Vec or a Map parameter is a copy of the caller's header — Odin's rule — + so growing it reallocates a block only this function's copy points at, and + the caller's container never sees the elements. The function being checked + and its container parameters, by slot, and the warnings found so far, one + per parameter, printed by [build_program]. A stack because a generic's copy + is checked from inside the body that called it. *) +let grow_params : (ctx * (int * Ast.field) list) list ref = ref [] +let grow_warnings : Loc.diag list ref = ref [] + +let note_grown ctx op loc (target : Tast.expr) = + (* The parameter the container is reached from, through struct fields + taken by value — a field of a parameter is in the parameter's copy too — + and the path written back out. A [Deref] ends the walk: through a + pointer the caller's own storage is what grows. *) + let rec root (e : Tast.expr) = + match e.Tast.e with + | Tast.Local s -> Some (s, fun p -> p) + | Tast.Field (inner, i) -> + (match inner.Tast.ty with + | Types.Named n -> + (match Hashtbl.find_opt ctx.env.structs n with + | Some st when i < List.length st.Tast.fields -> + let f = (List.nth st.Tast.fields i).Tast.fname in + Option.map + (fun (s, path) -> (s, fun p -> Printf.sprintf "(.%s %s)" f (path p))) + (root inner) + | _ -> None) + | _ -> None) + | _ -> None + in + match target.Tast.ty, root target, !grow_params with + | ((Types.Vec _ | Types.Map _) as t), Some (s, path), (c, ps) :: _ when c == ctx -> + (match List.assoc_opt s ps with + | Some (p : Ast.field) + when not + (List.exists + (fun (d : Loc.diag) -> d.Loc.dloc = p.Ast.floc) + !grow_warnings) -> + let ts = Types.to_string t in + let msg = + match target.Tast.e with + | Tast.Local _ -> + Printf.sprintf + "%s is a %s passed by value, a copy of the caller's header, so \ + the %s at %s grows this function's copy and the caller's \ + container never sees it. Take it as (Ptr %s) and write (%s \ + (deref %s) ...), and each caller passes (addr c) for its \ + container c" + p.Ast.fname ts op (Loc.to_string loc) ts op p.Ast.fname + | _ -> + let pt = Types.to_string (List.nth ctx.slot_tys (ctx.slots - 1 - s)) in + Printf.sprintf + "%s is a %s passed by value, a copy of the caller's, so the %s \ + at %s grows %s in this function's copy and the caller's never \ + sees it. Take it as (Ptr %s), where %s reaches the caller's own, \ + and each caller passes (addr c) for its %s c" + p.Ast.fname pt op (Loc.to_string loc) (path p.Ast.fname) pt + (path p.Ast.fname) pt + in + grow_warnings := + Loc.diag ~kind:"check/grown-parameter" p.Ast.floc msg :: !grow_warnings + | _ -> ()) + | _ -> () + (* Recovery, when [env.recovering] is on: a subexpression that is refused is recorded and stands as a [poison] of type [Never], which fits any want, so checking carries on around it and every error in a body is reported. What @@ -6089,12 +6299,12 @@ and check_recur ctx ~tail loc args = literals gets the nicer message, not just the speed. The cost that buys is real: nested [not] on a program that does not type-check re-runs this whole function once per level of nesting inside the level above it, - which is exponential in how deep the nesting goes — moot for a program - that compiles, since neither retry ever fires, and moot for ordinary - nesting depths, but visible within a second or so around twenty levels - of a [not] wrapped in a [not] wrapped in .... The dev daemon is the one - caller that could feel this, recompiling a half-typed form on every - edit; nobody has hit it in practice and it is not fixed here. + which would be exponential in how deep the nesting goes. What keeps it + linear is [truthy_failed]: a condition this function has already refused, + in the same body, is refused again with the same diagnostic rather than + re-checked, so a retry re-walks its subtree once and stops at the first + condition below it that was settled. The message is the one the first + pass produced, so no message changes. Keywords are a separate, deliberate loss rather than a bug: a bare [:kw] used to be checked here with [want:Types.Bool] from the start, so @@ -6109,6 +6319,30 @@ and check_recur ctx ~tail loc args = test_flan.ml pins the new answer down so it is not lost again by accident. *) and check_truthy ctx c = + (* Only where a refusal is raised: while recovering, one is recorded where + it happens and the check goes on, so a replayed one would hide others. *) + if ctx.env.recovering && ctx.env.speculating = 0 then check_truthy_once ctx c + else + match + List.find_opt + (fun (n, sc, r, _) -> n == c && r == ctx.ret && same_scope sc ctx.scope) + !truthy_failed + with + | Some (_, _, _, d) -> raise (Loc.Error d) + | None -> + let scope = ctx.scope in + incr truthy_depth; + Fun.protect + ~finally:(fun () -> + decr truthy_depth; + if !truthy_depth = 0 then truthy_failed := []) + (fun () -> + try check_truthy_once ctx c + with Loc.Error d as ex -> + truthy_failed := (c, scope, ctx.ret, d) :: !truthy_failed; + raise ex) + +and check_truthy_once ctx c = let loc = c.Ast.loc in (* Speculative, because a refusal here is answered by asking again at [bool]; and that second ask is guarded, because its refusal is re-worded @@ -6163,6 +6397,30 @@ and check_truthy ctx c = | exception Loc.Error _ -> check ctx ~want:Types.Bool c and check_if ctx ?(tail = false) ?want loc c t e = + if ctx.env.recovering && ctx.env.speculating = 0 then + check_if_once ctx ~tail ?want loc c t e + else + match + List.find_opt + (fun (n, (sc, r), w, _) -> + n == c && r == ctx.ret && w = want && same_scope sc ctx.scope) + (Hashtbl.find_all if_failed c.Ast.loc) + with + | Some (_, _, _, d) -> raise (Loc.Error d) + | None -> + let scope = ctx.scope in + incr if_depth; + Fun.protect + ~finally:(fun () -> + decr if_depth; + if !if_depth = 0 then Hashtbl.reset if_failed) + (fun () -> + try check_if_once ctx ~tail ?want loc c t e + with Loc.Error d as ex -> + Hashtbl.add if_failed c.Ast.loc (c, (scope, ctx.ret), want, d); + raise ex) + +and check_if_once ctx ~tail ?want loc c t e = let c = check_truthy ctx c in (* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))] is how nearly every loop is written, and the branch is still the last @@ -6206,6 +6464,34 @@ and check_if ctx ?(tail = false) ?want loc c t e = want = None && (match t.Tast.ty with Types.Slice _ | Types.Ptr _ -> true | _ -> false) in + (* A bool arm and a dyn arm meet at dyn, the bool boxed — Clojure's rule, + so (or false (box "s")) answers "s" rather than unboxing the string at + bool and trapping. The other order already met at dyn, the then arm + deciding. So after a bool then arm the else arm is checked on its own + terms first, since checking it at bool is what unboxes it, and kept + when it is a bool or a dyn. Anything else is abandoned and checked at + bool as before, for that path's messages. A chain whose arms all fit + is checked once; a refused one re-checks each level below the refusal + once more, the square of its depth. *) + let own_else = + if want = None && t.Tast.ty = Types.Bool then + match + trial ctx (fun () -> + let v = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in + match v.Tast.ty with + | Types.Bool | Types.Dyn | Types.Never -> v + | _ -> raise (Loc.Error (Loc.diag v.Tast.loc "not bool or dyn"))) + with + | Ok v -> Some v + | Error _ -> None + else None + in + let t = + match own_else with + | Some v when v.Tast.ty = Types.Dyn -> + expect ctx t.Tast.loc ~want:(Some Types.Dyn) t + | _ -> t + in let ewant = match want with | Some _ -> want @@ -6227,6 +6513,9 @@ and check_if ctx ?(tail = false) ?want loc c t e = location; and with an expectation in hand both arms are checked against it rather than against each other, so nothing here runs. *) let e = + match own_else with + | Some v -> v + | None -> let reworded = want = None && and_sentinel e in match branch ctx (fun () -> @@ -7972,9 +8261,16 @@ and not_numeric name what (a : Tast.expr) = so that the family says it one way: a body with no clause is given the whole clause, and a body that already has one is told which predicate to add rather than a clause that would drop the ones it has. *) -and cast_operand ctx loc name ~needs ~what ~is v = - if declares ctx.env.tvpreds v needs then () +and cast_operand ctx loc name ~needs ?also ~what ~is v = + if declares ctx.env.tvpreds v needs + || (match also with + | Some (p, _) -> declares ctx.env.tvpreds v p + | None -> false) + then () else + (* A conversion two bounds license is refused naming both, since which one + the reader meant is theirs to say. *) + let is = match also with Some (_, is') -> is ^ " or " ^ is' | None -> is in let declared = List.filter_map (fun (p : Ast.pred) -> @@ -7990,10 +8286,19 @@ and cast_operand ctx loc name ~needs ~what ~is v = (String.concat " and " ps) is in let fix = + let alt clause = + match also with + | Some (p, is') -> + Printf.sprintf ", or %s for %s" + (Printf.sprintf clause p v) is' + | None -> "" + in if ctx.env.tvpreds = [] then - Printf.sprintf "write {:where (%s $%s)} at the head of the body" - needs v - else Printf.sprintf "add (%s $%s) to the where clause" needs v + Printf.sprintf "write {:where (%s $%s)} at the head of the body%s" + needs v (alt "{:where (%s $%s)}") + else + Printf.sprintf "add (%s $%s) to the where clause%s" needs v + (alt "(%s $%s)") in Loc.failk "check/unconstrained-type-variable" loc "%s converts %s. %s — %s" name what known fix @@ -8288,14 +8593,20 @@ and file_guard ctx loc ~path_slot ~op mk_steps = missing annotation for a program that had written one. One list, read by both callers, so the next kind of type added cannot be added to one of them. *) +(* A global value that a bare name in a type position would reach instead of + a type. A type variable in scope is not shadowed by one: the prelude's + generics write [(vec-new t)], and a program's [(defonce t ...)] must not + change what the prelude means. *) +and global_value ctx n = + Hashtbl.mem ctx.env.globals n && not (tyvar_in_scope ctx.env n) + (* An argument written as a type: a type expression, or a bare name that is a type and not a local or a global of the same spelling. *) and type_arg ctx (a : Ast.expr) = type_of_expr a <> None || (match a.Ast.e with | Ast.Var n -> - lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) - && type_named ctx n + lookup ctx n = None && not (global_value ctx n) && type_named ctx n | _ -> false) and type_named ctx n = @@ -8328,9 +8639,7 @@ and vec_new_elem ctx ~want loc args = | a :: rest when type_of_expr a <> None -> Some (resolve ctx.env (Option.get (type_of_expr a)), rest) | { Ast.e = Ast.Var n; _ } :: rest - when lookup ctx n = None - && (not (Hashtbl.mem ctx.env.globals n)) - && type_named ctx n -> + when lookup ctx n = None && not (global_value ctx n) && type_named ctx n -> Some (resolve_name ctx.env ~seen:[] loc n, rest) | _ -> None in @@ -8393,9 +8702,7 @@ and map_kv loc what (t : Types.t) = says half of a type and half is not a type. *) and map_new_types ctx ~want loc args = let is_type n = - lookup ctx n = None - && (not (Hashtbl.mem ctx.env.globals n)) - && type_named ctx n + lookup ctx n = None && not (global_value ctx n) && type_named ctx n in (* A type position holds a bare name or a type expression Parse has read as one, as [vec-new]'s does. *) @@ -9324,6 +9631,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = [ target; check ctx ~want:Types.Dyn x; here loc ]) else begin let elem = vec_elem loc "push" target.Tast.ty in + note_grown ctx "push" loc target; let x = check ctx ~want:elem x in (* The element is bound before the loop so that a [retry] re-attempts the allocation and not the expression that produced the value. *) @@ -9355,6 +9663,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = let target = check_target ctx target in refuse_const_change ctx loc target; let n = check ctx ~want:index_ty n in + note_grown ctx "reserve" loc target; let n64 = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Cast (Types.Int Types.I64), [ n ])) in @@ -9482,6 +9791,57 @@ and named_call ?(qualified = false) ctx ~want loc name args = "free takes a Vec, a Map, or a slice (bytes s) or (clone xs) made — \ found %s" (Types.to_string other)) + (* Emitted by the prelude's [into] when no (map f) is in the chain, so that + every element pushed is a source element as it stands. A push copies an + element's header, and for an element that owns storage the copy and the + source then share one block: growing an element through either side + reallocates it and frees the block the other still points at. That is a + use after free the program never wrote, under a name that promised a + copy, so it is refused here. A bare (push w (at v 0)) is not: it copies a + header in plain sight, the Odin contract every container follows. + Arguments are the source, then the destination and the transforms as + written — those two only to be spelled back in the fix, never checked. *) + | "into-copies-elements" -> + (match args with + | src :: dst :: transforms -> + let s = check ctx src in + let elem = + match s.Tast.ty with + | Types.Vec e | Types.Slice (_, e) | Types.Array (_, e) -> Some e + | _ -> None + in + (match elem with + | Some e when owning ctx.env e -> + let v = spell_arg "v" src in + let et = Types.to_string e in + let fix = + if clone_accepts ctx.env e then + match spell_form dst, List.map spell_form transforms with + | Some d, ts when not (List.mem None ts) -> + Printf.sprintf + "Add (map clone) to the chain, which copies what each \ + element owns: (into %s)" + (String.concat " " + ((v :: d :: List.filter_map Fun.id ts) @ [ "(map clone)" ])) + | _ -> + "Add (map clone) to the chain, which copies what each element \ + owns" + else + Printf.sprintf + "Nothing copies what a %s owns, so no copy of %s can stand on \ + its own: read the elements where they are, or build each new \ + element and push that" + et v + in + Loc.failk "check/into-shares-elements" src.Ast.loc + "into copies each element of %s as it stands, and an element of \ + %s is a %s, which owns storage — the copy would share each \ + element's block with %s, and growing either one frees the block \ + the other points at. %s" + v v et v fix + | _ -> ()); + expect ctx loc ~want (mk loc Types.Unit Tast.Unit) + | _ -> expect ctx loc ~want (mk loc Types.Unit Tast.Unit)) (* (clone v) uses the current allocator, (clone v a) names one. A deep, independent copy: spec-memory.md's "copying is always explicit". *) | "clone" -> @@ -9517,9 +9877,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | (Types.Vec _ | Types.Map _) when region_only ctx.env target.Tast.ty -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ - can walk one to copy what it owns. Build a second container and \ - insert into it" + can walk one to copy what it owns. %s" (Types.to_string target.Tast.ty) + (insert_copies ctx.env target.Tast.ty) (* A slice's elements, copied into a block from the allocator and answered as a slice over it — what (bytes s) does for a string's bytes, and the same lowering. The same refusal as a Vec's, for the @@ -9527,9 +9887,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Types.Slice (_, elem) when owning ctx.env elem -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ - can walk one to copy what it owns. Build a container and insert \ - into it" + can walk one to copy what it owns. %s" (Types.to_string target.Tast.ty) + (insert_copies ctx.env target.Tast.ty) (* The copy is a block from an allocator, which the collector does not walk, so a dyn in it would be a root nothing marks. *) | Types.Slice (_, elem) when holds_dyn ctx.env elem -> @@ -9639,6 +9999,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = check ctx ~want:Types.Dyn v; here loc ]) else begin let kt, vt = map_kv loc "put" target.Tast.ty in + note_grown ctx "put" loc target; let k = check ctx ~want:kt k in let v = check ctx ~want:vt v in (* Deferred: the arguments are checked — so a move here is still a move @@ -10871,8 +11232,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = [ordered?] admits a type that does not, and that day is why the question is asked of the predicate and not of the set it denotes. *) | Types.Var v -> - cast_operand ctx loc name ~needs:"numeric?" ~what:"a number" - ~is:"a number" v + cast_operand ctx loc name ~needs:"numeric?" ~also:("enum?", "an enum") + ~what:"a number or an enum" ~is:"a number" v | t -> fail loc "%s converts a number, found %s" name (Types.to_string t)); prim (Tast.Cast target) target [ a ] | _ when is_cast name && List.length args = 1 -> @@ -10903,8 +11264,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = machine type, so what is in question is only the operand, and the [where] clause is what answers it. *) | Types.Var v -> - cast_operand ctx loc name ~needs:"numeric?" ~what:"a number" - ~is:"a number" v + cast_operand ctx loc name ~needs:"numeric?" ~also:("enum?", "an enum") + ~what:"a number or an enum" ~is:"a number" v | t -> fail loc "%s converts a number, found %s" name (Types.to_string t)); (match a.Tast.ty with | Types.Dyn -> cast_dyn ctx loc target a @@ -10956,6 +11317,14 @@ and ordinary_call ctx ~want loc name args = match capture ctx loc name with | Some b -> call_value ctx ~want loc (mk loc b.bty (Tast.Local b.slot)) args | None -> assert false) + (* A global holding a function value — a (CFn ...) table entry's cousin, + since a global is one of the zeroed positions a CFn may sit in. Called + by its name the way a local one is. *) + | _ when (match Hashtbl.find_opt ctx.env.globals name with + | Some (ty, _) -> callable_ty ty + | None -> false) -> + let ty, _ = Hashtbl.find ctx.env.globals name in + call_value ctx ~want loc (mk loc ty (Tast.Global name)) args | _ when Hashtbl.mem ctx.env.gsigs name -> private_ref ctx loc name; let vars, params, ret = Hashtbl.find ctx.env.gsigs name in @@ -12100,6 +12469,10 @@ let builtins : (string * string * string) list = its allocator's free-all. Refused for elements that own \ storage: a bytewise copy would alias the original's blocks under a \ name promising otherwise."); + ("into-copies-elements", "into-copies-elements [src dst transform...] ()", + "What into writes when its chain has no (map f). Refuses a source whose \ + elements own storage, because pushing them as they stand would share \ + their blocks. Not meant to be written by hand."); (* (Map K V) *) ("map-new", "map-new [K? V? Allocator?] (Map K V)", @@ -12993,6 +13366,55 @@ let check_union_members env = (* ── Declarations: pass 2, check bodies ────────────────────────────── *) +(* The names a body hands back or stores into: every name mentioned in a value + it answers — its last form's tails, a [return]'s value — and the name at + the root of every [set] place. A parameter among them is not warned at for + growing: the grown copy goes back to the caller, or the copy is the + function's own business. *) +let escaping_names ~returns (body : Ast.expr list) : string list = + let names = ref [] in + let rec mentions (e : Ast.expr) = + (match e.Ast.e with Ast.Var n -> names := n :: !names | _ -> ()); + ignore (Ast.map_children (fun x -> mentions x; x) e) + in + let rec tails (e : Ast.expr) = + match e.Ast.e with + | Ast.Do es | Ast.Let (_, es) -> + (match List.rev es with x :: _ -> tails x | [] -> ()) + | Ast.If (_, a, b) -> tails a; Option.iter tails b + | Ast.Match (_, arms) -> + List.iter + (fun (a : Ast.arm) -> + match List.rev a.Ast.body with x :: _ -> tails x | [] -> ()) + arms + (* A value that is the parameter, a field of it, or a literal built with + it. A call's result is its callee's business, and a unit form — the + push itself, last in a function that returns nothing — answers + nothing. *) + | Ast.Var _ | Ast.Field _ | Ast.Struct _ | Ast.Bare _ | Ast.Arr _ + | Ast.MapLit _ -> mentions e + | _ -> () + in + let rec root (e : Ast.expr) = + match e.Ast.e with + | Ast.Var n -> names := n :: !names + | Ast.Field (x, _) -> root x + | Ast.Call ({ Ast.e = Ast.Var ("at" | "deref"); _ }, x :: _) -> root x + | _ -> () + in + let rec walk (e : Ast.expr) = + (match e.Ast.e with + | Ast.Return (Some x) -> tails x + | Ast.Set (Ast.Pvar n, _) -> names := n :: !names + | Ast.Set ((Ast.Pfield (x, _) | Ast.Pindex (x, _) | Ast.Pderef x + | Ast.Pslot (x, _)), _) -> root x + | _ -> ()); + ignore (Ast.map_children (fun x -> walk x; x) e) + in + List.iter walk body; + if returns then (match List.rev body with x :: _ -> tails x | [] -> ()); + !names + let rec check_fn env (fn : Ast.fn) : Tast.fn = let params, ret = Hashtbl.find env.fns fn.Ast.name in let ctx = { (invented_ctx env ret) with owner = fn.Ast.name } in @@ -13015,6 +13437,41 @@ let rec check_fn env (fn : Ast.fn) : Tast.fn = end; ignore (bind ctx p.Ast.fname ty ~assignable:false)) fn.Ast.params params; + let grow_before = !grow_warnings in + let grow_saved = !grow_params in + grow_params := + ( ctx, + List.filter_map + (fun (p : Ast.field) -> + Option.map (fun b -> (b.slot, p)) (List.assoc_opt p.Ast.fname ctx.scope)) + fn.Ast.params ) + :: grow_saved; + let escaping = + lazy + (let names = + escaping_names ~returns:(not (Types.equal ret Types.Unit)) fn.Ast.fbody + in + List.filter_map + (fun (p : Ast.field) -> + if List.mem p.Ast.fname names then Some p.Ast.floc else None) + fn.Ast.params) + in + Fun.protect + ~finally:(fun () -> + grow_params := grow_saved; + let added = + List.filteri + (fun i _ -> i < List.length !grow_warnings - List.length grow_before) + !grow_warnings + in + if added <> [] then + grow_warnings := + List.filter + (fun (d : Loc.diag) -> + not (List.mem d.Loc.dloc (Lazy.force escaping))) + added + @ grow_before) + @@ fun () -> let body = match fn.Ast.fbody with | [] -> @@ -14135,30 +14592,37 @@ let shown_name n = else n let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) = - let fn_name (d : Ast.decl) = + (* A value name, and whether it is a function's. A program's global takes + a prelude function's name over as a program's function does: both are + names a call or a read reaches, and the prelude's own uses keep the + prelude's. *) + let value_name (d : Ast.decl) = match d.Ast.d with - | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> Some fn.Ast.name + | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> + Some (fn.Ast.name, true) + | Ast.Defvar (n, _, _, _) | Ast.Defconst (n, _, _) -> Some (n, false) | _ -> None in - let theirs = List.filter_map fn_name prelude in + let theirs = List.map fst (List.filter_map value_name prelude) in let taken = List.filter_map (fun (d : Ast.decl) -> - match fn_name d with - | Some n when List.mem n theirs -> Some (n, d.Ast.dloc) + match value_name d with + | Some (n, f) when List.mem n theirs -> Some (n, d.Ast.dloc, f) | _ -> None) decls in let warnings = List.map - (fun (n, at) -> + (fun (n, at, f) -> Loc.diag ~kind:"check/shadows-prelude" at (Printf.sprintf - "%s shadows the prelude's %s — every call in this file now \ + "%s shadows the prelude's %s — every %s in this file now \ reaches your definition" - n n)) + n n (if f then "call" else "use"))) taken in + let taken = List.map (fun (n, at, _) -> (n, at)) taken in let prelude, decls = List.fold_left (fun (prelude, decls) (n, (at : Loc.t)) -> @@ -14265,7 +14729,14 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : time it runs every signature is sound, so a body that fails to check cannot make the next body fail — which is what makes a declaration a resync point that needs no resynchronising. *) + grow_warnings := []; let decls = collect env decls in + if !print_warnings then + List.iter + (fun (d : Loc.diag) -> + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) + (List.rev !pairing_warnings); check_finite env; check_union_members env; let s = Loc.sink ~on:keep_going in @@ -14319,6 +14790,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : | _ -> None) decls in + if !print_warnings then + List.iter + (fun (d : Loc.diag) -> + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) + (List.rev !grow_warnings); Loc.finish s; (* The handler clauses lifted out along the way. They are ordinary functions from here down; nothing in the backend knows they were written inside diff --git a/lib/emit.ml b/lib/emit.ml index 4752a78d..640078e6 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -3177,6 +3177,9 @@ and call_ptr ?at f ret callee args = code, Some ("ptr " ^ env) | _ -> c, None in + (match callee.Tast.ty, at with + | Types.CFn _, Some loc -> null_check f loc callee.Tast.ty code + | _ -> ()); let vs = map_lr (fun (a : Tast.expr) -> let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in Option.iter (mark_call f) at; @@ -3184,6 +3187,19 @@ and call_ptr ?at f ret callee args = if at <> None then clear_call f; r +(* A (CFn ...) may be a zeroed field, array element or global, and a zeroed + one is a null address. Tested before the arguments are evaluated, so a + call that is not going to be made runs none of them — the x86 backend + tests at the same point. [flan_null_call] signals [NullCall] and returns + only when something transferred, the shape of a bounds failure. *) +and null_check f loc ty code = + let ok = fresh f in + ins f "%s = icmp ne ptr %s, null" ok code; + signal_block f loc ~guard:(fun () -> guard f) ok (fun id n -> + let tys = fst (fi_bytes f.md (Types.to_string ty ^ "\000")) in + ins f "call void @flan_null_call(ptr %s, i64 %d, ptr %s, ptr %s)" + id n tys xfer_param) + (* The code address behind one of the three [fnref]s, which is the same string whether it is wanted as a bare [(Ptr ())] or as the first word of a function value. @@ -4925,6 +4941,9 @@ declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold ; as C strings, then the cell and the channel. Signals StaleCall; returns when ; something answered. declare void @flan_stale_call(ptr, ptr, ptr, ptr, ptr) cold +; A call through a (CFn ...) holding null: the site, the value's type as a C +; string and the channel. Signals NullCall; returns when something answered. +declare void @flan_null_call(ptr, i64, ptr, ptr) cold declare ptr @flan_context_allocator() declare ptr @flan_context_use(ptr, i64) declare void @flan_context_value(ptr) diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index eb3bfd38..3b7b2512 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -200,13 +200,17 @@ and inline_text ?(lvl = 0) (f : Form.t) = w ^ " :" ^ k | Form.List [ { v = Form.Sym "return"; _ }; v ] -> "return " ^ at (max lvl 1) v | Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v + | Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; w ] + when not (R.simple_place t) -> + at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w | _ -> at lvl f (* [t = v], or [t += w] when [v] is [(+ t w)]. *) and assign_text ?(lvl = 0) t v = let tt = at 9 t in match v.v with - | Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ] when same a t -> + | Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ] + when same a t && R.simple_place t -> tt ^ " " ^ op ^ "= " ^ at (max lvl 1) w | _ -> tt ^ " = " ^ at (max lvl 1) v @@ -325,7 +329,7 @@ let body_split (h : Form.t) args = let sugar_heads = [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match"; "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; - "quasiquote" ] + "quasiquote"; "update" ] let rec block n (fs : Form.t list) : string list = let rec go = function @@ -441,6 +445,9 @@ and sugar n ~last (f : Form.t) : string list option = (match pairs bs with | None | Some [] -> None | Some prs -> Some (let_lines n ~last prs body)) + | Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym ("+" | "-" | "*" | "/"); _ }; _ ] + when not (R.simple_place t) -> + Some [ i ^ guard (inline_text f) ] | Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> let line = i ^ guard (assign_text t v) in if String.length line <= width then Some [ line ] diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index a5ea3a81..aefc217b 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -64,6 +64,35 @@ let is_op_word s = is_binop s || s = "not" || s = "=" let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ] +(* A place whose parts are all names and literals reads the same however + often it is evaluated, so [x += v] over one is [(set x (+ x v))], the form + the Lisp side writes. Any other place — an index that is a call — reads + [(update p + v)], which evaluates each part of the place once. The printer + asks the same question, so the round trip is exact either way. *) +let rec simple_place (f : Form.t) = + let atom (x : Form.t) = + match x.v with + | Form.Sym _ | Form.Int _ | Form.Kw _ | Form.Byte _ -> true + | _ -> false + in + match f.v with + | Form.Sym _ -> true + | Form.List [ { v = Form.Sym h; _ }; t ] + when (String.length h > 1 && h.[0] = '.') || h = "deref" -> + simple_place t + | Form.List ({ v = Form.Sym "at"; _ } :: t :: (_ :: _ as idx)) -> + simple_place t && List.for_all atom idx + | _ -> false + +let compound (at : Loc.t) op (e : Form.t) (v : Form.t) span = + if simple_place e then + Form.List + [ Form.make (Form.Sym "set") at; e; + Form.make (Form.List [ Form.make (Form.Sym op) at; e; v ]) span ] + else + Form.List + [ Form.make (Form.Sym "update") at; e; Form.make (Form.Sym op) at; v ] + (* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything else keeps the Lisp reading, so [--], [->] and [-=] stay names. *) let is_neg_char c = @@ -713,11 +742,7 @@ and inline_stmt p : Form.t = | NAME op when List.mem_assoc op assign_ops -> let eq = advance p in let v, _ = expr p in - mk p t.loc - (Form.List - [ sym eq.loc "set"; e; - Form.make (Form.List [ sym eq.loc (List.assoc op assign_ops); e; v ]) - (span p e.loc) ]) + mk p t.loc (compound eq.loc (List.assoc op assign_ops) e v (span p e.loc)) | _ -> e (* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the @@ -1114,10 +1139,7 @@ and expr_stmt (s : st) : Form.t = let eq = advance p in let v = value_line s ~after:(text_of e ^ " " ^ op) in let o = List.assoc op assign_ops in - mk p t0.loc - (Form.List - [ sym eq.loc "set"; e; - Form.make (Form.List [ sym eq.loc o; e; v ]) (span p e.loc) ]) + mk p t0.loc (compound eq.loc o e v (span p e.loc)) | COLON -> let before = (last p).tok in let c = advance p in diff --git a/lib/load.ml b/lib/load.ml index 70bb75cb..301babc1 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -1618,6 +1618,7 @@ let program ?(parse = Parse.program) ~file (forms : Form.t list) : t = in let decls = Parse.with_imported ~decls:(imported.decls @ !Parse.imported_decls) + ~fns:!Parse.shadowing_fns (macro_union imported.macros !Parse.imported_macros) (fun () -> parse forms) in diff --git a/lib/macro.ml b/lib/macro.ml index ae2577e7..1e570d0f 100644 --- a/lib/macro.ml +++ b/lib/macro.ml @@ -585,10 +585,39 @@ let with_module (l : loaded) (f : unit -> 'a) : 'a = left in them, so a second pass only reaches the calls to the new names. A macro that defines a macro whose expansion defines another costs one pass per level, and the fuel is the same bound [settle] uses. *) +(* The names these forms define as functions. A program's [defn] shadows a + macro of the same name — the prelude's [clamp] or [update], or an + imported one — as it shadows a prelude function: every call in the file + reaches the definition, and [Check.shadow_prelude] says so. So such a + name is not expanded here. A [defmacro] is a [defn] too once parsed, but + not yet: [macro_name] is what finds those, and they are left alone. *) +let defined_fns (forms : Form.t list) = + List.filter_map + (fun (f : Form.t) -> + match f.Form.v with + | Form.List ({ Form.v = Form.Sym ("defn" | "defn-"); _ } + :: { Form.v = Form.Sym n; _ } :: _) -> Some n + | _ -> None) + forms + let rec program_n left (forms : Form.t list) : Form.t list = match loaded_for forms with | None -> forms | Some l -> + (* Never the prelude's own forms: they are parsed inside a session's + evaluation too, and their calls are to their own macros. *) + let prelude = + match forms with + | f :: _ -> String.equal f.Form.loc.Loc.file Prelude.file + | [] -> false + in + let shadowed = + if prelude then [] else defined_fns forms @ !Parse.shadowing_fns + in + let l = + if shadowed = [] then l + else { l with fns = List.filter (fun (n, _) -> not (List.mem n shadowed)) l.fns } + in let before = macros_in forms in let out = with_module l (fun () -> List.map (expand_form l) forms) in let fresh = List.filter (fun n -> not (List.mem n before)) (macros_in out) in diff --git a/lib/parse.ml b/lib/parse.ml index e5190994..f148fe2e 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -30,6 +30,32 @@ let no_sigil (f : Form.t) = let dname (f : Form.t) = no_sigil f; sym f +(* A global's name. One spelled like a built-in type would stand where the + type is written — [(vec-new u8)] — and change what that means, in the + program and in the prelude alike, so it is refused where it is declared. *) +let gname (f : Form.t) = + (match f.v with + | Sym s when List.mem s Types.primitive_names -> + Loc.failk "parse/global-named-type" f.loc + "%s is a type, so it cannot also name a global — (vec-new %s) would \ + not know which was meant. Name it %s-value, or any name that is not \ + a type" + s s s + | _ -> ()); + dname f + +(* A type's name. A built-in type's is taken: a second [u8] would stand for + one or the other wherever a type is written, the prelude's included. *) +let tname (f : Form.t) = + (match f.v with + | Sym s when List.mem s Types.primitive_names -> + Loc.failk "parse/type-named-builtin" f.loc + "%s is a built-in type, so it cannot be declared again. Give the new \ + type a name of its own" + s + | _ -> ()); + dname f + (* Names for the temporaries this file mints — the value is bound once and everything that needs it reads *that*, so a destructuring pattern over a call calls it once and a short-circuit operand is evaluated once. [~] is a @@ -449,6 +475,14 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = | [ target; value ] -> mk (Ast.Set (place target, expr value)) | _ -> fail f "set is (set place value)") + (* What [update], [++] and [--] expand into: (update~ PLACE g NEW), where + NEW is written over the name [g]. The name has a [~] in it so no program + can write it; only a prelude macro builds one. See [modify]. *) + | Sym "update~" -> + (match args with + | [ target; { v = Sym g; _ }; value ] -> modify f target g value + | _ -> fail f "internal: update~ is (update~ place name value) — a compiler bug") + (* ── (vec-new [u8]) and (map-new string [u8]) ─────────────────────── The type positions of these two take a type expression. Whether this call is the builtin at all is the checker's to know — a program may define its @@ -1174,17 +1208,10 @@ and cond f (args : Form.t list) : Ast.expr = [f.loc] would blame the enclosing (and ...) for whichever operand is actually wrong. - What answering the operand costs, for both forms alike: the two arms are - now both real values, so mixing a dyn operand with a typed bool one makes - check_if unify them, and the then arm decides. A non-bool dyn value on - the losing side then meets the strict bool boundary at run time — - (or false (box "s")) and (and (box nil) some-bool) both trap, verified on - this tree. Each form used to be safe in exactly one of those directions, - because the sentinel it answered was a bool literal that boxed to fit - whatever the real branch was; neither is now, and they are at least - symmetric about it. Making bool and dyn arms join as dyn is a check_if - question, noted in TODO.org, "A bool arm and a dyn arm joining as dyn", - and not decided here. + The two arms are both real values, so mixing a dyn operand with a typed + bool one makes check_if unify them: a bool arm and a dyn arm meet at dyn + with the bool boxed, whichever side each is on, so (or false (box "s")) + answers "s" and (and (box nil) some-bool) answers nil. One known wart, measured rather than guessed, and left alone deliberately. In a want-free position — [(println (and true true (vec-new i32)))] — the @@ -1252,6 +1279,65 @@ and place (f : Form.t) : Ast.place = (deref p), or a class slot (get inst :slot)" (Form.to_string f) +(* A read-modify-write of a place, with every subexpression of the place + evaluated once — C's rule for compound assignment. (update (at grid (next) + c) inc) calls [next] once, and the read and the write land on the same + element. + + Each index, key and pointer is bound to a temp first, outermost and + leftmost first. The container a field or an index is taken from is not: it + has to stay a path to the storage, since a temp would be a copy of a struct + or an array and the write would land in the copy. Only a path made of + names, fields, indexes and derefs stays one; anything else in container + position — a call answering a Vec, say — is a value, and is bound like an + index. Then [g] is bound to the place's current value, and [value], written + over [g], is stored back through the same path. *) +and modify f target g value : Ast.expr = + let mk e = { Ast.e; loc = f.loc } in + let binds = ref [] in + let temp (e : Ast.expr) = + match e.Ast.e with + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ -> e + | _ -> + let t = fresh_temp "place" in + binds := { Ast.bname = t; bty = None; bval = e; bloc = e.Ast.loc } :: !binds; + { e with Ast.e = Ast.Var t } + in + let rec path (e : Ast.expr) = + match e.Ast.e with + | Ast.Var _ -> e + | Ast.Field (t, n) -> { e with Ast.e = Ast.Field (path t, n) } + | Ast.Call (({ Ast.e = Ast.Var "at"; _ } as h), t :: idx) when idx <> [] -> + let t = path t in + { e with Ast.e = Ast.Call (h, t :: List.map temp idx) } + | Ast.Call (({ Ast.e = Ast.Var "deref"; _ } as h), [ p ]) -> + { e with Ast.e = Ast.Call (h, [ temp p ]) } + | _ -> temp e + in + let p = + match place target with + | Ast.Pvar _ as p -> p + | Ast.Pfield (t, n) -> Ast.Pfield (path t, n) + | Ast.Pindex (t, idx) -> + let t = path t in + Ast.Pindex (t, List.map temp idx) + | Ast.Pderef p -> Ast.Pderef (temp p) + | Ast.Pslot (t, k) -> + let t = temp t in + Ast.Pslot (t, temp k) + in + let at e = { Ast.e; loc = target.loc } in + let read = + match p with + | Ast.Pvar n -> at (Ast.Var n) + | Ast.Pfield (t, n) -> at (Ast.Field (t, n)) + | Ast.Pindex (t, idx) -> at (Ast.Call (at (Ast.Var "at"), t :: idx)) + | Ast.Pderef p -> at (Ast.Call (at (Ast.Var "deref"), [ p ])) + | Ast.Pslot (t, k) -> at (Ast.Call (at (Ast.Var "get"), [ t; k ])) + in + let old = { Ast.bname = g; bty = None; bval = read; bloc = target.loc } in + mk (Ast.Let (List.rev (old :: !binds), [ mk (Ast.Set (p, expr value)) ])) + and arms f (items : Form.t list) : Ast.arm list = let rec go = function | [] -> [] @@ -1343,7 +1429,13 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defalias"; _ } :: args) -> (match args with - | [ n; t ] -> mk (Ast.Defalias (dname n, texpr t)) + (* int and float restate a builtin alias, which the checker takes up; + any other built-in type's name is refused as tname refuses it. *) + | [ n; t ] -> + let name = + match n.v with Sym ("int" | "float") -> dname n | _ -> tname n + in + mk (Ast.Defalias (name, texpr t)) | _ -> fail f "defalias is (defalias Name Type)") (* A parent comes before the fields, where Common Lisp's define-condition @@ -1353,16 +1445,16 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defstruct"; _ } :: args) -> (match args with | [ n; { v = Vec fs; _ } ] -> - mk (Ast.Defstruct (dname n, fields f fs, None)) + mk (Ast.Defstruct (tname n, fields f fs, None)) | [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] when fs <> [] -> - mk (Ast.Defstruct (dname n, fields f fs, Some (texpr p))) + mk (Ast.Defstruct (tname n, fields f fs, Some (texpr p))) (* An empty field vector is the same category as none. *) | [ n; { v = Kw "parent"; _ }; p ] | [ n; { v = Kw "parent"; _ }; p; { v = Vec []; _ } ] -> 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))) + mk (Ast.Defstruct (tname n, [ str "name"; str "message" ], Some (texpr p))) | _ -> fail f "defstruct is (defstruct Name [field Type ...]), or with a parent \ @@ -1370,7 +1462,7 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defdata"; _ } :: args) -> (match args with - | [ n; { v = Vec vs; _ } ] -> mk (Ast.Defdata (dname n, List.map variant vs)) + | [ n; { v = Vec vs; _ } ] -> mk (Ast.Defdata (tname n, List.map variant vs)) | _ -> fail f "defdata is (defdata Name [(Case [field Type ...]) ...])") (* C's union: one storage, as many ways of reading it as there are members. @@ -1413,7 +1505,7 @@ let rec decl (f : Form.t) : Ast.decl = [member Type ...]). This reads as a tagged sum — write \ (defdata Name [(Case [field Type ...]) ...])") ms; - mk (Ast.Defunion (dname n, fields f ms)) + mk (Ast.Defunion (tname n, fields f ms)) | _ -> fail f "defunion is (defunion Name [member Type ...])") (* The slot after the parameters is unconditionally the return type. It used @@ -1538,7 +1630,7 @@ let rec decl (f : Form.t) : Ast.decl = List.iter (fun (s : Form.t) -> match s.v with Sym _ -> no_sigil s | _ -> ()) slots; - mk (Ast.Defclass (dname n, pitems slots)) + mk (Ast.Defclass (tname n, pitems slots)) | _ -> fail f "defclass is (defclass Name [slot Type ...])") | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> @@ -1631,7 +1723,7 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defenum"; _ } :: args) -> (match args with | [ n; { v = Form.Vec ms; _ } ] -> - let ename = dname n in + let ename = tname n in (* An enum member is an [i32] at run time. [Shim] lowers the type to int32_t for C's benefit and [Check] builds every member as a [Tast.Int (v, I32)] -- but the reader hands this pass an [int64], so @@ -1781,11 +1873,11 @@ let rec decl (f : Form.t) : Ast.decl = (match args with | [ n; t ] -> let ty, init = defvar3 t in - mk (Ast.Defvar (dname n, Some ty, init, kind)) + mk (Ast.Defvar (gname n, Some ty, init, kind)) | [ n; t; { v = Sym "uninit"; _ } ] -> - mk (Ast.Defvar (dname n, Some (texpr t), Ast.Uninit, kind)) + mk (Ast.Defvar (gname n, Some (texpr t), Ast.Uninit, kind)) | [ n; t; v ] -> - mk (Ast.Defvar (dname n, Some (texpr t), Ast.Init (expr v), kind)) + mk (Ast.Defvar (gname n, Some (texpr t), Ast.Init (expr v), kind)) | _ -> fail f "%s is (%s name Type value?) or (%s name value) — a third element \ @@ -1824,8 +1916,8 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defconst"; _ } :: args) -> (match args with - | [ n; v ] -> mk (Ast.Defconst (dname n, None, expr v)) - | [ n; t; v ] -> mk (Ast.Defconst (dname n, Some (texpr t), expr v)) + | [ n; v ] -> mk (Ast.Defconst (gname n, None, expr v)) + | [ n; t; v ] -> mk (Ast.Defconst (gname n, Some (texpr t), expr v)) | _ -> fail f "defconst is (defconst name Type? value)") (* A macro is an ordinary function, and this is where it becomes one: @@ -2002,15 +2094,25 @@ let expansion_macros : Form.t list ref = ref [] written twice, in the file where the two copies could disagree silently. *) let imported_decls : Ast.decl list ref = ref [] -let with_imported ?(decls = []) (ms : Form.t list) (f : unit -> 'a) : 'a = +(* Functions a session already holds, by name. A program's [defn] shadows a + macro of its name, and a session's form is expanded alone, long after the + [defn] that shadows — so the session says which names those are, as it + says which macros it has. *) +let shadowing_fns : string list ref = ref [] + +let with_imported ?(decls = []) ?(fns = []) (ms : Form.t list) + (f : unit -> 'a) : 'a = let saved = !imported_macros in let saved_decls = !imported_decls in + let saved_fns = !shadowing_fns in imported_macros := ms; imported_decls := decls; + shadowing_fns := fns; Fun.protect ~finally:(fun () -> imported_macros := saved; - imported_decls := saved_decls) + imported_decls := saved_decls; + shadowing_fns := saved_fns) f (* Two entry points and not one function with a flag, and the reason is the diff --git a/lib/prelude.ml b/lib/prelude.ml index 85c022b4..5cc0ea01 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -197,6 +197,17 @@ let source = {flan| ;; nothing a handler supplies makes the old arguments fit the new body. (defstruct StaleCall :parent Error [callee string compiled string current string]) +;; A call through a (CFn ...) that holds no function. A CFn may be a struct +;; field, a fixed array's element or a global, and each of those starts out +;; zeroed, which for a function value is no address at all. Every call +;; through one tests first and signals this instead of jumping to nothing. +;; `type` is the value's type as written, "(CFn [i32] i32)". +;; +;; Signalled from the runtime — flan_null_call in runtime/flan_rt.c — so +;; **this field is a C struct that has to agree with this one**. No restart is +;; established at the call, BoundsError's decision for BoundsError's reason. +(defstruct NullCall :parent Error [type string]) + ;; What a generic function signals when no method answers. `generic` is the ;; name written at the defgeneric or defmulti, and `value` is what the ;; dispatch actually produced -- the class of the first argument for a @@ -2299,16 +2310,12 @@ let source = {flan| ;; because a macro does not have a type at all; the expansion is checked at the ;; call site as if it had been written there. ;; -;; **++ and -- read the place twice, and that is an accepted cost.** The -;; expansion is (set PLACE (+ PLACE 1)), so PLACE is evaluated once to read -;; and once to write. For a variable, a field or a deref that is free and -;; means nothing. For (at arr (next-index)) — an index with a side effect — -;; it means next-index runs twice and the read and the write land on different -;; elements. That is not a bug to be fixed here: macros are non-hygienic by -;; decision (plan.org, open decision 2), a macro cannot bind a temporary for -;; the *place* without a reference type it does not have, and -;; rl/with-drawing and rl/with-mode-2d already take the same trade on their -;; arguments. Write the index out first if it does anything. +;; **++ and -- evaluate the place once.** Each index, key and pointer in the +;; place is bound to a temp before the read, so (++ (at arr (next-index))) +;; calls next-index once and reads and writes the same element — C's rule for +;; compound assignment. They are update with + and -, spelled as the form +;; update~ that update itself expands into (a prelude macro may not call a +;; macro); lib/parse.ml's [modify] is where the place is taken apart. (defmacro inc [& args] (if (!= (length args) 1) `(inc-takes-one-number) @@ -2322,12 +2329,31 @@ let source = {flan| (defmacro ++ [& args] (if (!= (length args) 1) `(++-takes-one-place) - `(set ~(at args 0) (+ ~(at args 0) 1)))) + (let [g (gensym)] + `(~(Form.Sym {.s "update~"}) ~(at args 0) ~g (+ ~g 1))))) (defmacro -- [& args] (if (!= (length args) 1) `(---takes-one-place) - `(set ~(at args 0) (- ~(at args 0) 1)))) + (let [g (gensym)] + `(~(Form.Sym {.s "update~"}) ~(at args 0) ~g (- ~g 1))))) + +;; ── update: change a place by applying a function to it ──────────────── +;; +;; (update (.velocity g) inc) +;; (update (at grid r c) + 10) +;; +;; (update place f args ...) stores (f old args ...) back into the place, where +;; old is what the place held. f is written as the head of a call, so it may be +;; a function, an operator or a macro such as inc. Every place set takes is a +;; place here too — a name, a field, an element, a deref, a class slot — and +;; the place is evaluated once, as ++ says above. It answers what set answers. +(defmacro update [& args] + (if (< (length args) 2) + `(update-takes-a-place-and-a-function) + (let [g (gensym)] + `(~(Form.Sym {.s "update~"}) ~(at args 0) ~g + (~(at args 1) ~g ~@(form-rest args 2)))))) ;; ── into: a fused transformation, and not a transducer ──────────────── ;; @@ -2400,6 +2426,15 @@ let source = {flan| (form-sym? head "filter") (recur (- k 1) `(when (~f ~x) ~body)) :else `(into-transform-is-map-or-filter ~t)))))))) +;; Whether any transform in the chain is a (map f). +(defn into-maps? [ts [Form]] bool + (loop [k 0] + (cond + (= k (length ts)) false + (let [items (form-items (at ts k))] + (and (> (length items) 0) (form-sym? (at items 0) "map"))) true + :else (recur (+ k 1))))) + ;; The items of a list form, and the empty slice for anything else — a ;; non-list transform falls into the arity complaint above rather than needing ;; a case of its own. @@ -2452,10 +2487,19 @@ let source = {flan| named? (form-is-sym? from) src (if named? from (gensym)) bind (if named? (form-nil) (form-pair src from)) + ;; With no (map f) in the chain every element pushed is a source + ;; element as it stands, which copies only its header: the checker + ;; refuses that for an element that owns storage. The destination and + ;; the transforms ride along unevaluated, to be written back in the fix. + shares (if (into-maps? (form-rest args 2)) + (form-nil) + (form-cons `(into-copies-elements ~src ~(at args 1) ~@(form-rest args 2)) + (form-nil))) dst (gensym) x (gensym) i (gensym)] `(let [~dst ~(at args 1) ~@bind] + ~@shares (dotimes [~i (length ~src)] (let [~x (at ~src ~i)] ~(into-wrap (form-rest args 2) dst x))) diff --git a/lib/session.ml b/lib/session.ml index 508f3edb..d29fcc9e 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -800,6 +800,18 @@ let rehost t = t.built <- record_built env p p.Tast.fns SM.empty; t.live <- SM.empty +(* The session's own functions whose names a macro also has — see + [Parse.shadowing_fns]. A [defmacro] is a [defn] once parsed, so the + session's macros are taken back out. *) +let shadowing_fns t origin = + let macros = List.filter_map Macro.macro_name (macros_for t origin) in + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defn fn when not (List.mem fn.Ast.name macros) -> Some fn.Ast.name + | _ -> None) + t.decls + (* [forms], when given, are [src] already read — [pruned] runs this over a file a form fewer each round and has no text for the subset. [base] is the file an [(import ...)] in them is resolved against, the session's own when @@ -812,7 +824,7 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr (* What an annotated listing quotes for this form is what was sent, not what the file on disk said when it was last read. *) Loc.remember ~file:origin src; - Parse.with_imported ~decls:(package_decls t) (macros_for t origin) @@ fun () -> + Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () -> (* Through [Load] like any other source, so an evaluated (import ...) means what it means in a file. Its expansion is what gets spliced, which is also why the accumulated list is the post-Load one: re-evaluating a file that @@ -2628,7 +2640,7 @@ let eval_expr ?(origin = "") ?(pause = false) ?frame t src : change = a cold macro module costs its ~300ms before that clock starts, and the non-termination refusals raise [Loc.Error] out of this call, which the daemon already answers as an error rather than a silence. *) - let parsed = Parse.with_imported ~decls:(package_decls t) (macros_for t origin) (fun () -> Parse.expr form) in + let parsed = Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) (fun () -> Parse.expr form) in (* CIDER's rule: an expression sent from a package's file means what it would mean written in that file, so [(integrate 1.0)] in physics/step.flan reaches [physics/integrate]. The qualification [eval] gives a declaration @@ -2805,7 +2817,7 @@ let macroexpand ?(origin = "") ~(all : bool) t (src : string) : expansion let before = Expand.quasiquote form in (* And the session's macros in front of it, as [eval] and [eval_expr] both put them: [Macro.program] reads [Parse.imported_macros] directly. *) - Parse.with_imported ~decls:(package_decls t) (macros_for t origin) @@ fun () -> + Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () -> let after, name = if all then Macro.expand_all before else Macro.expand_step before in diff --git a/lib/x86.ml b/lib/x86.ml index 09d98367..10b3b60a 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1927,6 +1927,9 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit = | Types.Fn _ -> Some (Aint (shift c 8, Types.Ptr (Types.Mut, Types.Unit))) | _ -> None in + (match callee.Tast.ty with + | Types.CFn _ -> null_check f e.Tast.loc callee.Tast.ty c + | _ -> ()); call_flan f ?env ~at:e.Tast.loc ~target:(`Loc c) ~args ~rty:t dst | Tast.Do body -> block f body dst t | Tast.Let (bs, body) -> @@ -2713,6 +2716,26 @@ and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc = That is also the answer to "does a bounds trap run defers": an answered one does, because it leaves through the innermost pad; an unanswered one still does not, because it is a die inside C. Identical on both backends. *) +(* [Emit.null_check]: a (CFn ...) holding null is not called. Tested before + the arguments, as the LLVM backend does, and [flan_null_call] returns only + when something transferred. *) +and null_check f (loc : Loc.t) ty (c : loc) = + load_loc f ~reg:rax c ty; + test_rr f.b ~a:rax ~c:rax; + let ok = new_label f "fnok" in + jcc_lbl f.b ~cc:cc_ne ok; + note f "A null (CFn ...): the site, the type as a C string and the channel."; + str_args f ~preg:rdi ~nreg:rsi (Loc.to_string loc); + let tys, _ = fi_bytes f (Types.to_string ty ^ "\000") in + lea f.b ~dst:rdx ~mm:(Sym (tys, 0)); + chan_into f ~reg:rcx; + mark_at f loc; + xor_rr f.b ~dst:rax ~src:rax; + call_sym f.b "flan_null_call"; + guard f; + ud2 f.b; + lbl f.b ok + and bounds_call f sym (loc : Loc.t) (extra : int list) = note f (Printf.sprintf "Out of bounds: the location string, the operands, and this frame's channel, \ diff --git a/plan.org b/plan.org index cc973a99..4e49ecb5 100644 --- a/plan.org +++ b/plan.org @@ -248,11 +248,12 @@ and on a managed ~class~ instance. An ordinary ~struct~ never carries one. already refused so nothing else it could be. ~sort~ declares ~ordered?~ of its variable, the abstract pass then allows ~<~ in the body, and each instantiation checks the concrete type satisfies the predicate and refuses the call site if it - does not. There are *five* predicates — ~ordered?~, ~equal?~, ~hashable?~, - ~numeric?~, ~integer?~ — against Odin's forty-one, and they entail one another - in one direction, so one clause usually does: ~integer?~ gives ~numeric?~, - ~numeric?~ gives ~ordered?~, and ~ordered?~ gives ~equal?~. ~integer?~ exists - because ~numeric?~ admits floats. + does not. There are *six* predicates — ~ordered?~, ~equal?~, ~hashable?~, + ~numeric?~, ~integer?~, ~enum?~ — against Odin's forty-one, and they entail one + another in one direction, so one clause usually does: ~integer?~ gives + ~numeric?~, ~numeric?~ gives ~ordered?~, and ~ordered?~ gives ~equal?~. + ~integer?~ exists because ~numeric?~ admits floats. ~enum?~ gives ~ordered?~ + and a conversion to a number, and not arithmetic. ~hashable?~ is what lets a variable *key a map*: without it the type ~(Map $t i32)~ is refused where it is written, and with it the refusal moves to the call site that names an unhashable key. diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 2a500f0f..8801cff7 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -1538,6 +1538,51 @@ void flan_stale_call(const char *site, const char *callee, const char *want, rt_die(); } +/* ── A call through a null (CFn ...) ─────────────────────────────────── + * + * A (CFn ...) may sit in a struct field, a fixed array or a global, all of + * which zero-initialise, and a zeroed one is a null address. Every call + * through a CFn value tests it first and lands here on null, so the call is + * not made. It signals NullCall with `error` — BoundsError's shape and its + * decision about restarts: no value a handler supplies turns into a function + * to call, so what answers it is a restart the program already has, or the + * break loop in a dev build. + * + * `type` is copied and never freed, for flan_stale_call's reason: the text + * lives in the image of the module that compiled the call, which may be a + * thunk that is unloaded once it returns. Must agree with the prelude's + * (defstruct NullCall :parent Error [type string]). */ + +typedef struct { flan_slice type; } flan_nullcall_cond; + +static const uint8_t flan_nullcall_name[] = "NullCall"; +#define FLAN_NULLCALL_NAMELEN 8 + +static void nullcall_sentence(const char *ty) { + rt_sentence("this call is through a %s that holds no function — a field, " + "an array element or a global of that type starts out empty. " + "Store a function in it before calling it, or hold it as an " + "(Option %s) and match on it", + ty, ty); +} + +void flan_null_call(const uint8_t *loc, int64_t loclen, const char *ty, + void *xfer) { + flan_nullcall_cond c; + flan_condesc d; + uint32_t chain[2]; + c.type = flan_stale_copy(ty); + nullcall_sentence(ty); + rt_condesc(&d, chain, flan_nullcall_name, FLAN_NULLCALL_NAMELEN, loc, + loclen); + flan_signal(&d, &c, xfer); + if (*(void **)xfer != NULL) return; + nullcall_sentence(ty); /* in full; see flan_bounds_signal */ + if (rt_error_break(&d, &c, xfer)) return; + rt_print_sentence(loc, loclen); + rt_die(); +} + /* ── Allocators, spec-memory.md ──────────────────────────────────────── * * One type-erased procedure plus an opaque data pointer, which is Odin's diff --git a/spec-memory.md b/spec-memory.md index c06db1cd..1701ed4c 100644 --- a/spec-memory.md +++ b/spec-memory.md @@ -268,12 +268,14 @@ instantiates it: > field-free storage. It does **not** support `=`, `<`, `+`, or `hash`. What makes that liveable is a `where` clause of compile-time type predicates, -written as a map at the head of the body. There are five — `ordered?`, -`equal?`, `hashable?`, `numeric?`, `integer?` — they are not type classes +written as a map at the head of the body. There are six — `ordered?`, +`equal?`, `hashable?`, `numeric?`, `integer?`, `enum?` — they are not type classes because a predicate carries no implementations and merely gates a builtin the compiler already has, and they entail one another in one direction, so one clause usually does: `integer?` admits every integer kind and no float, and entails `numeric?`, which entails `ordered?`, which entails `equal?`. +`enum?` admits exactly the enums and entails `ordered?` and `equal?`, not +`numeric?`. `integer?` is what admits the bitwise operators, the shifts and an integer-only body like `abs`'s — under `numeric?` those bodies would be instantiated at the floats too (TODO.org, "abs is one generic, and a bound joins @@ -354,14 +356,14 @@ where the type is written, so neither is refused at the variable. A conversion was never a claim that the value survives. The conversion *to* an enum needs `integer?` exactly, because an enum is an `i32` and a float has no enum reading, and `numeric?` would admit an `f32` copy the concrete rule refuses. +The conversion *from* an enum to a number needs `enum?` or `numeric?`, and +its refusal names both. `ordered?`, `equal?` and `hashable?` admit no conversion at all: they say what can be compared or keyed, not what is a number — and that is a claim about what the predicate says, not about the set it denotes today, which currently does admit only numbers and enums. The refusal names the predicate to write (TODO.org, "A conversion is legal at a bounded variable when it is legal at every -type the bound admits"). One consequence is recorded as open: no predicate now -licenses a generic enum → integer conversion (TODO.org, "There is now no generic -enum to integer conversion"). +type the bound admits"). **A type variable is not instantiated at `dyn`.** Two models answer "one body, many types" and they are not rivals: this one copies per written type at diff --git a/spec-syntax.md b/spec-syntax.md index c62dcd24..c43bebb5 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -155,8 +155,9 @@ Each item: the proposal, then the reason in one line. `a < b <= c`, is refused. An operator glued to `(` is always a call. - **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v` reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads - `(set x (+ x v))`; like `++` today, the place is evaluated twice. **Built** - (also `-=`, `*=`, `/=`). + `(set x (+ x v))` where every part of the place is a name or a literal, and + `(update x + v)` otherwise, so the place is evaluated once either way, as + with `++`. **Built** (also `-=`, `*=`, `/=`). - **A run of the same operator flattens** (variadics, section 3): `a + b + c` reads `(+ a b c)`, `a < b < c` reads `(< a b c)` (Flan's chain semantics, `test/programs/chain.flan`). This keeps the converter round trip diff --git a/test/programs/dev-break-nullcall.flan b/test/programs/dev-break-nullcall.flan new file mode 100644 index 00000000..47de55f7 --- /dev/null +++ b/test/programs/dev-break-nullcall.flan @@ -0,0 +1,26 @@ +;;;; A program that stops on a call through a null CFn, for driving the break +;;;; loop over one. Nothing handles NullCall here, so the signal reaches the +;;;; break hook and the program parks, as a bad index does in +;;;; dev-break-bounds.flan; the program's own continue is the way on. +(import agent "vendor:agent") + +(defonce table [2 (CFn [i32] i32)]) +(defonce skipped i64) +(defonce ticks i64) + +(defn call-slot [i i32] i32 ((at table i) 5)) + +(defn frame [i i32] () + (restart-case + (do (println (call-slot i)) (println "frame done")) + (continue [] (set skipped (+ skipped 1))))) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-break-nullcall-fallback.sock") + ;; Slot 1 was never set, so it is null. + (frame 1) + (print skipped) (println "") + (dotimes [i 4000] + (agent/wait 5) + (set ticks (+ ticks 1))) + 0) diff --git a/test/programs/dev-inspect.flan b/test/programs/dev-inspect.flan index 81a65af3..85a30c54 100644 --- a/test/programs/dev-inspect.flan +++ b/test/programs/dev-inspect.flan @@ -11,8 +11,10 @@ ;;;; The other locals are the shapes a path step has to walk and that an ;;;; expression cannot reach at all: an option's payload, which has no ;;;; accessor form in the language, and a union case's field, whose offset -;;;; depends on which case the value is in. +;;;; depends on which case the value is in. And a local of a package's type, +;;;; which is named as the checker names it everywhere else: qualified. (import agent "vendor:agent") +(import shape "pkgs/shape") (defstruct Point [x f32 y f32]) (defstruct Boom [why i32]) @@ -38,7 +40,8 @@ (let [mark (Point {.x 1.5 .y 2.5}) xs [10 20 30] box (Some (Point {.x 4.5 .y 5.5})) - s (Shape.Rect {.w 3 .h 6})] + s (Shape.Rect {.w 3 .h 6}) + pk (shape/box 3 4)] (deeper))) (defonce ticks i64) diff --git a/test/programs/dyn-if-truthy.flan b/test/programs/dyn-if-truthy.flan index 609447c2..928162fd 100644 --- a/test/programs/dyn-if-truthy.flan +++ b/test/programs/dyn-if-truthy.flan @@ -92,6 +92,13 @@ ;; used to trap trying to unbox "x" as a strict bool. (println (or (box nil) (box "x"))) (println (or (box 5) (box "unreached"))) + ;; A typed bool operand beside a dyn one: the two meet at dyn, the bool + ;; boxed, so the dyn one comes back whichever side of the if it lands on. + (println (or false (box "s"))) + (println (or (= 1 2) (box nil))) + (println (and (box nil) (= 1 1))) + (println (and true (box "y"))) + (println (or true (box "unreached"))) ;; One operand is that operand, whatever it is -- no test, no sentinel. (println (and (box nil))) diff --git a/test/programs/enum-generic.flan b/test/programs/enum-generic.flan new file mode 100644 index 00000000..6de559ff --- /dev/null +++ b/test/programs/enum-generic.flan @@ -0,0 +1,28 @@ +;;;; A generic conversion from an enum, licensed by {:where (enum? $t)}. enum? +;;;; admits exactly the enums and entails ordered? and equal?, so a body under +;;;; it may convert, compare and test for equality, at any enum. + +(defenum Color [red green blue]) +(defenum Size [small 10 large 20]) + +(defn code [x $t] i32 + {:where (enum? $t)} + (i32 x)) + +(defn later? [a $t b $t] bool + {:where (enum? $t)} + (> a b)) + +(defn same? [a $t b $t] bool + {:where (enum? $t)} + (and (= a b) (<= a b))) + +(defn main [] i32 + (let [c (Color 2) + s (Size 20)] + (println (code c)) ; 2 + (println (code s)) ; 20 + (println (later? c (Color 0))) ; true + (println (same? (Color 1) (Color 1))) ; true + (println (f64 (code s)))) ; 20 + 0) diff --git a/test/programs/fn-cfn-table.flan b/test/programs/fn-cfn-table.flan new file mode 100644 index 00000000..3d796620 --- /dev/null +++ b/test/programs/fn-cfn-table.flan @@ -0,0 +1,55 @@ +;; A (CFn ...) in the places that zero-initialise: a struct field, a fixed +;; array's element and a global. A table of bare code addresses is what the +;; narrow function type is for, and the zero is the only objection there ever +;; was — a zeroed CFn is a null address. So a call through one tests it first +;; and signals NullCall rather than jumping to nothing. +;; +;; With no argument the empty calls are answered and the program carries on; +;; with "1" nothing answers and it dies, with the site and the type. + +(defn double [x i32] i32 (* x 2)) +(defn negate [x i32] i32 (- 0 x)) + +(defstruct Ops [name string run (CFn [i32] i32)]) + +(defonce table [3 (CFn [i32] i32)]) +(defonce hook (CFn [i32] i32)) +(defonce evaluated i32 0) +(defonce caught i32 0) +(defonce seen string "") + +(defn arg [x i32] i32 + (set evaluated (+ evaluated 1)) + x) + +(defn try-call [f (CFn [i32] i32) x i32] () + (restart-case + (do (print (f (arg x))) (println "")) + (continue [] (println "empty")))) + +(defn main [args [string]] i32 + (set (at table 0) double) + (set (at table 2) negate) + (let [ops (Ops {.name "half-built"})] + (if (> (length args) 1) + ;; Unanswered: the process dies at the call. + (do (print ((at table 1) 5)) (println "") 0) + (do + (handler-bind + [(NullCall [c] + (set caught (+ caught 1)) + (set seen (.type c)) + (invoke-restart 'continue))] + (dotimes [i 3] (try-call (at table i) 7)) ; 14, empty, -7 + (try-call (.run ops) 1) ; empty + (try-call hook 2) ; empty + (set hook double) + (try-call hook 2)) ; 4 + ;; The argument of a call that is not made is never evaluated. + (print evaluated) (println "") ; 3 + (print caught) (println "") ; 3 + (println seen) ; (CFn [i32] i32) + ;; And a filled field calls as any CFn does. + (let [full (Ops {.name "full" .run negate})] + (print ((.run full) 9)) (println "")) ; -9 + 0)))) diff --git a/test/programs/fn-in-struct.flan b/test/programs/fn-in-struct.flan index 0baf66ce..bc7ab3dd 100644 --- a/test/programs/fn-in-struct.flan +++ b/test/programs/fn-in-struct.flan @@ -9,10 +9,8 @@ ;; the collector and may be kept anywhere, and (Option (Fn ...)) is the field ;; that holds one — see fn-escape.flan. ;; -;; Which means a (CFn ...) field is refused too, and for the zero alone — -;; a table of function pointers is exactly what that type is for, and nothing -;; about capture stands in its way. An (Option (CFn ...)) field is already -;; legal and is the shape that works; TODO.org, "CFn in a struct or a fixed array", carries the rest as its own item. +;; A (CFn ...) field is not refused: every call through one tests for null and +;; signals NullCall, so its zero is an empty slot — fn-cfn-table.flan. (defstruct Ops [run (Fn [i32] i32)]) (defn main [] i32 0) diff --git a/test/programs/grow-param.flan b/test/programs/grow-param.flan new file mode 100644 index 00000000..4e0186c4 --- /dev/null +++ b/test/programs/grow-param.flan @@ -0,0 +1,35 @@ +;;;; A container parameter is a copy of the caller's header. Growing it grows +;;;; the copy, so the caller's container does not see the push; the function +;;;; is warned at, at the parameter, and the fix it names is the (Ptr ...) +;;;; below, which reaches the caller's own header. A struct passed by value +;;;; is a copy too, with its Vec fields in it, and is warned at the same way. + +(defstruct Bag [items (Vec i32) n i32]) +(defstruct Box [bag Bag]) + +(defn add-copy [v (Vec i32)] () (push v 1) (free v)) +(defn add-ptr [v (Ptr (Vec i32))] () (push (deref v) 2)) +(defn put-ptr [m (Ptr (Map i32 i32))] () (put (deref m) 7 8)) +(defn bag-copy [b Bag] () (push (.items b) 1) (free (.items b))) +(defn bag-ptr [x (Ptr Box)] () (push (.items (.bag x)) 3)) + +(defn main [] i32 + (let [v (vec-new i32) + m (map-new i32 i32)] + (add-copy v) + (println (length v)) ; 0 + (add-ptr (addr v)) + (add-ptr (addr v)) + (println (length v)) ; 2 + (println (at v 1)) ; 2 + (put-ptr (addr m)) + (println (length m)) ; 1 + (free v) + (free m)) + (let [x (Box {.bag (Bag {.items (vec-new i32) .n 0})})] + (bag-copy (.bag x)) + (println (length (.items (.bag x)))) ; 0 + (bag-ptr (addr x)) + (println (at (.items (.bag x)) 0)) ; 3 + (free (.items (.bag x)))) + 0) diff --git a/test/programs/into-owning.flan b/test/programs/into-owning.flan new file mode 100644 index 00000000..48bc4aaf --- /dev/null +++ b/test/programs/into-owning.flan @@ -0,0 +1,22 @@ +;;;; into over elements that own storage. Without a (map f) in the chain the +;;;; elements are pushed as they stand, which copies their headers and shares +;;;; their blocks — so that is refused, and (map clone) is the copy that +;;;; compiles. The outer Vecs are in an arena, as a container of owning +;;;; elements has to be; the inner ones are on the heap, where growing one +;;;; through a shared header would free the block the other still points at. + +(defn main [] i32 + (let [a (arena-new 65536) + v (vec-new (Vec i32) a)] + (push v (vec-new i32)) + (push (at v 0) 1) + (let [w (into v (vec-new (Vec i32) a) (map clone))] + (dotimes [i 100] (push (at w 0) i)) + (println (at (at v 0) 0)) ; 1 + (println (length (at v 0))) ; 1 + (println (length (at w 0))) ; 101 + (println (at (at w 0) 100)) ; 99 + (free (at w 0))) + (free (at v 0)) + (arena-destroy a) + 0)) diff --git a/test/programs/prelude-names.flan b/test/programs/prelude-names.flan new file mode 100644 index 00000000..a5fb7267 --- /dev/null +++ b/test/programs/prelude-names.flan @@ -0,0 +1,22 @@ +;;;; A program's names do not change what the prelude means. The prelude's +;;;; generics write their type variable bare, (vec-new t), and name +;;;; parameters t, k and v; a global or a type the program declares under one +;;;; of those names is the program's, and the prelude's own reading stands. + +(defonce t [4 i32]) +(defstruct k [x i32]) +(defenum v [lo hi]) + +(defn even? [x i32] bool (= (% x 2) 0)) + +(defn main [] i32 + (set (at t 0) 7) + (let [xs [1 2 3 4 5 6] + evens (filter (slice xs) even?)] + (println (length evens)) ; 3 + (println (at evens 2)) ; 6 + (free evens)) + (println (at t 0)) ; 7 + (println (.x (k {.x 5}))) ; 5 + (println (i32 (v 1))) ; 1 + 0) diff --git a/test/programs/shadow-prelude-global.flan b/test/programs/shadow-prelude-global.flan new file mode 100644 index 00000000..9cd578b7 --- /dev/null +++ b/test/programs/shadow-prelude-global.flan @@ -0,0 +1,14 @@ +;;;; A program's global named as a prelude function takes the name over for +;;;; its own file, as a program's function does, and the prelude's own calls +;;;; keep the prelude's: sort still swaps with the prelude's swap. +(defonce swap i32 3) +(defonce clamp i32 4) +(defconst reverse i32 5) + +(defn main [] i32 + (println (+ swap clamp reverse)) ; 12 + (let [xs [3 1 2]] + (sort (slice xs)) + (println (at xs 0)) ; 1 + (println (at xs 2))) ; 3 + 0) diff --git a/test/programs/shadow-prelude.flan b/test/programs/shadow-prelude.flan index a9d628ae..23cf3661 100644 --- a/test/programs/shadow-prelude.flan +++ b/test/programs/shadow-prelude.flan @@ -1,13 +1,23 @@ ;;;; A program's function named as a prelude function takes the name over for ;;;; the calls in its own file, and the prelude's own calls keep the prelude's: ;;;; ceil-f32 is written over the prelude's floor-f32, and still answers 3. +;;;; A prelude macro is taken over the same way: clamp and update below are +;;;; the program's functions, and format-f64, which the prelude writes with +;;;; its own clamp, still clamps its precision to 9. (defn abs-f32 [v f32] f32 (if (< v 0.0) (- v) (+ v (f32 100.0)))) (defn floor-f32 [x f32] f32 (f32 999.0)) (defn abs [x i32] i32 (* x 10)) +(defn clamp [x i32 lo i32 hi i32] i32 (+ x lo hi)) +(defn update [x i32] i32 (* x 7)) (defn main [] i32 (println (abs-f32 (f32 -2.5))) (println (abs-f32 (f32 2.5))) (println (floor-f32 (f32 2.3))) (println (ceil-f32 (f32 2.3))) (println (abs -3)) + (println (clamp 1 2 3)) + (println (update 6)) + (let [s (format-f64 0.5 40)] + (println (length s)) + (free s)) 0) diff --git a/test/programs/update-place.flan b/test/programs/update-place.flan new file mode 100644 index 00000000..8da35858 --- /dev/null +++ b/test/programs/update-place.flan @@ -0,0 +1,55 @@ +;;;; update, ++ and -- evaluate every subexpression of their place once, as +;;;; C's compound assignment does. `calls` counts the index function: one call +;;;; per form, and the read and the write land on the same element. + +(defonce calls i32 0) + +(defn next-index [] i32 + (set calls (+ calls 1)) + (- calls 1)) + +(defstruct Body [velocity i32 hits [3 i32]]) + +(defn add [x i32 y i32] i32 (+ x y)) + +(defclass counter [n i32]) + +(defn which-slot [] dyn + (set calls (+ calls 1)) + :n) + +(defn main [] i32 + (let [xs [10 20 30] + v (vec-new i32) + g (Body {.velocity 5})] + (push v 1) (push v 2) (push v 3) + ;; next-index answers 0, then 1, then 2. + (++ (at xs (next-index))) + (-- (at v (next-index))) + (update (at xs (next-index)) * 3) + (println calls) ; 3 + (println (at xs 0) (at xs 1) (at xs 2)) ; 11 20 90 + (println (at v 0) (at v 1) (at v 2)) ; 1 1 3 + ;; A field, with a macro as the function, and with arguments after it. + (update (.velocity g) inc) + (update (.velocity g) add 10) + (println (.velocity g)) ; 16 + ;; A path through a field into an element: the struct is written in place, + ;; not in a copy. + (set calls 0) + (update (at (.hits g) (next-index)) + 7) + (++ (at (.hits g) (next-index))) + (println calls) ; 2 + (println (at (.hits g) 0) (at (.hits g) 1)) ; 7 1 + ;; Through a pointer. + (let [p (addr (.velocity g))] + (update (deref p) * 2) + (println (.velocity g))) ; 32 + (free v)) + ;; A class slot, with the key computed once. + (let [c (counter 4)] + (set calls 0) + (++ (get c (which-slot))) + (update (get c (which-slot)) * 10) + (println calls (get c :n))) ; 2 50 + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 8b2db4ec..71bc029f 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -432,6 +432,13 @@ let () = match_enum_out; outputs ~dev:true "match over an enum, dev" "programs/match-enum.flan" match_enum_out; + (* update, ++ and -- evaluate their place's subexpressions once: the + counts are the number of calls an index or a key function got. *) + let update_out = "3\n11 20 90\n1 1 3\n16\n2\n7 1\n32\n2 50\n" in + outputs "update evaluates its place once" "programs/update-place.flan" + update_out; + outputs ~x86:true "update evaluates its place once, --x86" + "programs/update-place.flan" update_out; (* The count is [length] so that [len] is left to programs, and this is the claim that it really is one: a local holding a count, a parameter, and a defn the program calls by its bare name, all of @@ -581,10 +588,15 @@ let () = "programs/array-mixed.flan" mixed_out; (* A program's function named as a prelude function takes the name over for its own file; the prelude's own calls keep the prelude's. *) - let sp_out = "2.5\n102.5\n999\n3\n-30\n" in + let sp_out = "2.5\n102.5\n999\n3\n-30\n6\n42\n11\n" in outputs "a prelude function shadowed" "programs/shadow-prelude.flan" sp_out; outputs ~x86:true "a prelude function shadowed, x86" "programs/shadow-prelude.flan" sp_out; + (* And by a program's global, the same way. *) + outputs "a prelude function shadowed by a global" + "programs/shadow-prelude-global.flan" "12\n1\n3\n"; + outputs ~x86:true "a prelude function shadowed by a global, x86" + "programs/shadow-prelude-global.flan" "12\n1\n3\n"; (* (max-value T) and (min-value T), concrete and inside a generic. *) let maxof_out = "255\n0\n127\n-128\n2147483647\n-9223372036854775808\n\ @@ -613,6 +625,20 @@ let () = source transformed in two orders, which have to differ. *) outputs "into" "programs/into.flan" "7 8 9 \n2 4 6 8 10 12 \n4 8 12 \n21\n6 2 4 \n3 1 2 \n3 4 \n2 4 \n1\n"; + (* The fix into's refusal names for owning elements, (map clone): the + copy's inner Vec grows on the heap and the source's is untouched. *) + (* Program names that spell the prelude's own leave the prelude alone. *) + outputs "a program's names and the prelude's" "programs/prelude-names.flan" + "3\n6\n7\n5\n1\n"; + outputs ~x86:true "a program's names and the prelude's, --x86" + "programs/prelude-names.flan" "3\n6\n7\n5\n1\n"; + (* A grown container parameter reaches the caller only through a Ptr. *) + outputs "a grown parameter" "programs/grow-param.flan" "0\n2\n2\n1\n0\n3\n"; + outputs ~x86:true "a grown parameter, --x86" "programs/grow-param.flan" + "0\n2\n2\n1\n0\n3\n"; + outputs "into with (map clone)" "programs/into-owning.flan" "1\n1\n101\n99\n"; + outputs ~x86:true "into with (map clone), --x86" "programs/into-owning.flan" + "1\n1\n101\n99\n"; (* The prelude's slice algorithms. Every assertion here is over an input a wrong implementation fails: unsorted with duplicates, negatives and an odd length; a reverse-sorted slice; and a sort of a subslice whose @@ -1947,7 +1973,7 @@ let () = let dyn_if_truthy_out = "falsey\nfalsey\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\n\ truthy\ntruthy\ntruthy\nwhen 0 ran\nwhen empty-string ran\nb\nb\n\ - :kw\nfalse\nnil\n\n0\nfalse\nx\n5\n\ + :kw\nfalse\nnil\n\n0\nfalse\nx\n5\ns\nnil\nnil\ny\ntrue\n\ nil\n\nnil\n0\ntrue\nfalse\n\ nil\nand-reached\n2\n7\nor-reached\n1\n\ and-decider\nnil\nor-decider\n9\n\ @@ -4197,6 +4223,11 @@ level "1" lo\nmid\nhi\nother\n" in outputs "enum conversion" "programs/enum-convert.flan" enum_conv_out; + (* The generic enum-to-number conversion enum? licenses. *) + outputs "a generic enum conversion" "programs/enum-generic.flan" + "2\n20\ntrue\ntrue\n20\n"; + outputs ~x86:true "a generic enum conversion, --x86" + "programs/enum-generic.flan" "2\n20\ntrue\ntrue\n20\n"; outputs ~opt:"-O0" "enum conversion, -O0" "programs/enum-convert.flan" enum_conv_out; @@ -4691,6 +4722,35 @@ level "1" outputs ~dev:true "the two function types, dev" "programs/fn-cfn.flan" fn_ptr_out; + (* A CFn in a struct field, a fixed array and a global, each zeroed until + stored into. A call through an empty one signals NullCall, before its + arguments run; answered, the program carries on, and unanswered it dies + naming the site and the type — on both backends. *) + let cfn_table_out = + "14\nempty\n-7\nempty\nempty\n4\n3\n3\n(CFn [i32] i32)\n-9\n" + in + outputs "a CFn table" "programs/fn-cfn-table.flan" cfn_table_out; + outputs ~x86:true "a CFn table, --x86" "programs/fn-cfn-table.flan" + cfn_table_out; + outputs ~dev:true "a CFn table, dev" "programs/fn-cfn-table.flan" + cfn_table_out; + List.iter + (fun x86 -> + let exe = compile ~x86 "programs/fn-cfn-table.flan" in + let code, text = run exe (Some "1") in + if code <> 134 + || not (contains text "programs/fn-cfn-table.flan:") + || not (contains text "this call is through a (CFn [i32] i32) \ + that holds no function") + then begin + incr failures; + Printf.printf "FAIL an unanswered empty CFn call dies%s\n \ + got: %S (exit %d)\n" + (if x86 then ", --x86" else "") text code + end; + (try Sys.remove exe with Sys_error _ -> ())) + [ false; true ]; + (* Two signatures that flatten to one string under [mangle_ty], which is how the thunk memo used to be keyed. Keyed on the name, the second widening reuses the first's thunk at the wrong arity — a miscompile @@ -4946,6 +5006,17 @@ level "1" "(defn main [] i32 (++) 0)" "++-takes-one-place"; macro_arity "-- with two arguments" "(defn main [] i32 (let [a 1 b 2] (-- a b)) 0)" "---takes-one-place"; + macro_arity "update with no function" + "(defn main [] i32 (let [a 1] (update a)) 0)" + "update-takes-a-place-and-a-function"; + (* A place update takes is a place set takes, and is refused the same way. *) + macro_arity "update of something that is not a place" + "(defn main [] i32 (update 5 inc) 0)" "5 is not assignable"; + macro_arity "update of a parameter" + "(defn f [a i32] () (update a inc))" "a is a parameter"; + macro_arity "update whose function answers the wrong type" + "(defn yes [x i32] bool true)\n(defn f [] () (let [a 1] (update a yes)))" + "expected i32"; (* unless keeps a guard, and it is now the narrower one: a body may be missing, a test may not. *) macro_arity "unless with no test at all" @@ -7140,6 +7211,9 @@ level "1" (let code, text = cli "check programs/shadow-prelude.flan" in if code <> 0 || contains text "prelude~" || not (contains text "defn floor-f32") + (* A macro taken over is warned about as a function is. *) + || not (contains text "clamp shadows the prelude's clamp") + || not (contains text "update shadows the prelude's update") then begin incr failures; Printf.printf diff --git a/test/test_dev.ml b/test/test_dev.ml index 21823d3c..2fbffd7f 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2376,6 +2376,88 @@ let () = pointer: the bytes-view write that first crashed no longer compiles. *) trap_park ~refault:true "segfault" "dev-segv.flan" "SegFault" []; + (* ── A break over a call through a null CFn ───────────────────────── + + NullCall is a condition, signalled as a bad index is: nothing handles + it in dev-break-nullcall.flan, so the program parks with NullCall + named, the program's own continue on offer and takeable, and taking it + resumes — the transcript's 1 is continue's clause having run. On both + backends, since the null test before the call is emitted by each. *) + let null_park backend = + let nsock = tmp ("nullcall" ^ backend ^ ".sock") + and nout = tmp ("nullcall" ^ backend ^ ".out") in + (try Sys.remove nsock with Sys_error _ -> ()); + let nfd = + Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let npid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-break-nullcall.flan"; "-s"; nsock; backend |] + Unix.stdin nfd Unix.stderr + in + Unix.close nfd; + if not (listening ~pid:npid nsock) then begin + fail "the null-call daemon (%s) %s" backend !listen_why; + (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let out = Buffer.create 64 in + let c = connect nsock in + let ask sexp = + let r = Wire.parse (Wire.send c sexp; Wire.recv c) in + (match Wire.string_field r "output" with + | Some t -> Buffer.add_string out t + | None -> ()); + r + in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let last = ref (Wire.parse "()") in + if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last)) + then fail "a null CFn call never stopped the program (%s)" backend + else begin + (match Wire.string_field !last "condition" with + | Some "NullCall" -> () + | c -> + fail "a null CFn call is reported as %S (%s)" + (Option.value ~default:"" c) backend); + let r = ask "(:op \"break\")" in + (match Wire.field r "restarts" with + | Some { Form.v = Form.List l; _ } + when List.exists + (fun (n : Form.t) -> n.Form.v = Form.Str "continue") l -> () + | _ -> fail "a null CFn call offers no continue (%s)" backend); + let r = ask "(:op \"restart\" :name \"continue\")" in + if status r <> "ok" then + fail "continuing past a null CFn call (%s): %s" backend + (Option.value ~default:"" (Wire.string_field r "message")); + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + List.mem "1" + (String.split_on_char '\n' (Buffer.contents out)))) + then fail "the program never resumed past a null CFn call (%s)" backend + end; + ignore (ask "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] npid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ()) + end + end + in + null_park "--llvm"; + null_park "--x86"; + (* ── The locals of a stopped frame ─────────────────────────────── *) (* A third daemon, over a program that stops with something worth looking @@ -2731,6 +2813,21 @@ let () = want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})"; want "box" "(some \"x\")" "f32" "4.5"; want "s" "(\"Shape.Rect.w\")" "i32" "3"; + (* A package's type is its qualified name, in the inspector and in + the listing both, as a field's and a condition's already are: + two packages may each declare a Box. *) + want "pk" "()" "shape/Box" "(shape/Box {.w 3 .h 4})"; + (match Wire.field listing "locals" with + | Some { Form.v = Form.List l; _ } + when List.exists + (fun (e : Form.t) -> + match e.Form.v with + | Form.List + ({ Form.v = Form.Str "pk"; _ } + :: { Form.v = Form.Str "shape/Box"; _ } :: _) -> true + | _ -> false) + l -> () + | _ -> fail "the listing does not name pk's type as shape/Box"); (* Where each value is stored. The struct and its first field share an address and the second field is one f32 further on, so the number is the layout's and not a label. *) diff --git a/test/test_flan.ml b/test/test_flan.ml index b7599ca7..38f09568 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3190,6 +3190,45 @@ let () = rejects_check "clone on a slice of owning elements" "(defn f [v [(Vec i32)]] i32 (length (clone v)))" ~needle:"[(Vec i32)] cannot be cloned"; + (* into with no (map f) pushes the source's elements as they stand, which + for an owning element shares its block — pushing through the copy then + frees the source's. The fix it names is programs/into-owning.flan. *) + rejects_check "into copying owning elements, refused at the source" + "(defn f [a Allocator] i32\n\ + \ (let [v (vec-new (Vec i32) a)\n\ + \ w (into v (vec-new (Vec i32) a) (filter nonempty?))] (length w)))\n\ + (defn nonempty? [x (Vec i32)] bool (> (length x) 0))" + ~needle:"into copies each element of v as it stands, and an element of v \ + is a (Vec i32), which owns storage — the copy would share each \ + element's block with v, and growing either one frees the block \ + the other points at. Add (map clone) to the chain, which copies \ + what each element owns: (into v (vec-new (Vec i32) a) (filter \ + nonempty?) (map clone))"; + accepts "into with (map clone) over owning elements" + "(defn f [a Allocator] i32\n\ + \ (let [v (vec-new (Vec i32) a)\n\ + \ w (into v (vec-new (Vec i32) a) (map clone))] (length w)))"; + accepts "into of plain elements is untouched" + "(defn f [v [i32]] () (let [w (into v (vec-new i32))] (free w)))"; + rejects_check "into copying elements clone cannot copy, explained" + "(defstruct B [xs (Vec i32)])\n\ + (defn f [v [B] a Allocator] i32 (let [w (into v (vec-new B a))] (length w)))" + ~needle:"Nothing copies what a B owns, so no copy of v can stand on its \ + own"; + rejects_check "clone's refusal names a clone of each element" + "(defn f [v [(Vec i32)]] i32 (length (clone v)))" + ~needle:"push a (clone x) of each element into it"; + (* A program's names cannot change what the prelude means: a global or a + type spelled like a built-in type is refused where it is declared, and + the rest are programs/prelude-names.flan. *) + rejects_check "a global named like a built-in type" + "(defonce u8 i32)" + ~needle:"u8 is a type, so it cannot also name a global"; + rejects_check "a type named like a built-in type" + "(defstruct i32 [x i32])" + ~needle:"i32 is a built-in type, so it cannot be declared again"; + accepts "a global and a type named after the prelude's type variables" + "(defonce t [4 i32])\n(defstruct k [x i32])\n(defenum v [lo hi])"; accepts "clone on a slice, with and without an allocator" "(defn f [v [f64] a Allocator] i32 (+ (length (clone v)) (length (clone v a))))"; @@ -3569,6 +3608,23 @@ let () = "(defn h [x i32] i32 x) (defn g [i i32] (Fn [i32] i32) h)\n\ (defn f [] i32 (let [a (array-gen [2] g)] 0))" ~needle:"a fixed array's element cannot be (Fn [i32] i32)"; + (* A (CFn ...) is not refused in any of them: a call through one tests for + null and signals NullCall, so its zero is an empty slot. *) + accepts "a CFn struct field" + "(defstruct Ops [run (CFn [i32] i32)])\n\ + (defn f [o Ops] i32 ((.run o) 1))"; + accepts "a fixed array of CFn" + "(defonce tbl [4 (CFn [i32] i32)])\n(defn f [] i32 ((at tbl 0) 1))"; + accepts "a CFn global with no initialiser" + "(defonce hook (CFn [] ()))\n(defn f [] () (hook))"; + accepts "(zeroed) at a CFn" + "(defn f [] i32 (let [g (the (CFn [i32] i32) (zeroed))] (g 1)))"; + accepts "an array-gen of CFn" + "(defn h [x i32] i32 x) (defn g [i i32] (CFn [i32] i32) h)\n\ + (defn f [] i32 (let [a (array-gen [2] g)] ((at a 1) 3)))"; + rejects_check "an Fn struct field is still refused" + "(defstruct Ops [run (Fn [i32] i32)])" + ~needle:"the field run cannot be (Fn [i32] i32)"; (* The inline form, the design's canonical one. An fn normally takes its types from a (Fn ...) want, and this position has none — the *form* @@ -5639,6 +5695,42 @@ let () = rejects_check "and offers no comparison at all for a type that has none" "(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (if p 1 0)))" ~needle:"a condition is a bool or a dyn, and this is P"; + (* A deep nest of not over a condition that is refused. Each level retries + the level below it for its message, and a refusal already settled is + answered from memory, so two hundred levels fail at once — re-walking + each subtree doubled the work per level. The message is the innermost + condition's, as it is at one level. *) + (let deep = + let rec nest k e = if k = 0 then e else nest (k - 1) ("(not " ^ e ^ ")") in + "(defn g [x i32] bool " ^ nest 200 "x" ^ ")" + in + let t0 = Unix.gettimeofday () in + match checked deep with + | _ -> check "a deep not nest over an i32 is refused" false + | exception Loc.Error { Loc.dmsg; _ } -> + check "a deep not nest over an i32 fails fast" + (Unix.gettimeofday () -. t0 < 3.0); + check "a deep not nest keeps the one-level message" + (dmsg = "a condition is a bool or a dyn, and this is i32 — test it, as \ + (!= x 0)")); + (* A long or chain refused at its last operand, with nothing expected of it. + Each if tries its else arm on its own terms before checking it at bool, + and a refused if is answered from memory, so a thousand operands fail + at once rather than in the square of that. *) + (let deep = + "(defn g [x i32] bool (let [b (or " + ^ String.concat " " (List.init 1000 (Printf.sprintf "(= x %d)")) + ^ " 5)] b))" + in + (* Timed rather than under [Watchdog.within]: a catch-all inside the + checker can swallow the alarm's exception. *) + let t0 = Unix.gettimeofday () in + match checked deep with + | _ -> check "a refused or chain is refused" false + | exception Loc.Error { Loc.dmsg; _ } -> + check "a refused or chain fails fast" (Unix.gettimeofday () -. t0 < 3.0); + check "a refused or chain keeps the one-operand message" + (dmsg = "expected bool, found the integer literal 5")); (* A literal still names itself: that message knows something the rule does not, so the re-check's answer is kept wherever it is more specific. *) rejects_check "a literal condition keeps its own message" @@ -5754,6 +5846,97 @@ let () = (match checked shadow_src with | _ -> true | exception Loc.Error _ -> false); + (* A parameter vector paired by a lowercase type the program declares reads + as two dyn parameters the day the type goes, so the pairing is warned at, + naming the type and where it is declared. A capitalised type cannot be a + parameter name, so it has nothing to warn about. *) + (match + checked "(defstruct point [x i32])\n(defstruct Vec2 [x i32])\n\ + (defn px [p point] i32 (.x p))\n(defn vx [v Vec2] i32 (.x v))" + with + | _ -> + (match !Check.pairing_warnings with + | [ d ] -> + check "a lowercase declared type in a parameter vector is warned at" + (d.Loc.kind = "check/parameter-reads-a-type" + && d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 13 + && d.Loc.dmsg + = "[p point] is one parameter p of type point, the struct \ + declared at :1:1, and not two dyn parameters. If two \ + were meant, give the second a name no type has") + | ds -> + check + (Printf.sprintf "one pairing warning, not %d" (List.length ds)) + false) + | exception Loc.Error _ -> check "the paired program checks" false); + (* A Vec or Map parameter is the caller's header copied, so growing it is + warned at the parameter, once, naming the (Ptr ...) that reaches the + caller's own. A pointer parameter and a local are not warned at. The + running side is programs/grow-param.flan. *) + let grown src = + match checked src with + | _ -> Some !Check.grow_warnings + | exception Loc.Error _ -> None + in + (match + grown "(defn f [v (Vec i32) m (Map i32 i32)] ()\n\ + \ (push v 1) (reserve v 8) (put m 1 2))" + with + | Some [ dm; dv ] -> + check "a grown Vec parameter is warned at the parameter" + (dv.Loc.kind = "check/grown-parameter" + && dv.Loc.dloc.Loc.line = 1 && dv.Loc.dloc.Loc.col = 10 + && dv.Loc.dmsg + = "v is a (Vec i32) passed by value, a copy of the caller's header, \ + so the push at :2:3 grows this function's copy and the \ + caller's container never sees it. Take it as (Ptr (Vec i32)) \ + and write (push (deref v) ...), and each caller passes (addr c) \ + for its container c"); + check "and a grown Map parameter names put" + (dm.Loc.dloc.Loc.col = 22 + && Test_support.contains dm.Loc.dmsg "the put at :2:28") + | Some ds -> + check (Printf.sprintf "two grow warnings, not %d" (List.length ds)) false + | None -> check "the grown-parameter program checks" false); + (* A struct parameter is a copy with its Vec fields in it, through any + depth of fields taken by value; through a pointer, not. *) + (match + grown "(defstruct Bag [items (Vec i32)])\n(defstruct Box [bag Bag])\n\ + (defn f [x Box] () (push (.items (.bag x)) 1))\n\ + (defn g [x (Ptr Box)] () (push (.items (.bag x)) 1))" + with + | Some [ d ] -> + check "a grown field of a struct parameter is warned at the parameter" + (d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 10 + && d.Loc.dmsg + = "x is a Box passed by value, a copy of the caller's, so the push \ + at :3:20 grows (.items (.bag x)) in this function's copy \ + and the caller's never sees it. Take it as (Ptr Box), where \ + (.items (.bag x)) reaches the caller's own, and each caller \ + passes (addr c) for its Box c") + | Some ds -> + check (Printf.sprintf "one field grow warning, not %d" (List.length ds)) false + | None -> check "the grown-field program checks" false); + (* Not when the grown copy goes back to the caller — the parameter, or the + struct holding the field, is what the function answers — nor when the + field is given a container of the function's own before it grows. *) + check "a grown parameter the function returns is not warned at" + (grown "(defstruct Bag [items (Vec i32)])\n\ + (defn add [v (Vec i32) x i32] (Vec i32) (push v x) v)\n\ + (defn early [v (Vec i32) c bool] (Vec i32) (push v 1) \ + (when c (return v)) v)\n\ + (defn bag [b Bag] Bag (push (.items b) 1) b)\n\ + (defn items [b Bag] (Vec i32) (push (.items b) 1) (.items b))" + = Some []); + check "a field reassigned before it grows is not warned at" + (grown "(defstruct Bag [items (Vec i32)])\n\ + (defn f [b Bag] ()\n\ + \ (set (.items b) (vec-new i32)) (push (.items b) 1) (free (.items b)))" + = Some []); + check "a pointer parameter and a local are not warned at" + (grown "(defn f [v (Ptr (Vec i32))] ()\n\ + \ (push (deref v) 1) (let [w (vec-new i32)] (push w 1) (free w)))" + = Some []); check "a program that shadows nothing is warned at not at all" (Check.shadowed_builtins (program "(defn f [] i32 1)") = []); (* A prelude function's name is taken over the same way, for the calls in @@ -5772,6 +5955,20 @@ let () = | _ -> check "a defn of a prelude function's name warns exactly once" false); accepts "a defn of a prelude function's name is not defined twice" prelude_src; + (* A global takes the name over the same way, with the same warning. *) + (match + snd (Check.shadow_prelude (Parse.program (Prelude.forms ())) + (program "(defonce swap i32 3)")) + with + | [ d ] -> + check "a global of a prelude function's name warns once" + (d.Loc.kind = "check/shadows-prelude" + && d.Loc.dmsg + = "swap shadows the prelude's swap — every use in this file now \ + reaches your definition") + | _ -> check "a global of a prelude function's name warns exactly once" false); + accepts "a global of a prelude function's name is not defined twice" + "(defonce swap i32 3)\n(defn f [] i32 swap)"; rejects_check "a struct of a prelude type's name is still defined twice" "(defstruct Form [x i32])" ~needle:"Form is defined twice"; (* An operator is a builtin like any other and shadows like any other. @@ -6145,7 +6342,8 @@ let () = and the message says which predicate to write. *) rejects_check "ordered? does not admit a conversion" ~needle:"The where clause says t is ordered?, and that does not make it \ - a number — add (numeric? $t) to the where clause" + a number or an enum — add (numeric? $t) to the where clause, or \ + (enum? $t) for an enum" "(defn to32 [x $t] i32 {:where (ordered? $t)} (i32 x))"; rejects_check "nor does equal?" ~needle:"add (numeric? $t) to the where clause" @@ -6156,9 +6354,28 @@ let () = (* With no clause at all the message hands over the whole clause rather than a predicate to add to one that is not there. *) rejects_check "an unbounded variable does not convert" - ~needle:"i32 converts a number. Nothing here says t is a number — write \ - {:where (numeric? $t)} at the head of the body" + ~needle:"i32 converts a number or an enum. Nothing here says t is a \ + number or an enum — write {:where (numeric? $t)} at the head of \ + the body, or {:where (enum? $t)} for an enum" "(defn to32 [x $t] i32 (i32 x))"; + (* enum? is the other bound a conversion to a number takes: it admits the + enums, which convert as an i32, and entails ordered? and equal? but not + numeric?. The running side is programs/enum-generic.flan. *) + accepts "enum? admits the conversion from an enum" + "(defn code [x $t] i32 {:where (enum? $t)} (i32 x))"; + accepts "and compares, being ordered? and equal?" + "(defn later? [a $t b $t] bool {:where (enum? $t)} (and (> a b) (= a b)))"; + rejects_check "but is not a number" + ~needle:"$t" + "(defn sum [a $t b $t] $t {:where (enum? $t)} (+ a b))"; + rejects_check "and admits no integer at the call" + ~needle:"i32 is not enum?" + "(defn code [x $t] i32 {:where (enum? $t)} (i32 x))\n\ + (defn f [] i32 (code (i32 3)))"; + rejects_check "nor the conversion to an enum, which needs an integer" + ~needle:"add (integer? $t) to the where clause" + "(defenum K [lo -1 hi 1])\n\ + (defn as-k [n $t] K {:where (enum? $t)} (K n))"; (* The operand of a cast to a *variable* target is asked the same question the target was: the target's bound says nothing about a second variable standing in the argument. *) diff --git a/test/test_session.ml b/test/test_session.ml index 25c3bbe1..49fc2817 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -64,6 +64,19 @@ let () = fail "%s left a caller behind that nothing has" name | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" name m in + (* A session's defn named as a prelude macro shadows it for a later form + sent alone, as the same defn does in a file. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + match + ignore (Session.eval t "(defn clamp [x i64] i64 (+ x 1))"); + Session.eval t "(defn clamped [] i64 (clamp 4))" + with + | c -> + if not (List.mem "clamped" c.Session.fns) then + fail "a call to a session's clamp installed %s" + (String.concat " " c.Session.fns) + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a call to a session's clamp was expanded as the macro: %s" m); installs "a changed parameter type" "(defn outer [x i64] i64 (bump))"; installs "a changed return type" "(defn outer [] i32 (i32 (bump)))"; installs "a changed arity" "(defn outer [a i64 b i64] i64 (bump))"; diff --git a/test/test_syntax.ml b/test/test_syntax.ml index d8dc6426..ab4fb6a3 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -354,6 +354,9 @@ let () = reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)"; reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))"; reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))"; + (* A place with a call in it is evaluated once: it reads as update. *) + reads "assignment op over a call's place" "a[next()] += 1" + "(update (at a (next)) + 1)"; reads "for" "for :outer i in range(1, n)\n f(i)" "(dotimes :outer [i 1 n] (f i))"; reads "unit statement" "restart-case\n f()\nrestart continue()\n ()" "(restart-case (f) (continue [] (do)))"; @@ -413,6 +416,8 @@ let () = | exception e -> fail "%s: %s" name (diag_text e) in prints "compound assignment" "(defn f [] () (set x (+ x 1)))" " x += 1"; + prints "compound update" "(defn f [] () (update (at a (next)) + 1))" + " a[next()] += 1"; prints "arm statements" "(defn f [] () (match s 1 (break) _ (return 2)))" "1 -> break\n _ -> return 2"; prints "then and else statements" "(defn f [] () (if c (return 1) (set x 2)))" diff --git a/web/index.html b/web/index.html index 862104c5..ea18a0de 100644 --- a/web/index.html +++ b/web/index.html @@ -1277,13 +1277,14 @@ $t)} at the head of the body, or take the operation as a parameter — a

What makes that liveable is a where clause, written as a Clojure-style map at the head of the body — {:where (ordered? $t)}, or a vector when there is more than one: {:where [(ordered? $t) (hashable? $u)]}. There -are five predicates, and each gates builtins the compiler already has:

+are six predicates, and each gates builtins the compiler already has:

+ @@ -1292,7 +1293,8 @@ are five predicates, and each gates builtins the compiler already has:

They entail each other in one direction, so one clause usually does: integer? gives numeric?, numeric? gives -ordered?, and ordered? gives equal?. A +ordered?, and ordered? gives equal?; +enum? gives ordered? too. A sort that compares its elements declares ordered? and nothing else, and the prelude's abs declares integer? alone — the bound is what keeps its integer body away from the floats, whose

PredicateWhat it admits
integer?bit-and bit-or bit-xor << >> — every integer type, no float
numeric?+ - * / %, and a cast (t x)
enum?a cast to a number, (i32 x) — every enum type
ordered?< <= > >= min max
equal?= and !=
hashable?the variable as a Map key — (map-new t V), get, put, has-key?