From 6b9d1fa64451cd9be76c0e8c60e6baf0867516bc Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 06:58:06 +0700 Subject: [PATCH 1/7] A cast of NaN or an infinity to an integer says so by name, on both backends --- lib/emit.ml | 22 ++++++++++++++++++++-- lib/prelude.ml | 4 +++- lib/x86.ml | 22 ++++++++++++++++++++++ runtime/flan_rt.c | 17 ++++++++++++++++- test/programs/arith-condition.flan | 3 ++- test/programs/arith.flan | 6 ++++++ test/test_acceptance.ml | 19 +++++++++++++++---- 7 files changed, 84 insertions(+), 9 deletions(-) diff --git a/lib/emit.ml b/lib/emit.ml index f6af7bbc..9cf3a25f 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -1517,6 +1517,8 @@ let arith_rem_zero = 1 let arith_div_overflow = 2 let arith_rem_overflow = 3 let arith_cast_range = 4 +let arith_cast_nan = 5 +let arith_cast_inf = 6 (* ArithError's fields are i64 and an operand may be narrower, so every operand is widened on the way into the condition — signed or not according @@ -1668,11 +1670,27 @@ let check_cast f ~guard loc (src : Types.fkind) (k : Types.ikind) v = ins f "%s = fcmp olt double %s, %s" b v (dbl hi_f); let ok = fresh f in ins f "%s = and i1 %s, %s" ok a b; + (* NaN and the infinities are named rather than reported as out of range: + they are not values that overshot the type, they have no integer at + all. Worked out on the cold path, so the guard is still two compares. *) signal_block f loc ~guard ok (fun id nn -> + let nan = fresh f in + ins f "%s = fcmp uno double %s, %s" nan v v; + let pinf = fresh f in + ins f "%s = fcmp oeq double %s, %s" pinf v (dbl infinity); + let ninf = fresh f in + ins f "%s = fcmp oeq double %s, %s" ninf v (dbl neg_infinity); + let inf = fresh f in + ins f "%s = or i1 %s, %s" inf pinf ninf; + let c1 = fresh f in + ins f "%s = select i1 %s, i32 %d, i32 %d" c1 inf arith_cast_inf + arith_cast_range; + let code = fresh f in + ins f "%s = select i1 %s, i32 %d, i32 %s" code nan arith_cast_nan c1; ins f - "call void @flan_arith_error(ptr %s, i64 %d, i32 %d, i64 %Ld, i64 %Ld, \ + "call void @flan_arith_error(ptr %s, i64 %d, i32 %s, i64 %Ld, i64 %Ld, \ ptr %s)" - id nn arith_cast_range lo_i hi_i xfer_param) + id nn code lo_i hi_i xfer_param) end (* [at] is strict: the last valid index is len - 1. *) diff --git a/lib/prelude.ml b/lib/prelude.ml index ee7e83e9..f8deb3ff 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -123,9 +123,11 @@ let source = {flan| ;; 0 (/ a 0) 1 (% a 0) ;; 2 (/ min -1) 3 (% min -1) ;; 4 a float to integer cast whose value does not fit +;; 5 a float to integer cast of NaN +;; 6 a float to integer cast of an infinity ;; ;; `lhs` and `rhs` are the two operands for codes 0 through 3 and the -;; destination type's representable range for code 4 — the violated condition +;; destination type's representable range for codes 4 through 6 — the violated condition ;; written as a range, which is what flan_slice_promise_error already does ;; with BoundsError's fields. Two meanings over two fields rather than two ;; condition types, so that a handler writes one clause and not five. The diff --git a/lib/x86.ml b/lib/x86.ml index b01553ff..2a16a639 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -2812,8 +2812,30 @@ and check_cast f (loc : Loc.t) (src : Types.fkind) (k : Types.ikind) = ucomis f.b ~f64 ~a:1 ~c:xmm0; jcc_lbl f.b ~cc:cc_a ok; lbl f.b bad; + (* Which code, on the cold path: NaN and the infinities are named rather + than reported as out of range. xmm0 still holds the value here. *) + let call = new_label f "nofitcall" and notnan = new_label f "notnan" + and isinf = new_label f "isinf" in imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_range); store_int f.b ~src:rax ~mm:(Frame so) ~size:8; + ucomis f.b ~f64 ~a:xmm0 ~c:xmm0; + jcc_lbl f.b ~cc:cc_np notnan; + imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_nan); + store_int f.b ~src:rax ~mm:(Frame so) ~size:8; + jmp_lbl f.b call; + lbl f.b notnan; + let kpinf = float_const f infinity ~f64 + and kninf = float_const f neg_infinity ~f64 in + fload f.b ~dst:1 ~mm:(Sym (kpinf, 0)) ~f64; + ucomis f.b ~f64 ~a:xmm0 ~c:1; + jcc_lbl f.b ~cc:cc_e isinf; + fload f.b ~dst:1 ~mm:(Sym (kninf, 0)) ~f64; + ucomis f.b ~f64 ~a:xmm0 ~c:1; + jcc_lbl f.b ~cc:cc_ne call; + lbl f.b isinf; + imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_inf); + store_int f.b ~src:rax ~mm:(Frame so) ~size:8; + lbl f.b call; imm_into f ~reg:rax lo_i; store_int f.b ~src:rax ~mm:(Frame sa) ~size:8; imm_into f ~reg:rax hi_i; diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 00a9ddef..5c91b6c6 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -969,7 +969,9 @@ enum { FLAN_ARITH_REM_ZERO = 1, FLAN_ARITH_DIV_OVERFLOW = 2, FLAN_ARITH_REM_OVERFLOW = 3, - FLAN_ARITH_CAST_RANGE = 4 + FLAN_ARITH_CAST_RANGE = 4, + FLAN_ARITH_CAST_NAN = 5, + FLAN_ARITH_CAST_INF = 6 }; typedef struct { int32_t op; int64_t lhs, rhs; } flan_arith_cond; @@ -1005,6 +1007,19 @@ static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op, op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs, (long long)rhs); break; + /* NaN and the infinities did not overshoot the range: no integer is + * their value, whatever the type. Saying "does not fit" reads as too big. */ + case FLAN_ARITH_CAST_NAN: + fprintf(stderr, + "%.*s: this value is NaN, which has no integer value to cast to\n", + (int)loclen, (const char *)loc); + break; + case FLAN_ARITH_CAST_INF: + fprintf(stderr, + "%.*s: this value is infinite, which has no integer value to cast " + "to\n", + (int)loclen, (const char *)loc); + break; default: fprintf(stderr, "%.*s: this value does not fit the integer type it is cast to, " diff --git a/test/programs/arith-condition.flan b/test/programs/arith-condition.flan index 62ba1381..78bd2019 100644 --- a/test/programs/arith-condition.flan +++ b/test/programs/arith-condition.flan @@ -180,7 +180,8 @@ ;; NaN fails both halves of the range test, which is deliberate: a NaN ;; cast to an integer is exactly as undefined as a value out of range, - ;; and an unordered comparison would have waved it through. + ;; and an unordered comparison would have waved it through. Its code is + ;; 5, which names NaN, rather than 4, which says it overshot the range. (cast-frame (/ (f64 0.0) (f64 0.0))) (show "op" (i64 op)) diff --git a/test/programs/arith.flan b/test/programs/arith.flan index 71b747c4..9a9d0601 100644 --- a/test/programs/arith.flan +++ b/test/programs/arith.flan @@ -76,6 +76,12 @@ ;; double there, which agree because every bound is a power of two and is ;; exact in both. (= n 9) (print (i32 wide)) + ;; NaN and the infinities have no integer value at all, so the message + ;; names them rather than a range they did not overshoot. An f32 source + ;; for each too, since the two backends test it at different widths. + (= n 10) (print (i32 (/ (f64 1.0) (f64 0.0)))) + (= n 11) (print (u8 (/ (f32 -1.0) (f32 0.0)))) + (= n 12) (print (i32 (/ (f32 0.0) (f32 0.0)))) :else (println "?")) 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 58a8cf4e..3b5bfcdb 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2543,8 +2543,8 @@ let () = no overflow case because it has no most-negative value, and a float division by zero, which is an infinity and is a defined answer this language has no business refusing. *) - let arith ?opt () = - let exe = compile ?opt "programs/arith.flan" in + let arith ?opt ?x86 () = + let exe = compile ?opt ?x86 "programs/arith.flan" in let traps name arg reason = let code, text = run exe (Some arg) in if code <> 134 @@ -2587,7 +2587,7 @@ let () = would have waved it through into an fptosi that is as undefined for a NaN as it is for 1e300. *) traps "NaN cast to an integer" "7" - "does not fit the integer type it is cast to"; + "this value is NaN, which has no integer value to cast to"; (* One width down, and this is the case the two backends disagreed about *silently* rather than both dying: x86 loaded the operands sign-extended into 64-bit registers, divided there and truncated on @@ -2604,10 +2604,21 @@ let () = and this is the row that says so rather than the comment. *) traps "an f32 too large for an i32" "9" "which holds [-2147483648 2147483647]"; + (* NaN and the infinities are named: they did not overshoot a range, + they have no integer value at all. *) + traps "an infinity cast to an integer" "10" + "this value is infinite, which has no integer value to cast to"; + traps "an f32 negative infinity cast to a u8" "11" + "this value is infinite, which has no integer value to cast to"; + traps "an f32 NaN cast to an integer" "12" + "this value is NaN, which has no integer value to cast to"; (try Sys.remove exe with Sys_error _ -> ()) in arith (); arith ~opt:"-O0" (); + (* The x86 backend picks the code with its own instructions, so the three + named cases are asserted there as well as in the survey. *) + arith ~x86:true (); (* The release build drops the guards. Asserted on the IR and not by running an unchecked program, for the reason the bounds case gives: an @@ -2646,7 +2657,7 @@ let () = op 2\nlhs -9223372036854775808\nrhs -1\nop 3\n\ cast 3\ncast -3\n\ op 4\nlhs -9223372036854775808\nrhs 9223372036854775807\nop 4\n\ - cast8 12\nlhs -128\nrhs 127\nop 4\n\ + cast8 12\nlhs -128\nrhs 127\nop 5\n\ lit 4611686018427387903\nu 14\n\ frames 4\nskipped 8\ncleaned 12\n" in From 3a3674efb795ecf7ca2bd9ff95268f10ef708de4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 07:04:10 +0700 Subject: [PATCH 2/7] A gensym is never the same name twice in one compiler process, however many macro modules it loads --- lib/macro.ml | 18 +++++++++++++++++- lib/prelude.ml | 16 ++++++++-------- runtime/flan_rt.c | 8 ++++++++ test/programs/macro-gensym-rounds.flan | 24 ++++++++++++++++++++++++ test/test_acceptance.ml | 5 +++++ 5 files changed, 62 insertions(+), 9 deletions(-) create mode 100644 test/programs/macro-gensym-rounds.flan diff --git a/lib/macro.ml b/lib/macro.ml index 177b4c34..b31ed83a 100644 --- a/lib/macro.ml +++ b/lib/macro.ml @@ -380,12 +380,28 @@ let dir_of (l : loaded) (loc : Loc.t) = always has a signature, and the one thing that could put a name in [fns] without one is the two lists coming apart — in which case expanding unchecked is the wrong half to lose. *) +(* The gensym counter, process-wide. Every module links its own runtime and + so its own [flan_gensym_n], and a build loads several — one per round when + a macro calls a macro, then the one the program is expanded with, and a + session loads one per expansion. A counter that restarted in each would + hand a later module the name an earlier one had already baked into a + macro's code. So the count lives here and is written into the module + before every call and read back after, whether the call returns or + raises. *) +let gensym_n = ref 0L + +let with_gensym (l : loaded) f = + let cell = Dynload.dl_sym l.handle "flan_gensym_n" in + Dynload.poke_i64 cell 0 !gensym_n; + Fun.protect ~finally:(fun () -> gensym_n := Dynload.peek_i64 cell 0) f + let checked_call (l : loaded) n ~loc (args : Form.t list) : Form.t = (match List.assoc_opt n l.sigs with | Some sg -> Expand.check_call ~name:n ~loc sg args | None -> ()); dir_of l loc; - Expand.call ~loc:(Loc.from_macro n loc) (List.assoc n l.fns) args + with_gensym l (fun () -> + Expand.call ~loc:(Loc.from_macro n loc) (List.assoc n l.fns) args) let fuel = 200 diff --git a/lib/prelude.ml b/lib/prelude.ml index f8deb3ff..8f6cd1e2 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -2137,19 +2137,19 @@ let source = {flan| ;; explicit gensym is the settled decision (plan.org, open decision 2); this is ;; the escape hatch that makes it liveable. ;; -;; The counter lives in the loaded module rather than in the compiler, which is -;; the one place this departs from the sketch. A module is dlopened once -;; per compiler process and every macro in a program shares it, so the counter -;; is process-wide in practice; a second module would restart it, and the day -;; there is one, the fix is to seed this from the module's index. -(defonce gensym-n i64 0) +;; The counter is C data in the runtime, flan_gensym_n, because a build loads +;; more than one macro module — one per round when macros call macros, and +;; another for every expansion in a session — and each links its own copy of +;; the runtime. lib/macro.ml keeps the count across them: it writes it into +;; the module before every macro call and reads it back after, so no two +;; modules in one compiler process draw the same name. +(declare gensym-next [] i64 "flan_gensym_next") (defn gensym [] Form - (set gensym-n (+ gensym-n 1)) (let [v (vec-new u8)] (push v 126) ; ~ (push v 103) ; g - (let [d (i64->bytes gensym-n)] + (let [d (i64->bytes (gensym-next))] (dotimes [i (length d)] (push v (at d i)))) (Form.Sym {.s (string (slice v))}))) diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 5c91b6c6..7862ee28 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -3193,6 +3193,14 @@ const uint8_t *flan_getenv(const uint8_t *name, int64_t n, int64_t *len) { char flan_macro_dir[FLAN_PATH_MAX] = { 0 }; int64_t flan_macro_dir_n = 0; +/* The prelude's gensym counter. C data rather than a Flan global for the same + * reason as the two above: lib/macro.ml writes it into a module before every + * macro call and reads it back after, which is what keeps it counting across + * every module a compiler process loads rather than restarting in each. */ +int64_t flan_gensym_n = 0; + +int64_t flan_gensym_next(void) { return ++flan_gensym_n; } + /* The bytes are the caller's to read and nobody's to free: an expansion is * bounded by the size of the program being compiled, which is exactly the * budget lib/dynload.ml's `owned` note already spends on a macro's own diff --git a/test/programs/macro-gensym-rounds.flan b/test/programs/macro-gensym-rounds.flan new file mode 100644 index 00000000..74584556 --- /dev/null +++ b/test/programs/macro-gensym-rounds.flan @@ -0,0 +1,24 @@ +;;;; Two gensyms from two macro modules are never the same name. +;;;; +;;;; `outer` calls `baked` in its body, so `baked` is compiled in a round of +;;;; its own and `outer`'s body is expanded against that module before `outer` +;;;; is compiled. The gensym `baked` draws there becomes a literal in +;;;; `outer`'s code; the one `outer` draws itself comes from the later module +;;;; the program is expanded with. `main` comes first so that its expansion is +;;;; that module's first draw. Were the two the same name, the second binding +;;;; would shadow the first and this would print 200. + +(defn main [] i32 + (println (outer 1)) + 0) + +;; Expands to code that builds the symbol this expansion drew. +(defmacro baked [] + (match (gensym) + (Form.Sym s) `(Form.Sym {.s ~(Form.Str {.s s})}) + _ `(form-nil))) + +(defmacro outer [a] + (let [g (baked) + h (gensym)] + `(let [~g ~a ~h 100] (+ ~g ~h)))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 3b5bfcdb..cc32cacc 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3893,6 +3893,11 @@ level "1" outputs ~dev:true "a macro's parameter list, dev" "programs/macro-params.flan" macro_params_out; + (* A gensym drawn in one round's module and one drawn in the module the + program is expanded with are different names. 200 is the two colliding. *) + outputs "gensym counts across macro modules" + "programs/macro-gensym-rounds.flan" "101\n"; + (* A macro declared in an imported *package*, which is the half the refusal at [a package's macro is not visible unqualified] above leaves out. The program calls six of them qualified and one of its own From b4e19bebf879f9f52a1ca523bc4cb76fe4d6582a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 07:06:17 +0700 Subject: [PATCH 3/7] A loop's initialisers are checked in order and each sees the names bound before it, as a let's do --- lib/check.ml | 11 +++++------ test/programs/recur.flan | 6 ++++++ test/test_acceptance.ml | 2 +- 3 files changed, 12 insertions(+), 7 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 1383ce91..0865e717 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4737,8 +4737,10 @@ and check_dotimes ctx ~want loc label name (b : Ast.bounds) body = and check_loop ctx ?want loc bs body = scoped ctx (fun () -> (* Each initial value is evaluated once, before the loop, exactly as a - [let]'s is and as [dotimes]'s bound is. *) - let inits = + [let]'s is and as [dotimes]'s bound is — and bound before the next is + checked, as a [let]'s is, so a later initialiser sees an earlier + name. *) + let binds = map_lr (fun (n, v) -> let v = check ctx v in @@ -4747,12 +4749,9 @@ and check_loop ctx ?want loc bs body = fail v.Tast.loc "%s would be bound to %s, which is not a value" n (Types.to_string v.Tast.ty) | _ -> ()); - (n, v)) + (bind ctx n v.Tast.ty ~assignable:true, v)) bs in - let binds = - List.map (fun (n, v) -> (bind ctx n v.Tast.ty ~assignable:true, v)) inits - in let names = List.map (fun (slot, v) -> (slot, v.Tast.ty)) binds in (* The singleton is [in_loop]'s doing: it sits in this recursive group and is therefore monomorphic, and every other caller hands it a list. *) diff --git a/test/programs/recur.flan b/test/programs/recur.flan index 5c6f32a0..e03cf332 100644 --- a/test/programs/recur.flan +++ b/test/programs/recur.flan @@ -99,4 +99,10 @@ (Some v) (recur (+ i 1) (+ acc v)) None acc))) (println "") ; 0+1+2+3 = 6 + + ;; The bindings are sequential, as a let's are: the second initialiser reads + ;; the first name. Only the initial values are; recur still rebinds at once. + (print (loop [a 1 b (+ a 10)] + (if (> a 3) b (recur (+ a 1) (+ b a))))) + (println "") ; 11+1+2+3 = 17 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index cc32cacc..7a21bb0c 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -501,7 +501,7 @@ let () = rather than running out of stack. The swap line is the other — recur rebinds every name at once, and interleaved writes would print 1. *) outputs "loop and recur" "programs/recur.flan" - "10\n2\n21\n8\n10000000\n64\n012\n0\n4\n012\n6\n"; + "10\n2\n21\n8\n10000000\n64\n012\n0\n4\n012\n6\n17\n"; (* 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 From aa629da2e591e86318a0c64a1fd027a29753e377 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 07:10:48 +0700 Subject: [PATCH 4/7] vec-new and map-new take a type expression where they take a type, so (vec-new [u8]) makes a Vec of byte slices --- lib/ast.ml | 8 +++++++- lib/check.ml | 31 +++++++++++++++++++++++++------ lib/load.ml | 3 ++- lib/parse.ml | 27 +++++++++++++++++++++++++++ test/programs/vec-new-type.flan | 25 +++++++++++++++++++++++++ test/test_acceptance.ml | 6 ++++++ test/test_flan.ml | 7 +++++++ 7 files changed, 99 insertions(+), 8 deletions(-) create mode 100644 test/programs/vec-new-type.flan diff --git a/lib/ast.ml b/lib/ast.ml index c49e9e36..cf923cc0 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -97,6 +97,12 @@ and expr_kind = fails on an unknown name. This is that position's answer, and it says what it does rather than looking like a vector of two things. *) | ArrayOf of texpr (* the whole array type, built by Parse *) + (* (vec-new [u8]) and (map-new string [u8]) — a type written where an + argument goes. Only the type positions of those two forms read one, and + only when the form's shape says type and not value: brackets, or a + parenthesised Ptr, Option, Vec, Map, Fn or CFn. A bare name stays a + [Var], which the checker already answers as a type. *) + | TypeArg of texpr (* (array-fill [r c] v) and (array-gen [r c] f) — a fixed array of any rank as an *expression*, which is what [ArrayOf] and [dotimes] between them could not be: [ArrayOf] produces the zeroed value only, and [dotimes] is @@ -403,7 +409,7 @@ let map_children f (e : expr) : expr = let kind = match e.e with | Int _ | Float _ | Byte _ | Str _ | Kw _ | Quote _ | Var _ | ArrayOf _ - | Break _ | Continue _ -> e.e + | TypeArg _ | Break _ | Continue _ -> e.e | Do es -> Do (List.map ex es) | Let (bs, es) -> Let (List.map bind bs, List.map ex es) | If (c, a, b) -> If (ex c, ex a, Option.map ex b) diff --git a/lib/check.ml b/lib/check.ml index 0865e717..49711623 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3547,6 +3547,11 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.ArrayOf t -> let ty = resolve ctx.env t in expect ctx loc ~want (mk loc ty (Tast.Zero ty)) + (* Parse writes one only into a type position of vec-new or map-new, and + those read it before it could get here. *) + | Ast.TypeArg _ -> + fail loc "internal: a type argument reached the checker outside vec-new or \ + map-new — this is a compiler bug" | 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.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms @@ -6564,12 +6569,15 @@ and type_named ctx n = || Hashtbl.mem ctx.env.enums n || Hashtbl.mem ctx.env.aliases n -(* The element type for [vec-new]: a leading bare symbol naming a type, or the - expectation at the site. A bare symbol shadowed by a local or a global is - that binding — an allocator, in practice — and not a type. *) +(* The element type for [vec-new]: a leading bare symbol naming a type, a + leading type expression — [(vec-new [u8])], [(vec-new (Ptr Cell))], which + Parse has already read as one — or the expectation at the site. A bare + symbol shadowed by a local or a global is that binding — an allocator, in + practice — and not a type. *) and vec_new_elem ctx ~want loc args = let named = match args with + | { Ast.e = Ast.TypeArg t; _ } :: rest -> Some (resolve ctx.env t, rest) | { Ast.e = Ast.Var n; _ } :: rest when lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) @@ -6604,10 +6612,21 @@ and map_new_types ctx ~want loc args = && (not (Hashtbl.mem ctx.env.globals n)) && type_named ctx n in + (* A type position holds a bare name or a type expression Parse has read + as one, as [vec-new]'s does. *) + let as_type (a : Ast.expr) = + match a.Ast.e with + | Ast.TypeArg t -> Some (resolve ctx.env t) + | Ast.Var n when is_type n -> Some (resolve_name ctx.env ~seen:[] loc n) + | _ -> None + in match args with - | { Ast.e = Ast.Var k; _ } :: { Ast.e = Ast.Var v; _ } :: rest - when is_type k && is_type v -> - resolve_name ctx.env ~seen:[] loc k, resolve_name ctx.env ~seen:[] loc v, rest + | k :: v :: rest when as_type k <> None && as_type v <> None -> + Option.get (as_type k), Option.get (as_type v), rest + | { Ast.e = Ast.TypeArg _; _ } :: _ -> + fail loc + "(map-new) names a key and no value — write both, as (map-new string \ + i32), or give the binding a type" | { Ast.e = Ast.Var k; _ } :: rest when is_type k && rest = [] -> fail loc "(map-new %s) names a key and no value — write both, as (map-new %s \ diff --git a/lib/load.ml b/lib/load.ml index 96629722..4fb38a9e 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -307,6 +307,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = Ast.MapLit (tag, List.map (fun (k, v) -> (go k, go v)) kvs) | Ast.Arr items -> Ast.Arr (gos items) | Ast.ArrayOf t -> Ast.ArrayOf (rename_texpr owned alias t) + | Ast.TypeArg t -> Ast.TypeArg (rename_texpr owned alias t) (* The dimensions too, for the reason [rename_texpr] gives about the one inside [Tarray]: a dimension written as a name is an ordinary compile-time constant of the package and has to be qualified like any @@ -787,7 +788,7 @@ let rec expr_uses acc (e : Ast.expr) = | Ast.Bare kvs -> List.iter (fun (_, v) -> go v) kvs | Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs | Ast.Arr items -> gos items - | Ast.ArrayOf t -> texpr_uses acc t + | Ast.ArrayOf t | Ast.TypeArg t -> texpr_uses acc t (* 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) -> diff --git a/lib/parse.ml b/lib/parse.ml index 456c8a8b..d17399b2 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -425,6 +425,33 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = | [ target; value ] -> mk (Ast.Set (place target, expr value)) | _ -> fail f "set is (set place value)") + (* ── (vec-new [u8]) and (map-new string [u8]) ─────────────────────── + The type positions of these two take a type expression as well as a bare + name. A bare name is left for the checker, which knows whether it names a + type or an allocator; a bracket or a parenthesised type constructor can + only be a type there, so it is read as one now, with [texpr], the reader + a parameter list's types go through. *) + | Sym (("vec-new" | "builtin/vec-new" | "map-new" | "builtin/map-new") as n) -> + let slots = + if n = "vec-new" || n = "builtin/vec-new" then 1 else 2 + in + let is_type (a : Form.t) = + match a.v with + | Vec _ -> true + | List ({ v = Sym ("Ptr" | "Option" | "Vec" | "Map" | "Fn" | "CFn"); _ } + :: _ :: _) -> true + | _ -> false + in + let args = + List.mapi + (fun i a -> + if i < slots && is_type a then + { Ast.e = Ast.TypeArg (texpr a); loc = a.loc } + else expr a) + args + in + mk (Ast.Call (expr head, args)) + (* ── (array 4 rl/Vector2) ─────────────────────────────────────────── A zeroed fixed array, told its count and its element type. The type spelling [4 rl/Vector2] is unchanged and still works everywhere a type is diff --git a/test/programs/vec-new-type.flan b/test/programs/vec-new-type.flan new file mode 100644 index 00000000..5d338a70 --- /dev/null +++ b/test/programs/vec-new-type.flan @@ -0,0 +1,25 @@ +;;;; vec-new and map-new take a type expression where they take a type, so a +;;;; local can hold a Vec of slices, of arrays or of pointers with nothing +;;;; else naming the element type. The last Vec names an allocator after its +;;;; type, which is the one argument that may follow. + +(defn main [] i32 + (let [a (arena-new 4096) + words (vec-new [u8]) + pairs (vec-new [2 i32]) + ptrs (vec-new (Ptr i32)) + opts (vec-new (Option i64) a) + m (map-new string [u8]) + x (i32 7)] + (push words (bytes-view "ab")) + (push words (bytes-view "cde")) + (push pairs [3 4]) + (push ptrs (addr x)) + (push opts (Some (i64 9))) + (put m "k" (bytes-view "xyz")) + (println (length words) (length (at words 1)) + (at (at pairs 0) 1) (deref (at ptrs 0)) + (match (at opts 0) (Some v) v None -1) + (match (get m "k") (Some v) (length v) None -1)) + (free words) (free pairs) (free ptrs) (free m)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 7a21bb0c..d1163867 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -502,6 +502,12 @@ let () = rebinds every name at once, and interleaved writes would print 1. *) outputs "loop and recur" "programs/recur.flan" "10\n2\n21\n8\n10000000\n64\n012\n0\n4\n012\n6\n17\n"; + (* A type expression where vec-new and map-new take a type: a slice, an + array, a pointer and an option, with nothing else naming the element. *) + outputs "vec-new takes a type expression" "programs/vec-new-type.flan" + "2 3 4 7 9 3\n"; + outputs ~x86:true "vec-new takes a type expression, x86" + "programs/vec-new-type.flan" "2 3 4 7 9 3\n"; (* 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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 04f993e8..ff0cf47d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6031,6 +6031,13 @@ let () = rejects_check "vec-new with no element type and nothing to take one from" ~needle:"nothing here says what (vec-new) is a Vec of" "(defn f [x $t] i32 (do x (let [v (vec-new)] (free v) 0)))"; + (* A type expression in a type position, generic or not. *) + accepts "vec-new over a slice of a type variable" + "(defn f [x [$t]] i32 (let [v (vec-new [$t])] (push v x) \ + (let [n (length v)] (free v) n)))"; + rejects_check "map-new with a key type expression and no value type" + ~needle:"(map-new) names a key and no value" + "(defn f [] i32 (let [m (map-new [u8])] (free m) 0))"; (* And a sigil on a name nothing binds is answered as the unbound variable it is, rather than as a missing element type — with the names that *are* bound, because inside a signature that introduces one the mistake is From f142cfaadf08cc4f5de95e082ea525d0f59ca897 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 07:16:42 +0700 Subject: [PATCH 5/7] A u64 constant above 2^63 can be written in decimal, and a cast's integer literal too wide for i32 is read at the cast's type --- lib/check.ml | 16 ++++++++++++++-- lib/reader.ml | 16 ++++++++++++++-- test/programs/u64-decimal.flan | 16 ++++++++++++++++ test/test_acceptance.ml | 8 ++++++++ test/test_flan.ml | 7 +++++++ 5 files changed, 59 insertions(+), 4 deletions(-) create mode 100644 test/programs/u64-decimal.flan diff --git a/lib/check.ml b/lib/check.ml index 49711623..6957088c 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3744,7 +3744,8 @@ and in_range loc k n = else if bits = 64 then (* A u64 literal is its 64-bit pattern, so anything at or above 2^63 arrives here as a negative [int64] and is still in range — - 0xcbf29ce484222325 is a real u64 and not an error. The cost is that a + 0xcbf29ce484222325 is a real u64 and not an error, and so is its + decimal, which the reader reads as the same pattern. The cost is that a negative *decimal* literal is accepted as a u64 too, because the reader records only the value and not how it was written. Narrower unsigned types keep the strict check, which is where a typo like 300 @@ -8796,7 +8797,18 @@ and named_call ?(qualified = false) ctx ~want loc name args = prim (Tast.Cast target) target [ a ] | _ when is_cast name && List.length args = 1 -> let target = resolve_name ctx.env ~seen:[] loc name in - let a = check ctx (List.hd args) in + (* An integer literal too wide for the i32 it would default to is checked + at the target instead, so (u64 2935910691) and (i64 5000000000) are the + constants they say. One that fits i32 keeps the default and the cast, + which is what (u32 -1) has always meant. *) + let want = + match (List.hd args).Ast.e, target with + | Ast.Int n, (Types.Int _ | Types.Float _) + when Int64.compare n (-2147483648L) < 0 + || Int64.compare n 2147483647L > 0 -> Some target + | _ -> None + in + let a = check ctx ?want (List.hd args) in (match a.Tast.ty with | Types.Enum _ -> () (* A dyn opens here — [cast_dyn], TODO.org, "A numeric cast opens a dyn diff --git a/lib/reader.ml b/lib/reader.ml index 0e098a79..eee007a5 100644 --- a/lib/reader.ml +++ b/lib/reader.ml @@ -153,10 +153,22 @@ let read_number st = | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st)) "malformed float literal %s" text else + (* A decimal above the largest i64 and below 2^64 is read as its 64-bit + pattern, as a hex literal is, so a u64 constant can be written in + decimal. It therefore arrives negative, and [Check.in_range] makes the + same allowance for it that it makes for hex. *) + let unsigned () = + if String.for_all (fun c -> c >= '0' && c <= '9') text then + Int64.of_string_opt ("0u" ^ text) + else None + in match Int64.of_string_opt text with | Some i -> spanned st loc (Form.Int i) - | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st)) - "malformed integer literal %s" text + | None -> + match unsigned () with + | Some i -> spanned st loc (Form.Int i) + | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st)) + "malformed integer literal %s" text let read_symbol_or_keyword st = let loc = here st in diff --git a/test/programs/u64-decimal.flan b/test/programs/u64-decimal.flan new file mode 100644 index 00000000..00b0c92a --- /dev/null +++ b/test/programs/u64-decimal.flan @@ -0,0 +1,16 @@ +;;;; A u64 constant above 2^63 written in decimal, and an integer literal too +;;;; wide for i32 as a cast's argument. + +(defconst top u64 18446744073709551615) +(defonce fnv u64 14695981039346656037) + +(defn main [] i32 + (println top) + (println fnv) + (println (u64 2935910691)) + (println (u64 18446744073709551615)) + (println (i64 -5000000000)) + (println (f64 4000000000)) + ;; A literal that fits i32 keeps its default and is cast, as before. + (println (u32 -1)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index d1163867..745846d8 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -508,6 +508,14 @@ let () = "2 3 4 7 9 3\n"; outputs ~x86:true "vec-new takes a type expression, x86" "programs/vec-new-type.flan" "2 3 4 7 9 3\n"; + (* A u64 above 2^63 in decimal, and a cast of a literal too wide for i32. *) + let u64_out = + "18446744073709551615\n14695981039346656037\n2935910691\n\ + 18446744073709551615\n-5000000000\n4e+09\n4294967295\n" + in + outputs "a u64 constant in decimal" "programs/u64-decimal.flan" u64_out; + outputs ~x86:true "a u64 constant in decimal, x86" + "programs/u64-decimal.flan" u64_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 diff --git a/test/test_flan.ml b/test/test_flan.ml index ff0cf47d..fa77e13c 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -92,6 +92,13 @@ let () = reads "bare plus" "+" "+"; reads "float" "0.05" "0.05"; reads "hex" "0xE6B800FF" "3870818559"; + (* A decimal between 2^63 and 2^64 is its bit pattern, as hex is; one past + 2^64, or a negative one past the smallest i64, is still malformed. *) + reads "u64 decimal" "18446744073709551615" "-1"; + rejects "decimal past 2^64" "18446744073709551616" + ~needle:"malformed integer literal"; + rejects "negative decimal past i64" "-9223372036854775809" + ~needle:"malformed integer literal"; reads "string" "\"SAND\"" "\"SAND\""; reads "symbol" "empty-at?" "empty-at?"; reads "qualified" "rl/draw-fps" "rl/draw-fps"; From 7b843f675331327be2e208016b7908db9e586126 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 07:17:07 +0700 Subject: [PATCH 6/7] TODO.org records what this lane settled and the one decision it left --- TODO.org | 76 +++++++++++++++++++++++++++++++------------------------- 1 file changed, 42 insertions(+), 34 deletions(-) diff --git a/TODO.org b/TODO.org index fcf9257b..097ba9b5 100644 --- a/TODO.org +++ b/TODO.org @@ -73,11 +73,13 @@ is wrong where it was written rather than aborting the compile with no location. The prelude's own =unless= has not been converted and still answers a bare undefined name. -** TODO gensym's counter restarts in a second module -The counter lives in the loaded module and a module is dlopened once per compiler -process, so it is process-wide in practice — but the rounds already build more -than one module for a program whose macros call macros. Seed it from the module's -index. +** DONE gensym's counter restarts in a second module +CLOSED: [2026-09-25] +The counter is C data in the runtime (=flan_gensym_n=), and =lib/macro.ml= writes +the compiler's own count into the module before every macro call and reads it +back after. It counts across every module a compiler process loads — each round, +the program's module, and every expansion in a session. Rules out a counter per +module, seeded or not. ** TODO A quasiquote inside a quasiquote is refused Nothing counts nesting levels — not the reader, deliberately, and not the @@ -141,11 +143,14 @@ as words the reader will not read back. =(/ 1.0 0.0)= is the only route to an infinity, and the constant folder is integers only, so it cannot be a =defconst=. Closing it needs a reader literal or a float-capable folding pass. -** TODO A u64 constant above 2^63 cannot be written in decimal -The reader reads a decimal integer literal as a signed 64-bit number; hex is read -as a bit pattern and works. The same limit has a second face: a cast's argument is -checked against the default type, so =(u64 2935910691)= is refused for not fitting -in an =i32=. +** DONE A u64 constant above 2^63 cannot be written in decimal +CLOSED: [2026-09-25] +A decimal between 2^63 and 2^64 is read as its bit pattern, as hex is. 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. It inherits +hex's hole: a decimal above 2^63 at =i64= is accepted as a negative, and a refusal +at a narrower type prints the negative number. Rules out a separate unsigned +literal in =Form=, whose layout the prelude's =Form= mirrors. ** DONE {.row .col} binds same-named locals CLOSED: [2026-09-20] @@ -790,14 +795,11 @@ program that does not type-check. Moot for anything that compiles; only the daemon's half-typed recompiles could feel it. A cheaper retry was tried and shelved because it changes which literal gets the nicer message. -** TODO and's last operand gets a misdirected caret -=(println (and true true (vec-new i32)))= puts the caret on the second =true=. The -last operand of an =and= is the then arm and the then arm is typed first, so the -mismatch is blamed on the else arm, which carries the previous operand's location. -The fix is preferring the arm that is not a compiler temp when deciding whom to -blame. Three others were considered and rejected: relabelling the else arm reads -backwards, a bool sentinel reverts the =or= fix, and inverting the condition costs -a =not= per operand. +** DONE and's last operand gets a misdirected caret +CLOSED: [2026-09-25] +Already fixed by 3672da2, which blames the arm that is not a compiler temp; the +caret is on the last operand and =test/test_flan.ml= asserts its column. Rules +out relabelling the else arm, a bool sentinel, and inverting the condition. ** TODO Signature pairing's cold-rebuild edge Whether a parameter vector reads as one annotated parameter or two dyn ones @@ -841,14 +843,20 @@ Iteration is built; the remaining refusal is generics. A =defn= has to name its types and =(defn map-keys [m (Map K V)] (Vec K))= has no =K=. The loop is three lines at the call site, where =K= is known. -** TODO (vec-new [u8]) is refused -The element type must be a bare symbol naming a type, so a =(Vec [u8])= can only -be made where the context names it. The fix is letting it take a type expression — -the same parser that already reads =[u8]= in a parameter list. +** DONE (vec-new [u8]) is refused +CLOSED: [2026-09-25] +The type positions of =vec-new= and =map-new= take a type expression: brackets, or +a parenthesised =Ptr=, =Option=, =Vec=, =Map=, =Fn= or =CFn=. Parse reads it with +=texpr= into =Ast.TypeArg=; a bare name is still left for the checker to tell a +type from an allocator. Rules out a type expression anywhere else in expression +position. ** TODO An array literal cannot say it is [f32] A float literal defaults to =f64=, an array literal has no context, and a =let= has no annotation. Same shape as =(vec-new [u8])= and probably the same fix. +Not the same fix: a bracket literal has no argument to put a type in. Decision: +how a literal names its element type — a spelling of its own, or a =let= +annotation. ** TODO A let binding takes no type annotation Everything under the surface is there — the binding carries a type slot and the @@ -1808,12 +1816,12 @@ instrumented copy; the equivalent here is a dev-build-only instrumented redefinition, which the cell indirection already makes deliverable. Open: whether stepping suspends the frame loop, and what it does to a game's clock. -** TODO A NaN cast says "does not fit", which reads as too big -=runtime/flan_rt.c:1008= covers every out-of-range float with one sentence, so -=(i32 nan)= reports the =i32= bounds as if the value had overshot them. NaN and -the infinities convert to no integer at all and want saying so by name. Found -by filling a struct holding an =f32= with =(filled 0xFF)=, where every bit set -is NaN. +** DONE A NaN cast says "does not fit", which reads as too big +CLOSED: [2026-09-25] +Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity, +each with its own sentence. Both backends choose the code on the cold path, so the +guard is still two compares. =lhs= and =rhs= still carry the range. Rules out +carrying the float value in the condition. ** TODO The break buffer prints fields, not the sentence the runtime wrote =ArithError — op 4, lhs -2147483648, rhs 2147483647= where the runtime's own @@ -1837,12 +1845,12 @@ It prints the source line and carets for the stop (=flan-cnr.el:197=) and lists frames, but no key opens the file at that line. Wants RET-on-a-frame, or =M-.=, and =next-error= over the frame list. -** TODO loop's bindings should be sequential, like let's -=check_loop= (=lib/check.ml:4741=) checks every initialiser before binding any, -so =(loop [curr-r r next-r (inc curr-r)] ...)= cannot see =curr-r= and the -refusal reads as an unknown name. Every binding form is sequential — there is -no =let*= here and there is not going to be one. Check the other binding forms -for the same gap while fixing it. +** DONE loop's bindings should be sequential, like let's +CLOSED: [2026-09-25] +=check_loop= binds each name before checking the next initialiser; =recur= still +rebinds all at once. No other form had the gap: =let= was already sequential, +=dotimes= binds one name, and =fn=, =defn=, =match= and the handler and restart +clauses bind parameters with no initialisers. ** TODO C-c C-c reports one error, not every error in the form Whole-file paths use =Check.program_all= and report every bad declaration. The From cb0be62087ed8e615d127dafbfe326957449478f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 07:43:24 +0700 Subject: [PATCH 7/7] An integer written at or above 2^63 is a u64 and nothing else, and vec-new reads a type from its argument only when the builtin is what was called --- TODO.org | 25 ++++---- lib/ast.ml | 3 +- lib/check.ml | 98 ++++++++++++++++++++++++------- lib/expand.ml | 5 +- lib/form.ml | 6 ++ lib/load.ml | 5 +- lib/parse.ml | 31 +++++----- lib/prelude.ml | 7 +-- lib/reader.ml | 10 ++-- test/programs/vec-new-shadow.flan | 14 +++++ test/test_acceptance.ml | 4 ++ test/test_flan.ml | 48 ++++++++++++++- 12 files changed, 196 insertions(+), 60 deletions(-) create mode 100644 test/programs/vec-new-shadow.flan diff --git a/TODO.org b/TODO.org index 097ba9b5..0d8c7dc6 100644 --- a/TODO.org +++ b/TODO.org @@ -145,12 +145,16 @@ Closing it needs a reader literal or a float-capable folding pass. ** DONE A u64 constant above 2^63 cannot be written in decimal CLOSED: [2026-09-25] -A decimal between 2^63 and 2^64 is read as its bit pattern, as hex is. 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. It inherits -hex's hole: a decimal above 2^63 at =i64= is accepted as a negative, and a refusal -at a narrower type prints the negative number. Rules out a separate unsigned -literal in =Form=, whose layout the prelude's =Form= mirrors. +An integer written at or above 2^63 — a decimal up to 2^64 - 1, or hex with the +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 +=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 that passes through a macro +comes back as an ordinary =Int=, because the macro side's =Form= has one integer +case. Rules out a second integer case in the prelude's =Form=. ** DONE {.row .col} binds same-named locals CLOSED: [2026-09-20] @@ -846,10 +850,11 @@ lines at the call site, where =K= is known. ** DONE (vec-new [u8]) is refused CLOSED: [2026-09-25] The type positions of =vec-new= and =map-new= take a type expression: brackets, or -a parenthesised =Ptr=, =Option=, =Vec=, =Map=, =Fn= or =CFn=. Parse reads it with -=texpr= into =Ast.TypeArg=; a bare name is still left for the checker to tell a -type from an allocator. Rules out a type expression anywhere else in expression -position. +a parenthesised =Ptr=, =Option=, =Vec=, =Map=, =Fn= or =CFn=. The arguments stay +ordinary expressions and the builtin reads the type back out of one +(=Check.type_of_expr=), so a program's own =vec-new= still gets values; only a +type an expression cannot hold, such as =(Fn [i32] ())=, is parsed as +=Ast.TypeArg=. Rules out a type expression anywhere else in expression position. ** TODO An array literal cannot say it is [f32] A float literal defaults to =f64=, an array literal has no context, and a =let= diff --git a/lib/ast.ml b/lib/ast.ml index cf923cc0..f3677360 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -36,6 +36,7 @@ type expr = { e : expr_kind; loc : Loc.t } and expr_kind = | Int of int64 + | UInt of int64 * string (* 18446744073709551615 — u64 only *) | Float of float | Byte of int | Str of string @@ -408,7 +409,7 @@ let map_children f (e : expr) : expr = in let kind = match e.e with - | Int _ | Float _ | Byte _ | Str _ | Kw _ | Quote _ | Var _ | ArrayOf _ + | Int _ | UInt _ | Float _ | Byte _ | Str _ | Kw _ | Quote _ | Var _ | ArrayOf _ | TypeArg _ | Break _ | Continue _ -> e.e | Do es -> Do (List.map ex es) | Let (bs, es) -> Let (List.map bind bs, List.map ex es) diff --git a/lib/check.ml b/lib/check.ml index 6957088c..3c7cb852 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -395,6 +395,7 @@ let spell_arg stand_for (a : Ast.expr) = match a.Ast.e with | Ast.Var v -> v | Ast.Int n -> Int64.to_string n + | Ast.UInt (_, s) -> s | _ -> stand_for (* What a [break] or a [continue] may be talking about, innermost first. @@ -1938,7 +1939,9 @@ let check_fn_ref : (env -> Ast.fn -> Tast.fn) ref = (* Untyped literals: their machine type comes from context, so when one is an operand of a binary operator we look at the *other* operand first. *) let is_literal (e : Ast.expr) = - match e.Ast.e with Ast.Int _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false + match e.Ast.e with + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true + | _ -> false (* [addr] takes the address of a place, but the parser only builds places for [set]. Recover one from the expression it parsed instead. *) @@ -3297,6 +3300,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = ctx.tail <- false; match e.Ast.e with | 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 -> int_literal loc ~want ~preds:ctx.env.tvpreds ~default:Types.U8 (Int64.of_int b) @@ -3547,11 +3551,11 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.ArrayOf t -> let ty = resolve ctx.env t in expect ctx loc ~want (mk loc ty (Tast.Zero ty)) - (* Parse writes one only into a type position of vec-new or map-new, and - those read it before it could get here. *) + (* Parse writes one only into a type position of a call named vec-new or + map-new, and the builtins read it before it could get here. A program's + own function of that name does not. *) | Ast.TypeArg _ -> - fail loc "internal: a type argument reached the checker outside vec-new or \ - map-new — this is a compiler bug" + 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.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms @@ -3732,6 +3736,29 @@ and int_literal loc ~want ?(preds = []) ?(default = Types.I32) n = (Types.to_string other) n | _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default)) +(* 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 + was written in — its pattern read as an i64 is a different number. *) +and wide_literal loc ~want n s = + match want with + | Some (Types.Int Types.U64) -> mk loc (Types.Int Types.U64) (Tast.Int (n, Types.U64)) + | Some (Types.Int k) -> + Loc.failk literal_at_want loc "%s does not fit in %s" s (Types.ikind_name k) + | Some (Types.Float _ as t) -> + Loc.failk literal_at_want loc + "%s is too large for any integer type but u64, and an integer literal \ + where %s is wanted is read as one — write (%s (u64 %s))" + s (Types.to_string t) (Types.to_string t) s + | Some Types.Never | None -> + Loc.failk literal_at_want loc + "%s does not fit in i32, the type an integer literal takes when nothing \ + says otherwise — write (u64 %s) for a u64" + s s + | Some other -> + Loc.failk literal_at_want loc + "expected %s, found the integer literal %s, which only a u64 holds" + (Types.to_string other) 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 = @@ -3742,14 +3769,10 @@ and in_range loc k n = || (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 u64 literal is its 64-bit pattern, so anything at or above 2^63 - arrives here as a negative [int64] and is still in range — - 0xcbf29ce484222325 is a real u64 and not an error, and so is its - decimal, which the reader reads as the same pattern. The cost is that a - negative *decimal* literal is accepted as a u64 too, because the - reader records only 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 actually shows up. *) + (* 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 else Int64.compare n 0L >= 0 @@ -6578,7 +6601,8 @@ and type_named ctx n = and vec_new_elem ctx ~want loc args = let named = match args with - | { Ast.e = Ast.TypeArg t; _ } :: rest -> Some (resolve ctx.env t, rest) + | a :: rest when type_of_expr a <> None -> + Some (resolve ctx.env (Option.get (type_of_expr a)), rest) | { Ast.e = Ast.Var n; _ } :: rest when lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) @@ -6596,6 +6620,39 @@ and vec_new_elem ctx ~want loc args = "nothing here says what (vec-new) is a Vec of — write the element \ type, as (vec-new i32), or give the binding a type") +(* A type written as an argument to vec-new or map-new, read back out of the + expression Parse made of it. Only the shapes that cannot be a value there: + brackets — an allocator is never an array — or a parenthesised Ptr, + Option, Vec, Map, Fn or CFn. A bare name is not one of them, because there + it may be an allocator's name; the callers ask about that themselves. *) +and type_of_expr (e : Ast.expr) : Ast.texpr option = + let mk t = { Ast.t; tloc = e.Ast.loc } in + let inner (e : Ast.expr) = + match e.Ast.e with + | Ast.Var s -> Some { Ast.t = Ast.Tname s; tloc = e.Ast.loc } + | _ -> type_of_expr e + in + let all es = + let ts = List.filter_map inner es in + if List.length ts = List.length es then Some ts else None + in + match e.Ast.e with + | Ast.TypeArg t -> Some t + | Ast.Arr [ x ] -> Option.map (fun t -> mk (Ast.Tslice t)) (inner x) + | Ast.Arr [ { Ast.e = Ast.Int n; _ }; x ] -> + Option.map (fun t -> mk (Ast.Tarray (Ast.Lint n, t))) (inner x) + | Ast.Arr [ { Ast.e = Ast.Var n; _ }; x ] -> + Option.map (fun t -> mk (Ast.Tarray (Ast.Lname n, t))) (inner x) + | Ast.Call ({ Ast.e = Ast.Var (("Fn" | "CFn") as which); _ }, + [ { Ast.e = Ast.Arr ps; _ }; r ]) -> + (match all ps, inner r with + | Some ps, Some r -> Some (mk (Ast.Tfn (which = "Fn", ps, r))) + | _ -> None) + | Ast.Call ({ Ast.e = Ast.Var (("Ptr" | "Option" | "Vec" | "Map") as c); _ }, + (_ :: _ as args)) -> + Option.map (fun ts -> mk (Ast.Tapp (c, ts))) (all args) + | _ -> None + (* The key and value types, or the reason this is not a Map. *) and map_kv loc what (t : Types.t) = match t with @@ -6616,15 +6673,15 @@ and map_new_types ctx ~want loc args = (* A type position holds a bare name or a type expression Parse has read as one, as [vec-new]'s does. *) let as_type (a : Ast.expr) = - match a.Ast.e with - | Ast.TypeArg t -> Some (resolve ctx.env t) - | Ast.Var n when is_type n -> Some (resolve_name ctx.env ~seen:[] loc n) + match a.Ast.e, type_of_expr a with + | _, Some t -> Some (resolve ctx.env t) + | Ast.Var n, None when is_type n -> Some (resolve_name ctx.env ~seen:[] loc n) | _ -> None in match args with | k :: v :: rest when as_type k <> None && as_type v <> None -> Option.get (as_type k), Option.get (as_type v), rest - | { Ast.e = Ast.TypeArg _; _ } :: _ -> + | a :: _ when type_of_expr a <> None -> fail loc "(map-new) names a key and no value — write both, as (map-new string \ i32), or give the binding a type" @@ -8806,6 +8863,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Ast.Int n, (Types.Int _ | Types.Float _) when Int64.compare n (-2147483648L) < 0 || Int64.compare n 2147483647L > 0 -> Some target + | Ast.UInt _, (Types.Int _ | Types.Float _) -> Some target | _ -> None in let a = check ctx ?want (List.hd args) in @@ -9131,7 +9189,7 @@ and generic_call ctx ~want loc name vars pats pret args = else is checked on its own terms. *) let untyped_literal = match a.Ast.e with - | Ast.Int _ | Ast.Float _ | Ast.Byte _ -> true + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false in let a = @@ -9603,7 +9661,7 @@ and binary ctx ?(dyn_ok = false) ?(join = true) name loc ~want args = let y_decides = (is_literal x && not (is_literal y)) || (match x.Ast.e, y.Ast.e with - | (Ast.Int _ | Ast.Byte _), Ast.Float _ -> true + | (Ast.Int _ | Ast.UInt _ | Ast.Byte _), Ast.Float _ -> true | _ -> false) in (* A form that cannot be checked without being told what is wanted. A diff --git a/lib/expand.ml b/lib/expand.ml index 017bfe73..98bbfe94 100644 --- a/lib/expand.ml +++ b/lib/expand.ml @@ -114,6 +114,9 @@ let rec write (sites : sites) p (f : Form.t) = | Form.Kw s -> str TKw s | Form.Str s -> str TStr s | Form.Int i -> tag TInt; Dynload.poke_i64 p payload i + (* A macro's Form has one integer case, so a wide literal crosses as its + pattern and comes back as an ordinary [Int]. *) + | Form.UInt (i, _) -> tag TInt; Dynload.poke_i64 p payload i | Form.Float x -> tag TFloat; Dynload.poke_f64 p payload x | Form.Byte b -> tag TByte; Dynload.poke_i32 p payload (Int32.of_int b) | Form.List xs -> seq TList xs @@ -251,7 +254,7 @@ let rec quote (f : Form.t) : Form.t = inner form with form-cons" | Form.Sym s -> node loc "Sym" "s" (Form.Str s) | Form.Kw s -> node loc "Kw" "s" (Form.Str s) - | Form.Int i -> node loc "Int" "i" (Form.Int i) + | Form.Int i | Form.UInt (i, _) -> node loc "Int" "i" (Form.Int i) | Form.Float x -> node loc "Float" "x" (Form.Float x) | Form.Str s -> node loc "Str" "s" (Form.Str s) | Form.Byte b -> node loc "Byte" "b" (Form.Int (Int64.of_int b)) diff --git a/lib/form.ml b/lib/form.ml index b16ace01..2eda0357 100644 --- a/lib/form.ml +++ b/lib/form.ml @@ -12,6 +12,10 @@ and value = | Sym of string (* foo rl/draw-fps .pos + *) | Kw of string (* :space :else (leading : dropped) *) | Int of int64 (* 42 -1 0xE6B800FF *) + (* An integer written at or above 2^63 — 18446744073709551615, or a hex + literal with its top bit set. Its 64-bit pattern and its spelling: only a + u64 holds it, and a refusal anywhere else prints the number as written. *) + | UInt of int64 * string | Float of float (* 0.05 *) | Str of string (* "SAND" *) | Byte of int (* \space \0 \( (0..255) *) @@ -30,6 +34,7 @@ let rec to_string f = | Sym s -> s | Kw s -> ":" ^ s | Int i -> Int64.to_string i + | UInt (_, s) -> s | Float x -> Printf.sprintf "%g" x | Str s -> Printf.sprintf "%S" s | Byte b -> @@ -126,6 +131,7 @@ let rec to_source f = | Sym s -> s | Kw s -> ":" ^ s | Int i -> Int64.to_string i + | UInt (_, s) -> s | Float x -> float_repr x | Str s -> "\"" ^ escape s ^ "\"" | Byte b -> byte_repr b diff --git a/lib/load.ml b/lib/load.ml index 4fb38a9e..cac0d6c6 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -223,7 +223,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = let name n = qualify_name owned alias bound n in let k = match e.Ast.e with - | Ast.Int _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ | Ast.Quote _ -> e.Ast.e | Ast.Var n -> Ast.Var (name n) | Ast.Do body -> Ast.Do (gos body) @@ -754,7 +754,8 @@ let rec expr_uses acc (e : Ast.expr) = let go = expr_uses acc in let gos = List.iter go in match e.Ast.e with - | Ast.Int _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ | Ast.Quote _ -> + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ + | Ast.Quote _ -> () (* The name is not one an import can supply, but the arguments are ordinary expressions and may well use one. *) diff --git a/lib/parse.ml b/lib/parse.ml index d17399b2..acc61a0f 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -310,6 +310,7 @@ let rec expr (f : Form.t) : Ast.expr = let mk e = { Ast.e; loc = f.loc } in match f.v with | Int i -> mk (Ast.Int i) + | UInt (i, s) -> mk (Ast.UInt (i, s)) | Float x -> mk (Ast.Float x) | Byte b -> mk (Ast.Byte b) | Str s -> mk (Ast.Str s) @@ -426,28 +427,26 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = | _ -> fail f "set is (set place value)") (* ── (vec-new [u8]) and (map-new string [u8]) ─────────────────────── - The type positions of these two take a type expression as well as a bare - name. A bare name is left for the checker, which knows whether it names a - type or an allocator; a bracket or a parenthesised type constructor can - only be a type there, so it is read as one now, with [texpr], the reader - a parameter list's types go through. *) + The type positions of these two take a type expression. Whether this call + is the builtin at all is the checker's to know — a program may define its + own [vec-new] — so the arguments are read as ordinary expressions and + [Check.type_of_expr] reads a type back out of one when the builtin is + what was called. The one type an expression cannot carry is [()], as in + [(Fn [i32] ())], so an argument that is not an expression but is a type + is kept as a [TypeArg]. *) | Sym (("vec-new" | "builtin/vec-new" | "map-new" | "builtin/map-new") as n) -> let slots = if n = "vec-new" || n = "builtin/vec-new" then 1 else 2 in - let is_type (a : Form.t) = - match a.v with - | Vec _ -> true - | List ({ v = Sym ("Ptr" | "Option" | "Vec" | "Map" | "Fn" | "CFn"); _ } - :: _ :: _) -> true - | _ -> false - in let args = List.mapi - (fun i a -> - if i < slots && is_type a then - { Ast.e = Ast.TypeArg (texpr a); loc = a.loc } - else expr a) + (fun i (a : Form.t) -> + match expr a with + | e -> e + | exception (Loc.Error _ as not_expr) when i < slots -> + (match texpr a with + | t -> { Ast.e = Ast.TypeArg t; loc = a.loc } + | exception Loc.Error _ -> raise not_expr)) args in mk (Ast.Call (expr head, args)) diff --git a/lib/prelude.ml b/lib/prelude.ml index 8f6cd1e2..29dbfe74 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -234,10 +234,9 @@ let source = {flan| ;; LLVM; at this width there is no such case to guard. ;; ;; The multiplier is written in hex, which is how it is written everywhere - ;; it appears: in decimal it is 12605985483714917081, and a decimal - ;; literal that large is refused here because the reader reads one as a - ;; signed 64-bit number. Hex is read as a bit pattern, and this is a bit - ;; pattern. It is written here rather than given a name of its own: a + ;; it appears: in decimal it is 12605985483714917081. Either spelling is + ;; a u64 literal and nothing else. It is written here rather than given a + ;; name of its own: a ;; prelude constant is a name in every program, and this is an ;; implementation number that nothing outside these four lines wants. (let [w (* (bit-xor (>> s (+ (>> s 59) 5)) s) 0xAEF17502108EF2D9)] diff --git a/lib/reader.ml b/lib/reader.ml index eee007a5..40890424 100644 --- a/lib/reader.ml +++ b/lib/reader.ml @@ -144,6 +144,8 @@ let read_number st = in if is_hex then match Int64.of_string_opt text with + (* A top bit set is a value at or above 2^63, which only a u64 holds. *) + | Some i when Int64.compare i 0L < 0 -> spanned st loc (Form.UInt (i, text)) | Some i -> spanned st loc (Form.Int i) | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st)) "malformed hex literal %s" text @@ -153,10 +155,8 @@ let read_number st = | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st)) "malformed float literal %s" text else - (* A decimal above the largest i64 and below 2^64 is read as its 64-bit - pattern, as a hex literal is, so a u64 constant can be written in - decimal. It therefore arrives negative, and [Check.in_range] makes the - same allowance for it that it makes for hex. *) + (* A decimal above the largest i64 and below 2^64 is a [UInt], as a hex + literal with its top bit set is: only a u64 holds it. *) let unsigned () = if String.for_all (fun c -> c >= '0' && c <= '9') text then Int64.of_string_opt ("0u" ^ text) @@ -166,7 +166,7 @@ let read_number st = | Some i -> spanned st loc (Form.Int i) | None -> match unsigned () with - | Some i -> spanned st loc (Form.Int i) + | Some i -> spanned st loc (Form.UInt (i, text)) | None -> Loc.failk "reader/malformed-number" (Loc.upto loc (here st)) "malformed integer literal %s" text diff --git a/test/programs/vec-new-shadow.flan b/test/programs/vec-new-shadow.flan new file mode 100644 index 00000000..9be6e154 --- /dev/null +++ b/test/programs/vec-new-shadow.flan @@ -0,0 +1,14 @@ +;;;; A program's own vec-new is an ordinary function: a bracket passed to it +;;;; is an array value, not an element type. builtin/vec-new is still the +;;;; builtin and still reads one as a type. + +(defn vec-new [xs [1 i32]] i32 (at xs 0)) + +(defn main [] i32 + (let [x 7 + v (builtin/vec-new [u8])] + (println (vec-new [x])) + (push v (bytes-view "ab")) + (println (length (at v 0))) + (free v)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 745846d8..58fbe8bb 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -508,6 +508,10 @@ let () = "2 3 4 7 9 3\n"; outputs ~x86:true "vec-new takes a type expression, x86" "programs/vec-new-type.flan" "2 3 4 7 9 3\n"; + (* A program's own vec-new takes its arguments as values; the builtin, + reached as builtin/vec-new, still reads a bracket as a type. *) + outputs "a vec-new of the program's own" "programs/vec-new-shadow.flan" + "7\n2\n"; (* A u64 above 2^63 in decimal, and a cast of a literal too wide for i32. *) let u64_out = "18446744073709551615\n14695981039346656037\n2935910691\n\ diff --git a/test/test_flan.ml b/test/test_flan.ml index fa77e13c..7e015a8f 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -94,7 +94,8 @@ let () = reads "hex" "0xE6B800FF" "3870818559"; (* A decimal between 2^63 and 2^64 is its bit pattern, as hex is; one past 2^64, or a negative one past the smallest i64, is still malformed. *) - reads "u64 decimal" "18446744073709551615" "-1"; + reads "u64 decimal" "18446744073709551615" "18446744073709551615"; + reads "hex top bit" "0xFFFFFFFFFFFFFFFF" "0xFFFFFFFFFFFFFFFF"; rejects "decimal past 2^64" "18446744073709551616" ~needle:"malformed integer literal"; rejects "negative decimal past i64" "-9223372036854775809" @@ -6045,6 +6046,51 @@ let () = rejects_check "map-new with a key type expression and no value type" ~needle:"(map-new) names a key and no value" "(defn f [] i32 (let [m (map-new [u8])] (free m) 0))"; + accepts "vec-new over a function type returning unit" + "(defn f [] i32 (let [v (vec-new (Fn [i32] ()))] (free v) 0))"; + accepts "a program's own vec-new takes an array literal" + "(defn vec-new [xs [3 i32]] i32 (at xs 2)) \ + (defn f [] i32 (vec-new [1 2 3]))"; + accepts "builtin/vec-new over a type expression" + "(defn f [] i32 (let [v (builtin/vec-new [u8])] (free v) 0))"; + + (* An integer written at or above 2^63 — decimal, or hex with the top bit + set — is a u64 and nothing else, and a refusal prints it as written. *) + accepts "a wide decimal at u64" + "(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)"; + 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 \ + 18446744073709551615)" + "(defn f [] () (println 18446744073709551615))"; + rejects_check "a wide decimal cast to i64" + ~needle:"18446744073709551615 does not fit in i64" + "(defn f [] i64 (i64 18446744073709551615))"; + rejects_check "a wide decimal cast to f64" + ~needle:"write (f64 (u64 18446744073709551615))" + "(defn f [] f64 (f64 18446744073709551615))"; + rejects_check "a wide decimal constant at i32" + ~needle:"18446744073709551615 does not fit in i32" + "(defconst x i32 18446744073709551615)"; + rejects_check "a wide decimal constant at f64" + ~needle:"write (f64 (u64 12345678901234567890))" + "(defconst x f64 12345678901234567890)"; + rejects_check "a wide decimal argument to an i8 parameter" + ~needle:"18446744073709551600 does not fit in i8" + "(defn g [a i8] i8 a) (defn f [] i8 (g 18446744073709551600))"; + rejects_check "a wide decimal operand prints as written" + ~needle:"9223372036854775808 does not fit in i32" + "(defn f [] () (println (+ 1 9223372036854775808)))"; + rejects_check "a hex literal with the top bit set at i32" + ~needle:"0xFFFFFFFFFFFFFFFF does not fit in i32" + "(defconst x i32 0xFFFFFFFFFFFFFFFF)"; + rejects_check "a hex literal with the top bit set at i64" + ~needle:"0xFFFFFFFFFFFFFFFF does not fit in i64" + "(defconst x i64 0xFFFFFFFFFFFFFFFF)"; (* And a sigil on a name nothing binds is answered as the unbound variable it is, rather than as a missing element type — with the names that *are* bound, because inside a signature that introduces one the mistake is