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

The checker refuses what it cannot type honestly and says which element is wrong

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 13:29:56 +07:00
commit 8eca8c78f2
26 changed files with 1216 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
TODO.org
View File

@ -147,14 +147,7 @@ CLOSED: [2026-09-25]
=f64-inf=, =f64-nan=, =f32-inf= and =f32-nan= are names the checker supplies =f64-inf=, =f64-nan=, =f32-inf= and =f32-nan= are names the checker supplies
(=Check.special_float=), reached only after every local, global and function has (=Check.special_float=), reached only after every local, global and function has
missed, so a program's own binding of one wins. Negative infinity is missed, so a program's own binding of one wins. Negative infinity is
=(- 0.0 f64-inf)=: the decision wrote =(- f64-inf)=, and there is no unary minus. =(- f64-inf)=. Rules out Clojure's =##Inf= reader literal.
Rules out Clojure's =##Inf= reader literal.
** TODO (!= x x) is false for a NaN
=!== on floats is LLVM's ordered =one= on both backends (=lib/emit.ml= =fcmp_op=,
=lib/x86.ml= =float_cc=), so =(!= f64-nan f64-nan)= is =false= where C, Odin and
IEEE 754 say =true=; =(not (= x x))= is the only NaN test that works. Changing it
to =une= is a decision about what =!== means.
** DONE A u64 constant above 2^63 cannot be written in decimal ** DONE A u64 constant above 2^63 cannot be written in decimal
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
@ -162,8 +155,8 @@ An integer written at or above 2^63 — a decimal up to 2^64 - 1, or hex with th
top bit set — reads as =Form.UInt=, its pattern and its spelling. It is accepted top bit set — reads as =Form.UInt=, its pattern and its spelling. It is accepted
where the type is =u64=, a =(u64 ...)= cast included, and refused everywhere else where the type is =u64=, a =(u64 ...)= cast included, and refused everywhere else
in the spelling it was written in. Hex with the top bit set was accepted as a in the spelling it was written in. Hex with the top bit set was accepted as a
negative at any integer type before this; it is refused now too. A negative negative at any integer type before this; it is refused now too. A cast's
decimal is still a =u64= bit pattern. A cast's integer literal that does not fit integer literal that does not fit
=i32= is checked at the cast's type; one that fits keeps the =i32= default, so =i32= is checked at the cast's type; one that fits keeps the =i32= default, so
=(u32 -1)= still means what it did. A wide literal passed to a macro as an =(u32 -1)= still means what it did. A wide literal passed to a macro as an
argument comes back wide: it crosses as an =Int= with a token in the unused argument comes back wide: it crosses as an =Int= with a token in the unused
@ -957,19 +950,13 @@ type an expression cannot hold, such as =(Fn [i32] ())=, is parsed as
** DONE An array literal cannot say it is [f32] ** DONE An array literal cannot say it is [f32]
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
With nothing outside an array literal naming its element type, the first =(the [f32] [1 2.5])= names the element type; with nothing naming one, a literal
element's type is the want for the rest, so =[(f32 1.0) 2.5]= is a =[2 f32]=. A element takes the other elements' type. Rules out a =1.0f= suffix for now.
refusal of a later element carries a note at the first saying it set the type.
Rules out a =1.0f= suffix for now.
** NEXT A let binding takes no type annotation ** DONE A let binding takes no type annotation
Decided 2026-09-25: =(the T expr)=, Common Lisp's special operator, gives any expression its want; checked at compile time like any other want, and it compiles to nothing. =let= is unchanged. On a =dyn= operand it is refused, naming the cast. The refusals that say "annotate the binding" — =None=, an empty =[]=, and =(zeroed)=/=(filled)=/=(dead-beef)= with no want — suggest it instead, because today their suggestion cannot compile. CLOSED: [2026-09-25]
Everything under the surface is there — the binding carries a type slot and the =(the T expr)= gives any expression its want and =let= stays a flat list of
checker consumes it as the want — and only the way it is written is open, because pairs. Rules out a type slot in =let=.
=let= is a flat list of pairs and cannot disambiguate by count. No longer the
blocker it was, since =(array 4 T)= answers the case that raised it. plan.org's
rule is "annotate function signatures, infer locals", so a general annotation is a
deliberate absence.
** NEXT A read-only slice type ** NEXT A read-only slice type
Decided 2026-09-25: =[const u8]=, Zig's spelling in Flan's brackets. =bytes-view= answers one and a =set= through it is a compile error; a =[T]= converts to =[const T]= and not back, and the prelude's read-only functions take it. =const= is reserved as a name, since =[n T]= accepts a constant's name for =n=. Decided 2026-09-25: =[const u8]=, Zig's spelling in Flan's brackets. =bytes-view= answers one and a =set= through it is a compile error; a =[T]= converts to =[const T]= and not back, and the prelude's read-only functions take it. =const= is reserved as a name, since =[n T]= accepts a constant's name for =n=.
@ -1025,10 +1012,9 @@ died in the backend as a redefinition of a symbol, a message with no source
location. location.
** DONE A u64 literal is its 64-bit pattern ** DONE A u64 literal is its 64-bit pattern
The cost of accepting the pattern is that a negative decimal literal is accepted A negative literal fits no unsigned type, u64 included; =(u64 -1)= is how the
as a =u64=, because the reader records the value and not how it was written. pattern is written, and a constant folds it. Rules out a negative decimal as a
Narrower unsigned types keep the strict check, which is where a typo like =300= u64's bit pattern.
for a =u8= shows up.
** DONE A folded constant does not skip the range check ** DONE A folded constant does not skip the range check
The folding pass makes its own call to the range test, because a global's The folding pass makes its own call to the range test, because a global's
@ -1090,11 +1076,6 @@ An unknown call whose near miss is a value — =(context-allocator)= against
=context/allocator=, or a global — says the name is a value written without =context/allocator=, or a global — says the name is a value written without
parentheses, and names no call at all when the call had arguments. parentheses, and names no call at all when the call had arguments.
** NEXT (max-value T) and (min-value T)
Decided 2026-09-25: the type-limit constants as a form taking a type, Odin's
max(T), valid at any numeric type or a numeric?-bounded variable. For a float,
min-of is the most negative finite value.
** NEXT (Ptr const T), the pointer beside [const T] ** NEXT (Ptr const T), the pointer beside [const T]
Decided 2026-09-25: addr through a read-only slice gives a (Ptr const T), which Decided 2026-09-25: addr through a read-only slice gives a (Ptr const T), which
nothing writes through; (Ptr T) widens to it and never back; a C parameter nothing writes through; (Ptr T) widens to it and never back; a C parameter
@ -1575,14 +1556,19 @@ incarnation it was made for; every use compares the incarnation, so a destroyed
arena traps whether or not a later arena-new reused its record. Rules out arena traps whether or not a later arena-new reused its record. Rules out
static tracking of destroy, which is move semantics. static tracking of destroy, which is move semantics.
** NEXT A mixed array literal with no want is a dyn vector ** DONE A mixed array literal with no want is a dyn vector
Decided 2026-09-25: with nothing expected of it, an array literal whose elements CLOSED: [2026-09-25]
agree (numbers widening together) is typed; one whose elements mix — [10 "Hi"], Elements that agree, numbers meeting at the wider, are typed; elements that mix
[nil 1] — is a dyn vector. (the [T] ...) forces a typed one, and a want from are a dyn vector, except numbers with no common type, which are refused. Rules
context still wins. Replaces the first-element carry-over. out the first element typing the rest.
* Dev loop * Dev loop
** TODO A prelude function shadowed live is reached by the prelude's own calls
A defn of a prelude function's name sent to a running =flan dev= installs into the
host's cell for that name, so the prelude's calls compiled into the host follow it;
a rebuild gives them the prelude's again, as =Check.shadow_prelude= intends.
** DONE The dev loop, step 1: the reload primitive ** DONE The dev loop, step 1: the reload primitive
A list of top-level forms is recompiled and installed into a running process, and A list of top-level forms is recompiled and installed into a running process, and
call sites compiled before those forms existed follow them through an indirection call sites compiled before those forms existed follow them through an indirection

5
bin/main.ml
View File

