Merge branch 'master' into worktree-agent-afbb9bcfd4d47bb1b
# Conflicts: # lib/check.ml
This commit is contained in:
commit
fd6510e0b5
8
TODO.org
8
TODO.org
@ -824,14 +824,6 @@ One spelling for one operation; != stays, and not= is refused with a suggestion
|
|||||||
of !=.
|
of !=.
|
||||||
|
|
||||||
* Checker
|
* Checker
|
||||||
** TODO A u64 above the i64 maximum becomes -1 when it crosses into dyn
|
|
||||||
=(+ z u)= and =(max u 0 z)= with u = u64 max read u as -1, silently. It should trap at
|
|
||||||
the crossing, as a u64 field read through a view already does.
|
|
||||||
** TODO A dyn nil past the first pair of a fold is refused at compile time
|
|
||||||
=(+ 1 2 (the dyn nil))= says nil has no None at i32, while =(+ (the dyn nil) 1 2)= traps
|
|
||||||
at run time. Both should trap at run time.
|
|
||||||
** TODO A generic $t beside a dyn operand is refused
|
|
||||||
"does not cross into a written type yet"; rule 117 says typed beside dyn gives dyn.
|
|
||||||
** WAIT Checking a wide fold of let operands is slow
|
** WAIT Checking a wide fold of let operands is slow
|
||||||
Parked 2026-09-26: design first; remeasure on a quiet machine, it was timed under load 20.
|
Parked 2026-09-26: design first; remeasure on a quiet machine, it was timed under load 20.
|
||||||
A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators);
|
A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators);
|
||||||
|
|||||||
215
lib/check.ml
215
lib/check.ml
@ -4436,6 +4436,10 @@ let box ?ctx loc (e : Tast.expr) : Tast.expr =
|
|||||||
(* Dyn text is immutable and a String is not, so a String crosses as a copy
|
(* Dyn text is immutable and a String is not, so a String crosses as a copy
|
||||||
of its bytes rather than as the view any other struct would be. *)
|
of its bytes rather than as the view any other struct would be. *)
|
||||||
| t when is_string_ty t -> dyn "flan_dyn_from_string" [ string_vec loc e ]
|
| t when is_string_ty t -> dyn "flan_dyn_from_string" [ string_vec loc e ]
|
||||||
|
(* A dyn int is an i64, so a u64 past the largest i64 has none to become:
|
||||||
|
read as its bits it would be a different, negative number. It traps
|
||||||
|
here, at the crossing, as one read through a view does. *)
|
||||||
|
| Types.Int Types.U64 -> dyn "flan_dyn_from_u64" [ e; here loc ]
|
||||||
| Types.Int _ -> dyn "flan_dyn_from_i64" [ widen loc dyn_i64 e ]
|
| Types.Int _ -> dyn "flan_dyn_from_i64" [ widen loc dyn_i64 e ]
|
||||||
| Types.Float _ -> dyn "flan_dyn_from_f64" [ widen loc dyn_f64 e ]
|
| Types.Float _ -> dyn "flan_dyn_from_f64" [ widen loc dyn_f64 e ]
|
||||||
(* The ABI takes an [int32_t], because a C signature that says [_Bool] is a
|
(* The ABI takes an [int32_t], because a C signature that says [_Bool] is a
|
||||||
@ -4456,6 +4460,28 @@ let box ?ctx loc (e : Tast.expr) : Tast.expr =
|
|||||||
Loc.failk "check/dyn-unit" loc
|
Loc.failk "check/dyn-unit" loc
|
||||||
"() does not box into dyn. The absent dyn value is nil — write nil"
|
"() does not box into dyn. The absent dyn value is nil — write nil"
|
||||||
| Types.Never -> e
|
| Types.Never -> e
|
||||||
|
(* A [$t] is seen only in a generic's abstract pass; each copy is checked
|
||||||
|
again at its concrete type, where the value boxes as that type does, and
|
||||||
|
this node is thrown away with the rest of the pass. Admitting it is sound
|
||||||
|
only when every type the variable can be at crosses, or a refusal would
|
||||||
|
move from the definition to whichever call instantiates it at a pointer,
|
||||||
|
an enum or a function, with no written requirement to blame — the rule
|
||||||
|
beside [println]'s deferral. Every [is-numeric] type crosses (a u64 past
|
||||||
|
the largest i64 traps at run time, not at a copy's check), so that bound
|
||||||
|
admits it. [is-ordered] and [is-equal] do not: both admit an enum, which
|
||||||
|
has no dyn value. The node is a cast rather than [flan_dyn_nil] because
|
||||||
|
[is_nil_lit] would read that as a nil literal. *)
|
||||||
|
| Types.Var v
|
||||||
|
when (match ctx with
|
||||||
|
| Some c -> declares c.env.tvpreds v "is-numeric"
|
||||||
|
| None -> false) ->
|
||||||
|
mk loc Types.Dyn (Tast.Prim (Tast.Cast Types.Dyn, [ e ]))
|
||||||
|
| Types.Var _ ->
|
||||||
|
let t = tyname loc e.Tast.ty in
|
||||||
|
Loc.failk "check/dyn-type-variable" loc
|
||||||
|
"%s may be a type with no dyn value, such as a pointer or an enum, so \
|
||||||
|
it crosses into dyn only as a number. Write %s at the head of the body"
|
||||||
|
t (where_text loc "is-numeric" t)
|
||||||
(* A view, not a copy: the box holds a small record naming where the
|
(* A view, not a copy: the box holds a small record naming where the
|
||||||
storage is and what one element is (its descriptor, [view_desc]), and
|
storage is and what one element is (its descriptor, [view_desc]), and
|
||||||
every read or write goes straight through to the container's own
|
every read or write goes straight through to the container's own
|
||||||
@ -4543,7 +4569,7 @@ let box ?ctx loc (e : Tast.expr) : Tast.expr =
|
|||||||
caller that starts doing that gets a sentence instead of a silent
|
caller that starts doing that gets a sentence instead of a silent
|
||||||
mis-lowering. *)
|
mis-lowering. *)
|
||||||
| Types.Named _ | Types.Enum _ | Types.Option _ | Types.Ptr _
|
| Types.Named _ | Types.Enum _ | Types.Option _ | Types.Ptr _
|
||||||
| Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Var _ | Types.Len _
|
| Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Len _
|
||||||
| Types.LArray _ | Types.Vec _ | Types.Array _ | Types.Slice _ ->
|
| Types.LArray _ | Types.Vec _ | Types.Array _ | Types.Slice _ ->
|
||||||
no_dyn_yet loc ~into:true e.Tast.ty ""
|
no_dyn_yet loc ~into:true e.Tast.ty ""
|
||||||
|
|
||||||
@ -4568,14 +4594,14 @@ module Found = Ephemeron.K1.Make (struct
|
|||||||
let mismatch_found : Types.t Found.t = Found.create 16
|
let mismatch_found : Types.t Found.t = Found.create 16
|
||||||
|
|
||||||
let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr =
|
let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr =
|
||||||
let need sym ty = rt loc ty sym [ e ] in
|
let need sym ty = rt loc ty sym [ e; here loc ] in
|
||||||
match want with
|
match want with
|
||||||
| Types.Float Types.F64 -> need "flan_dyn_need_f64" dyn_f64
|
| Types.Float Types.F64 -> need "flan_dyn_need_f64_at" dyn_f64
|
||||||
| Types.Bool ->
|
| Types.Bool ->
|
||||||
(* The ABI answers an [int32_t]; [bool] is an [i1]. The narrowing is the
|
(* The ABI answers an [int32_t]; [bool] is an [i1]. The narrowing is the
|
||||||
language's own cast and cannot fail — the runtime already decided the
|
language's own cast and cannot fail — the runtime already decided the
|
||||||
value was a bool, so what comes back is 0 or 1. *)
|
value was a bool, so what comes back is 0 or 1. *)
|
||||||
widen loc Types.Bool (need "flan_dyn_need_bool" (Types.Int Types.I32))
|
widen loc Types.Bool (need "flan_dyn_need_bool_at" (Types.Int Types.I32))
|
||||||
(* Only a dyn char: an int is a number until (char n) converts it. *)
|
(* Only a dyn char: an int is a number until (char n) converts it. *)
|
||||||
| Types.Char -> rt loc Types.Char "flan_dyn_need_char" [ e; here loc ]
|
| Types.Char -> rt loc Types.Char "flan_dyn_need_char" [ e; here loc ]
|
||||||
(* Any integer width, checked at run time at this site (TODO.org, "Dyn
|
(* Any integer width, checked at run time at this site (TODO.org, "Dyn
|
||||||
@ -4981,6 +5007,56 @@ let const_note ?(fln = false) env ~(want : Types.t) ~(got : Types.t) =
|
|||||||
(Types.spell ~indented:fln want) (Types.spell ~indented:fln got)
|
(Types.spell ~indented:fln want) (Types.spell ~indented:fln got)
|
||||||
| _ -> ""
|
| _ -> ""
|
||||||
|
|
||||||
|
let nil_has_no_none loc w =
|
||||||
|
fail loc
|
||||||
|
"nil has no None to become at %s — nil only converts to (Option T) \
|
||||||
|
or to dyn itself; wrap the type in Option, or keep the value dyn"
|
||||||
|
(tyname loc w)
|
||||||
|
|
||||||
|
(* A literal boxed where a dyn was wanted, and the literal. It brings no dyn
|
||||||
|
of its own to an operator: (+ nil 1) over a literal 1 checked at dyn is as
|
||||||
|
typed as (+ nil x) over an i32 x. *)
|
||||||
|
let boxed_literal (e : Tast.expr) =
|
||||||
|
match e.Tast.e with
|
||||||
|
| Tast.Prim (Tast.Rt ("flan_dyn_from_i64" | "flan_dyn_from_f64"
|
||||||
|
| "flan_dyn_from_char" | "flan_dyn_from_bool"), [ x ]) ->
|
||||||
|
let x = match x.Tast.e with Tast.Prim (Tast.Cast _, [ y ]) -> y | _ -> x in
|
||||||
|
(match x.Tast.e with
|
||||||
|
| Tast.Int (n, _) when x.Tast.ty <> Types.Char ->
|
||||||
|
(* The type the literal takes where nothing is wanted. *)
|
||||||
|
let k =
|
||||||
|
if Int64.compare n (Int64.of_int32 Int32.max_int) > 0
|
||||||
|
|| Int64.compare n (Int64.of_int32 Int32.min_int) < 0
|
||||||
|
then Types.I64 else Types.I32
|
||||||
|
in
|
||||||
|
Some (Types.Int k)
|
||||||
|
| Tast.Int _ | Tast.Float _ | Tast.Bool _ -> Some x.Tast.ty
|
||||||
|
| _ -> None)
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
|
(* The operands of an arithmetic, bitwise or ordering operator gone dyn,
|
||||||
|
before they are boxed: a literal [nil] among them with nothing else dyn is
|
||||||
|
refused as [expect] refuses it at a typed want, whichever position it is
|
||||||
|
in and whether or not the form has a want. A dyn that holds nil is the
|
||||||
|
run-time trap's, so (+ 1 2 nil) is refused and (+ 1 2 (the dyn nil))
|
||||||
|
traps. [=] and [!=] ask no such question: nil is unequal to a number. *)
|
||||||
|
let no_bare_nil (ops : Tast.expr list) =
|
||||||
|
match List.find_opt is_nil_lit ops with
|
||||||
|
| None -> ()
|
||||||
|
| Some nil ->
|
||||||
|
let makes_dyn (e : Tast.expr) =
|
||||||
|
e.Tast.ty = Types.Dyn && not (is_nil_lit e) && boxed_literal e = None
|
||||||
|
in
|
||||||
|
if not (List.exists makes_dyn ops) then
|
||||||
|
match
|
||||||
|
List.find_map
|
||||||
|
(fun (e : Tast.expr) ->
|
||||||
|
if e.Tast.ty <> Types.Dyn then Some e.Tast.ty else boxed_literal e)
|
||||||
|
ops
|
||||||
|
with
|
||||||
|
| Some t -> nil_has_no_none nil.Tast.loc t
|
||||||
|
| None -> ()
|
||||||
|
|
||||||
let rec expect ctx loc ~want (got : Tast.expr) =
|
let rec expect ctx loc ~want (got : Tast.expr) =
|
||||||
match want with
|
match want with
|
||||||
| None -> got
|
| None -> got
|
||||||
@ -5004,11 +5080,7 @@ let rec expect ctx loc ~want (got : Tast.expr) =
|
|||||||
actually see — the literal, written right where the mismatch is.
|
actually see — the literal, written right where the mismatch is.
|
||||||
Refused here, at the offending line, instead of waiting for the
|
Refused here, at the offending line, instead of waiting for the
|
||||||
runtime trap [unbox] would otherwise reach for two arms down. *)
|
runtime trap [unbox] would otherwise reach for two arms down. *)
|
||||||
| w, Types.Dyn when is_nil_lit got ->
|
| w, Types.Dyn when is_nil_lit got -> nil_has_no_none loc w
|
||||||
fail loc
|
|
||||||
"nil has no None to become at %s — nil only converts to (Option T) \
|
|
||||||
or to dyn itself; wrap the type in Option, or keep the value dyn"
|
|
||||||
(tyname loc w)
|
|
||||||
| _, Types.Dyn when Types.fits ~expected:w ~actual:Types.Dyn -> got
|
| _, Types.Dyn when Types.fits ~expected:w ~actual:Types.Dyn -> got
|
||||||
| (Types.String | Types.Slice _ | Types.Array _), Types.Dyn ->
|
| (Types.String | Types.Slice _ | Types.Array _), Types.Dyn ->
|
||||||
let opened = into_typed ctx loc w got in
|
let opened = into_typed ctx loc w got in
|
||||||
@ -6854,6 +6926,13 @@ and int_literal loc ~want ?(preds = []) ?(default = Types.I32) n =
|
|||||||
(tyname loc other) n
|
(tyname loc other) n
|
||||||
| _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default))
|
| _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default))
|
||||||
|
|
||||||
|
(* A wide literal where a dyn is wanted. A global's initialiser adds the fix
|
||||||
|
(its type); anywhere else there is nothing to retype. *)
|
||||||
|
and wide_at_dyn s =
|
||||||
|
Printf.sprintf
|
||||||
|
"expected dyn, found the integer literal %s, which is above the largest \
|
||||||
|
dyn int (9223372036854775807), so it has no dyn value" s
|
||||||
|
|
||||||
(* An integer written at or above 2^63, in decimal or in hex. Only a u64 holds
|
(* An integer written at or above 2^63, in decimal or in hex. Only a u64 holds
|
||||||
one, so it is accepted there and refused everywhere else, in the spelling it
|
one, so it is accepted there and refused everywhere else, in the spelling it
|
||||||
was written in — its pattern read as an i64 is a different number. *)
|
was written in — its pattern read as an i64 is a different number. *)
|
||||||
@ -6872,12 +6951,7 @@ and wide_literal loc ~want n s =
|
|||||||
"%s does not fit in i32, the type an integer literal takes when nothing \
|
"%s does not fit in i32, the type an integer literal takes when nothing \
|
||||||
says otherwise — write (u64 %s) for a u64"
|
says otherwise — write (u64 %s) for a u64"
|
||||||
s s
|
s s
|
||||||
| Some Types.Dyn ->
|
| Some Types.Dyn -> Loc.failk literal_at_want loc "%s" (wide_at_dyn s)
|
||||||
Loc.failk literal_at_want loc
|
|
||||||
"expected dyn, found the integer literal %s, which only a u64 holds — a \
|
|
||||||
dyn integer is an i64. Write (u64 %s) for the u64, which a dyn holds as \
|
|
||||||
the i64 with the same bits, %Ld"
|
|
||||||
s s n
|
|
||||||
| Some other ->
|
| Some other ->
|
||||||
Loc.failk literal_at_want loc
|
Loc.failk literal_at_want loc
|
||||||
"expected %s, found the integer literal %s, which only a u64 holds"
|
"expected %s, found the integer literal %s, which only a u64 holds"
|
||||||
@ -9944,6 +10018,16 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) =
|
|||||||
v.Ast.loc items
|
v.Ast.loc items
|
||||||
| _ -> expect ctx v.Ast.loc ~want:(Some ty) (check ctx ~want:ty v)
|
| _ -> expect ctx v.Ast.loc ~want:(Some ty) (check ctx ~want:ty v)
|
||||||
in
|
in
|
||||||
|
(* (the dyn nil) is a dyn value that holds nil, not the literal: at a typed
|
||||||
|
want it traps at run time as any dyn holding nil does, where a bare nil
|
||||||
|
is refused. (the dyn 1) is likewise a dyn, not a literal that brings
|
||||||
|
nothing dyn to an operator ([no_bare_nil]). [is_nil_lit] and
|
||||||
|
[boxed_literal] see through nothing, so the [Do] hides both. *)
|
||||||
|
let r =
|
||||||
|
if ty = Types.Dyn && (is_nil_lit r || boxed_literal r <> None) then
|
||||||
|
mk loc Types.Dyn (Tast.Do [ r ])
|
||||||
|
else r
|
||||||
|
in
|
||||||
expect ctx loc ~want r
|
expect ctx loc ~want r
|
||||||
|
|
||||||
(* [f] run for its answer alone: whatever it wrote into the context is put
|
(* [f] run for its answer alone: whatever it wrote into the context is put
|
||||||
@ -12038,7 +12122,7 @@ and fold_left_prim ctx ~want loc name p ~needs ok what args =
|
|||||||
| `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl
|
| `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl
|
||||||
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
||||||
else
|
else
|
||||||
match fold_operand ctx acc.Tast.ty (check ctx ~want:acc.Tast.ty arg) with
|
match fold_arg ctx acc.Tast.ty arg with
|
||||||
| `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl
|
| `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl
|
||||||
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
||||||
in
|
in
|
||||||
@ -12065,7 +12149,7 @@ and fold_left_prim ctx ~want loc name p ~needs ok what args =
|
|||||||
let rec steps acc = function
|
let rec steps acc = function
|
||||||
| [] -> expect ctx loc ~want acc
|
| [] -> expect ctx loc ~want acc
|
||||||
| arg :: tl ->
|
| arg :: tl ->
|
||||||
match fold_operand ctx ty (check ctx ~want:ty arg) with
|
match fold_arg ctx ty arg with
|
||||||
| `Typed v -> steps (mk loc ty (Tast.Prim (p, [ acc; v ]))) tl
|
| `Typed v -> steps (mk loc ty (Tast.Prim (p, [ acc; v ]))) tl
|
||||||
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
||||||
in
|
in
|
||||||
@ -12083,6 +12167,37 @@ and fold_operand ctx ty (v : Tast.expr) =
|
|||||||
| Some d -> `Dyn d
|
| Some d -> `Dyn d
|
||||||
| None -> `Typed v
|
| None -> `Typed v
|
||||||
|
|
||||||
|
(* An operand past a fold's first pair, from the source: at the type so far,
|
||||||
|
and on its own terms only when that is refused, as [binary_pair] checks
|
||||||
|
the second of the pair. A dyn it turns out to be joins the fold as a dyn,
|
||||||
|
so (+ 1 2 (the dyn nil)) traps at run time as (+ (the dyn nil) 1 2) does
|
||||||
|
instead of being refused for a nil with no value at i32, and a dyn beside
|
||||||
|
a [$t] is not opened at the variable. Anything else is checked at the type
|
||||||
|
again, for real, so its refusal is the one it always gave and recovery
|
||||||
|
records it. *)
|
||||||
|
and fold_arg ctx ty (arg : Ast.expr) =
|
||||||
|
match trial_at ctx arg ty with
|
||||||
|
| Ok v -> fold_operand ctx ty v
|
||||||
|
| Error _ ->
|
||||||
|
(* Only asked, and asked with the literal locals' uses unrecorded: a
|
||||||
|
[trial] does not take back what the session recorded, and the operand
|
||||||
|
on its own terms is not how the program reads it unless it is a dyn —
|
||||||
|
(+ x y) over an int x and a float y would merge the two and move the
|
||||||
|
refusal onto x. A dyn is then checked again, recorded. *)
|
||||||
|
let unrecorded f =
|
||||||
|
match ctx.lits with
|
||||||
|
| Some s when s.recording ->
|
||||||
|
s.recording <- false;
|
||||||
|
Fun.protect ~finally:(fun () -> s.recording <- true) f
|
||||||
|
| _ -> f ()
|
||||||
|
in
|
||||||
|
let is_dyn =
|
||||||
|
probe ctx arg.Ast.loc (fun () -> unrecorded (fun () -> (check ctx arg).Tast.ty))
|
||||||
|
= Some Types.Dyn
|
||||||
|
in
|
||||||
|
if is_dyn then `Dyn (to_dyn ctx (check ctx arg))
|
||||||
|
else fold_operand ctx ty (check ctx ~want:ty arg)
|
||||||
|
|
||||||
(* A pair an arithmetic operator refused, when one operand is a char: that
|
(* A pair an arithmetic operator refused, when one operand is a char: that
|
||||||
is the refusal to give, rather than the mismatch between the two. Asked
|
is the refusal to give, rather than the mismatch between the two. Asked
|
||||||
only after the refusal, so a pair that checks costs nothing more. *)
|
only after the refusal, so a pair that checks costs nothing more. *)
|
||||||
@ -12194,12 +12309,7 @@ and dyn_fold ctx ~want loc name first rest =
|
|||||||
language's type error, and until now it printed with no file, no line and
|
language's type error, and until now it printed with no file, no line and
|
||||||
no column — [here loc] is the same string literal [cast_dyn] hands the
|
no column — [here loc] is the same string literal [cast_dyn] hands the
|
||||||
runtime, and the runtime prints it as a GNU prefix. *)
|
runtime, and the runtime prints it as a GNU prefix. *)
|
||||||
let apply acc b = rt loc Types.Dyn sym [ acc; box loc b; here loc ] in
|
let apply acc b = rt loc Types.Dyn sym [ acc; box ~ctx loc b; here loc ] in
|
||||||
let acc =
|
|
||||||
match first with
|
|
||||||
| [ a; b ] -> apply (box loc a) b
|
|
||||||
| _ -> assert false
|
|
||||||
in
|
|
||||||
let operand arg =
|
let operand arg =
|
||||||
if bitwise then begin
|
if bitwise then begin
|
||||||
let v = check ctx arg in
|
let v = check ctx arg in
|
||||||
@ -12208,7 +12318,14 @@ and dyn_fold ctx ~want loc name first rest =
|
|||||||
end
|
end
|
||||||
else check ctx ~want:Types.Dyn arg
|
else check ctx ~want:Types.Dyn arg
|
||||||
in
|
in
|
||||||
let acc = List.fold_left (fun acc arg -> apply acc (operand arg)) acc rest in
|
let rest = map_lr operand rest in
|
||||||
|
no_bare_nil (first @ rest);
|
||||||
|
let acc =
|
||||||
|
match first with
|
||||||
|
| [ a; b ] -> apply (box ~ctx loc a) b
|
||||||
|
| _ -> assert false
|
||||||
|
in
|
||||||
|
let acc = List.fold_left apply acc rest in
|
||||||
expect ctx loc ~want acc
|
expect ctx loc ~want acc
|
||||||
|
|
||||||
(* The runtime's entry point for each bit operation on a dyn int. *)
|
(* The runtime's entry point for each bit operation on a dyn int. *)
|
||||||
@ -13655,7 +13772,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
|||||||
two things being unalike is the answer to "are these equal", not an
|
two things being unalike is the answer to "are these equal", not an
|
||||||
error. The orderings do trap, and rightly — there is no true answer to
|
error. The orderings do trap, and rightly — there is no true answer to
|
||||||
whether a string is less than a vector. *)
|
whether a string is less than a vector. *)
|
||||||
(* [ops] are every operand, boxed. *)
|
(* [ops] are every operand, not yet boxed. *)
|
||||||
let dyn_chain ops =
|
let dyn_chain ops =
|
||||||
let sym =
|
let sym =
|
||||||
match name with
|
match name with
|
||||||
@ -13680,17 +13797,22 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
|||||||
mk loc Types.Bool (Tast.Prim (Tast.Not, [ cmp ]))
|
mk loc Types.Bool (Tast.Prim (Tast.Not, [ cmp ]))
|
||||||
else cmp
|
else cmp
|
||||||
in
|
in
|
||||||
let r =
|
let ops =
|
||||||
match rest with
|
match rest with
|
||||||
| [] -> link (box loc a) (box loc b)
|
| [] -> [ a; b ]
|
||||||
| _ -> cmp_over ctx loc Types.Dyn ~pairs ~link (ops ())
|
| _ -> ops ()
|
||||||
|
in
|
||||||
|
if not (String.equal sym "flan_dyn_eq") then no_bare_nil ops;
|
||||||
|
let r =
|
||||||
|
match List.map (box ~ctx loc) ops with
|
||||||
|
| [ a; b ] -> link a b
|
||||||
|
| ops -> cmp_over ctx loc Types.Dyn ~pairs ~link ops
|
||||||
in
|
in
|
||||||
expect ctx loc ~want r
|
expect ctx loc ~want r
|
||||||
in
|
in
|
||||||
if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then
|
if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then
|
||||||
dyn_chain (fun () ->
|
dyn_chain (fun () ->
|
||||||
box loc a :: box loc b
|
a :: b :: map_lr (fun e -> check ctx ~want:Types.Dyn e) rest)
|
||||||
:: map_lr (fun e -> box loc (check ctx ~want:Types.Dyn e)) rest)
|
|
||||||
else begin
|
else begin
|
||||||
(* [=] and [!=] admit types [<] does not. A handle is one: a pair of
|
(* [=] and [!=] admit types [<] does not. A handle is one: a pair of
|
||||||
numbers in one word and where being the same entity is the question the
|
numbers in one word and where being the same entity is the question the
|
||||||
@ -13726,14 +13848,13 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
|||||||
| _ ->
|
| _ ->
|
||||||
let ty = a.Tast.ty in
|
let ty = a.Tast.ty in
|
||||||
let link u v = mk loc Types.Bool (Tast.Prim (p, [ u; v ])) in
|
let link u v = mk loc Types.Bool (Tast.Prim (p, [ u; v ])) in
|
||||||
let rest = map_lr (fun e -> fold_operand ctx ty (check ctx ~want:ty e)) rest in
|
let rest = map_lr (fold_arg ctx ty) rest in
|
||||||
(* A dyn past the first pair makes the whole chain the dyn runtime's,
|
(* A dyn past the first pair makes the whole chain the dyn runtime's,
|
||||||
for [fold_operand]'s reason: a chain is its pairs, and a pair with a
|
for [fold_operand]'s reason: a chain is its pairs, and a pair with a
|
||||||
dyn in it is a dyn comparison. *)
|
dyn in it is a dyn comparison. *)
|
||||||
if List.exists (function `Dyn _ -> true | `Typed _ -> false) rest then
|
if List.exists (function `Dyn _ -> true | `Typed _ -> false) rest then
|
||||||
dyn_chain (fun () ->
|
dyn_chain (fun () ->
|
||||||
box loc a :: box loc b
|
a :: b :: List.map (function `Dyn d -> d | `Typed v -> v) rest)
|
||||||
:: List.map (function `Dyn d -> d | `Typed v -> box loc v) rest)
|
|
||||||
else
|
else
|
||||||
let ops =
|
let ops =
|
||||||
a :: b :: List.map (function `Typed v -> v | `Dyn d -> d) rest in
|
a :: b :: List.map (function `Typed v -> v | `Dyn d -> d) rest in
|
||||||
@ -13815,8 +13936,9 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
|||||||
(fun (v : Tast.expr) ->
|
(fun (v : Tast.expr) ->
|
||||||
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v)
|
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v)
|
||||||
[ a; b ];
|
[ a; b ];
|
||||||
|
no_bare_nil [ a; b ];
|
||||||
expect ctx loc ~want
|
expect ctx loc ~want
|
||||||
(rt loc Types.Dyn (dyn_bits_sym name) [ box loc a; box loc b; here loc ])
|
(rt loc Types.Dyn (dyn_bits_sym name) [ box ~ctx loc a; box ~ctx loc b; here loc ])
|
||||||
end else begin
|
end else begin
|
||||||
bits_operand ctx loc name a;
|
bits_operand ctx loc name a;
|
||||||
(* A shift by the operand's own width or more is poison in LLVM, which at
|
(* A shift by the operand's own width or more is poison in LLVM, which at
|
||||||
@ -13881,7 +14003,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
|
|||||||
let rec steps acc = function
|
let rec steps acc = function
|
||||||
| [] -> expect ctx loc ~want acc
|
| [] -> expect ctx loc ~want acc
|
||||||
| arg :: tl ->
|
| arg :: tl ->
|
||||||
match fold_operand ctx ty (check ctx ~want:ty arg) with
|
match fold_arg ctx ty arg with
|
||||||
| `Typed v -> steps (pick acc v) tl
|
| `Typed v -> steps (pick acc v) tl
|
||||||
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
| `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl
|
||||||
in
|
in
|
||||||
@ -17320,8 +17442,17 @@ and binary_pair ctx ~dyn_ok ~join ~char_ok loc ~want (x : Ast.expr) (y : Ast.exp
|
|||||||
let needs_want (f : Ast.expr) =
|
let needs_want (f : Ast.expr) =
|
||||||
is_literal f || (match f.Ast.e with Ast.Kw _ -> true | _ -> false)
|
is_literal f || (match f.Ast.e with Ast.Kw _ -> true | _ -> false)
|
||||||
in
|
in
|
||||||
|
(* A dyn the want opened is put back: beside a dyn a typed operand gives
|
||||||
|
dyn (rule 117), so the pair is the dyn runtime's and only its answer
|
||||||
|
is opened at the want. Opening the operand first made (+ p 1 1) at an
|
||||||
|
i32 want an i32 add that wraps, where (+ 1 1 p) was a dyn add whose
|
||||||
|
answer traps at the i32. *)
|
||||||
|
let reopen (v : Tast.expr) =
|
||||||
|
if not dyn_ok then v
|
||||||
|
else match opened_dyn ~box:(to_dyn ctx) v with Some d -> d | None -> v
|
||||||
|
in
|
||||||
if y_decides then begin
|
if y_decides then begin
|
||||||
let b = check ctx ?want y in
|
let b = reopen (check ctx ?want y) in
|
||||||
(* An integer literal before a char, under [+] or [-], is an integer:
|
(* An integer literal before a char, under [+] or [-], is an integer:
|
||||||
the pair is char arithmetic ([char_step]). *)
|
the pair is char arithmetic ([char_step]). *)
|
||||||
let a =
|
let a =
|
||||||
@ -17348,7 +17479,7 @@ and binary_pair ctx ~dyn_ok ~join ~char_ok loc ~want (x : Ast.expr) (y : Ast.exp
|
|||||||
what [needs_want] settles — a literal still gets the first operand's
|
what [needs_want] settles — a literal still gets the first operand's
|
||||||
type, so [(+ x 1)] over a dyn x goes on building an i64 one. *)
|
type, so [(+ x 1)] over a dyn x goes on building an i64 one. *)
|
||||||
else if dyn_ok && not (needs_want y) then begin
|
else if dyn_ok && not (needs_want y) then begin
|
||||||
let a = check ctx ?want x in
|
let a = reopen (check ctx ?want x) in
|
||||||
(* y at [a]'s type first, and on its own terms only if that is
|
(* y at [a]'s type first, and on its own terms only if that is
|
||||||
refused: checking it both ways every time made a chain of these
|
refused: checking it both ways every time made a chain of these
|
||||||
nested in their second operands twice as slow per level. A dyn
|
nested in their second operands twice as slow per level. A dyn
|
||||||
@ -17397,7 +17528,7 @@ and binary_pair ctx ~dyn_ok ~join ~char_ok loc ~want (x : Ast.expr) (y : Ast.exp
|
|||||||
| None -> raise (Loc.Error d)))
|
| None -> raise (Loc.Error d)))
|
||||||
end
|
end
|
||||||
else begin
|
else begin
|
||||||
let a = check ctx ?want x in
|
let a = reopen (check ctx ?want x) in
|
||||||
match trial_at ctx y a.Tast.ty with
|
match trial_at ctx y a.Tast.ty with
|
||||||
| Ok b -> a, b
|
| Ok b -> a, b
|
||||||
| Error d ->
|
| Error d ->
|
||||||
@ -19651,6 +19782,11 @@ let check_global env (d : Ast.decl) : Tast.global option =
|
|||||||
{ Tast.e = Tast.Uninit ty; ty; loc = d.Ast.dloc }
|
{ Tast.e = Tast.Uninit ty; ty; loc = d.Ast.dloc }
|
||||||
| Ast.Init v ->
|
| Ast.Init v ->
|
||||||
let c = ctx () in
|
let c = ctx () in
|
||||||
|
(match v.Ast.e with
|
||||||
|
| Ast.UInt (_, s) when ty = Types.Dyn ->
|
||||||
|
Loc.failk literal_at_want v.Ast.loc "%s. Give %s the type u64"
|
||||||
|
(wide_at_dyn s) n
|
||||||
|
| _ -> ());
|
||||||
let v =
|
let v =
|
||||||
view_global_init := Some (n, kind);
|
view_global_init := Some (n, kind);
|
||||||
Fun.protect ~finally:(fun () -> view_global_init := None)
|
Fun.protect ~finally:(fun () -> view_global_init := None)
|
||||||
@ -20971,6 +21107,9 @@ let memory_class (sym : string) (args : Tast.expr list) =
|
|||||||
| "flan_dyn_from_i64" when (match args with [ x ] -> int_may_spill x | _ -> true) ->
|
| "flan_dyn_from_i64" when (match args with [ x ] -> int_may_spill x | _ -> true) ->
|
||||||
gc "may allocate: an i64 outside ±2^47 does not fit a dyn's payload and \
|
gc "may allocate: an i64 outside ±2^47 does not fit a dyn's payload and \
|
||||||
spills onto the collector's heap"
|
spills onto the collector's heap"
|
||||||
|
| "flan_dyn_from_u64" when (match args with x :: _ -> int_may_spill x | [] -> true) ->
|
||||||
|
gc "may allocate: a u64 above 2^47 does not fit a dyn's payload and \
|
||||||
|
spills onto the collector's heap"
|
||||||
(* ── An allocator the program named ── *)
|
(* ── An allocator the program named ── *)
|
||||||
| "flan_arena_new" ->
|
| "flan_arena_new" ->
|
||||||
native "allocates: an arena takes its whole region from the host here"
|
native "allocates: an arena takes its whole region from the host here"
|
||||||
|
|||||||
@ -5067,6 +5067,7 @@ declare void @flan_alloc_set_budget(ptr, i64)
|
|||||||
; ever looks inside one, so every operation on a dyn value is one of these.
|
; ever looks inside one, so every operation on a dyn value is one of these.
|
||||||
declare i64 @flan_dyn_nil()
|
declare i64 @flan_dyn_nil()
|
||||||
declare i64 @flan_dyn_from_i64(i64)
|
declare i64 @flan_dyn_from_i64(i64)
|
||||||
|
declare i64 @flan_dyn_from_u64(i64, ptr, i64)
|
||||||
declare i64 @flan_dyn_from_f64(double)
|
declare i64 @flan_dyn_from_f64(double)
|
||||||
declare i64 @flan_dyn_from_bool(i32)
|
declare i64 @flan_dyn_from_bool(i32)
|
||||||
declare i64 @flan_dyn_from_bytes(ptr, i64)
|
declare i64 @flan_dyn_from_bytes(ptr, i64)
|
||||||
@ -5148,6 +5149,8 @@ declare ptr @flan_dev_literal(ptr, i64)
|
|||||||
declare i64 @flan_dyn_need_i64(i64)
|
declare i64 @flan_dyn_need_i64(i64)
|
||||||
declare double @flan_dyn_need_f64(i64)
|
declare double @flan_dyn_need_f64(i64)
|
||||||
declare i32 @flan_dyn_need_bool(i64)
|
declare i32 @flan_dyn_need_bool(i64)
|
||||||
|
declare double @flan_dyn_need_f64_at(i64, ptr, i64)
|
||||||
|
declare i32 @flan_dyn_need_bool_at(i64, ptr, i64)
|
||||||
declare i32 @flan_dyn_need_i32(i64, ptr, i64)
|
declare i32 @flan_dyn_need_i32(i64, ptr, i64)
|
||||||
declare i64 @flan_dyn_need_int(i64, i32, ptr, i64)
|
declare i64 @flan_dyn_need_int(i64, i32, ptr, i64)
|
||||||
declare i64 @flan_dyn_int_of(i64)
|
declare i64 @flan_dyn_int_of(i64)
|
||||||
|
|||||||
@ -1909,6 +1909,26 @@ flan_dyn flan_dyn_from_i64(int64_t x) {
|
|||||||
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* A u64 has a dyn int to become only up to the largest i64; past it the trap
|
||||||
|
* names the number, which read as an i64 would be a different one. [what] is
|
||||||
|
* "u64" for a scalar crossing and "u64 element" for one read through a view,
|
||||||
|
* so both say the same sentence. */
|
||||||
|
static flan_dyn u64_to_dyn(const uint8_t *loc, int64_t loclen, const char *op,
|
||||||
|
const char *what, uint64_t x) {
|
||||||
|
if (x > (uint64_t)INT64_MAX) {
|
||||||
|
flan_say(loc, loclen,
|
||||||
|
"dyn%s%s: this %s is %llu, above the largest dyn int "
|
||||||
|
"(9223372036854775807), so it has no dyn value",
|
||||||
|
op[0] ? " " : "", op, what, (unsigned long long)x);
|
||||||
|
dyn_trap((const uint8_t *)"DynRange", 8);
|
||||||
|
}
|
||||||
|
return flan_dyn_from_i64((int64_t)x);
|
||||||
|
}
|
||||||
|
|
||||||
|
flan_dyn flan_dyn_from_u64(uint64_t x, const uint8_t *loc, int64_t loclen) {
|
||||||
|
return u64_to_dyn(loc, loclen, "", "u64", x);
|
||||||
|
}
|
||||||
|
|
||||||
flan_dyn flan_dyn_from_f64(double x) {
|
flan_dyn flan_dyn_from_f64(double x) {
|
||||||
flan_dyn v;
|
flan_dyn v;
|
||||||
/* Every NaN becomes the one positive quiet NaN, which is what keeps a
|
/* Every NaN becomes the one positive quiet NaN, which is what keeps a
|
||||||
@ -2797,11 +2817,14 @@ int64_t flan_dyn_need_i64(flan_dyn v) {
|
|||||||
* makes rather than a surprise somebody meets. Softening the check here is the
|
* makes rather than a surprise somebody meets. Softening the check here is the
|
||||||
* option not to take: this function sees a tag and nothing else, so it could
|
* option not to take: this function sees a tag and nothing else, so it could
|
||||||
* not tell (g 1) from (g (length xs)). */
|
* not tell (g 1) from (g (length xs)). */
|
||||||
double flan_dyn_need_f64(flan_dyn v) {
|
/* The _at forms trap at the site the checker hands over; the plain ones are
|
||||||
|
* for C callers that have none. */
|
||||||
|
double flan_dyn_need_f64_at(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
||||||
if (flan_dyn_tag(v) != FLAN_DYN_TAG_FLOAT)
|
if (flan_dyn_tag(v) != FLAN_DYN_TAG_FLOAT)
|
||||||
trap1(NULL, 0, TYPE_TRAP, "f64", "a float was wanted", v);
|
trap1(loc, loclen, TYPE_TRAP, "f64", "a float was wanted", v);
|
||||||
return dyn_num_value(v);
|
return dyn_num_value(v);
|
||||||
}
|
}
|
||||||
|
double flan_dyn_need_f64(flan_dyn v) { return flan_dyn_need_f64_at(v, NULL, 0); }
|
||||||
|
|
||||||
static const char *an(const char *w); /* forward: "a" or "an" */
|
static const char *an(const char *w); /* forward: "a" or "an" */
|
||||||
|
|
||||||
@ -2894,11 +2917,12 @@ uint32_t flan_dyn_need_char(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|||||||
flan_trap((const uint8_t *)"DynType", 7);
|
flan_trap((const uint8_t *)"DynType", 7);
|
||||||
}
|
}
|
||||||
|
|
||||||
uint8_t flan_dyn_need_bool(flan_dyn v) {
|
uint8_t flan_dyn_need_bool_at(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
||||||
if (flan_dyn_tag(v) != FLAN_DYN_TAG_BOOL)
|
if (flan_dyn_tag(v) != FLAN_DYN_TAG_BOOL)
|
||||||
trap1(NULL, 0, TYPE_TRAP, "bool", "a bool was wanted", v);
|
trap1(loc, loclen, TYPE_TRAP, "bool", "a bool was wanted", v);
|
||||||
return (uint8_t)(dyn_payload(v) ? 1 : 0);
|
return (uint8_t)(dyn_payload(v) ? 1 : 0);
|
||||||
}
|
}
|
||||||
|
uint8_t flan_dyn_need_bool(flan_dyn v) { return flan_dyn_need_bool_at(v, NULL, 0); }
|
||||||
|
|
||||||
/* ── A numeric cast opening a box ───────────────────────────────────────
|
/* ── A numeric cast opening a box ───────────────────────────────────────
|
||||||
*
|
*
|
||||||
@ -4046,14 +4070,7 @@ static flan_dyn view_read(const uint8_t *loc, int64_t loclen, const char *op,
|
|||||||
case 'L': {
|
case 'L': {
|
||||||
uint64_t x;
|
uint64_t x;
|
||||||
memcpy(&x, p, 8);
|
memcpy(&x, p, 8);
|
||||||
if (x > (uint64_t)INT64_MAX) {
|
return u64_to_dyn(loc, loclen, op, "u64 element", x);
|
||||||
flan_say(loc, loclen,
|
|
||||||
"dyn %s: this u64 element is %llu, above the largest dyn int "
|
|
||||||
"(9223372036854775807), so it has no dyn value",
|
|
||||||
op, (unsigned long long)x);
|
|
||||||
dyn_trap((const uint8_t *)"DynRange", 8);
|
|
||||||
}
|
|
||||||
return flan_dyn_from_i64((int64_t)x);
|
|
||||||
}
|
}
|
||||||
case 'f': { float x; memcpy(&x, p, 4); return flan_dyn_from_f64((double)x); }
|
case 'f': { float x; memcpy(&x, p, 4); return flan_dyn_from_f64((double)x); }
|
||||||
case 'd': { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); }
|
case 'd': { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); }
|
||||||
|
|||||||
@ -86,6 +86,8 @@ typedef struct flan_desc {
|
|||||||
|
|
||||||
flan_dyn flan_dyn_nil(void);
|
flan_dyn flan_dyn_nil(void);
|
||||||
flan_dyn flan_dyn_from_i64(int64_t x);
|
flan_dyn flan_dyn_from_i64(int64_t x);
|
||||||
|
/* Traps at [loc] on a u64 above the largest i64, which no dyn int holds. */
|
||||||
|
flan_dyn flan_dyn_from_u64(uint64_t x, const uint8_t *loc, int64_t loclen);
|
||||||
flan_dyn flan_dyn_from_f64(double x);
|
flan_dyn flan_dyn_from_f64(double x);
|
||||||
flan_dyn flan_dyn_from_bool(uint8_t b);
|
flan_dyn flan_dyn_from_bool(uint8_t b);
|
||||||
|
|
||||||
@ -304,6 +306,9 @@ void flan_dyn_emit_watch(flan_dyn v);
|
|||||||
int64_t flan_dyn_need_i64(flan_dyn v);
|
int64_t flan_dyn_need_i64(flan_dyn v);
|
||||||
double flan_dyn_need_f64(flan_dyn v);
|
double flan_dyn_need_f64(flan_dyn v);
|
||||||
uint8_t flan_dyn_need_bool(flan_dyn v);
|
uint8_t flan_dyn_need_bool(flan_dyn v);
|
||||||
|
/* The same, trapping at the site [loc] names. */
|
||||||
|
double flan_dyn_need_f64_at(flan_dyn v, const uint8_t *loc, int64_t loclen);
|
||||||
|
uint8_t flan_dyn_need_bool_at(flan_dyn v, const uint8_t *loc, int64_t loclen);
|
||||||
/* For a typed integer of width [kind], 0..7 for i8 u8 i16 u16 i32 u32 i64
|
/* For a typed integer of width [kind], 0..7 for i8 u8 i16 u16 i32 u32 i64
|
||||||
* u64: an int in range, or a char's code point where it fits (ASCII only
|
* u64: an int in range, or a char's code point where it fits (ASCII only
|
||||||
* into a byte), as an i64 the caller narrows. Anything else traps at [loc].
|
* into a byte), as an i64 the caller narrows. Anything else traps at [loc].
|
||||||
|
|||||||
94
test/programs/dyn-crossing.flan
Normal file
94
test/programs/dyn-crossing.flan
Normal file
@ -0,0 +1,94 @@
|
|||||||
|
;;;; Typed values crossing into dyn beside a dyn operand: a u64, a dyn nil past
|
||||||
|
;;;; a fold's pair (a bare nil is refused, see test_flan), and an is-numeric $t.
|
||||||
|
;;;; With an argument, the program runs the trap that argument names instead.
|
||||||
|
|
||||||
|
(defn add-dyn [x $t] dyn
|
||||||
|
{:where (is-numeric $t)}
|
||||||
|
(+ x (the dyn 1)))
|
||||||
|
|
||||||
|
(defn add-late [x $t d dyn] dyn
|
||||||
|
{:where (is-numeric $t)}
|
||||||
|
(+ x 1 d))
|
||||||
|
|
||||||
|
(defn dyn-first [x $t d dyn] dyn
|
||||||
|
{:where (is-numeric $t)}
|
||||||
|
(* d x 2))
|
||||||
|
|
||||||
|
(defn less-late [x $t d dyn] bool
|
||||||
|
{:where (is-numeric $t)}
|
||||||
|
(< x 10 d))
|
||||||
|
|
||||||
|
(defn biggest [x $t d dyn] dyn
|
||||||
|
{:where (is-numeric $t)}
|
||||||
|
(max x d 0))
|
||||||
|
|
||||||
|
(defn low-bits [x $t d dyn] dyn
|
||||||
|
{:where (is-integer $t)}
|
||||||
|
(bit-and x 7 d))
|
||||||
|
|
||||||
|
(defn boxed [x $t] dyn
|
||||||
|
{:where (is-numeric $t)}
|
||||||
|
(the dyn x))
|
||||||
|
|
||||||
|
(defn main [args [str]] i32
|
||||||
|
(let [z (the dyn 0)
|
||||||
|
n (the dyn 4)
|
||||||
|
small (the u64 9223372036854775807)
|
||||||
|
big (the u64 18446744073709551615)
|
||||||
|
nothing (the dyn nil)]
|
||||||
|
;; A u64 up to the largest i64 crosses as its value.
|
||||||
|
(println (+ z small) (max small 0 z) (the dyn small) (= small (+ z small)))
|
||||||
|
;; A $t at i32, f64 and u64, beside a dyn in any position.
|
||||||
|
(println (add-dyn 2) (add-dyn 2.5) (add-dyn (the u64 7)))
|
||||||
|
(println (add-late 2 n) (add-late 2.5 n) (dyn-first 3 n) (dyn-first 1.5 n))
|
||||||
|
(println (less-late 1 n) (less-late 1 (the dyn 20)) (less-late 0.5 (the dyn 10.5)))
|
||||||
|
(println (biggest 3 n) (biggest -2.5 (the dyn -1)) (low-bits 13 n) (low-bits (the u8 255) n))
|
||||||
|
(println (boxed 7) (boxed 0.25) (boxed small))
|
||||||
|
;; A nil past the pair is compared, not refused.
|
||||||
|
(println (= 1 1 nothing) (!= 1 2 nothing) (= 1 1 (the dyn nil)))
|
||||||
|
(when (> (length args) 1)
|
||||||
|
(let [a (at args 1)]
|
||||||
|
(when (= a "u64") (println (+ z big)))
|
||||||
|
(when (= a "u64-max") (println (max big 0 z)))
|
||||||
|
(when (= a "u64-generic") (println (boxed big)))
|
||||||
|
(when (= a "nil-first") (println (+ (the dyn nil) 1 2)))
|
||||||
|
(when (= a "nil-last") (println (+ 1 2 (the dyn nil))))
|
||||||
|
(when (= a "nil-less") (println (< 1 2 (the dyn nil))))
|
||||||
|
(when (= a "nil-min") (println (min 1 2 nothing)))
|
||||||
|
(when (= a "nil-bits") (println (bit-or 1 2 nothing)))
|
||||||
|
;; At a typed want too: the dyn nil traps in any position.
|
||||||
|
(let [r (the i32 0)]
|
||||||
|
(when (= a "nil-want-first") (set r (+ (the dyn nil) 1 2)))
|
||||||
|
(when (= a "nil-want-last") (set r (+ 1 2 (the dyn nil))))
|
||||||
|
(set r (+ r (at-i32 a))) (the-literal a)
|
||||||
|
(println r)))))
|
||||||
|
0)
|
||||||
|
|
||||||
|
;; A dyn beside typed operands at an i32 want: the whole form is dyn, and only
|
||||||
|
;; its answer is opened at i32, so every position wraps nowhere and traps alike.
|
||||||
|
(defn at-i32 [a str] i32
|
||||||
|
(let [big (the dyn 2147483647)
|
||||||
|
none (the dyn nil)]
|
||||||
|
(cond
|
||||||
|
(= a "big-first") (+ big 1 1)
|
||||||
|
(= a "big-mid") (+ 1 big 1)
|
||||||
|
(= a "big-last") (+ 1 1 big)
|
||||||
|
(= a "big-pair") (+ 1 big)
|
||||||
|
(= a "big-shift") (<< big 1)
|
||||||
|
(= a "i32-nil-first") (+ none 1 1)
|
||||||
|
(= a "i32-nil-mid") (+ 1 none 1)
|
||||||
|
(= a "i32-nil-last") (+ 1 1 none)
|
||||||
|
:else 0)))
|
||||||
|
|
||||||
|
;; (the dyn <literal>) is a dyn like any other: beside nil it traps at run
|
||||||
|
;; time, as a dyn bound to a name does. And opening one at f64 or bool names
|
||||||
|
;; its site.
|
||||||
|
(defn the-literal [a str] ()
|
||||||
|
(let [x (the f64 0.0)
|
||||||
|
b false]
|
||||||
|
(when (= a "lit-int") (println (+ (the dyn 1) nil)))
|
||||||
|
(when (= a "lit-float") (println (+ (the dyn 1.5) nil)))
|
||||||
|
(when (= a "lit-bool") (println (+ (the dyn true) nil)))
|
||||||
|
(when (= a "lit-let") (let [d (the dyn 1)] (println (+ d nil))))
|
||||||
|
(when (= a "want-f64") (set x (the dyn 3)) (println x))
|
||||||
|
(when (= a "want-bool") (set b (the dyn 3)) (println b))))
|
||||||
@ -5677,6 +5677,68 @@ level "1"
|
|||||||
(if x86 then ", --x86" else "") text code
|
(if x86 then ", --x86" else "") text code
|
||||||
end)
|
end)
|
||||||
[ false; true ];
|
[ false; true ];
|
||||||
|
(* A u64, a dyn nil past the pair and an is-numeric $t, each beside a
|
||||||
|
dyn: the typed value crosses, and what cannot cross traps at its site. *)
|
||||||
|
let crossing_out =
|
||||||
|
"9223372036854775807 9223372036854775807 9223372036854775807 true\n\
|
||||||
|
3 3.5 8\n7 7.5 24 12\nfalse true true\n4 0 4 4\n\
|
||||||
|
7 0.25 9223372036854775807\nfalse true false\n"
|
||||||
|
in
|
||||||
|
outputs "dyn: typed values crossing beside a dyn" "programs/dyn-crossing.flan"
|
||||||
|
crossing_out;
|
||||||
|
outputs ~opt:"-O0" "dyn: typed values crossing beside a dyn, -O0"
|
||||||
|
"programs/dyn-crossing.flan" crossing_out;
|
||||||
|
outputs ~x86:true "dyn: typed values crossing beside a dyn, --x86"
|
||||||
|
"programs/dyn-crossing.flan" crossing_out;
|
||||||
|
let too_big = "dyn: this u64 is 18446744073709551615, above the largest \
|
||||||
|
dyn int (9223372036854775807), so it has no dyn value" in
|
||||||
|
let too_wide n =
|
||||||
|
"dyn: an i32 is wanted here, and the int " ^ n ^ " is outside an i32's range" in
|
||||||
|
let crossing_traps =
|
||||||
|
[ "u64", "51:36", too_big;
|
||||||
|
"u64-max", "52:40", too_big;
|
||||||
|
"u64-generic", "31:12", too_big;
|
||||||
|
"nil-first", "54:42", "dyn +: nil and int, and it takes two numbers — (+ nil 1)";
|
||||||
|
"nil-last", "55:41", "dyn +: int and nil, and it takes two numbers — (+ 3 nil)";
|
||||||
|
"nil-less", "56:41", "dyn <: int and nil";
|
||||||
|
"nil-min", "57:40", "dyn min: int and nil";
|
||||||
|
"nil-bits", "58:41", "dyn bit-or: int and nil";
|
||||||
|
"nil-want-first", "61:47", "dyn +: nil and int, and it takes two numbers — (+ nil 1)";
|
||||||
|
"nil-want-last", "62:46", "dyn +: int and nil, and it takes two numbers — (+ 3 nil)";
|
||||||
|
(* At an i32 want the form is dyn in every position and only its
|
||||||
|
answer is opened: no position wraps. *)
|
||||||
|
"big-first", "73:25", too_wide "2147483649";
|
||||||
|
"big-mid", "74:23", too_wide "2147483649";
|
||||||
|
"big-last", "75:24", too_wide "2147483649";
|
||||||
|
"big-pair", "76:24", too_wide "2147483648";
|
||||||
|
"big-shift", "77:25", too_wide "4294967294";
|
||||||
|
"i32-nil-first", "78:29", "dyn +: nil and int, and it takes two numbers — (+ nil 1)";
|
||||||
|
"i32-nil-mid", "79:27", "dyn +: int and nil, and it takes two numbers — (+ 1 nil)";
|
||||||
|
"i32-nil-last", "80:28", "dyn +: int and nil, and it takes two numbers — (+ 2 nil)";
|
||||||
|
(* (the dyn <literal>) beside nil traps as a named dyn does, and an
|
||||||
|
f64 or bool opening names its site. *)
|
||||||
|
"lit-int", "89:36", "dyn +: int and nil, and it takes two numbers — (+ 1 nil)";
|
||||||
|
"lit-float", "90:38", "dyn +: float and nil, and it takes two numbers — (+ 1.5 nil)";
|
||||||
|
"lit-bool", "91:37", "dyn +: bool and nil, and it takes two numbers — (+ true nil)";
|
||||||
|
"lit-let", "92:57", "dyn +: int and nil, and it takes two numbers — (+ 1 nil)";
|
||||||
|
"want-f64", "93:35", "dyn f64: int, and a float was wanted — (f64 3)";
|
||||||
|
"want-bool", "94:36", "dyn bool: int, and a bool was wanted — (bool 3)" ]
|
||||||
|
in
|
||||||
|
List.iter
|
||||||
|
(fun x86 ->
|
||||||
|
let exe = compile ~x86 "programs/dyn-crossing.flan" in
|
||||||
|
List.iter
|
||||||
|
(fun (arg, at, msg) ->
|
||||||
|
let code, text = run exe (Some arg) in
|
||||||
|
let want = "programs/dyn-crossing.flan:" ^ at ^ ": " ^ msg in
|
||||||
|
if code <> 134 || not (contains text want) then begin
|
||||||
|
incr failures;
|
||||||
|
Printf.printf "FAIL dyn: crossing trap %s%s\n \
|
||||||
|
got: %S (exit %d)\n"
|
||||||
|
arg (if x86 then ", --x86" else "") text code
|
||||||
|
end)
|
||||||
|
crossing_traps)
|
||||||
|
[ false; true ];
|
||||||
List.iter
|
List.iter
|
||||||
(fun x86 ->
|
(fun x86 ->
|
||||||
let exe = compile ~x86 "programs/char-arith.flan" in
|
let exe = compile ~x86 "programs/char-arith.flan" in
|
||||||
|
|||||||
@ -2066,6 +2066,86 @@ let () =
|
|||||||
rejects_check "nil at a bare T is refused at compile time"
|
rejects_check "nil at a bare T is refused at compile time"
|
||||||
"(defn take [n i32] i32 n)\n(defn main [] i32 (take nil))"
|
"(defn take [n i32] i32 n)\n(defn main [] i32 (take nil))"
|
||||||
~needle:"nil has no None to become";
|
~needle:"nil has no None to become";
|
||||||
|
(* A bare nil in an arithmetic, bitwise or ordering operator with nothing
|
||||||
|
else dyn is refused in every position, with or without a want; a dyn that
|
||||||
|
holds nil is left to trap at run time (dyn-crossing.flan). *)
|
||||||
|
(* The 1-based column of [sub] in [form], placed at column [base]. *)
|
||||||
|
let col_of base form sub =
|
||||||
|
let n = String.length sub in
|
||||||
|
let rec at i = if String.sub form i n = sub then i else at (i + 1) in
|
||||||
|
base + at 0
|
||||||
|
in
|
||||||
|
List.iter
|
||||||
|
(fun form ->
|
||||||
|
List.iter
|
||||||
|
(fun (what, base, src) ->
|
||||||
|
let col = col_of base form "nil" in
|
||||||
|
match
|
||||||
|
(try ignore (checked src); None with Loc.Error d -> Some d)
|
||||||
|
with
|
||||||
|
| Some d when contains d.Loc.dmsg "nil has no None to become at i32"
|
||||||
|
&& d.Loc.dloc.Loc.col = col -> ()
|
||||||
|
| Some d ->
|
||||||
|
incr failures;
|
||||||
|
Printf.printf "FAIL a bare nil in %s, %s: got %d: %s\n" form what
|
||||||
|
d.Loc.dloc.Loc.col d.Loc.dmsg
|
||||||
|
| None ->
|
||||||
|
incr failures;
|
||||||
|
Printf.printf "FAIL a bare nil in %s, %s: accepted\n" form what)
|
||||||
|
[ "at a want", 16,
|
||||||
|
Printf.sprintf "(defn f [] i32 %s)\n(defn main [] i32 (f))" form;
|
||||||
|
"with none", 25,
|
||||||
|
Printf.sprintf "(defn f [] i32 (println %s) 0)\n(defn main [] i32 (f))" form ])
|
||||||
|
[ "(+ nil 1 2)"; "(+ 1 nil 2)"; "(+ 1 2 nil)"; "(+ 1 nil)";
|
||||||
|
"(< nil 1 2)"; "(< 1 2 nil)"; "(min 1 2 nil)"; "(bit-or nil 1 2)";
|
||||||
|
"(bit-or 1 2 nil)" ];
|
||||||
|
accepts "a dyn holding nil in a fold is left to the run time"
|
||||||
|
"(defn f [p dyn] i32 (+ 1 2 p (the dyn nil)))\n\
|
||||||
|
(defn g [] i32 (let [r (the i32 0)] (set r (+ (the dyn nil) 1 2)) r))\n\
|
||||||
|
(defn main [] i32 (println (< 1 2 (the dyn nil))) 0)";
|
||||||
|
accepts "nil beside (the dyn <literal>) is left to the run time"
|
||||||
|
"(defn main [] i32\n\
|
||||||
|
(println (+ (the dyn 1) nil) (+ (the dyn 1.5) nil) (+ (the dyn true) nil)\n\
|
||||||
|
(< (the dyn 1) nil) (min 2 (the dyn 1.5) nil)) 0)";
|
||||||
|
accepts "nil beside a real dyn in a fold is left to the run time"
|
||||||
|
"(defn f [p dyn] dyn (+ 1 2 p nil))\n(defn main [] i32 0)";
|
||||||
|
(* An operand past the pair asked on its own terms records nothing: the
|
||||||
|
float y is blamed, not the int x it would have merged with. *)
|
||||||
|
List.iter
|
||||||
|
(fun form ->
|
||||||
|
let col = col_of 45 form "y)" in
|
||||||
|
match
|
||||||
|
(try ignore (checked ("(defn main [] i32 (let [x 5 y 2.5] (println "
|
||||||
|
^ form ^ ")) 0)")); None
|
||||||
|
with Loc.Error d -> Some d)
|
||||||
|
with
|
||||||
|
| Some d when d.Loc.dloc.Loc.col = col -> ()
|
||||||
|
| Some d ->
|
||||||
|
incr failures;
|
||||||
|
Printf.printf "FAIL %s blames col %d, not y at %d: %s\n" form
|
||||||
|
d.Loc.dloc.Loc.col col d.Loc.dmsg
|
||||||
|
| None -> incr failures; Printf.printf "FAIL %s: accepted\n" form)
|
||||||
|
[ "(+ (the i64 1) 2 (+ x y))"; "(* (the i64 1) 2 (* x y))";
|
||||||
|
"(max (the i64 1) 2 (max x y))"; "(< (the i64 1) 2 (+ x y))" ];
|
||||||
|
rejects_check "a wide literal at dyn with nothing to retype"
|
||||||
|
"(defn main [] i32 (println (the dyn 0xFFFFFFFFFFFFFFFF)) 0)"
|
||||||
|
~needle:"0xFFFFFFFFFFFFFFFF, which is above the largest dyn int \
|
||||||
|
(9223372036854775807), so it has no dyn value";
|
||||||
|
rejects_check "a wide literal beside a dyn"
|
||||||
|
"(defn main [] i32 (println (+ (the dyn 0) 0xFFFFFFFFFFFFFFFF)) 0)"
|
||||||
|
~needle:"so it has no dyn value";
|
||||||
|
(* A $t crosses into dyn only under a bound every type of which has a dyn
|
||||||
|
value; an unbounded one could be a pointer, refused at no call site. *)
|
||||||
|
rejects_check "an unbounded $t does not cross into dyn"
|
||||||
|
"(defn f [x $t] dyn (+ x (the dyn 1)))\n\
|
||||||
|
(defn main [] i32 (println (f 2)) 0)"
|
||||||
|
~needle:"$t may be a type with no dyn value, such as a pointer or an \
|
||||||
|
enum, so it crosses into dyn only as a number. Write \
|
||||||
|
{:where (is-numeric $t)}";
|
||||||
|
rejects_check "an is-ordered $t does not cross into dyn"
|
||||||
|
"(defn f [x $t] dyn {:where (is-ordered $t)} (the dyn x))\n\
|
||||||
|
(defn main [] i32 (println (f 2)) 0)"
|
||||||
|
~needle:"crosses into dyn only as a number";
|
||||||
rejects_check "nil at a bare T is refused at compile time, return position"
|
rejects_check "nil at a bare T is refused at compile time, return position"
|
||||||
"(defn f [] i64 nil)\n(defn main [] i32 0)"
|
"(defn f [] i64 nil)\n(defn main [] i32 0)"
|
||||||
~needle:"nil has no None to become";
|
~needle:"nil has no None to become";
|
||||||
@ -8018,11 +8098,11 @@ let () =
|
|||||||
parse_rejects "a wide enum member is refused for its range"
|
parse_rejects "a wide enum member is refused for its range"
|
||||||
"(defenum E [A 0xFFFFFFFFFFFFFFFF B])"
|
"(defenum E [A 0xFFFFFFFFFFFFFFFF B])"
|
||||||
~needle:"the member A of E is 0xFFFFFFFFFFFFFFFF, which does not fit i32";
|
~needle:"the member A of E is 0xFFFFFFFFFFFFFFFF, which does not fit i32";
|
||||||
rejects_check "a wide literal in a dyn global names the u64 cast"
|
rejects_check "a wide literal in a dyn global names the type u64"
|
||||||
"(defonce big 0xFFFFFFFFFFFFFFFF)"
|
"(defonce big 0xFFFFFFFFFFFFFFFF)"
|
||||||
~needle:"Write (u64 0xFFFFFFFFFFFFFFFF) for the u64";
|
~needle:"so it has no dyn value. Give big the type u64";
|
||||||
accepts "the cast the dyn refusal names compiles"
|
accepts "the type the dyn refusal names compiles"
|
||||||
"(defonce big (u64 0xFFFFFFFFFFFFFFFF))";
|
"(defonce big u64 0xFFFFFFFFFFFFFFFF)";
|
||||||
(* A macro's Form has one integer case; the literal comes back wide all the
|
(* A macro's Form has one integer case; the literal comes back wide all the
|
||||||
same, and is refused where it would have been refused unexpanded. *)
|
same, and is refused where it would have been refused unexpanded. *)
|
||||||
rejects_check "a wide literal through a macro is still wide"
|
rejects_check "a wide literal through a macro is still wide"
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user