The checker refuses what it cannot type honestly and says which element is wrong
This commit is contained in:
commit
8eca8c78f2
58
TODO.org
58
TODO.org
@ -147,14 +147,7 @@ CLOSED: [2026-09-25]
|
||||
=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
|
||||
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.
|
||||
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.
|
||||
=(- f64-inf)=. Rules out Clojure's =##Inf= reader literal.
|
||||
|
||||
** DONE A u64 constant above 2^63 cannot be written in decimal
|
||||
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
|
||||
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
|
||||
negative at any integer type before this; it is refused now too. A negative
|
||||
decimal is still a =u64= bit pattern. A cast's integer literal that does not fit
|
||||
negative at any integer type before this; it is refused now too. A cast's
|
||||
integer literal that does not fit
|
||||
=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
|
||||
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]
|
||||
CLOSED: [2026-09-25]
|
||||
With nothing outside an array literal naming its element type, the first
|
||||
element's type is the want for the rest, so =[(f32 1.0) 2.5]= is a =[2 f32]=. A
|
||||
refusal of a later element carries a note at the first saying it set the type.
|
||||
Rules out a =1.0f= suffix for now.
|
||||
=(the [f32] [1 2.5])= names the element type; with nothing naming one, a literal
|
||||
element takes the other elements' type. Rules out a =1.0f= suffix for now.
|
||||
|
||||
** NEXT 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.
|
||||
Everything under the surface is there — the binding carries a type slot and the
|
||||
checker consumes it as the want — and only the way it is written is open, because
|
||||
=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.
|
||||
** DONE A let binding takes no type annotation
|
||||
CLOSED: [2026-09-25]
|
||||
=(the T expr)= gives any expression its want and =let= stays a flat list of
|
||||
pairs. Rules out a type slot in =let=.
|
||||
|
||||
** 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=.
|
||||
@ -1025,10 +1012,9 @@ died in the backend as a redefinition of a symbol, a message with no source
|
||||
location.
|
||||
|
||||
** DONE A u64 literal is its 64-bit pattern
|
||||
The cost of accepting the pattern is that a negative decimal literal is accepted
|
||||
as a =u64=, because the reader records the value and not how it was written.
|
||||
Narrower unsigned types keep the strict check, which is where a typo like =300=
|
||||
for a =u8= shows up.
|
||||
A negative literal fits no unsigned type, u64 included; =(u64 -1)= is how the
|
||||
pattern is written, and a constant folds it. Rules out a negative decimal as a
|
||||
u64's bit pattern.
|
||||
|
||||
** 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
|
||||
@ -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
|
||||
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]
|
||||
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
|
||||
@ -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
|
||||
static tracking of destroy, which is move semantics.
|
||||
|
||||
** NEXT 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
|
||||
agree (numbers widening together) is typed; one whose elements mix — [10 "Hi"],
|
||||
[nil 1] — is a dyn vector. (the [T] ...) forces a typed one, and a want from
|
||||
context still wins. Replaces the first-element carry-over.
|
||||
** DONE A mixed array literal with no want is a dyn vector
|
||||
CLOSED: [2026-09-25]
|
||||
Elements that agree, numbers meeting at the wider, are typed; elements that mix
|
||||
are a dyn vector, except numbers with no common type, which are refused. Rules
|
||||
out the first element typing the rest.
|
||||
|
||||
* 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
|
||||
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
|
||||
|
||||
@ -362,6 +362,7 @@ let () =
|
||||
p.globals;
|
||||
List.iter
|
||||
(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
|
||||
(String.concat " "
|
||||
(List.map Flan.Types.to_string f.params))
|
||||
@ -736,6 +737,8 @@ let () =
|
||||
if List.mem warn_memory_flag rest then
|
||||
print_memory_warnings ~file:path p)
|
||||
in
|
||||
Flan.Build.need_main ~file:path ~doing:"flan build has nothing to link"
|
||||
f.program;
|
||||
ignore (Flan.Build.executable
|
||||
~opts:{ Flan.Build.default with checks; dev; debug; sanitize;
|
||||
target; x86;
|
||||
@ -915,6 +918,8 @@ let () =
|
||||
(Printf.sprintf "flan-run-%d" (Unix.getpid ()))
|
||||
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
|
||||
~opts:{ Flan.Build.default with checks; debug; sanitize;
|
||||
x86;
|
||||
|
||||
@ -129,7 +129,7 @@
|
||||
(defconst flan--special
|
||||
'("quote" "do" "let" "if" "when" "cond" "and" "or"
|
||||
"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"
|
||||
"handler-bind" "handler-case" "restart-case" "invoke-restart")
|
||||
"The heads `Parse.form' dispatches on — the forms with a meaning of their own.
|
||||
|
||||
@ -126,6 +126,10 @@ and expr_kind =
|
||||
dimension; [ArrayFill]'s is the element value itself, evaluated once. *)
|
||||
| ArrayFill 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. *)
|
||||
| Fn of string list * expr list (* (fn [x y] ...) *)
|
||||
(* (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. *)
|
||||
| ArrayFill (ds, v) -> ArrayFill (ds, ex v)
|
||||
| ArrayGen (ds, f) -> ArrayGen (ds, ex f)
|
||||
| The (t, x) -> The (t, ex x)
|
||||
| Fn (ps, es) -> Fn (ps, List.map ex es)
|
||||
| Dotimes (l, n, b, es) ->
|
||||
Dotimes (l, n,
|
||||
|
||||
16
lib/build.ml
16
lib/build.ml
@ -744,6 +744,22 @@ let compile_c ~opts ?tflags ?(warn = []) ~src ~name () =
|
||||
end;
|
||||
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
|
||||
shim a package binds through, and the arguments needed to link the library
|
||||
it binds to.
|
||||
|
||||
739
lib/check.ml
739
lib/check.ml
@ -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
|
||||
|
||||
(* 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
|
||||
is read: a defconst has a type of its own, and only an untyped constant may
|
||||
stand at a type variable. *)
|
||||
let rec literal_arith (e : Ast.expr) : int64 option =
|
||||
match e.Ast.e with
|
||||
| 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) ->
|
||||
let step a b =
|
||||
match op with
|
||||
@ -2098,6 +2106,10 @@ let rec literal_arith (e : Ast.expr) : int64 option =
|
||||
(literal_arith x) (y :: rest)
|
||||
| _ -> 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
|
||||
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
|
||||
ctx.tail <- false;
|
||||
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.UInt (n, s) -> wide_literal loc ~want n s
|
||||
| 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
|
||||
fixed-array literal they always were. *)
|
||||
| Ast.Arr items when want = Some Types.Dyn ->
|
||||
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; 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 ]))
|
||||
dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items)
|
||||
| Ast.Arr items -> check_arr ctx ~want loc items
|
||||
(* (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
|
||||
@ -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"
|
||||
| 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.The (t, v) -> check_the ctx ~want loc t v
|
||||
| Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms
|
||||
(* Constant integer arithmetic where a type variable is wanted is folded to
|
||||
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
|
||||
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 ok =
|
||||
if Types.signed k then
|
||||
bits = 64
|
||||
|| (Int64.compare n (Int64.neg (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; see
|
||||
[wide_literal]. A negative decimal is accepted as a u64's bit pattern,
|
||||
which is a settled rule. Narrower unsigned types keep the strict
|
||||
check, which is where a typo like 300 for a u8 actually shows up. *)
|
||||
true
|
||||
(* A literal at or above 2^63 is a [UInt] and never reaches here as a
|
||||
literal; see [wide_literal]. [pattern] is the folded-constant path,
|
||||
which holds a u64 as its 64-bit pattern and cannot tell 2^64 - 1 from
|
||||
-1, so there every pattern is a u64. *)
|
||||
else if bits = 64 then pattern || Int64.compare n 0L >= 0
|
||||
else
|
||||
Int64.compare n 0L >= 0
|
||||
&& Int64.compare n (Int64.shift_left 1L bits) < 0
|
||||
in
|
||||
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
|
||||
(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
|
||||
"nothing here says what None is an Option of — annotate the \
|
||||
function's return type or the binding")
|
||||
"nothing here says what None is an Option of — use it where an \
|
||||
Option is expected, or name one, as in (the (Option i32) None)")
|
||||
(* spec-memory.md puts the allocator in the calling convention as
|
||||
[context/allocator] and [context/temp]. They read as names rather than
|
||||
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. *)
|
||||
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)))
|
||||
(* 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 ->
|
||||
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,
|
||||
@ -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
|
||||
location; and with an expectation in hand both arms are checked against
|
||||
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 =
|
||||
match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with
|
||||
| v -> v
|
||||
@ -5371,6 +5420,18 @@ and check_if ctx ?(tail = false) ?want loc c t e =
|
||||
in
|
||||
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
|
||||
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,
|
||||
@ -5696,63 +5757,31 @@ and check_arr ctx ~want loc items =
|
||||
| Some (Types.Slice t) -> Some t
|
||||
| _ -> None
|
||||
in
|
||||
(* With nothing outside saying what the elements are, the first one says:
|
||||
[[(f32 1.0) 2.5]] is an [[2 f32]], its [2.5] checked at [f32] the way it
|
||||
would be at an [f32] parameter. *)
|
||||
let items =
|
||||
match elem_want, items with
|
||||
| Some _, _ | None, [] -> map_lr (fun i -> check ctx ?want:elem_want i) items
|
||||
| None, first :: rest ->
|
||||
let first_ast = first in
|
||||
let first = check ctx first in
|
||||
let want =
|
||||
match first.Tast.ty with Types.Never -> None | t -> Some t
|
||||
in
|
||||
(* A refusal of the element itself says where its type came from. *)
|
||||
let one (i : Ast.expr) =
|
||||
(match i.Ast.e, want with
|
||||
| Ast.UInt (_, text), Some (Types.Int k) when k <> Types.U64 ->
|
||||
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
|
||||
| None, _ :: _ ->
|
||||
(match arr_elem_type ctx items with
|
||||
| Some t ->
|
||||
let n = Int64.of_int (List.length items) in
|
||||
expect ctx loc ~want
|
||||
(check_arr ctx ~want:(Some (Types.Array (n, t))) loc items)
|
||||
| None ->
|
||||
(match
|
||||
trial ctx (fun () ->
|
||||
dyn_vec ctx loc (map_lr (fun i -> check ctx ~want:Types.Dyn i) items))
|
||||
with
|
||||
| Ok v -> expect ctx loc ~want v
|
||||
| Error d -> mixed_refusal ctx items d))
|
||||
| _ ->
|
||||
let items = map_lr (fun i -> check ctx ?want:elem_want i) items in
|
||||
let n = Int64.of_int (List.length items) in
|
||||
let elem =
|
||||
match elem_want, items with
|
||||
| Some t, _ -> t
|
||||
| None, first :: _ -> first.Tast.ty
|
||||
| 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
|
||||
List.iter
|
||||
(fun (i : Tast.expr) ->
|
||||
@ -5768,6 +5797,206 @@ and check_arr ctx ~want loc items =
|
||||
an array literal does not satisfy a slice expectation. *)
|
||||
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) ──────────────────────
|
||||
|
||||
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)) ],
|
||||
[ 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 =
|
||||
let ns = array_dims ctx loc dims 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 seen = Hashtbl.create 8 in
|
||||
let saw_wild = ref false in
|
||||
let arms =
|
||||
let resolved =
|
||||
map_lr
|
||||
(fun (a : Ast.arm) ->
|
||||
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"
|
||||
(match subject with `Enum _ -> ":" ^ c | _ -> 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 () ->
|
||||
(* What each name in this arm is, in words, for the one refusal
|
||||
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
|
||||
want := Some body.Tast.ty;
|
||||
{ Tast.acase = ctor; binds; abody = [ body ] }))
|
||||
arms
|
||||
order
|
||||
in
|
||||
let arms =
|
||||
List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) checked)
|
||||
in
|
||||
(* 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,
|
||||
@ -6609,12 +6955,9 @@ and arity _ctx loc name n args =
|
||||
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
|
||||
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
|
||||
for [/], and this language has no unary minus anywhere: the prelude writes
|
||||
every negation as [(- 0 n)] or [(- 0.0 x)], and [(- x)] meaning something
|
||||
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.
|
||||
an intent. One operand is refused for every operator but [-], whose one
|
||||
operand form is negation and is [named_call]'s. For [/] it would be the
|
||||
reciprocal, and integer division makes that a trap: [(/ 3)] would be 0.
|
||||
|
||||
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
|
||||
@ -6623,10 +6966,6 @@ and arity _ctx loc name n args =
|
||||
and fold_arity loc name args =
|
||||
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 "/" ->
|
||||
fail loc
|
||||
"/ 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
|
||||
both callers, so the next kind of type added cannot be added to one of
|
||||
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 =
|
||||
(* 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
|
||||
@ -7283,6 +7632,33 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
||||
| _ when (not qualified) && shadows_builtin ctx loc name ->
|
||||
ordinary_call ctx ~want loc name args
|
||||
(* ── 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
|
||||
| "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul
|
||||
@ -7508,6 +7884,67 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
||||
expect ctx loc ~want
|
||||
(List.fold_left (fun acc arg -> pick acc (check ctx ~want:ty arg))
|
||||
(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,
|
||||
so it only means anything where a type is expected of it. *)
|
||||
| "zeroed" ->
|
||||
@ -7519,7 +7956,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
||||
| _ ->
|
||||
fail loc
|
||||
"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
|
||||
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
|
||||
"%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))
|
||||
|
||||
(* 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 \
|
||||
add at i64 — and i32 with u32 has no such type and is refused.");
|
||||
("-", "- [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?",
|
||||
"Product, folded left over two or more operands of one numeric type.");
|
||||
("/", "/ [numeric? ...] numeric?",
|
||||
@ -10368,7 +10806,8 @@ let builtins : (string * string * string) list =
|
||||
ordered.");
|
||||
("!=", "!= [equal? ...] bool",
|
||||
"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",
|
||||
"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 \
|
||||
@ -10399,6 +10838,13 @@ let builtins : (string * string * string) list =
|
||||
i16-y) is an i16.");
|
||||
("max", "max [ordered? ...] ordered?",
|
||||
"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",
|
||||
"The all-bytes-zero value of whatever it is being stored into, so 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 \
|
||||
everywhere else.");
|
||||
("None", "None (Option T)",
|
||||
"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 \
|
||||
is an Option of.");
|
||||
"The absent Option. It takes its type from its context — a return type, \
|
||||
a parameter, or (the (Option i32) None) — because nothing about the \
|
||||
word says what it is an Option of.");
|
||||
("context/allocator", "context/allocator Allocator",
|
||||
"The allocator in effect here: what with-allocator rebinds, and what an \
|
||||
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.Byte b -> Some (Int64.of_int b)
|
||||
| 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
|
||||
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
|
||||
@ -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
|
||||
compile-time constant, and [(/ screen-height cell-size)] is one — the
|
||||
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 =
|
||||
match Hashtbl.find_opt env.consts n, ty with
|
||||
| Some k, Types.Int kind ->
|
||||
(* Still range-checked: this path skips [check], and [in_range] is the
|
||||
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 }
|
||||
| _ -> check (ctx ()) ~want:ty v
|
||||
in
|
||||
@ -12427,6 +12903,68 @@ let is_env_struct = Closures.is_env_struct
|
||||
let heap_env = Closures.heap_env
|
||||
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) :
|
||||
Tast.program * env * string list =
|
||||
let env = new_env () in
|
||||
@ -12482,7 +13020,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
|
||||
end
|
||||
else raise e)
|
||||
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
|
||||
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
|
||||
@ -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
|
||||
the shape [Loc] gives an error, so a checker in an editor parses it the
|
||||
same way. *)
|
||||
if !print_warnings then
|
||||
List.iter
|
||||
(fun (d : Loc.diag) ->
|
||||
prerr_endline
|
||||
(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
|
||||
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
|
||||
|
||||
24
lib/dev.ml
24
lib/dev.ml
@ -1448,7 +1448,10 @@ let describe t =
|
||||
ok
|
||||
[ ":fns "
|
||||
^ 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);
|
||||
":globals "
|
||||
^ Wire.strings
|
||||
@ -1560,6 +1563,7 @@ let defs t =
|
||||
Hashtbl.replace macro_locs f.Tast.name (Loc.to_string f.Tast.floc);
|
||||
None
|
||||
| None when List.mem f.Tast.name class_names -> None
|
||||
| None when Check.internal_name f.Tast.name -> None
|
||||
| None ->
|
||||
Some
|
||||
(entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f)
|
||||
@ -2007,7 +2011,7 @@ let backtrace_op t =
|
||||
(List.map
|
||||
(fun (name, loc, mine, nslots, _sig, _rsig) ->
|
||||
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");
|
||||
string_of_int nslots ])
|
||||
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
|
||||
build's rename finding nothing to rename. *)
|
||||
let need_main ~file (session : Session.t) =
|
||||
if not
|
||||
(List.exists (fun (f : Tast.fn) -> f.Tast.name = "main")
|
||||
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)
|
||||
Build.need_main ~file ~doing:"flan dev has nothing to run"
|
||||
session.Session.host
|
||||
|
||||
(* [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
|
||||
@ -5820,7 +5815,10 @@ let merged_setup () =
|
||||
marshalling a [Session.t] through a file, which buys nothing: the source
|
||||
cannot have changed between the two, because the build that produced
|
||||
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
|
||||
Check.print_warnings := true;
|
||||
(* 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
|
||||
replaced before the program starts, and the accept loop drains it —
|
||||
|
||||
@ -2277,8 +2277,11 @@ let icmp_op signed = function
|
||||
| Tast.Ge -> if signed then "sge" else "uge"
|
||||
| _ -> 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
|
||||
| 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"
|
||||
| _ -> 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_div(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_le(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_gt(i64, i64, ptr, i64)
|
||||
|
||||
33
lib/load.ml
33
lib/load.ml
@ -315,6 +315,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
|
||||
other reference to it. *)
|
||||
| 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.The (t, v) -> Ast.The (rename_texpr owned alias t, go v)
|
||||
| Ast.Fn (ps, body) ->
|
||||
Ast.Fn (ps, List.map (rename_expr owned alias (ps @ bound)) body)
|
||||
| Ast.Dotimes (l, i, b, body) ->
|
||||
@ -554,6 +555,37 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
|
||||
in
|
||||
{ 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 ──────────────────────────────────
|
||||
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
|
||||
@ -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.Arr items -> gos items
|
||||
| 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
|
||||
inside [Tarray]. *)
|
||||
| Ast.ArrayFill (ds, v) | Ast.ArrayGen (ds, v) ->
|
||||
|
||||
@ -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
|
||||
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. *)
|
||||
(* ── (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) ->
|
||||
let usage () =
|
||||
fail f
|
||||
|
||||
@ -427,6 +427,7 @@ let source = {flan|
|
||||
;; or more numbers, and a defn cannot shadow a builtin: nothing shadows [+]
|
||||
;; either. These reduce a slice, which is a different operation with a
|
||||
;; 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)
|
||||
{:where (ordered? $t)}
|
||||
(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
|
||||
;; 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
|
||||
;; 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
|
||||
|
||||
@ -186,6 +186,10 @@ let stale_sites ?(live = SM.empty) ?(running = false) built (p : Tast.program) :
|
||||
m acc
|
||||
in
|
||||
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 ->
|
||||
match String.compare a.at.Loc.file b.at.Loc.file with
|
||||
| 0 -> Loc.before a.at b.at
|
||||
|
||||
22
lib/x86.ml
22
lib/x86.ml
@ -1318,18 +1318,20 @@ let int_cc ~signed (p : Tast.prim) =
|
||||
|
||||
(* Parity, which on [ucomis] means "unordered": one of the operands was a NaN.
|
||||
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
|
||||
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.
|
||||
|
||||
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,
|
||||
one, olt, ...), which answers false for a NaN, and [setb] after an
|
||||
unordered compare answers true. So [<] and [<=] swap their operands and ask
|
||||
for a/ae, which are the two codes a NaN makes false; [=] and [!=] cannot be
|
||||
spelled by one code at all and take a second [setnp] beside them.
|
||||
comparison Flan has but one is LLVM's *ordered* one ([emit.ml]'s
|
||||
[fcmp_op]: oeq, olt, ...), which answers false for a NaN, and [setb] after
|
||||
an unordered compare answers true. So [<] and [<=] swap their operands and
|
||||
ask for a/ae, which are the two codes a NaN makes false; [=] cannot be
|
||||
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
|
||||
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"
|
||||
|
||||
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) =
|
||||
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;
|
||||
and_rr f.b ~dst:rax ~src:rcx
|
||||
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
|
||||
load_loc f ~reg:rax la a.Tast.ty;
|
||||
load_loc f ~reg:rcx lb b.Tast.ty;
|
||||
|
||||
@ -2076,6 +2076,14 @@ flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
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,
|
||||
int64_t loclen) {
|
||||
return arith(loc, loclen, "*", a, b);
|
||||
|
||||
@ -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_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_neg(flan_dyn a, const uint8_t *loc, int64_t loclen);
|
||||
|
||||
/* Answer a bool dyn. Numbers compare as numbers and text compares bytewise;
|
||||
* a mixture of the two, or anything else, traps. */
|
||||
|
||||
@ -985,6 +985,8 @@ static void refuse(const char *what) {
|
||||
if (strcmp(what, "add") == 0) (void)FDYN_add(flan_dyn_from_i64(3), t);
|
||||
else if (strcmp(what, "sub") == 0)
|
||||
(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)
|
||||
(void)FDYN_mul(flan_dyn_from_bool(1), flan_dyn_from_i64(2));
|
||||
else if (strcmp(what, "div") == 0)
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
;;;; 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
|
||||
;;;; 2.5 is an f32 literal rather than an f64 refused for not being one.
|
||||
;;;; takes that from the elements that are not literals: [(f32 1.0) 2.5] is a
|
||||
;;;; [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 main [] i32
|
||||
|
||||
59
test/programs/array-mixed.flan
Normal file
59
test/programs/array-mixed.flan
Normal 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))
|
||||
@ -60,6 +60,10 @@
|
||||
(print " ")
|
||||
(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
|
||||
;; The integers, each printed as the exact decimal the expected output pins.
|
||||
(println i8-max)
|
||||
@ -115,17 +119,26 @@
|
||||
;; 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.
|
||||
(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"
|
||||
(< (- 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
|
||||
;; 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.
|
||||
(say "f64-inf" (= f64-inf (* f64-max 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 "f32-inf negated" (< (- (f32 0.0) f32-inf) (- (f32 0.0) f32-max)))
|
||||
(say "f64-inf negated" (< (- f64-inf) (- f64-max)))
|
||||
(say "f32-inf negated" (< (- f32-inf) (- f32-max)))
|
||||
(say "f64-nan" (not (= f64-nan f64-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)
|
||||
|
||||
18
test/programs/literal-arm.flan
Normal file
18
test/programs/literal-arm.flan
Normal 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
54
test/programs/max-value.flan
Normal 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
25
test/programs/negate.flan
Normal 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
13
test/programs/shadow-prelude.flan
Normal 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)
|
||||
@ -563,13 +563,50 @@ let () =
|
||||
fpu_out;
|
||||
outputs ~x86:true "a pointer and a union filled, x86"
|
||||
"programs/fill-ptr-union.flan" fpu_out;
|
||||
(* An array literal takes its element type from its first element when
|
||||
nothing outside it names one. *)
|
||||
(* A literal element takes its type from the other elements when nothing
|
||||
outside the array names one. *)
|
||||
let first_out = "3\n6.75\n9000000002\n255\n" in
|
||||
outputs "an array literal's first element types the rest"
|
||||
"programs/array-first-element.flan" first_out;
|
||||
outputs ~x86:true "an array literal's first element types the rest, x86"
|
||||
"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
|
||||
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
|
||||
@ -5684,7 +5721,9 @@ level "1"
|
||||
f32'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-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
|
||||
outputs "type limits" "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"
|
||||
"build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2
|
||||
~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
|
||||
after this point may look at [failures] until every one of them has
|
||||
|
||||
@ -205,6 +205,7 @@ let () =
|
||||
let refusals =
|
||||
[ ("add", "dyn +: int and text");
|
||||
("sub", "dyn -: nil and int");
|
||||
("neg", "dyn -: text, and it takes a number");
|
||||
("mul", "dyn *: bool and int");
|
||||
("div", "dyn /: vec and int");
|
||||
("rem", "dyn %: int and nil");
|
||||
|
||||
@ -1245,7 +1245,7 @@ let () =
|
||||
accepts "return type types the literal" "(defn f [] u8 0)";
|
||||
accepts "return type types None" "(defn f [] (Option f64) 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"
|
||||
"(defn g [x u8] ()) (defn f [] () (g 3))";
|
||||
rejects_check "wrong argument type"
|
||||
@ -1337,14 +1337,18 @@ let () =
|
||||
infers "min at four" "(min 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
|
||||
element and one a unary operator this language does not have; both are a
|
||||
typo far more often than an intent, so both are refused by name. *)
|
||||
element, and one is refused for every operator but -, whose one-operand
|
||||
form negates. *)
|
||||
rejects_check "a sum with no terms"
|
||||
"(defn f [] i32 (+))" ~needle:"+ takes two arguments or more, given 0";
|
||||
rejects_check "a product with no factors"
|
||||
"(defn f [] i32 (*))" ~needle:"* takes two arguments or more, given 0";
|
||||
rejects_check "there is no unary minus"
|
||||
"(defn f [] i32 (- 1))" ~needle:"there is no unary minus";
|
||||
infers "a negated literal" "(- 1)" "i32";
|
||||
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"
|
||||
"(defn f [] f64 (/ 2.0))" ~needle:"there is no reciprocal";
|
||||
rejects_check "one operand is not a bitwise and"
|
||||
@ -3001,7 +3005,7 @@ let () =
|
||||
~needle:"needs to know the type it is filling";
|
||||
rejects_check "a dead-beef in a position with no expected type"
|
||||
"(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
|
||||
no range check of this builtin's own, and there does not need to be. *)
|
||||
rejects_check "a fill byte out of range"
|
||||
@ -5406,6 +5410,24 @@ let () =
|
||||
| exception Loc.Error _ -> false);
|
||||
check "a program that shadows nothing is warned at not at all"
|
||||
(Check.shadowed_builtins (program "(defn f [] i32 1)") = []);
|
||||
(* A prelude function's name is taken over the same way, for the calls in
|
||||
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.
|
||||
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
|
||||
@ -6205,8 +6227,61 @@ let () =
|
||||
"(defconst a u64 18446744073709551615) (defonce b u64 0xFFFFFFFFFFFFFFFF) \
|
||||
(defn f [x u64] u64 (+ x 9223372036854775808)) \
|
||||
(defn g [] f64 (f64 (u64 12345678901234567890)))";
|
||||
accepts "a negative decimal is still a u64 bit pattern"
|
||||
"(defconst a u64 -1)";
|
||||
(* A negative literal fits no unsigned type, wherever the type comes from;
|
||||
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"
|
||||
~needle:"18446744073709551615 does not fit in i32, the type an integer \
|
||||
literal takes when nothing says otherwise — write (u64 \
|
||||
@ -6510,17 +6585,106 @@ let () =
|
||||
parse_rejects "the $ refusal names the bare spelling"
|
||||
"(defn $foo [x i32] i32 x)" ~needle:"Name it foo";
|
||||
|
||||
(* ── An array literal's first element types the rest ───────────── *)
|
||||
accepts "an f32 array literal from its first element"
|
||||
"(defn main [] i32 (let [a [(f32 1.0) 2.5]] (i32 (length a))))";
|
||||
(match checked "(defn main [] i32 (let [a [(u8 1) 256]] 0))" with
|
||||
| _ -> check "an element that does not fit the first element's type" false
|
||||
(* ── An array literal with nothing outside it naming a type ────── *)
|
||||
infers "a literal takes the other elements' type" "[(f32 1.0) 2.5]" "[2 f32]";
|
||||
infers "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]";
|
||||
infers "an int and a float literal meet at f64" "[1 2.5]" "[2 f64]";
|
||||
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 ->
|
||||
check "the refusal says the first element set the type"
|
||||
(List.exists
|
||||
check "elements that cannot become a dyn are refused against the first"
|
||||
(contains d.Loc.dmsg "expected P, found the integer literal 2"
|
||||
&& List.exists
|
||||
(fun (n : Loc.note) ->
|
||||
contains n.Loc.nmsg "this array's first element is u8")
|
||||
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 ──────────────────────────────── *)
|
||||
parse_rejects "a wide enum member is refused for its range"
|
||||
@ -6541,10 +6705,7 @@ let () =
|
||||
"(defmacro idm [x] x) \
|
||||
(defn f [] u64 (idm 18446744073709551615))";
|
||||
|
||||
rejects_check "a wide element after a narrow first names the u64 array"
|
||||
"(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"
|
||||
accepts "a u64 array with a cast first element"
|
||||
"(defn main [] i32 (let [a [(u64 1) 18446744073709551615]] 0))";
|
||||
|
||||
(* ── Suggestions that compile ─────────────────────────────────── *)
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user