@ -362,6 +362,7 @@ let () =
p.globals; p.globals;
List.iter List.iter
(fun (f : Flan.Tast.fn) -> (fun (f : Flan.Tast.fn) ->
if not (Flan.Check.internal_name f.name) then
Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name
(String.concat " " (String.concat " "
(List.map Flan.Types.to_string f.params)) (List.map Flan.Types.to_string f.params))
@ -736,6 +737,8 @@ let () =
if List.mem warn_memory_flag rest then if List.mem warn_memory_flag rest then
print_memory_warnings ~file:path p) print_memory_warnings ~file:path p)
in in
Flan.Build.need_main ~file:path ~doing:"flan build has nothing to link"
f.program;
ignore (Flan.Build.executable ignore (Flan.Build.executable
~opts:{ Flan.Build.default with checks; dev; debug; sanitize; ~opts:{ Flan.Build.default with checks; dev; debug; sanitize;
target; x86; target; x86;
@ -915,6 +918,8 @@ let () =
(Printf.sprintf "flan-run-%d" (Unix.getpid ())) (Printf.sprintf "flan-run-%d" (Unix.getpid ()))
in in
let f = Flan.Front.linked ~all:true path in let f = Flan.Front.linked ~all:true path in
Flan.Build.need_main ~file:path ~doing:"flan run has nothing to run"
f.program;
ignore (Flan.Build.executable ignore (Flan.Build.executable
~opts:{ Flan.Build.default with checks; debug; sanitize; ~opts:{ Flan.Build.default with checks; debug; sanitize;
x86; x86;

2
emacs/flan-mode.el
View File

@ -129,7 +129,7 @@
(defconst flan--special (defconst flan--special
'("quote" "do" "let" "if" "when" "cond" "and" "or" '("quote" "do" "let" "if" "when" "cond" "and" "or"
"while" "until" "break" "continue" "return" "set" "while" "until" "break" "continue" "return" "set"
"array" "array-fill" "array-gen" "match" "fn" "dotimes" "loop" "recur" "array" "array-fill" "array-gen" "the" "match" "fn" "dotimes" "loop" "recur"
"defer" "some" "try" "signal" "error" "defer" "some" "try" "signal" "error"
"handler-bind" "handler-case" "restart-case" "invoke-restart") "handler-bind" "handler-case" "restart-case" "invoke-restart")
"The heads `Parse.form' dispatches on — the forms with a meaning of their own. "The heads `Parse.form' dispatches on — the forms with a meaning of their own.

5
lib/ast.ml
View File

@ -126,6 +126,10 @@ and expr_kind =
dimension; [ArrayFill]'s is the element value itself, evaluated once. *) dimension; [ArrayFill]'s is the element value itself, evaluated once. *)
| ArrayFill of len list * expr | ArrayFill of len list * expr
| ArrayGen of len list * expr | ArrayGen of len list * expr
(* (the T e) — [e] checked with [T] as its expectation, Common Lisp's
special operator. A binding has no type slot, and this is what gives any
expression one; it compiles to [e]. *)
| The of texpr * expr
(* These bind names or alter control flow, so none of them can be a call. *) (* These bind names or alter control flow, so none of them can be a call. *)
| Fn of string list * expr list (* (fn [x y] ...) *) | Fn of string list * expr list (* (fn [x y] ...) *)
(* (dotimes :o [i n] ...), (dotimes [i start stop] ...) and (* (dotimes :o [i n] ...), (dotimes [i start stop] ...) and
@ -438,6 +442,7 @@ let map_children f (e : expr) : expr =
subexpressions. The dimensions are [len]s and hold none. *) subexpressions. The dimensions are [len]s and hold none. *)
| ArrayFill (ds, v) -> ArrayFill (ds, ex v) | ArrayFill (ds, v) -> ArrayFill (ds, ex v)
| ArrayGen (ds, f) -> ArrayGen (ds, ex f) | ArrayGen (ds, f) -> ArrayGen (ds, ex f)
| The (t, x) -> The (t, ex x)
| Fn (ps, es) -> Fn (ps, List.map ex es) | Fn (ps, es) -> Fn (ps, List.map ex es)
| Dotimes (l, n, b, es) -> | Dotimes (l, n, b, es) ->
Dotimes (l, n, Dotimes (l, n,

16
lib/build.ml
View File

@ -744,6 +744,22 @@ let compile_c ~opts ?tflags ?(warn = []) ~src ~name () =
end; end;
obj obj
(* A program with no [main] builds every function and then fails at the link,
as an undefined reference from the C startup code — a message about crt1.o
for a mistake in the .flan file. Asked here, by the commands that make an
executable, rather than inside [executable], whose callers include hosts
and tests that supply their own [main]. *)
let need_main ~file ~doing (p : Tast.program) =
if not (List.exists (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns)
then
failwith
(Printf.sprintf
"%s has no main, so %s. A program starts at a function named main, \
for example:\n\n\
\ (defn main [] i32\n\
\ 0)"
file doing)
(* [csrcs] and [lflags] come from the imported packages (see [Load]): the C (* [csrcs] and [lflags] come from the imported packages (see [Load]): the C
shim a package binds through, and the arguments needed to link the library shim a package binds through, and the arguments needed to link the library
it binds to. it binds to.

741
lib/check.ml
View File

@ -2074,12 +2074,20 @@ let mk loc ty e : Tast.expr = { Tast.e; ty; loc }
let unit_at loc = mk loc Types.Unit Tast.Unit let unit_at loc = mk loc Types.Unit Tast.Unit
(* The compiler temp an [and] leaves in its else arm; see [check_if]. *)
let and_sentinel (x : Ast.expr) =
match x.Ast.e with
| Ast.Var n -> String.length n > 4 && String.sub n 0 4 = "and~"
| _ -> false
(* Integer arithmetic over literals alone, folded. Unlike [const_int] no name (* Integer arithmetic over literals alone, folded. Unlike [const_int] no name
is read: a defconst has a type of its own, and only an untyped constant may is read: a defconst has a type of its own, and only an untyped constant may
stand at a type variable. *) stand at a type variable. *)
let rec literal_arith (e : Ast.expr) : int64 option = let rec literal_arith (e : Ast.expr) : int64 option =
match e.Ast.e with match e.Ast.e with
| Ast.Int n -> Some n | Ast.Int n -> Some n
| Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) ->
Option.map Int64.neg (literal_arith x)
| Ast.Call ({ Ast.e = Ast.Var op; _ }, x :: y :: rest) -> | Ast.Call ({ Ast.e = Ast.Var op; _ }, x :: y :: rest) ->
let step a b = let step a b =
match op with match op with
@ -2098,6 +2106,10 @@ let rec literal_arith (e : Ast.expr) : int64 option =
(literal_arith x) (y :: rest) (literal_arith x) (y :: rest)
| _ -> None | _ -> None
(* A value with no type until one is asked of it: a literal, or arithmetic
over literals alone. *)
let lone_literal (e : Ast.expr) = is_literal e || literal_arith e <> None
(* The environment for a lifted body, built once its own body has been checked (* The environment for a lifted body, built once its own body has been checked
and [caught] is therefore final. spec-memory.md's case 2, and the whole of and [caught] is therefore final. spec-memory.md's case 2, and the whole of
@ -3571,6 +3583,28 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
let tail = ctx.tail in let tail = ctx.tail in
ctx.tail <- false; ctx.tail <- false;
match e.Ast.e with match e.Ast.e with
(* A negative literal in a generic body, at an instantiation that made it
unsigned. The cast the ordinary refusal names would be wrong at every
other type the function is called at, so the fix is one that needs no
negative number at all, and the refusal says which call asked. *)
| Ast.Int n
when Int64.compare n 0L < 0 && ctx.env.chain <> []
&& (match want with
| Some (Types.Int k) -> not (Types.signed k)
| _ -> false) ->
let t = Option.get want in
let gname, _, at = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in
let var =
match List.find_opt (fun (_, u) -> Types.equal u t) ctx.env.subst with
| Some (v, _) -> Printf.sprintf "$%s = %s" v (Types.to_string t)
| None -> Types.to_string t
in
Loc.failk literal_at_want loc
~notes:[ Loc.note at (Printf.sprintf "%s is instantiated at %s here" gname var) ]
"%Ld does not fit in %s, which holds no negative number, and %s is called \
at %s — the body has to work at every type it is called at, so write \
it with no negative literal, as in (- x %Ld) in place of (+ x %Ld)"
n (Types.to_string t) gname var (Int64.neg n) n
| Ast.Int n -> int_literal loc ~want ~preds:ctx.env.tvpreds n | Ast.Int n -> int_literal loc ~want ~preds:ctx.env.tvpreds n
| Ast.UInt (n, s) -> wide_literal loc ~want n s | Ast.UInt (n, s) -> wide_literal loc ~want n s
| Ast.Byte b -> | Ast.Byte b ->
@ -3826,18 +3860,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
{:xs [1 2]} mean what it reads as. Everywhere else brackets stay the {:xs [1 2]} mean what it reads as. Everywhere else brackets stay the
fixed-array literal they always were. *) fixed-array literal they always were. *)
| Ast.Arr items when want = Some Types.Dyn -> | Ast.Arr items when want = Some Types.Dyn ->
let v = fresh_slot ctx Types.Dyn in dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items)
let vval = mk loc Types.Dyn (Tast.Local v) in
let pushes =
List.map
(fun x ->
rt loc Types.Unit "flan_dyn_push"
[ vval; check ctx ~want:Types.Dyn x; here loc ])
items
in
mk loc Types.Dyn
(Tast.Let ([ (v, rt loc Types.Dyn "flan_dyn_vec_new" []) ],
pushes @ [ vval ]))
| Ast.Arr items -> check_arr ctx ~want loc items | Ast.Arr items -> check_arr ctx ~want loc items
(* (array 4 rl/Vector2). Parse already assembled the whole array type, so (* (array 4 rl/Vector2). Parse already assembled the whole array type, so
there is nothing to infer: resolve it and hand back its all-bytes-zero there is nothing to infer: resolve it and hand back its all-bytes-zero
@ -3852,6 +3875,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
fail loc "this is a type, and a value is wanted here" fail loc "this is a type, and a value is wanted here"
| Ast.ArrayFill (dims, v) -> check_array_fill ctx ~want loc dims v | Ast.ArrayFill (dims, v) -> check_array_fill ctx ~want loc dims v
| Ast.ArrayGen (dims, f) -> check_array_gen ctx ~want loc dims f | Ast.ArrayGen (dims, f) -> check_array_gen ctx ~want loc dims f
| Ast.The (t, v) -> check_the ctx ~want loc t v
| Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms | Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms
(* Constant integer arithmetic where a type variable is wanted is folded to (* Constant integer arithmetic where a type variable is wanted is folded to
the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever
@ -4069,24 +4093,34 @@ and wide_literal loc ~want n s =
(* Arithmetic wraps, but a literal that does not fit its type is a typo, not a (* Arithmetic wraps, but a literal that does not fit its type is a typo, not a
wrap — 300 is never what someone meant by a u8. *) wrap — 300 is never what someone meant by a u8. *)
and in_range loc k n = and in_range ?(pattern = false) loc k n =
let bits = Types.bits k in let bits = Types.bits k in
let ok = let ok =
if Types.signed k then if Types.signed k then
bits = 64 bits = 64
|| (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0 || (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0
&& Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0) && Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0)
else if bits = 64 then (* A literal at or above 2^63 is a [UInt] and never reaches here as a
(* A literal at or above 2^63 is a [UInt] and never reaches here; see literal; see [wide_literal]. [pattern] is the folded-constant path,
[wide_literal]. A negative decimal is accepted as a u64's bit pattern, which holds a u64 as its 64-bit pattern and cannot tell 2^64 - 1 from
which is a settled rule. Narrower unsigned types keep the strict -1, so there every pattern is a u64. *)
check, which is where a typo like 300 for a u8 actually shows up. *) else if bits = 64 then pattern || Int64.compare n 0L >= 0
true
else else
Int64.compare n 0L >= 0 Int64.compare n 0L >= 0
&& Int64.compare n (Int64.shift_left 1L bits) < 0 && Int64.compare n (Int64.shift_left 1L bits) < 0
in in
if ok then n if ok then n
else if Int64.compare n 0L < 0 && not (Types.signed k) then
(* A negative number at an unsigned type is never the value it reads as.
The cast is how to ask for the bit pattern, and names what it is. *)
let mask =
if bits = 64 then -1L else Int64.sub (Int64.shift_left 1L bits) 1L
in
let tn = Types.ikind_name k in
Loc.failk literal_at_want loc
"%Ld does not fit in %s, which holds no negative number — write (%s %Ld) \
for the %s with the same bits, %Lu"
n tn tn n tn (Int64.logand n mask)
else Loc.failk literal_at_want loc "%Ld does not fit in %s" n else Loc.failk literal_at_want loc "%Ld does not fit in %s" n
(Types.ikind_name k) (Types.ikind_name k)
@ -4129,8 +4163,8 @@ and var ctx ?(qualified = false) loc ~want name =
fail loc "expected %s, found None" (Types.to_string other) fail loc "expected %s, found None" (Types.to_string other)
| _ -> | _ ->
fail loc fail loc
"nothing here says what None is an Option of — annotate the \ "nothing here says what None is an Option of — use it where an \
function's return type or the binding") Option is expected, or name one, as in (the (Option i32) None)")
(* spec-memory.md puts the allocator in the calling convention as (* spec-memory.md puts the allocator in the calling convention as
[context/allocator] and [context/temp]. They read as names rather than [context/allocator] and [context/temp]. They read as names rather than
calls because that is how the spec writes them, and they are dynamic calls because that is how the spec writes them, and they are dynamic
@ -5321,6 +5355,27 @@ and check_if ctx ?(tail = false) ?want loc c t e =
no value on the missing side. `when` desugars to this. *) no value on the missing side. `when` desugars to this. *)
let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in
expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc)))
(* Two literal arms meet at the wider of their own types, as two literal
elements of an array do: [(if c 1 2.5)] is an f64. *)
| Some e
when want = None && lone_literal t && lone_literal e
&& (match literal_join ctx t e with
| Some j -> not (Types.equal j (Types.Int Types.I32))
| None -> false) ->
let want = literal_join ctx t e in
let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in
let e = branch ctx (fun () -> in_tail (fun () -> check ctx ?want e)) in
mk loc t.Tast.ty (Tast.If (c, t, e))
| Some e when want = None && lone_literal t && not (lone_literal e)
&& not (and_sentinel e) ->
(* A literal has no type of its own until something asks, so with no
expectation the other arm decides: [(if c 4000000 n)] over an i64 [n]
is an i64, as [(+ 4000000 n)] is. *)
let e = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in
let twant = if e.Tast.ty = Types.Never then None else Some e.Tast.ty in
let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:twant t)) in
let ty = if e.Tast.ty = Types.Never then t.Tast.ty else e.Tast.ty in
mk loc ty (Tast.If (c, t, e))
| Some e -> | Some e ->
let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in
(* With no expectation the then-branch supplies one for the else-branch, (* With no expectation the then-branch supplies one for the else-branch,
@ -5344,12 +5399,6 @@ and check_if ctx ?(tail = false) ?want loc c t e =
sentinel in the then arm, so every operand is already blamed at its own sentinel in the then arm, so every operand is already blamed at its own
location; and with an expectation in hand both arms are checked against location; and with an expectation in hand both arms are checked against
it rather than against each other, so nothing here runs. *) it rather than against each other, so nothing here runs. *)
let and_sentinel (x : Ast.expr) =
match x.Ast.e with
| Ast.Var n ->
String.length n > 4 && String.sub n 0 4 = "and~"
| _ -> false
in
let e = let e =
match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with
| v -> v | v -> v
@ -5371,6 +5420,18 @@ and check_if ctx ?(tail = false) ?want loc c t e =
in in
mk loc ty (Tast.If (c, t, e)) mk loc ty (Tast.If (c, t, e))
(* The type two literals meet at, each at its own type — a wide integer at
u64, which is the only type that holds one. *)
and literal_join ctx (a : Ast.expr) (b : Ast.expr) =
let own (x : Ast.expr) =
match x.Ast.e with
| Ast.UInt _ -> Some (Types.Int Types.U64)
| _ -> probe ctx x.Ast.loc (fun () -> (check ctx x).Tast.ty)
in
match own a, own b with
| Some x, Some y -> Types.join x y
| _ -> None
(* Whether a name would reach a callee if it were called — a global function, a (* Whether a name would reach a callee if it were called — a global function, a
generic, or a local holding a function value. The three sources [named_call] generic, or a local holding a function value. The three sources [named_call]
itself consults, in its own order; builtins are deliberately not among them, itself consults, in its own order; builtins are deliberately not among them,
@ -5696,63 +5757,31 @@ and check_arr ctx ~want loc items =
| Some (Types.Slice t) -> Some t | Some (Types.Slice t) -> Some t
| _ -> None | _ -> None
in in
(* With nothing outside saying what the elements are, the first one says: match elem_want, items with
[[(f32 1.0) 2.5]] is an [[2 f32]], its [2.5] checked at [f32] the way it | None, _ :: _ ->
would be at an [f32] parameter. *) (match arr_elem_type ctx items with
let items = | Some t ->
match elem_want, items with let n = Int64.of_int (List.length items) in
| Some _, _ | None, [] -> map_lr (fun i -> check ctx ?want:elem_want i) items expect ctx loc ~want
| None, first :: rest -> (check_arr ctx ~want:(Some (Types.Array (n, t))) loc items)
let first_ast = first in | None ->
let first = check ctx first in (match
let want = trial ctx (fun () ->
match first.Tast.ty with Types.Never -> None | t -> Some t dyn_vec ctx loc (map_lr (fun i -> check ctx ~want:Types.Dyn i) items))
in with
(* A refusal of the element itself says where its type came from. *) | Ok v -> expect ctx loc ~want v
let one (i : Ast.expr) = | Error d -> mixed_refusal ctx items d))
(match i.Ast.e, want with | _ ->
| Ast.UInt (_, text), Some (Types.Int k) when k <> Types.U64 -> let items = map_lr (fun i -> check ctx ?want:elem_want i) items in
let first_src =
match first_ast.Ast.e with
| Ast.Int _ | Ast.Byte _ -> Some (spell_arg "" first_ast)
| _ -> None
in
Loc.failk literal_at_want i.Ast.loc
~notes:
[ Loc.note first.Tast.loc
(Printf.sprintf
"this array's first element is %s, so every element is"
(Types.ikind_name k)) ]
"%s does not fit in %s, and only a u64 holds it%s" text
(Types.ikind_name k)
(match first_src with
| Some f ->
Printf.sprintf " — write the first element as (u64 %s) for an \
array of u64" f
| None -> " — make the first element a u64 for an array of u64")
| _ -> ());
try check ctx ?want i with
| Loc.Error d when d.Loc.dloc = i.Ast.loc && want <> None ->
raise
(Loc.Error
{ d with
Loc.notes =
d.Loc.notes
@ [ Loc.note first.Tast.loc
(Printf.sprintf
"this array's first element is %s, so every \
element is"
(Types.to_string first.Tast.ty)) ] })
in
first :: map_lr one rest
in
let n = Int64.of_int (List.length items) in let n = Int64.of_int (List.length items) in
let elem = let elem =
match elem_want, items with match elem_want, items with
| Some t, _ -> t | Some t, _ -> t
| None, first :: _ -> first.Tast.ty | None, first :: _ -> first.Tast.ty
| None, [] -> | None, [] ->
fail loc "an empty array literal needs a type — annotate the binding" fail loc
"an empty array literal needs a type — use it where one is expected, \
or name it, as in (the [0 i32] [])"
in in
List.iter List.iter
(fun (i : Tast.expr) -> (fun (i : Tast.expr) ->
@ -5768,6 +5797,206 @@ and check_arr ctx ~want loc items =
an array literal does not satisfy a slice expectation. *) an array literal does not satisfy a slice expectation. *)
expect ctx loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items)) expect ctx loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items))
(* The element type of an array literal nothing outside it names, or [None]
for a dyn vector. Every element is looked at on its own terms first, by
[probe], so nothing here is checked for real — [check_arr] does that once,
at the answer.
Elements that agree are a typed array: one type, or numbers that meet at
the wider of them the way two operands of [+] do. A literal takes the
others' type if it fits it, so [[(f32 1.0) 2.5]] is an [[2 f32]] and
[[(u8 1) 300]] an [[2 i32]]. An element that cannot be checked without
being told what it is — [None], a bare struct — takes the same type.
Elements that do not agree — [[10 "Hi"]], a dyn beside anything that is
not one — are a dyn vector, which is what the same brackets are where a
dyn is expected. Numbers that do not agree are refused instead; see
[numbers_disagree]. *)
and arr_elem_type ctx (items : Ast.expr list) : Types.t option =
let natural (i : Ast.expr) =
match i.Ast.e with
(* Refused with no want, and only a u64 holds one. *)
| Ast.UInt _ -> Some (Types.Int Types.U64)
| _ -> probe ctx i.Ast.loc (fun () -> (check ctx i).Tast.ty)
in
let fits t (i : Ast.expr) =
probe ctx i.Ast.loc (fun () -> ignore (check ctx ~want:t i)) <> None
in
let lits, rest = List.partition lone_literal items in
let typed, needs =
List.partition_map
(fun i ->
match natural i with Some t -> Left (i, t) | None -> Right i)
rest
in
let tys =
List.filter (fun t -> t <> Types.Never) (List.map snd typed)
in
let lit_tys = List.filter_map natural lits in
let join_all = function
| [] -> None
| t :: ts ->
List.fold_left
(fun acc t -> Option.bind acc (fun a -> Types.join a t)) (Some t) ts
in
let mixed_dyn =
List.mem Types.Dyn tys
&& (List.exists (fun t -> t <> Types.Dyn) tys || lits <> [])
in
let all_fit t = List.for_all (fits t) lits && List.for_all (fits t) needs in
(* A candidate the literals do not all fit is widened by the ones that do
not, once: [[x 2.5]] over an i32 [x] meets at f64. *)
let settle = function
| None -> None
| Some t when all_fit t -> Some t
| Some t ->
let t' =
List.fold_left
(fun acc i ->
if fits t i then acc
else Option.bind acc (fun a -> Option.bind (natural i) (Types.join a)))
(Some t) lits
in
(match t' with
| Some t' when not (Types.equal t' t) && all_fit t' -> Some t'
| _ -> None)
in
let candidates =
if tys <> [] then [ join_all tys ]
else join_all lit_tys :: List.map Option.some lit_tys
in
if mixed_dyn then None
else if tys = [] && lits = [] then
(match typed, needs with
| _ :: _, [] -> Some Types.Never
(* Nothing here says what any of them is. The first one's own refusal is
the one worth reading. *)
| _, first :: _ -> ignore (check ctx first); None
| [], [] -> None)
else
match
List.fold_left
(fun found c -> match found with Some _ -> found | None -> settle c)
None candidates
with
| Some t -> Some t
| None ->
let numeric t = match t with Types.Int _ | Types.Float _ -> true | _ -> false in
if needs = [] && List.for_all numeric (tys @ lit_tys) then
numbers_disagree ctx
(List.filter_map
(fun i -> Option.map (fun t -> (i, t)) (natural i)) items)
else None
(* Numbers with no type they all meet at — an i32 beside an f32, an i64 beside
a u64 — are refused rather than boxed into a dyn vector: the elements are
all numbers, and which one should move is the program's to say. The fix
named converts the second of the first disagreeing pair, into the float
when one of the two is a float and into the first's type otherwise. *)
and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a =
fun ctx elems ->
match elems with
| [] -> fail Loc.unknown "internal: an array of numbers with no elements"
| _ :: _ ->
(* A literal is not one of the disagreeing types when it fits the others:
each is checked at the type the rest meet at — or, with every element a
literal, at the u64 a wide one needs — and the first that does not fit
is the refusal, its own. *)
let lit (e, _) = lone_literal e in
let others = List.filter (fun p -> not (lit p)) elems in
let meet =
match others with
| [] ->
if List.exists (fun (e, _) -> match e.Ast.e with Ast.UInt _ -> true | _ -> false) elems
then Some (Types.Int Types.U64) else None
| (_, t) :: ts ->
List.fold_left (fun acc (_, u) -> Option.bind acc (fun a -> Types.join a u))
(Some t) ts
in
(match meet with
| Some (Types.Int _ as m) ->
List.iter
(fun (e, t) ->
if lone_literal e && (match t with Types.Int _ -> true | _ -> false)
then ignore (check ctx ~want:m e))
elems
| _ -> ());
let pool = if others = [] then elems else others in
let first, t1 = List.hd pool in
let second, t2 =
match List.find_opt (fun (_, t) -> Types.join t1 t = None) (List.tl pool) with
| Some p -> p
| None ->
(match List.find_opt (fun (_, t) -> Types.join t1 t = None) elems with
| Some p -> p
| None -> List.nth elems (List.length elems - 1))
in
let target, moved, moved_ty, other =
match t1, t2 with
| Types.Int _, Types.Float _ -> t2, first, t1, second
| _ -> t1, second, t2, first
in
ignore ctx;
let tn = Types.to_string target in
Loc.failk "check/array-numbers-disagree" moved.Ast.loc
~notes:[ Loc.note other.Ast.loc (Printf.sprintf "this element is %s" tn) ]
"this array's elements are %s and %s, and neither holds every value of \
the other — %s"
(Types.to_string moved_ty) tn
(match spell_arg "" moved with
| "" ->
Printf.sprintf "convert the %s element with the %s cast" (Types.to_string moved_ty) tn
| x -> Printf.sprintf "convert one, as in (%s %s)" tn x)
(* Elements that do not agree and cannot all become a dyn either: a struct
beside a number, a type variable beside a literal. The dyn vector's refusal
would be about dyn, which the program never mentioned, so the elements are
refused against each other instead — the first one's type is what the rest
are checked at, and the refusal points back at it. [d] is the answer if
that finds nothing. *)
and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a =
fun ctx items d ->
match items with
| [] -> raise (Loc.Error d)
| first :: rest ->
let first = check ctx first in
let want = match first.Tast.ty with Types.Never -> None | t -> Some t in
List.iter
(fun (i : Ast.expr) ->
match check ctx ?want i with
| v ->
(match want with
| Some t when not (Types.fits ~expected:t ~actual:v.Tast.ty) ->
fail i.Ast.loc "this array's elements are %s, but this one is %s"
(Types.to_string t) (Types.to_string v.Tast.ty)
| _ -> ())
| exception Loc.Error e when e.Loc.dloc = i.Ast.loc && want <> None ->
raise
(Loc.Error
{ e with
Loc.notes =
e.Loc.notes
@ [ Loc.note first.Tast.loc
(Printf.sprintf
"this array's first element is %s, so every \
element is"
(match first.Tast.ty with
| Types.Var v -> "$" ^ v
| t -> Types.to_string t)) ] }))
rest;
raise (Loc.Error d)
(* A dyn vector built where it stands from elements already checked at dyn:
the runtime's own vec, pushed to in order. *)
and dyn_vec ctx loc (items : Tast.expr list) =
let v = fresh_slot ctx Types.Dyn in
let vval = mk loc Types.Dyn (Tast.Local v) in
let pushes =
List.map (fun x -> rt loc Types.Unit "flan_dyn_push" [ vval; x; here loc ])
items
in
mk loc Types.Dyn
(Tast.Let ([ (v, rt loc Types.Dyn "flan_dyn_vec_new" []) ], pushes @ [ vval ]))
(* ── (array-fill [r c] v) and (array-gen [r c] f) ────────────────────── (* ── (array-fill [r c] v) and (array-gen [r c] f) ──────────────────────
TODO.org, "A value-producing array constructor". [(array 4 T)] is TODO.org, "A value-producing array constructor". [(array 4 T)] is
@ -5886,6 +6115,78 @@ and array_build ctx loc ns elem ~pre ~element =
(Tast.Let (pre @ [ (arr, mk loc aty (Tast.Zero aty)) ], (Tast.Let (pre @ [ (arr, mk loc aty (Tast.Zero aty)) ],
[ nest ns islots; arrv ])) [ nest ns islots; arrv ]))
(* (the T e): [e] with [T] as its expectation, which is every conversion an
annotation would make — a literal built at T, a narrower number widened —
and nothing more. A dyn operand is the exception: an expectation would
unbox it and trap at run time on a mismatch, and [the] is a statement about
the type rather than a conversion, so it is refused and the cast named.
[(the [T] [...])] asks for the literal's element type and answers the
[n T] the literal is, since an array literal is never a slice. *)
and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) =
let ty = resolve ctx.env t in
let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in
if ty <> Types.Dyn && not is_nil
&& probe ctx loc (fun () -> (check ctx v).Tast.ty) = Some Types.Dyn
then begin
let tn = Types.to_string ty in
let numeric = match ty with Types.Int _ | Types.Float _ -> true | _ -> false in
if numeric then
fail v.Ast.loc
"the checks a value as %s and does not convert one, and this is a dyn \
— %s"
tn
(match spell_arg "" v with
| "" -> Printf.sprintf "convert it with the %s cast instead" tn
| s -> Printf.sprintf "write (%s %s) to convert it" tn s)
else
(* What a dyn does at this type is the boundary's own answer, asked of
it rather than restated: some types take one where a value is passed,
returned or stored, and the rest do not take one at all. *)
let crosses =
probe ctx loc (fun () ->
ignore (expect ctx v.Ast.loc ~want:(Some ty) (check ctx v)))
in
match crosses with
| Some () ->
fail v.Ast.loc
"the checks a value as %s and does not convert one, and this is a \
dyn — a dyn becomes a %s where a %s is passed, returned or stored"
tn tn tn
| None ->
(match check ctx ~want:ty v with
| _ ->
fail v.Ast.loc
"the checks a value as %s and does not convert one, and this is \
a dyn" tn
| exception Loc.Error d ->
fail v.Ast.loc
"the checks a value as %s and does not convert one, and this is \
a dyn — %s" tn d.Loc.dmsg)
end;
let r =
match ty, v.Ast.e with
| Types.Slice elem, Ast.Arr items ->
check_arr ctx
~want:(Some (Types.Array (Int64.of_int (List.length items), elem)))
v.Ast.loc items
| _ -> expect ctx v.Ast.loc ~want:(Some ty) (check ctx ~want:ty v)
in
expect ctx loc ~want r
(* [f] run for its answer alone: whatever it wrote into the context is put
back whether it succeeded or not, so a form can be checked once to see what
it is and then checked again for real. [None] if it was refused. *)
and probe : 'a. ctx -> Loc.t -> (unit -> 'a) -> 'a option = fun ctx loc f ->
let answer = ref None in
(match
trial ctx (fun () ->
answer := Some (f ());
raise (Loc.Error (Loc.diag loc "probe")))
with
| _ -> ());
!answer
and check_array_fill ctx ~want loc dims v = and check_array_fill ctx ~want loc dims v =
let ns = array_dims ctx loc dims in let ns = array_dims ctx loc dims in
let elem_want = array_elem_want (List.length ns) want in let elem_want = array_elem_want (List.length ns) want in
@ -6080,7 +6381,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
let want = ref want in let want = ref want in
let seen = Hashtbl.create 8 in let seen = Hashtbl.create 8 in
let saw_wild = ref false in let saw_wild = ref false in
let arms = let resolved =
map_lr map_lr
(fun (a : Ast.arm) -> (fun (a : Ast.arm) ->
let ctor, binds = resolve_pat a in let ctor, binds = resolve_pat a in
@ -6091,6 +6392,48 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
fail a.Ast.aloc "this match has two %s arms" fail a.Ast.aloc "this match has two %s arms"
(match subject with `Enum _ -> ":" ^ c | _ -> c); (match subject with `Enum _ -> ":" ^ c | _ -> c);
Hashtbl.add seen c ()); Hashtbl.add seen c ());
(a, ctor, binds))
arms
in
(* With nothing expected of the match, the first arm's type is every arm's —
unless that arm is a bare literal, which has no type until asked. So the
arms whose value is a literal are checked last, and take their type from
the others, as an [if]'s literal arm does. The order is only the order
they are checked in; they are put back in source order below. *)
let literal_arm ((a : Ast.arm), _, _) =
match List.rev a.Ast.body with last :: _ -> lone_literal last | [] -> false
in
(* Every arm a literal: they meet at the wider of their own types, as an
[if]'s two do. *)
(if !want = None && resolved <> [] && List.for_all literal_arm resolved then
let lasts =
List.map (fun ((a : Ast.arm), _, _) -> List.hd (List.rev a.Ast.body))
resolved
in
match lasts with
| first :: rest ->
let j =
List.fold_left
(fun acc x ->
Option.bind acc (fun a ->
Option.bind (literal_join ctx first x) (Types.join a)))
(literal_join ctx first first) rest
in
(match j with
| Some t when not (Types.equal t (Types.Int Types.I32)) -> want := Some t
| _ -> ())
| [] -> ());
let order =
let idx = List.mapi (fun i r -> (i, r)) resolved in
if !want <> None then idx
else
List.filter (fun (_, r) -> not (literal_arm r)) idx
@ List.filter (fun (_, r) -> literal_arm r) idx
in
let checked =
map_lr
(fun (i, ((a : Ast.arm), ctor, binds)) ->
i,
branch ctx (fun () -> branch ctx (fun () ->
(* What each name in this arm is, in words, for the one refusal (* What each name in this arm is, in words, for the one refusal
that needs it: a case pattern binds fields positionally, so the that needs it: a case pattern binds fields positionally, so the
@ -6126,7 +6469,10 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
if !want = None && body.Tast.ty <> Types.Never then if !want = None && body.Tast.ty <> Types.Never then
want := Some body.Tast.ty; want := Some body.Tast.ty;
{ Tast.acase = ctor; binds; abody = [ body ] })) { Tast.acase = ctor; binds; abody = [ body ] }))
arms order
in
let arms =
List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) checked)
in in
(* Exhaustiveness is refused, not defaulted. A match that silently fell (* Exhaustiveness is refused, not defaulted. A match that silently fell
through would have to produce a value of the match's type out of nothing, through would have to produce a value of the match's type out of nothing,
@ -6609,12 +6955,9 @@ and arity _ctx loc name n args =
Two is the floor, and the two missing cases are refused rather than Two is the floor, and the two missing cases are refused rather than
invented. Zero operands would have to mean an identity element, 0 for + and invented. Zero operands would have to mean an identity element, 0 for + and
1 for *, and a sum with no terms in it is a typo far more often than it is 1 for *, and a sum with no terms in it is a typo far more often than it is
an intent. One operand would have to mean negation for [-] and reciprocal an intent. One operand is refused for every operator but [-], whose one
for [/], and this language has no unary minus anywhere: the prelude writes operand form is negation and is [named_call]'s. For [/] it would be the
every negation as [(- 0 n)] or [(- 0.0 x)], and [(- x)] meaning something reciprocal, and integer division makes that a trap: [(/ 3)] would be 0.
else than the [-] two lines above it is a rule a reader has to carry rather
than see. Integer division makes the reciprocal worse still: [(/ 3)] would
be 0.
A one-operand comparison would have to be [true] — there is no pair to A one-operand comparison would have to be [true] — there is no pair to
disagree, and nothing for a lone value to be distinct from — and a test disagree, and nothing for a lone value to be distinct from — and a test
@ -6623,10 +6966,6 @@ and arity _ctx loc name n args =
and fold_arity loc name args = and fold_arity loc name args =
match args with match args with
| _ :: _ :: _ -> () | _ :: _ :: _ -> ()
| [ _ ] when String.equal name "-" ->
fail loc
"- takes two arguments or more, given 1 — there is no unary minus; \
write (- 0 x) to negate"
| [ _ ] when String.equal name "/" -> | [ _ ] when String.equal name "/" ->
fail loc fail loc
"/ takes two arguments or more, given 1 — there is no reciprocal; \ "/ takes two arguments or more, given 1 — there is no reciprocal; \
@ -7013,6 +7352,16 @@ and file_guard ctx loc ~path_slot ~op mk_steps =
missing annotation for a program that had written one. One list, read by 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 both callers, so the next kind of type added cannot be added to one of
them. *) them. *)
(* 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
| _ -> false)
and type_named ctx n = and type_named ctx n =
(* A type variable names a type here too, which is what lets [(vec-new t)] (* A type variable names a type here too, which is what lets [(vec-new t)]
and [(vec-new $t)] be written in a generic body: inside an instantiation and [(vec-new $t)] be written in a generic body: inside an instantiation
@ -7283,6 +7632,33 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| _ when (not qualified) && shadows_builtin ctx loc name -> | _ when (not qualified) && shadows_builtin ctx loc name ->
ordinary_call ctx ~want loc name args ordinary_call ctx ~want loc name args
(* ── arithmetic and comparison ─────────────────────────────────── *) (* ── arithmetic and comparison ─────────────────────────────────── *)
(* (- x) negates, Clojure's rule. A literal operand is the negative literal,
so it takes its type from the site as any literal does. A float is
subtracted from -0.0, which is exact negation — 0.0 - 0.0 would answer
+0.0 — and an integer from 0, which wraps as (- 0 x) does. *)
| "-" when List.length args = 1 ->
let x = List.hd args in
(match x.Ast.e, literal_arith x with
(* Integer arithmetic over literals alone negates to a literal, so
[(- (- 1))] is the literal 1 and fits a u8. *)
| _, Some n when n <> Int64.min_int ->
check ctx ?want { Ast.e = Ast.Int (Int64.neg n); loc }
| Ast.Float v, _ -> check ctx ?want { Ast.e = Ast.Float (-.v); loc }
| _ ->
let v = check ctx ?want:(numeric_want want) x in
if v.Tast.ty = Types.Dyn then
expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_neg" [ v; here loc ])
else begin
unconstrained ctx.env loc name ~needs:"numeric?" v.Tast.ty;
if not (Types.is_numeric v.Tast.ty || generic_ty v.Tast.ty) then
not_numeric name "numbers" v;
let zero =
match v.Tast.ty with
| Types.Float k -> mk loc v.Tast.ty (Tast.Float (-0.0, k))
| ty -> int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L
in
expect ctx loc ~want (mk loc v.Tast.ty (Tast.Prim (Tast.Sub, [ zero; v ])))
end)
| "+" | "-" | "*" | "/" -> | "+" | "-" | "*" | "/" ->
let p = match name with let p = match name with
| "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul | "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul
@ -7508,6 +7884,67 @@ and named_call ?(qualified = false) ctx ~want loc name args =
expect ctx loc ~want expect ctx loc ~want
(List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg)) (List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg))
(pick a b) rest) (pick a b) rest)
(* A type handed to the prelude's slice reductions: the reach for the
type-limit constants under the name of the reduction beside them. *)
| ("max-of" | "min-of")
when (not (shadows_builtin ctx loc name))
&& (match args with [ a ] -> type_arg ctx a | _ -> false) ->
let which = if String.equal name "max-of" then "max-value" else "min-value" in
fail loc
"%s reduces a slice to its %s element, and this is a type — the %s value \
of a type is (%s %s)"
name (if which = "max-value" then "largest" else "least")
(if which = "max-value" then "largest" else "least") which
(spell_arg "i32" (List.hd args))
(* (max-value T) and (min-value T): the type-limit constants, by type, so a
generic body can name its own type's. Odin's max(T) and min(T), and the
same answer for a float: the largest finite value and its negation, not
the smallest positive one. *)
| "max-value" | "min-value" ->
arity ctx loc name 1 args;
if not (type_arg ctx (List.hd args)) then
fail (List.hd args).Ast.loc "%s takes a type, as in (%s i32)" name name;
let a = List.hd args in
let ty =
match type_of_expr a, a.Ast.e with
| Some t, _ -> resolve ctx.env t
| _, Ast.Var n -> resolve_name ctx.env ~seen:[] a.Ast.loc n
| _ -> fail a.Ast.loc "internal: %s's type argument is not a type" name
in
let max = String.equal name "max-value" in
let v =
match ty with
| Types.Int k ->
let b = Types.bits k in
let n =
if Types.signed k then
let top = Int64.shift_left 1L (b - 1) in
if max then Int64.sub top 1L else Int64.neg top
else if not max then 0L
else if b = 64 then -1L
else Int64.sub (Int64.shift_left 1L b) 1L
in
mk loc ty (Tast.Int (n, k))
| Types.Float k ->
let m =
match k with
| Types.F32 -> Int32.float_of_bits 0x7f7fffffl
| Types.F64 -> Float.max_float
in
mk loc ty (Tast.Float ((if max then m else -.m), k))
| Types.Var v ->
if not (declares ctx.env.tvpreds v "numeric?") then
Loc.failk "check/unconstrained-type-variable" a.Ast.loc
"%s is a limit of a numeric type, and nothing declares $%s \
numeric — write {:where (numeric? $%s)} at the head of the body"
name v v;
int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L
| _ ->
fail a.Ast.loc
"%s takes a numeric? type, and %s is not one — as in (%s i32)" name
(Types.to_string ty) name
in
expect ctx loc ~want v
(* (zeroed) is the all-bytes-zero value of whatever it is being stored into, (* (zeroed) is the all-bytes-zero value of whatever it is being stored into,
so it only means anything where a type is expected of it. *) so it only means anything where a type is expected of it. *)
| "zeroed" -> | "zeroed" ->
@ -7519,7 +7956,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| _ -> | _ ->
fail loc fail loc
"zeroed needs to know the type it is zeroing — use it where one is \ "zeroed needs to know the type it is zeroing — use it where one is \
expected, as in (set grid (zeroed))") expected, or name it, as in (the [4 i32] (zeroed))")
(* [zeroed]'s two siblings, and the same shape exactly: a value of whatever (* [zeroed]'s two siblings, and the same shape exactly: a value of whatever
type is expected of it, so [(set grid (filled 0xFF))] is how a place is type is expected of it, so [(set grid (filled 0xFF))] is how a place is
@ -7616,7 +8053,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| _ -> | _ ->
fail loc fail loc
"%s needs to know the type it is filling — use it where one is \ "%s needs to know the type it is filling — use it where one is \
expected, as in (set grid (%s))" expected, or name it, as in (the [4 u32] (%s))"
name (if is_byte then "filled 0xFF" else name)) name (if is_byte then "filled 0xFF" else name))
(* The one half of a destructuring [let] that [Parse] cannot do on its own. (* The one half of a destructuring [let] that [Parse] cannot do on its own.
@ -10352,7 +10789,8 @@ let builtins : (string * string * string) list =
numeric types meet at the wider one when that cannot lose — i32 and i64 \ numeric types meet at the wider one when that cannot lose — i32 and i64 \
add at i64 — and i32 with u32 has no such type and is refused."); add at i64 — and i32 with u32 has no such type and is refused.");
("-", "- [numeric? ...] numeric?", ("-", "- [numeric? ...] numeric?",
"Difference, folded left: (- a b c) is ((a - b) - c)."); "Difference, folded left: (- a b c) is ((a - b) - c). With one operand, \
its negation: (- x).");
("*", "* [numeric? ...] numeric?", ("*", "* [numeric? ...] numeric?",
"Product, folded left over two or more operands of one numeric type."); "Product, folded left over two or more operands of one numeric type.");
("/", "/ [numeric? ...] numeric?", ("/", "/ [numeric? ...] numeric?",
@ -10368,7 +10806,8 @@ let builtins : (string * string * string) list =
ordered."); ordered.");
("!=", "!= [equal? ...] bool", ("!=", "!= [equal? ...] bool",
"All different: (!= a b c) is true when every operand differs from every \ "All different: (!= a b c) is true when every operand differs from every \
other, so (!= 1 2 1) is false. Over everything = accepts."); other, so (!= 1 2 1) is false. Over everything = accepts. A float NaN \
is != to everything, itself included.");
("<", "< [ordered? ...] bool", ("<", "< [ordered? ...] bool",
"Less than, chained: (< a b c) is a < b and b < c, and every operand is \ "Less than, chained: (< a b c) is a < b and b < c, and every operand is \
evaluated once. Machine numbers and enums only — ordering a handle \ evaluated once. Machine numbers and enums only — ordering a handle \
@ -10399,6 +10838,13 @@ let builtins : (string * string * string) list =
i16-y) is an i16."); i16-y) is an i16.");
("max", "max [ordered? ...] ordered?", ("max", "max [ordered? ...] ordered?",
"The largest of two or more operands, each evaluated exactly once."); "The largest of two or more operands, each evaluated exactly once.");
("max-value", "max-value [type] T",
"The largest value of a numeric type: (max-value u8) is 255, and at a \
float the largest finite value. Takes a type variable under \
{:where (numeric? $t)}.");
("min-value", "min-value [type] T",
"The least value of a numeric type: (min-value i8) is -128, 0 at an \
unsigned type, and at a float the negation of the largest finite value.");
("zeroed", "zeroed [] T", ("zeroed", "zeroed [] T",
"The all-bytes-zero value of whatever it is being stored into, so it \ "The all-bytes-zero value of whatever it is being stored into, so it \
only means anything where a type is expected of it."); only means anything where a type is expected of it.");
@ -10643,9 +11089,9 @@ let builtins : (string * string * string) list =
not hold. It becomes None where an (Option T) is wanted, and stays dyn \ not hold. It becomes None where an (Option T) is wanted, and stays dyn \
everywhere else."); everywhere else.");
("None", "None (Option T)", ("None", "None (Option T)",
"The absent Option. It takes its type from its context — a return type \ "The absent Option. It takes its type from its context — a return type, \
or an annotated binding — because nothing about the word says what it \ a parameter, or (the (Option i32) None) — because nothing about the \
is an Option of."); word says what it is an Option of.");
("context/allocator", "context/allocator Allocator", ("context/allocator", "context/allocator Allocator",
"The allocator in effect here: what with-allocator rebinds, and what an \ "The allocator in effect here: what with-allocator rebinds, and what an \
allocating operation uses when none is named at the site."); allocating operation uses when none is named at the site.");
@ -10711,6 +11157,22 @@ let rec const_int env (e : Ast.expr) : int64 option =
| Ast.Int n -> Some n | Ast.Int n -> Some n
| Ast.Byte b -> Some (Int64.of_int b) | Ast.Byte b -> Some (Int64.of_int b)
| Ast.Var n -> Hashtbl.find_opt env.consts n | Ast.Var n -> Hashtbl.find_opt env.consts n
| Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) ->
Option.map Int64.neg (const_int env x)
(* A conversion to an integer type, which is how a negative number is
written as an unsigned constant's bit pattern: [(u64 -1)]. Truncated to
the type's width and extended by its sign, as the cast does at run time. *)
| Ast.Call ({ Ast.e = Ast.Var k; _ }, [ x ])
when Types.ikind_of_name k <> None ->
let k = Option.get (Types.ikind_of_name k) in
let bits = Types.bits k in
Option.map
(fun n ->
if bits = 64 then n
else if Types.signed k then
Int64.shift_right (Int64.shift_left n (64 - bits)) (64 - bits)
else Int64.logand n (Int64.sub (Int64.shift_left 1L bits) 1L))
(const_int env x)
(* Left to right over any number of operands, because that is how the (* Left to right over any number of operands, because that is how the
checker reads the same form: an array length that type-checks as a checker reads the same form: an array length that type-checks as a
product of three literals and is then not a constant would be a product of three literals and is then not a constant would be a
@ -11758,12 +12220,26 @@ let check_global env (d : Ast.decl) : Tast.global option =
than the expression it came from: a global's initialiser has to be a than the expression it came from: a global's initialiser has to be a
compile-time constant, and [(/ screen-height cell-size)] is one — the compile-time constant, and [(/ screen-height cell-size)] is one — the
folding pass is the only thing that knows it. *) folding pass is the only thing that knows it. *)
(* A folded conversion is still a value of the type it converts to. *)
(match v.Ast.e, ty with
| Ast.Call ({ Ast.e = Ast.Var c; _ }, [ _ ]), Types.Int kind
when (match Types.ikind_of_name c with
| Some k ->
k <> kind
&& not (Types.widens_to ~from:(Types.Int k) ~into:(Types.Int kind))
| None -> false) ->
fail v.Ast.loc "expected %s, found %s" (Types.ikind_name kind) c
| _ -> ());
let ginit = let ginit =
match Hashtbl.find_opt env.consts n, ty with match Hashtbl.find_opt env.consts n, ty with
| Some k, Types.Int kind -> | Some k, Types.Int kind ->
(* Still range-checked: this path skips [check], and [in_range] is the (* Still range-checked: this path skips [check], and [in_range] is the
only thing that rejects 300 as a u8. *) only thing that rejects 300 as a u8. *)
{ Tast.e = Tast.Int (in_range d.Ast.dloc kind k, kind); ty; { Tast.e =
Tast.Int
(in_range
~pattern:(match v.Ast.e with Ast.Int _ -> false | _ -> true)
v.Ast.loc kind k, kind); ty;
loc = d.Ast.dloc } loc = d.Ast.dloc }
| _ -> check (ctx ()) ~want:ty v | _ -> check (ctx ()) ~want:ty v
in in
@ -12427,6 +12903,68 @@ let is_env_struct = Closures.is_env_struct
let heap_env = Closures.heap_env let heap_env = Closures.heap_env
let place_closures fns = Closures.place ~dev:false fns let place_closures fns = Closures.place ~dev:false fns
(* A program's function named as a prelude function takes the name over, the
way a definition of a builtin's name does: every call written in the file
that defines it reaches the program's, and every call anywhere else — the
prelude's own among them, which were written against the prelude's
signature — keeps reaching the prelude's. The prelude's is renamed out of
the way, under a qualifier no source can spell, rather than dropped.
Functions only: a type or a global of the prelude's name is still defined
twice. *)
let prelude_alias = "prelude~"
(* Off for a check whose warnings were already printed for the same source:
the dev program re-creating the session its launcher built and warned for. *)
let print_warnings = ref true
(* A name the renaming above made, which nobody wrote: left out of every
listing a person reads, and shown as whose it is where a frame has to be. *)
let internal_name n = String.starts_with ~prefix:(prelude_alias ^ "/") n
let shown_name n =
if internal_name n then
let p = String.length prelude_alias + 1 in
"the prelude's " ^ String.sub n p (String.length n - p)
else n
let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) =
let fn_name (d : Ast.decl) =
match d.Ast.d with
| Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> Some fn.Ast.name
| _ -> None
in
let theirs = List.filter_map fn_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)
| _ -> None)
decls
in
let warnings =
List.map
(fun (n, at) ->
Loc.diag ~kind:"check/shadows-prelude" at
(Printf.sprintf
"%s shadows the prelude's %s — every call in this file now \
reaches your definition"
n n))
taken
in
let prelude, decls =
List.fold_left
(fun (prelude, decls) (n, (at : Loc.t)) ->
( List.map (Load.rename_refs [ n ] prelude_alias) prelude,
List.map
(fun (d : Ast.decl) ->
if String.equal d.Ast.dloc.Loc.file at.Loc.file then d
else Load.rename_refs [ n ] prelude_alias d)
decls ))
(prelude, decls) taken
in
(prelude @ decls, warnings)
let build_program ~keep_going ?tolerate (decls : Ast.decl list) : let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
Tast.program * env * string list = Tast.program * env * string list =
let env = new_env () in let env = new_env () in
@ -12482,7 +13020,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
end end
else raise e) else raise e)
in in
let decls = Parse.program (Prelude.forms ()) @ decls in let decls, prelude_warnings =
shadow_prelude (Parse.program (Prelude.forms ())) decls
in
(* Before anything is collected: every (declare-c ...) becomes an ordinary (* Before anything is collected: every (declare-c ...) becomes an ordinary
flattened [declare] with a Flan [defn] over it, and the C that does the flattened [declare] with a Flan [defn] over it, and the C that does the
flattening comes back to be compiled into the build. Nothing below this flattening comes back to be compiled into the build. Nothing below this
@ -12502,11 +13042,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
reload, which is where a defn is most likely to be written. Printed in reload, which is where a defn is most likely to be written. Printed in
the shape [Loc] gives an error, so a checker in an editor parses it the the shape [Loc] gives an error, so a checker in an editor parses it the
same way. *) same way. *)
if !print_warnings then
List.iter List.iter
(fun (d : Loc.diag) -> (fun (d : Loc.diag) ->
prerr_endline prerr_endline
(Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
(shadowed_builtins decls); (shadowed_builtins decls @ prelude_warnings);
(* Pass one, and it stops at the first thing it refuses. That is not (* Pass one, and it stops at the first thing it refuses. That is not
laziness: every name, type and signature in the file comes from here, so a laziness: every name, type and signature in the file comes from here, so a
declaration this pass could not make sense of leaves a hole that pass two declaration this pass could not make sense of leaves a hole that pass two

24
lib/dev.ml
View File

@ -1448,7 +1448,10 @@ let describe t =
ok ok
[ ":fns " [ ":fns "
^ Wire.strings ^ Wire.strings
(List.map (fun (f : Tast.fn) -> f.Tast.name) (List.filter_map
(fun (f : Tast.fn) ->
if Check.internal_name f.Tast.name then None
else Some f.Tast.name)
t.session.Session.program.Tast.fns); t.session.Session.program.Tast.fns);
":globals " ":globals "
^ Wire.strings ^ Wire.strings
@ -1560,6 +1563,7 @@ let defs t =
Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc); Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc);
None None
| None when List.mem f.Tast.name class_names -> None | None when List.mem f.Tast.name class_names -> None
| None when Check.internal_name f.Tast.name -> None
| None -> | None ->
Some Some
(entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f) (entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f)
@ -2007,7 +2011,7 @@ let backtrace_op t =
(List.map (List.map
(fun (name, loc, mine, nslots, _sig, _rsig) -> (fun (name, loc, mine, nslots, _sig, _rsig) ->
Wire.list Wire.list
[ Wire.quote name; Wire.quote loc; [ Wire.quote (Check.shown_name name); Wire.quote loc;
Wire.quote (if mine then "program" else "eval"); Wire.quote (if mine then "program" else "eval");
string_of_int nslots ]) string_of_int nslots ])
frames); frames);
@ -4891,17 +4895,8 @@ let make_session_dir ~file dir =
would find that out at the link — as a missing symbol, or as the merged would find that out at the link — as a missing symbol, or as the merged
build's rename finding nothing to rename. *) build's rename finding nothing to rename. *)
let need_main ~file (session : Session.t) = let need_main ~file (session : Session.t) =
if not Build.need_main ~file ~doing:"flan dev has nothing to run"
(List.exists (fun (f : Tast.fn) -> f.Tast.name = "main") session.Session.host
session.Session.host.Tast.fns)
then
failwith
(Printf.sprintf
"%s has no main, so flan dev has nothing to run. A program starts at \
a function named main, for example:\n\n\
\ (defn main [] i32\n\
\ 0)"
file)
(* [debug] is off by default, which keeps [flan dev] exactly what it was: a (* [debug] is off by default, which keeps [flan dev] exactly what it was: a
-O2 host and -O2 modules. It is opt-in rather than always-on because a debug -O2 host and -O2 modules. It is opt-in rather than always-on because a debug
@ -5820,7 +5815,10 @@ let merged_setup () =
marshalling a [Session.t] through a file, which buys nothing: the source marshalling a [Session.t] through a file, which buys nothing: the source
cannot have changed between the two, because the build that produced cannot have changed between the two, because the build that produced
this binary is the one that exec'd it. *) this binary is the one that exec'd it. *)
(* Its warnings were printed by the launcher over the same source. *)
Check.print_warnings := false;
let session, _ = Session.create ~debug ~x86 ~file () in let session, _ = Session.create ~debug ~x86 ~file () in
Check.print_warnings := true;
(* The program's output has to reach an editor exactly as it did when the (* The program's output has to reach an editor exactly as it did when the
daemon held the other end of a pipe. Same pipe, one process: fd 1 is daemon held the other end of a pipe. Same pipe, one process: fd 1 is
replaced before the program starts, and the accept loop drains it — replaced before the program starts, and the accept loop drains it —

6
lib/emit.ml
View File

@ -2277,8 +2277,11 @@ let icmp_op signed = function
| Tast.Ge -> if signed then "sge" else "uge" | Tast.Ge -> if signed then "sge" else "uge"
| _ -> assert false | _ -> assert false
(* [!=] is unordered and the rest are ordered, so a NaN is unequal to
everything, itself included, and neither less, greater nor equal: IEEE 754's
answers, and C's and Odin's. *)
let fcmp_op = function let fcmp_op = function
| Tast.Eq -> "oeq" | Tast.Ne -> "one" | Tast.Lt -> "olt" | Tast.Eq -> "oeq" | Tast.Ne -> "une" | Tast.Lt -> "olt"
| Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge" | Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
| _ -> assert false | _ -> assert false
@ -4793,6 +4796,7 @@ declare i64 @flan_dyn_sub(i64, i64, ptr, i64)
declare i64 @flan_dyn_mul(i64, i64, ptr, i64) declare i64 @flan_dyn_mul(i64, i64, ptr, i64)
declare i64 @flan_dyn_div(i64, i64, ptr, i64) declare i64 @flan_dyn_div(i64, i64, ptr, i64)
declare i64 @flan_dyn_rem(i64, i64, ptr, i64) declare i64 @flan_dyn_rem(i64, i64, ptr, i64)
declare i64 @flan_dyn_neg(i64, ptr, i64)
declare i64 @flan_dyn_lt(i64, i64, ptr, i64) declare i64 @flan_dyn_lt(i64, i64, ptr, i64)
declare i64 @flan_dyn_le(i64, i64, ptr, i64) declare i64 @flan_dyn_le(i64, i64, ptr, i64)
declare i64 @flan_dyn_gt(i64, i64, ptr, i64) declare i64 @flan_dyn_gt(i64, i64, ptr, i64)

33
lib/load.ml
View File

@ -315,6 +315,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
other reference to it. *) other reference to it. *)
| Ast.ArrayFill (ds, v) -> Ast.ArrayFill (List.map (rename_len owned alias) ds, go v) | Ast.ArrayFill (ds, v) -> Ast.ArrayFill (List.map (rename_len owned alias) ds, go v)
| Ast.ArrayGen (ds, v) -> Ast.ArrayGen (List.map (rename_len owned alias) ds, go v) | Ast.ArrayGen (ds, v) -> Ast.ArrayGen (List.map (rename_len owned alias) ds, go v)
| Ast.The (t, v) -> Ast.The (rename_texpr owned alias t, go v)
| Ast.Fn (ps, body) -> | Ast.Fn (ps, body) ->
Ast.Fn (ps, List.map (rename_expr owned alias (ps @ bound)) body) Ast.Fn (ps, List.map (rename_expr owned alias (ps @ bound)) body)
| Ast.Dotimes (l, i, b, body) -> | Ast.Dotimes (l, i, b, body) ->
@ -554,6 +555,37 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
in in
{ d with Ast.d = k } { d with Ast.d = k }
(* [qualify_decl]'s rename of every use of an [owned] name, without the rename
of the declaration's own name unless that name is one of them. How a
program's definition of a name the prelude also defines takes the name
over: the prelude's declaration and its uses outside the program's file
move to the qualified name, and the program's file keeps the bare one. *)
let rename_refs owned alias (d : Ast.decl) : Ast.decl =
match Ast.declared_name d, d.Ast.d with
| _, (Ast.Package _ | Ast.Import _) -> d
| Some n, _ when List.mem n owned -> qualify_decl owned alias d
| _ ->
let q = qualify_decl owned alias d in
let named (fn : Ast.fn) (o : Ast.fn) = { fn with Ast.name = o.Ast.name } in
let k =
match q.Ast.d, d.Ast.d with
| Ast.Declare (fn, c), Ast.Declare (o, _) -> Ast.Declare (named fn o, c)
| Ast.DeclareC (fn, c), Ast.DeclareC (o, _) -> Ast.DeclareC (named fn o, c)
| Ast.Defn fn, Ast.Defn o -> Ast.Defn (named fn o)
| Ast.Defgeneric fn, Ast.Defgeneric o -> Ast.Defgeneric (named fn o)
| Ast.Defmulti fn, Ast.Defmulti o -> Ast.Defmulti (named fn o)
| Ast.Defenum (_, ms), Ast.Defenum (n, _) -> Ast.Defenum (n, ms)
| Ast.Defalias (_, t), Ast.Defalias (n, _) -> Ast.Defalias (n, t)
| Ast.Defconst (_, t, v), Ast.Defconst (n, _, _) -> Ast.Defconst (n, t, v)
| Ast.Defstruct (_, fs), Ast.Defstruct (n, _) -> Ast.Defstruct (n, fs)
| Ast.Defunion (_, fs), Ast.Defunion (n, _) -> Ast.Defunion (n, fs)
| Ast.Defdata (_, vs), Ast.Defdata (n, _) -> Ast.Defdata (n, vs)
| Ast.Defvar (_, t, i, r), Ast.Defvar (n, _, _, _) -> Ast.Defvar (n, t, i, r)
| Ast.Defclass (_, ss), Ast.Defclass (n, _) -> Ast.Defclass (n, ss)
| k, _ -> k
in
{ q with Ast.d = k }
(* ── Qualifying a package's macros ────────────────────────────────── (* ── Qualifying a package's macros ──────────────────────────────────
The rename above works over the Ast and a macro cannot go that way. By the The rename above works over the Ast and a macro cannot go that way. By the
time [Parse] is finished with a [defmacro] its quasiquote has been desugared time [Parse] is finished with a [defmacro] its quasiquote has been desugared
@ -790,6 +822,7 @@ let rec expr_uses acc (e : Ast.expr) =
| Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs | Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs
| Ast.Arr items -> gos items | Ast.Arr items -> gos items
| Ast.ArrayOf t | Ast.TypeArg t -> texpr_uses acc t | Ast.ArrayOf t | Ast.TypeArg t -> texpr_uses acc t
| Ast.The (t, v) -> texpr_uses acc t; go v
(* A dimension written as a name is a use of that constant, exactly as it is (* A dimension written as a name is a use of that constant, exactly as it is
inside [Tarray]. *) inside [Tarray]. *)
| Ast.ArrayFill (ds, v) | Ast.ArrayGen (ds, v) -> | Ast.ArrayFill (ds, v) | Ast.ArrayGen (ds, v) ->

9
lib/parse.ml
View File

@ -489,6 +489,15 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
array of integers — the wrong reading, and a silent one. Read here, the array of integers — the wrong reading, and a silent one. Read here, the
brackets are [len]s: the same integer-or-constant's-name the [n T] type brackets are [len]s: the same integer-or-constant's-name the [n T] type
spelling takes, refused by [len] when they are anything else. *) spelling takes, refused by [len] when they are anything else. *)
(* ── (the T e) ──────────────────────────────────────────────────── *)
| Sym "the" ->
(match args with
| [ t; v ] -> mk (Ast.The (texpr t, expr v))
| _ ->
fail f
"the is (the TYPE value), as in (the u8 0) — the value, checked as \
a TYPE")
| Sym (("array-fill" | "array-gen") as which) -> | Sym (("array-fill" | "array-gen") as which) ->
let usage () = let usage () =
fail f fail f

3
lib/prelude.ml
View File

@ -427,6 +427,7 @@ let source = {flan|
;; or more numbers, and a defn cannot shadow a builtin: nothing shadows [+] ;; or more numbers, and a defn cannot shadow a builtin: nothing shadows [+]
;; either. These reduce a slice, which is a different operation with a ;; either. These reduce a slice, which is a different operation with a
;; different arity, so the different name is honest rather than a workaround. ;; different arity, so the different name is honest rather than a workaround.
;; A type's own limits are (min-value T) and (max-value T).
(defn min-of [s [$t]] (Option $t) (defn min-of [s [$t]] (Option $t)
{:where (ordered? $t)} {:where (ordered? $t)}
(if (= (length s) 0) (if (= (length s) 0)
@ -716,7 +717,7 @@ let source = {flan|
;; The floats are three questions and not two, which is why there is no ;; The floats are three questions and not two, which is why there is no
;; f32-min here to sit beside f32-max. ;; f32-min here to sit beside f32-max.
;; ;;
;; A float's least value is just the negation of its greatest — (- 0.0 f32-max) ;; A float's least value is just the negation of its greatest — (- f32-max)
;; — so a constant for it would say nothing the language cannot. What a caller ;; — so a constant for it would say nothing the language cannot. What a caller
;; actually reaches for under the name "min" is the smallest positive one, and ;; actually reaches for under the name "min" is the smallest positive one, and
;; that is a different number entirely. Naming it f32-min would make the two ;; that is a different number entirely. Naming it f32-min would make the two

4
lib/session.ml
View File

@ -186,6 +186,10 @@ let stale_sites ?(live = SM.empty) ?(running = false) built (p : Tast.program) :
m acc m acc
in in
from ~kept:true live (from ~kept:false built []) from ~kept:true live (from ~kept:false built [])
(* A caller or callee the prelude-shadowing rename made is not the
program's, and there is nothing in the program to recompile for it. *)
|> List.filter (fun s ->
not (Check.internal_name s.caller || Check.internal_name s.target))
|> List.sort (fun a b -> |> List.sort (fun a b ->
match String.compare a.at.Loc.file b.at.Loc.file with match String.compare a.at.Loc.file b.at.Loc.file with
| 0 -> Loc.before a.at b.at | 0 -> Loc.before a.at b.at

22
lib/x86.ml
View File

@ -1318,18 +1318,20 @@ let int_cc ~signed (p : Tast.prim) =
(* Parity, which on [ucomis] means "unordered": one of the operands was a NaN. (* Parity, which on [ucomis] means "unordered": one of the operands was a NaN.
Nothing else in this file reads it. *) Nothing else in this file reads it. *)
let cc_np = 11 let cc_p = 10 and cc_np = 11
(* [ucomis] sets the flags the *unsigned* codes read, whichever way the (* [ucomis] sets the flags the *unsigned* codes read, whichever way the
operands are signed, so a float comparison never uses l/g — and it sets operands are signed, so a float comparison never uses l/g — and it sets
CF, ZF and PF all at once when either operand is a NaN. CF, ZF and PF all at once when either operand is a NaN.
That last part is why this is not simply the unsigned table. Every That last part is why this is not simply the unsigned table. Every
comparison Flan has is LLVM's *ordered* one ([emit.ml]'s [fcmp_op]: oeq, comparison Flan has but one is LLVM's *ordered* one ([emit.ml]'s
one, olt, ...), which answers false for a NaN, and [setb] after an [fcmp_op]: oeq, olt, ...), which answers false for a NaN, and [setb] after
unordered compare answers true. So [<] and [<=] swap their operands and ask an unordered compare answers true. So [<] and [<=] swap their operands and
for a/ae, which are the two codes a NaN makes false; [=] and [!=] cannot be ask for a/ae, which are the two codes a NaN makes false; [=] cannot be
spelled by one code at all and take a second [setnp] beside them. spelled by one code at all and takes a second [setnp] beside it. The one is
[!=], which is [une] — true for a NaN, as IEEE 754 and C have it — and is
[setne] or'd with [setp].
[(not (= x x))] is how [format-f64] in the prelude detects a NaN, and it is [(not (= x x))] is how [format-f64] in the prelude detects a NaN, and it is
the whole of the difference: with [sete] alone, [(/ 0.0 0.0)] formatted as the whole of the difference: with [sete] alone, [(/ 0.0 0.0)] formatted as
@ -1345,7 +1347,7 @@ let float_cc (p : Tast.prim) =
| _ -> unsupported "not a comparison" | _ -> unsupported "not a comparison"
let float_ordered (p : Tast.prim) = let float_ordered (p : Tast.prim) =
match p with Tast.Eq | Tast.Ne -> true | _ -> false match p with Tast.Eq -> true | _ -> false
let is_cmp (p : Tast.prim) = let is_cmp (p : Tast.prim) =
match p with match p with
@ -3274,6 +3276,12 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
movzx8 f.b ~dst:rcx ~src:rcx; movzx8 f.b ~dst:rcx ~src:rcx;
and_rr f.b ~dst:rax ~src:rcx and_rr f.b ~dst:rax ~src:rcx
end end
else if p = Tast.Ne then begin
movzx8 f.b ~dst:rax ~src:rax;
setcc f.b ~cc:cc_p ~dst:rcx;
movzx8 f.b ~dst:rcx ~src:rcx;
or_rr f.b ~dst:rax ~src:rcx
end
end else begin end else begin
load_loc f ~reg:rax la a.Tast.ty; load_loc f ~reg:rax la a.Tast.ty;
load_loc f ~reg:rcx lb b.Tast.ty; load_loc f ~reg:rcx lb b.Tast.ty;

8
runtime/flan_dyn.c
View File

@ -2076,6 +2076,14 @@ flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) { int64_t loclen) {
return arith(loc, loclen, "-", a, b); return arith(loc, loclen, "-", a, b);
} }
/* (- x): an int wraps, as (- 0 x) does, and a float flips its sign, so the
* negation of 0.0 is -0.0 and not the 0.0 a subtraction from zero gives. */
flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen) {
if (!is_num(a)) trap1(loc, loclen, TYPE_TRAP, "-", "it takes a number", a);
if (flan_dyn_tag(a) == FLAN_DYN_TAG_INT)
return flan_dyn_from_i64((int64_t)(0 - (uint64_t)dyn_int_value(a)));
return flan_dyn_from_f64(-dyn_num_value(a));
}
flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc,
int64_t loclen) { int64_t loclen) {
return arith(loc, loclen, "*", a, b); return arith(loc, loclen, "*", a, b);

1
runtime/flan_dyn.h
View File

@ -168,6 +168,7 @@ flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen
flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen);
/* Answer a bool dyn. Numbers compare as numbers and text compares bytewise; /* Answer a bool dyn. Numbers compare as numbers and text compares bytewise;
* a mixture of the two, or anything else, traps. */ * a mixture of the two, or anything else, traps. */

2
test/dyn_ops.c
View File

@ -985,6 +985,8 @@ static void refuse(const char *what) {
if (strcmp(what, "add") == 0) (void)FDYN_add(flan_dyn_from_i64(3), t); if (strcmp(what, "add") == 0) (void)FDYN_add(flan_dyn_from_i64(3), t);
else if (strcmp(what, "sub") == 0) else if (strcmp(what, "sub") == 0)
(void)FDYN_sub(flan_dyn_nil(), flan_dyn_from_i64(1)); (void)FDYN_sub(flan_dyn_nil(), flan_dyn_from_i64(1));
else if (strcmp(what, "neg") == 0)
(void)flan_dyn_neg(t, NULL, 0);
else if (strcmp(what, "mul") == 0) else if (strcmp(what, "mul") == 0)
(void)FDYN_mul(flan_dyn_from_bool(1), flan_dyn_from_i64(2)); (void)FDYN_mul(flan_dyn_from_bool(1), flan_dyn_from_i64(2));
else if (strcmp(what, "div") == 0) else if (strcmp(what, "div") == 0)

4
test/programs/array-first-element.flan
View File

@ -1,6 +1,6 @@
;;;; An array literal with nothing outside it saying what its elements are ;;;; An array literal with nothing outside it saying what its elements are
;;;; takes that from its first element: [(f32 1.0) 2.5] is a [2 f32], and the ;;;; takes that from the elements that are not literals: [(f32 1.0) 2.5] is a
;;;; 2.5 is an f32 literal rather than an f64 refused for not being one. ;;;; [2 f32], and the 2.5 is an f32 literal rather than an f64.
(defn sum3 [a [3 f32]] f32 (+ (at a 0) (at a 1) (at a 2))) (defn sum3 [a [3 f32]] f32 (+ (at a 0) (at a 1) (at a 2)))
(defn main [] i32 (defn main [] i32

59
test/programs/array-mixed.flan Normal file
View File

@ -0,0 +1,59 @@
;;;; An array literal with nothing outside it naming a type: elements that agree
;;;; are a typed array, numbers meeting at the wider and a literal taking the
;;;; others' type, and elements that do not are a dyn vector.
(defstruct P [x i32 y i32])
(defn mixed [] i32
(let [x (i32 4)
a [(f32 1.0) 2.5 3.25]
b [(i64 1) 2 3]
c [(u8 1) 300]
d [x 2.5]
e [1 18446744073709551615]
f [10 "Hi"]
g [nil 1]
h [None (Some 3)]
i [(P 1 2) {.x 3 .y 4}]
j [[1 2] [3 4]]
k [1 2.5]
m [x (i64 5)]
dd [:a "b" 3]]
(println (length a))
(println (+ (at c 1) (i32 (at c 0))))
(println (at d 1))
(println (at e 1))
(println f)
(println g)
(println (length f))
(println (match (at h 1) None 0 (Some v) v))
(println (.y (at i 1)))
(println (at (at j 1) 0))
(println (at k 0))
(println (+ (at m 0) (i64 9000000000)))
(println dd))
0)
;; (the T e) gives any expression its type.
(defn the-forms [] i32
(let [a (the u8 200)
b (the i64 5000000000)
c (the f32 2.5)
d (the [3 f32] [1 2 3.5])
e (the [f32] [1 2.5])
f (the (Option i32) None)
g (the (Option i32) nil)
h (the dyn 3)
n (the i64 (+ (the i32 1) 2))
v (the (Vec i32) (vec-new))]
(println (+ a (u8 55)))
(println b)
(println (* c (f32 2.0)))
(println (+ (at d 0) (at d 2)))
(println (length e))
(println (match f None 0 (Some x) x))
(println (match g None 7 (Some x) x))
(println h)
(println n)
(println (length v)))
0)
(defn main [] i32 (mixed) (the-forms))

21
test/programs/limits.flan
View File

@ -60,6 +60,10 @@
(print " ") (print " ")
(println (if ok "ok" "WRONG"))) (println (if ok "ok" "WRONG")))
(defn ne-f64 [a f64 b f64] bool (!= a b))
(defn ne-f32 [a f32 b f32] bool (!= a b))
(defn ne-dyn [a dyn b dyn] bool (!= a b))
(defn main [] i32 (defn main [] i32
;; The integers, each printed as the exact decimal the expected output pins. ;; The integers, each printed as the exact decimal the expected output pins.
(println i8-max) (println i8-max)
@ -115,17 +119,26 @@
;; the absence is recorded rather than merely unmentioned: a float's least ;; the absence is recorded rather than merely unmentioned: a float's least
;; value is the negation of its greatest, and there is nothing to derive. ;; value is the negation of its greatest, and there is nothing to derive.
(say "f32's least value negates its greatest" (say "f32's least value negates its greatest"
(< (- (f32 0.0) f32-max) (- (f32 0.0) f32-min-positive))) (< (- f32-max) (- f32-min-positive)))
(say "f64's least value negates its greatest" (say "f64's least value negates its greatest"
(< (- 0.0 f64-max) (- 0.0 f64-min-positive))) (< (- f64-max) (- f64-min-positive)))
;; The infinities and NaNs, which no literal writes. Each infinity is the ;; The infinities and NaNs, which no literal writes. Each infinity is the
;; overflow of its type's greatest value, negated it is below the least ;; overflow of its type's greatest value, negated it is below the least
;; finite one, and a NaN is the one value not equal to itself. ;; finite one, and a NaN is the one value not equal to itself.
(say "f64-inf" (= f64-inf (* f64-max 2.0))) (say "f64-inf" (= f64-inf (* f64-max 2.0)))
(say "f32-inf" (= f32-inf (* f32-max (f32 2.0)))) (say "f32-inf" (= f32-inf (* f32-max (f32 2.0))))
(say "f64-inf negated" (< (- 0.0 f64-inf) (- 0.0 f64-max))) (say "f64-inf negated" (< (- f64-inf) (- f64-max)))
(say "f32-inf negated" (< (- (f32 0.0) f32-inf) (- (f32 0.0) f32-max))) (say "f32-inf negated" (< (- f32-inf) (- f32-max)))
(say "f64-nan" (not (= f64-nan f64-nan))) (say "f64-nan" (not (= f64-nan f64-nan)))
(say "f32-nan" (not (= f32-nan f32-nan))) (say "f32-nan" (not (= f32-nan f32-nan)))
;; != is the one unordered comparison: a NaN is unequal to everything,
;; itself included, and the dyn side agrees. The operands arrive as
;; parameters so that no constant folder answers in the backend's place.
(say "f64-nan != itself" (ne-f64 f64-nan f64-nan))
(say "f32-nan != itself" (ne-f32 f32-nan f32-nan))
(say "!= over ordinary floats"
(and (ne-f64 1.0 2.0) (not (ne-f64 1.5 1.5))
(ne-f32 (f32 1.0) (f32 2.0)) (not (ne-f32 (f32 1.5) (f32 1.5)))))
(say "a dyn NaN != itself" (ne-dyn f64-nan f64-nan))
0) 0)

18
test/programs/literal-arm.flan Normal file
View File

@ -0,0 +1,18 @@
;;;; A literal arm takes its type from the arm that is not a literal, in an
;;;; if, a cond and a match alike, as a literal operand of + does.
(defn g [c bool n i64] i64 (let [x (if c 4000000 n)] x))
(defn h [k i32 n i64] i64
(let [x (cond (= k 0) 5000000000 (= k 1) 7 :else n)] x))
(defn m [o (Option i64)] i64
(let [x (match o None 3 (Some v) v)] x))
(defn f32s [c bool y f32] f32 (let [x (if c 2.5 y)] x))
(defn main [] i32
(println (g true (i64 3)))
(println (g false (i64 9000000000)))
(println (h 0 (i64 1)))
(println (h 1 (i64 1)))
(println (h 2 (i64 9000000000)))
(println (m None))
(println (m (Some (i64 9000000000))))
(println (f32s true (f32 1.0)))
0)

54
test/programs/max-value.flan Normal file
View File

@ -0,0 +1,54 @@
;;;; (max-value T) and (min-value T): a numeric type's limits, named by the type, at
;;;; a concrete type and inside a generic whose bound admits numbers.
;; A selection sort, descending, whose running best starts at the least value
;; of the element type, so any element beats it.
(defn sort-desc [s [$t]] ()
{:where (numeric? $t)}
(dotimes [i (length s)]
(let [best (min-value $t)
at-best i]
(dotimes [j (- (length s) i)]
(let [k (+ i j)]
(when (> (at s k) best)
(set best (at s k))
(set at-best k))))
(swap s i at-best))))
(defn largest [s [$t]] $t
{:where (numeric? $t)}
(let [best (min-value t)]
(dotimes [i (length s)]
(when (> (at s i) best) (set best (at s i))))
best))
(defn show-i32 [s [i32]] ()
(dotimes [i (length s)] (print (at s i)) (print " "))
(println ""))
(defn show-f64 [s [f64]] ()
(dotimes [i (length s)] (print (at s i)) (print " "))
(println ""))
(defn main [] i32
(println (max-value u8))
(println (min-value u8))
(println (max-value i8))
(println (min-value i8))
(println (max-value i32))
(println (min-value i64))
(println (max-value u64))
(println (= (max-value f32) f32-max))
(println (= (min-value f64) (- f64-max)))
(println (= (max-value i16) i16-max))
(let [a [(i32 3) -7 12 0 -2147483648 5]
b [2.5 -1.0 1e300 -1e308]
c [(u8 4) 0 200 9]]
(sort-desc (slice a))
(show-i32 (slice a))
(sort-desc (slice b))
(show-f64 (slice b))
(println (largest (slice c)))
(println (let [d [(i64 -5) -9]] (largest (slice d))))
(println (let [e [(f32 -1.0) -3.0]] (= (largest (slice e)) (f32 -1.0)))))
0)

25
test/programs/negate.flan Normal file
View File

@ -0,0 +1,25 @@
;;;; (- x) negates: an integer wraps, a float flips its sign — the negation of
;;;; 0.0 is -0.0, which 1/x tells apart — and a dyn does either by its tag.
(defn negi [x i32] i32 (- x))
(defn negf [x f64] f64 (- x))
(defn negf32 [x f32] f32 (- x))
(defn negu [x u8] u8 (- x))
(defn negd [x dyn] dyn (- x))
(defn negg [x $t] $t {:where (numeric? $t)} (- x))
(defn main [] i32
(println (negi 3))
(println (negi -7))
(println (negf 2.5))
(println (/ 1.0 (negf 0.0)))
(println (negf32 (f32 1.5)))
(println (negu (u8 1)))
(println (negd 4))
(println (negd 2.5))
(println (/ 1.0 (negd 0.0)))
(println (negg (i64 9000000000)))
(println (negg 0.5))
(let [a (- 5) b (i64 (- 3))]
(println (+ a (i32 b))))
(println (- f64-inf))
(println (< (- f64-inf) (- f64-max)))
0)

13
test/programs/shadow-prelude.flan Normal file
View File

@ -0,0 +1,13 @@
;;;; 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.
(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 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))
0)

67
test/test_acceptance.ml
View File

@ -563,13 +563,50 @@ let () =
fpu_out; fpu_out;
outputs ~x86:true "a pointer and a union filled, x86" outputs ~x86:true "a pointer and a union filled, x86"
"programs/fill-ptr-union.flan" fpu_out; "programs/fill-ptr-union.flan" fpu_out;
(* An array literal takes its element type from its first element when (* A literal element takes its type from the other elements when nothing
nothing outside it names one. *) outside the array names one. *)
let first_out = "3\n6.75\n9000000002\n255\n" in let first_out = "3\n6.75\n9000000002\n255\n" in
outputs "an array literal's first element types the rest" outputs "an array literal's first element types the rest"
"programs/array-first-element.flan" first_out; "programs/array-first-element.flan" first_out;
outputs ~x86:true "an array literal's first element types the rest, x86" outputs ~x86:true "an array literal's first element types the rest, x86"
"programs/array-first-element.flan" first_out; "programs/array-first-element.flan" first_out;
(* An array literal whose elements agree is typed and one whose elements
mix is a dyn vector; (the T e) gives any expression its type. *)
let mixed_out =
"3\n301\n2.5\n18446744073709551615\n[ 10 \"Hi\"]\n[ nil 1]\n2\n3\n4\n\
3\n1\n9000000004\n[ :a \"b\" 3]\n\
255\n5000000000\n5\n4.5\n2\n0\n7\n3\n3\n0\n" in
outputs "mixed array literals and the" "programs/array-mixed.flan" mixed_out;
outputs ~x86:true "mixed array literals and the, x86"
"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
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;
(* (max-value T) and (min-value T), concrete and inside a generic. *)
let maxof_out =
"255\n0\n127\n-128\n2147483647\n-9223372036854775808\n\
18446744073709551615\ntrue\ntrue\ntrue\n\
12 5 3 0 -7 -2147483648 \n1e+300 2.5 -1 -1e+308 \n200\n-5\ntrue\n" in
outputs "max-value and min-value" "programs/max-value.flan" maxof_out;
outputs ~opt:"-O0" "max-value and min-value, -O0" "programs/max-value.flan" maxof_out;
outputs ~x86:true "max-value and min-value, x86" "programs/max-value.flan" maxof_out;
(* (- x) negates, on every numeric type, a type variable and a dyn. *)
let neg_out =
"-3\n7\n-2.5\n-inf\n-1.5\n255\n-4\n-2.5\n-inf\n-9000000000\n\
-0.5\n-8\n-inf\ntrue\n" in
outputs "unary minus" "programs/negate.flan" neg_out;
outputs ~opt:"-O0" "unary minus, -O0" "programs/negate.flan" neg_out;
outputs ~x86:true "unary minus, x86" "programs/negate.flan" neg_out;
(* A literal arm takes the other arm's type. *)
let arm_out =
"4000000\n9000000000\n5000000000\n7\n9000000000\n3\n9000000000\n2.5\n" in
outputs "a literal arm takes the other arm's type"
"programs/literal-arm.flan" arm_out;
outputs ~x86:true "a literal arm takes the other arm's type, x86"
"programs/literal-arm.flan" arm_out;
(* into. The count of pulls is the assertion a unit test cannot make: one (* into. The count of pulls is the assertion a unit test cannot make: one
pass, one call per element per stage it reaches, and no intermediate pass, one call per element per stage it reaches, and no intermediate
collection anywhere. The two show lines either side of it are the same collection anywhere. The two show lines either side of it are the same
@ -5684,7 +5721,9 @@ level "1"
f32's least value negates its greatest ok\n\ f32's least value negates its greatest ok\n\
f64's least value negates its greatest ok\n\ f64's least value negates its greatest ok\n\
f64-inf ok\nf32-inf ok\nf64-inf negated ok\nf32-inf negated ok\n\ f64-inf ok\nf32-inf ok\nf64-inf negated ok\nf32-inf negated ok\n\
f64-nan ok\nf32-nan ok\n" f64-nan ok\nf32-nan ok\n\
f64-nan != itself ok\nf32-nan != itself ok\n\
!= over ordinary floats ok\na dyn NaN != itself ok\n"
in in
outputs "type limits" "programs/limits.flan" limits_out; outputs "type limits" "programs/limits.flan" limits_out;
outputs ~opt:"-O0" "type limits, -O0" "programs/limits.flan" limits_out; outputs ~opt:"-O0" "type limits, -O0" "programs/limits.flan" limits_out;
@ -6716,6 +6755,28 @@ level "1"
cli_case "--debug and an explicit -O are refused together" cli_case "--debug and an explicit -O are refused together"
"build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2 "build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2
~says:[ "--debug"; "-O2"; "Drop one of the two" ]; ~says:[ "--debug"; "-O2"; "Drop one of the two" ];
(* The name a shadowed prelude function is moved to is nobody's to read. *)
(let code, text = cli "check programs/shadow-prelude.flan" in
if code <> 0 || contains text "prelude~"
|| not (contains text "defn floor-f32")
then begin
incr failures;
Printf.printf
"FAIL check's listing leaves out the renamed prelude function\n\
\ got: %S (exit %d)\n" text code
end);
(* A file with no main is refused by name before the link, which would
otherwise report an undefined reference from crt1.o. *)
let nomain = Filename.concat scratch "no-main.flan" in
Out_channel.with_open_bin nomain (fun oc ->
output_string oc "(defn f [] i32 0)\n");
cli_case "build of a file with no main names main"
(Printf.sprintf "build %s -o /dev/null" (Filename.quote nomain)) ~code:1
~says:[ "has no main"; "(defn main [] i32" ];
cli_case "run of a file with no main names main"
(Printf.sprintf "run %s" (Filename.quote nomain)) ~code:1
~says:[ "has no main"; "(defn main [] i32" ];
Sys.remove nomain;
(* Every row above that went through the pool has been forked; nothing (* Every row above that went through the pool has been forked; nothing
after this point may look at [failures] until every one of them has after this point may look at [failures] until every one of them has

1
test/test_dyn.ml
View File

@ -205,6 +205,7 @@ let () =
let refusals = let refusals =
[ ("add", "dyn +: int and text"); [ ("add", "dyn +: int and text");
("sub", "dyn -: nil and int"); ("sub", "dyn -: nil and int");
("neg", "dyn -: text, and it takes a number");
("mul", "dyn *: bool and int"); ("mul", "dyn *: bool and int");
("div", "dyn /: vec and int"); ("div", "dyn /: vec and int");
("rem", "dyn %: int and nil"); ("rem", "dyn %: int and nil");

205
test/test_flan.ml
View File

@ -1245,7 +1245,7 @@ let () =
accepts "return type types the literal" "(defn f [] u8 0)"; accepts "return type types the literal" "(defn f [] u8 0)";
accepts "return type types None" "(defn f [] (Option f64) None)"; accepts "return type types None" "(defn f [] (Option f64) None)";
rejects_check "bare None has no type" "(defconst x None)" rejects_check "bare None has no type" "(defconst x None)"
~needle:"what None is an Option of"; ~needle:"(the (Option i32) None)";
accepts "param types the literal" accepts "param types the literal"
"(defn g [x u8] ()) (defn f [] () (g 3))"; "(defn g [x u8] ()) (defn f [] () (g 3))";
rejects_check "wrong argument type" rejects_check "wrong argument type"
@ -1337,14 +1337,18 @@ let () =
infers "min at four" "(min 4 1 3 2)" "i32"; infers "min at four" "(min 4 1 3 2)" "i32";
infers "max at four" "(max 4 1 3 2)" "i32"; infers "max at four" "(max 4 1 3 2)" "i32";
(* And the two counts below the floor. Zero would have to mean an identity (* And the two counts below the floor. Zero would have to mean an identity
element and one a unary operator this language does not have; both are a element, and one is refused for every operator but -, whose one-operand
typo far more often than an intent, so both are refused by name. *) form negates. *)
rejects_check "a sum with no terms" rejects_check "a sum with no terms"
"(defn f [] i32 (+))" ~needle:"+ takes two arguments or more, given 0"; "(defn f [] i32 (+))" ~needle:"+ takes two arguments or more, given 0";
rejects_check "a product with no factors" rejects_check "a product with no factors"
"(defn f [] i32 (*))" ~needle:"* takes two arguments or more, given 0"; "(defn f [] i32 (*))" ~needle:"* takes two arguments or more, given 0";
rejects_check "there is no unary minus" infers "a negated literal" "(- 1)" "i32";
"(defn f [] i32 (- 1))" ~needle:"there is no unary minus"; infers "a negated literal takes its type from the site" "(i64 (- 1))" "i64";
rejects_check "unary minus over a string names the operand"
"(defn f [s string] () (println (- s)))" ~needle:"- takes numbers";
rejects_check "unary minus at an unsigned literal is out of range"
"(defn f [] u8 (- 1))" ~needle:"does not fit in u8";
rejects_check "there is no reciprocal" rejects_check "there is no reciprocal"
"(defn f [] f64 (/ 2.0))" ~needle:"there is no reciprocal"; "(defn f [] f64 (/ 2.0))" ~needle:"there is no reciprocal";
rejects_check "one operand is not a bitwise and" rejects_check "one operand is not a bitwise and"
@ -3001,7 +3005,7 @@ let () =
~needle:"needs to know the type it is filling"; ~needle:"needs to know the type it is filling";
rejects_check "a dead-beef in a position with no expected type" rejects_check "a dead-beef in a position with no expected type"
"(defn f [] () (print (dead-beef)))" "(defn f [] () (print (dead-beef)))"
~needle:"needs to know the type it is filling"; ~needle:"(the [4 u32] (dead-beef))";
(* The byte is a u8 and the ordinary literal rule applies to it — there is (* The byte is a u8 and the ordinary literal rule applies to it — there is
no range check of this builtin's own, and there does not need to be. *) no range check of this builtin's own, and there does not need to be. *)
rejects_check "a fill byte out of range" rejects_check "a fill byte out of range"
@ -5406,6 +5410,24 @@ let () =
| exception Loc.Error _ -> false); | exception Loc.Error _ -> false);
check "a program that shadows nothing is warned at not at all" check "a program that shadows nothing is warned at not at all"
(Check.shadowed_builtins (program "(defn f [] i32 1)") = []); (Check.shadowed_builtins (program "(defn f [] i32 1)") = []);
(* A prelude function's name is taken over the same way, for the calls in
the defining file. *)
let prelude_src = "(defn abs-f32 [v f32] f32 v)" in
(match
snd (Check.shadow_prelude (Parse.program (Prelude.forms ()))
(program prelude_src))
with
| [ d ] ->
check "a defn of a prelude function's name warns once"
(d.Loc.kind = "check/shadows-prelude"
&& d.Loc.dmsg
= "abs-f32 shadows the prelude's abs-f32 — every call in this file \
now reaches your definition")
| _ -> 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;
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. (* An operator is a builtin like any other and shadows like any other.
Pinned in both halves because it is the case most likely to be thought Pinned in both halves because it is the case most likely to be thought
of as special and quietly excepted later: the warning is the same of as special and quietly excepted later: the warning is the same
@ -6205,8 +6227,61 @@ let () =
"(defconst a u64 18446744073709551615) (defonce b u64 0xFFFFFFFFFFFFFFFF) \ "(defconst a u64 18446744073709551615) (defonce b u64 0xFFFFFFFFFFFFFFFF) \
(defn f [x u64] u64 (+ x 9223372036854775808)) \ (defn f [x u64] u64 (+ x 9223372036854775808)) \
(defn g [] f64 (f64 (u64 12345678901234567890)))"; (defn g [] f64 (f64 (u64 12345678901234567890)))";
accepts "a negative decimal is still a u64 bit pattern" (* A negative literal fits no unsigned type, wherever the type comes from;
"(defconst a u64 -1)"; the cast the refusal names is how to write the bit pattern. *)
List.iter
(fun (what, src, needle) -> rejects_check what src ~needle)
[ ("a negative literal at a u64 constant", "(defconst a u64 -1)",
"-1 does not fit in u64, which holds no negative number — write \
(u64 -1) for the u64 with the same bits, 18446744073709551615");
("a negative literal at a u32 global", "(defonce g u32 -5)",
"write (u32 -5) for the u32 with the same bits, 4294967291");
("a negative literal as a u64 return", "(defn f [] u64 -1)",
"-1 does not fit in u64");
("a negative literal as a u32 argument",
"(defn t [x u32] u32 x) (defn f [] u32 (t -2))", "-2 does not fit in u32");
("a negative literal in a u8 field",
"(defstruct S [a u8]) (defn f [] S (S -3))", "write (u8 -3)");
("a negative literal given a u64 by the",
"(defn f [] i32 (let [a (the u64 -1)] 0))", "-1 does not fit in u64");
("a negative literal beside a u64-only literal",
"(defn f [] i32 (let [a [-1 18446744073709551615]] 0))",
"write (u64 -1) for the u64");
("a negative literal beside a u64 element",
"(defn f [x u64] i32 (let [a [x -1]] 0))", "write (u64 -1) for the u64") ];
accepts "the casts those refusals name compile"
"(defconst a u64 (u64 -1)) (defonce g u32 (u32 -5)) \
(defstruct S [a u8]) (defn f [x u64] S \
(let [a [(u64 -1) 18446744073709551615] b [x (u64 -1)] \
c (the u64 (u64 -1))] \
(S (u8 -3))))";
(* The literal that does not fit is the one blamed, not one that does. *)
rejects_check "a negative literal among u64 elements is the one blamed"
"(defn f [] () (println [(u64 2) 1 -1]))" ~needle:"-1 does not fit in u64";
rejects_check "a negative literal after a u64 element is the one blamed"
"(defn f [] () (println [1 (u64 2) -1]))" ~needle:"-1 does not fit in u64";
(* In a generic body the cast would break the other instantiations. *)
(match
checked
"(defn add1 [x $t] $t {:where (numeric? $t)} (+ x -1)) \
(defn main [] i32 (add1 3) (add1 (u64 5)) 0)"
with
| _ -> check "a negative literal at a u64 instantiation is refused" false
| exception Loc.Error d ->
check "the generic's refusal names a fix for every type and the call"
(contains d.Loc.dmsg "as in (- x 1) in place of (+ x -1)"
&& not (contains d.Loc.dmsg "(u64 -1)")
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "add1 is instantiated at $t = u64 here")
d.Loc.notes));
accepts "the generic's fix compiles at both types"
"(defn add1 [x $t] $t {:where (numeric? $t)} (- x 1)) \
(defn main [] i32 (add1 3) (add1 (u64 5)) 0)";
accepts "a doubly negated literal is positive at an unsigned type"
"(defn f [] u8 (- (- 1)))";
rejects_check "a folded constant's conversion is still its type"
"(defconst a u8 (i32 5))" ~needle:"expected u8, found i32";
rejects_check "a wide decimal with nothing to say u64" rejects_check "a wide decimal with nothing to say u64"
~needle:"18446744073709551615 does not fit in i32, the type an integer \ ~needle:"18446744073709551615 does not fit in i32, the type an integer \
literal takes when nothing says otherwise — write (u64 \ literal takes when nothing says otherwise — write (u64 \
@ -6510,17 +6585,106 @@ let () =
parse_rejects "the $ refusal names the bare spelling" parse_rejects "the $ refusal names the bare spelling"
"(defn $foo [x i32] i32 x)" ~needle:"Name it foo"; "(defn $foo [x i32] i32 x)" ~needle:"Name it foo";
(* ── An array literal's first element types the rest ───────────── *) (* ── An array literal with nothing outside it naming a type ────── *)
accepts "an f32 array literal from its first element" infers "a literal takes the other elements' type" "[(f32 1.0) 2.5]" "[2 f32]";
"(defn main [] i32 (let [a [(f32 1.0) 2.5]] (i32 (length a))))"; infers "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]";
(match checked "(defn main [] i32 (let [a [(u8 1) 256]] 0))" with infers "an int and a float literal meet at f64" "[1 2.5]" "[2 f64]";
| _ -> check "an element that does not fit the first element's type" false infers "a wide literal makes the array u64" "[1 18446744073709551615]" "[2 u64]";
infers "None takes the other element's Option" "[None (Some 1)]" "[2 (Option i32)]";
infers "a number and a string are a dyn vector" "[10 \"Hi\"]" "dyn";
infers "nil beside a number is a dyn vector" "[nil 1]" "dyn";
infers "two dyns are a typed array of dyn" "[nil nil]" "[2 dyn]";
infers "the names the element type of a mixed literal" "(the [dyn] [1 2.5])" "[2 dyn]";
infers "the with a slice type gives the literal's array type"
"(the [f32] [1 2.5])" "[2 f32]";
(match checked "(defstruct P [x i32]) (defn main [] i32 (let [a [(P 1) 2]] 0))" with
| _ -> check "a struct beside a number is refused" false
| exception Loc.Error d -> | exception Loc.Error d ->
check "the refusal says the first element set the type" check "elements that cannot become a dyn are refused against the first"
(List.exists (contains d.Loc.dmsg "expected P, found the integer literal 2"
(fun (n : Loc.note) -> && List.exists
contains n.Loc.nmsg "this array's first element is u8") (fun (n : Loc.note) ->
d.Loc.notes)); contains n.Loc.nmsg "this array's first element is P")
d.Loc.notes));
(match checked "(defn g [x $t] i32 (let [a [x 1]] 0))" with
| _ -> check "a type variable beside a literal is refused" false
| exception Loc.Error d ->
check "a type variable beside a literal names the bound and spells $t"
(contains d.Loc.dmsg "{:where (numeric? $t)}"
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "this array's first element is $t")
d.Loc.notes));
rejects_check "numbers with no common type are refused and the fix named"
"(defn f [x i32 y f32] i32 (let [a [x y]] 0))"
~needle:"elements are i32 and f32, and neither holds every value of the \
other — convert one, as in (f32 x)";
accepts "the conversion that refusal names compiles"
"(defn f [x i32 y f32] i32 (let [a [(f32 x) y]] 0))";
rejects_check "two integer types with no common type are refused"
"(defn f [x i64 y u64] i32 (let [a [x y]] 0))" ~needle:"as in (i64 y)";
accepts "the integer conversion that refusal names compiles"
"(defn f [x i64 y u64] i32 (let [a [x (i64 y)]] 0))";
rejects_check "every element needing a type names the first's refusal"
"(defn main [] i32 (let [a [None None]] 0))"
~needle:"what None is an Option of";
(* ── (max-value T) and (min-value T) ──────────────────────────────── *)
infers "max-value carries its type" "(max-value u16)" "u16";
infers "min-value at a float" "(min-value f32)" "f32";
(match checked "(defn f [x $t] $t (max-value $t))" with
| _ -> check "max-value at an unbounded type variable is refused" false
| exception Loc.Error d ->
check "max-value at an unbounded type variable names the bound and only it"
(contains d.Loc.dmsg "write {:where (numeric? $t)}"
&& not (contains d.Loc.dmsg "Fn")));
infers "two literal if arms meet at the wider" "(if true 1 2.5)" "f64";
infers "two integer if arms stay i32" "(if true 1 2)" "i32";
infers "two literal match arms meet at the wider"
"(match (Some 1) (Some v) 1 None 2.5)" "f64";
accepts "max-value at a type variable the bound admits"
"(defn f [x $t] $t {:where (integer? $t)} (max-value t))";
rejects_check "max-value at a type that is not a number names the bound"
"(defn f [] string (max-value string))"
~needle:"max-value takes a numeric? type, and string is not one";
rejects_check "max-value of a value says it takes a type"
"(defn f [x i32] i32 (max-value x))" ~needle:"max-value takes a type";
accepts "max-of of a slice is the prelude's reduction"
"(defn f [xs [i32]] (Option i32) (max-of xs))";
rejects_check "max-of of a type names max-value"
"(defn f [] u8 (max-of u8))" ~needle:"the largest value of a type is (max-value u8)";
(* ── (the T e) ─────────────────────────────────────────────────── *)
infers "the gives a literal its type" "(the u8 200)" "u8";
infers "the widens as an annotation does" "(the i64 (the i32 1))" "i64";
rejects_check "the does not narrow"
"(defn f [x i64] i32 (the i32 x))" ~needle:"expected i32, found i64";
rejects_check "the refuses a dyn and names the cast"
"(defn f [x dyn] i32 (the i32 x))" ~needle:"write (i32 x) to convert it";
accepts "the cast that refusal names compiles" "(defn f [x dyn] i32 (i32 x))";
rejects_check "the refuses a dyn at a type a dyn does not become"
"(defn f [x dyn] string (the string x))"
~needle:"dyn — string does not cross into a written type yet";
rejects_check "the refuses a dyn at bool, which a dyn becomes where passed"
"(defn f [x dyn] bool (the bool x))"
~needle:"a dyn becomes a bool where a bool is passed";
accepts "the bool a dyn becomes where it is returned" "(defn f [x dyn] bool x)";
accepts "the at an Option takes nil" "(defn f [] (Option i32) (the (Option i32) nil))";
parse_rejects "the takes a type and a value" "(defn f [] i32 (the i32))"
~needle:"the is (the TYPE value)";
(* The refusals of a form with no type of its own name the as a way out, and
the spellings they name compile. *)
rejects_check "an empty array literal names the"
"(defn main [] i32 (let [a []] 0))" ~needle:"(the [0 i32] [])";
accepts "the empty array that refusal names compiles"
"(defn main [] i32 (let [a (the [0 i32] [])] (length a)))";
accepts "the None that refusal names compiles"
"(defn main [] i32 (let [a (the (Option i32) None)] 0))";
accepts "the zeroed that refusal names compiles"
"(defn main [] i32 (let [a (the [4 i32] (zeroed))] (at a 0)))";
accepts "the fills that refusal names compile"
"(defn main [] i32 (let [a (the [4 u32] (filled 0xFF)) \
b (the [4 u32] (dead-beef))] 0))";
(* ── A wide literal's follow-ups ──────────────────────────────── *) (* ── A wide literal's follow-ups ──────────────────────────────── *)
parse_rejects "a wide enum member is refused for its range" parse_rejects "a wide enum member is refused for its range"
@ -6541,10 +6705,7 @@ let () =
"(defmacro idm [x] x) \ "(defmacro idm [x] x) \
(defn f [] u64 (idm 18446744073709551615))"; (defn f [] u64 (idm 18446744073709551615))";
rejects_check "a wide element after a narrow first names the u64 array" accepts "a u64 array with a cast first element"
"(defn main [] i32 (let [a [1 18446744073709551615]] 0))"
~needle:"write the first element as (u64 1) for an array of u64";
accepts "the u64 array that refusal names compiles"
"(defn main [] i32 (let [a [(u64 1) 18446744073709551615]] 0))"; "(defn main [] i32 (let [a [(u64 1) 18446744073709551615]] 0))";
(* ── Suggestions that compile ─────────────────────────────────── *) (* ── Suggestions that compile ─────────────────────────────────── *)