diff --git a/TODO.org b/TODO.org index 08a02ae2..b518cdfa 100644 --- a/TODO.org +++ b/TODO.org @@ -20,6 +20,12 @@ Dyn text stays immutable, with chars and text converting to and from a dyn vector of characters; length and indexing count characters on dyn text and bytes on str. Waits on the dyn-unless-annotated design. +** DONE String is a prelude struct over (Vec u8), kept valid by the checker +CLOSED: [2026-09-26] +Its field and constructor are refused outside the prelude; a str or a code point is checked at +run time at the append that stores it (literals at compile time), a [const u8] is refused for +(str b). Rules out a String type in the backends, s[i] = c, and a byte path that skips the check. + ** DONE Any typed container crosses into dyn as a view CLOSED: [2026-09-26] A str element reads as a copy and is never written, an aggregate element is written diff --git a/docs/BUILT.md b/docs/BUILT.md index e9f3ef4f..d4fb8678 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -7522,3 +7522,25 @@ struct literal's field, an array literal's element, a runtime call's argument (d sibling, a whole struct passed by value, a struct nested in a literal, a call through a function value, and an array literal indexed while the index runs, directly and through a struct literal's field. Without the pins every line prints freed memory. + +## String is a prelude struct, and the checker is its wall + +`String` is `(defstruct String [bytes (Vec u8)])` in `lib/prelude.ml`, so its +allocator, free, retry on exhaustion and dev-registry notes are the Vec's and +neither backend has a String of its own. What makes it always valid UTF-8 is +`lib/check.ml`'s String section: outside the prelude the field and the +constructor are refused, `(at s i)` and `(set (at s i) c)` are refused, and every +byte arrives through `string-new`, `append`, `insert` or `bytes->string`. Text +the checker cannot prove valid — any str, since `(str b)` does not check — is +checked by `flan_utf8_check` at the site that stores it; a code point by +`flan_rune_check` inside `flan_string_put_rune`. Literals are checked at compile +time. The prelude's builders end in `(bytes->string b)`, so a builder given bytes +that are not UTF-8 stops at the prelude's line, not the caller's. + +Positions are characters: `flan_string_index` walks to one and signals +BoundsError with the character count as the length, which is why it joins +`flan_vec_at` in both backends' `rt_signals`. `flan_vec_append` and +`flan_vec_insert` find a source inside the Vec's own block before growing it, so +`(append s s)` and `(append s (str s))` read the bytes they meant to. `render.ml` +and `inspect.ml` print a String as its text; `box` copies it into dyn text with +`flan_dyn_from_string`. diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 96e0c01c..ee167b5e 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -1771,7 +1771,7 @@ lambda or a `Fn(...)' type, and not after a match arm's." (flan-fln--return-type-matcher 1 font-lock-type-face) ;; The package half of a qualified name, as `flan-mode' draws it. ("\\_<\\([a-zA-Z][a-zA-Z0-9!?*+=<>._-]*/\\)" 1 font-lock-type-face) - ("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|str\\|dyn\\|Never\\|Allocator\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>" + ("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|str\\|dyn\\|Never\\|Allocator\\|String\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>" . font-lock-type-face) ("\\_<\\$[^][ \t\n(){},;\":]*" . font-lock-type-face) ;; A character literal, `\c' or `\space'. diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 4e0d3b30..d1b10b3d 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -164,6 +164,8 @@ face says.") "alloc-live-blocks" "with-allocator" ;; Vec "vec-new" "push" "reserve" "free" "clone" + ;; String + "string-new" "bytes->string" "append" "insert" "remove" "runes" "rune-count" ;; Map "map-new" "put" "get" "map-remove" "map-next" "has-key?" ;; dyn @@ -253,7 +255,7 @@ reason and is the odd one — it is legal only as the last item of a `def' or a ;; word outright — unit is spelled `()'. Drawing it as a valid type would ;; advertise a spelling the parser rejects, which is the same reason ;; `find-restart' and `await' are left out of `flan--special'. - ("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|str\\|dyn\\|const\\|int\\|float\\|Never\\|Allocator\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>" + ("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|str\\|dyn\\|const\\|int\\|float\\|Never\\|Allocator\\|String\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>" . font-lock-type-face) ;; A type variable, `$t', which is what a generic `defn' names its ;; parameter types with and what `{:where (ordered? $t)}' constrains. diff --git a/lib/check.ml b/lib/check.ml index aa7423a1..5b3089a0 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4046,6 +4046,30 @@ let refuse_frame_escapes (f : Tast.fn) = if returns then match List.rev f.Tast.body with x :: _ -> tails x | [] -> () +(* ── String, the prelude's owned text ──────────────────────────────── + A (defstruct String [bytes (Vec u8)]) in the prelude, kept valid UTF-8 by + the arms in [named_call] that are the only way to change one — see + [string_call]. Every run-time operation reaches the Vec, which is the + struct's one field: the backends see a struct holding a Vec and nothing + else, which is why neither has a String of its own. *) +let string_ty = Types.Named "String" +let is_string_ty t = Types.equal t string_ty +let string_vec_ty = Types.Vec (Types.Int Types.U8) +let u8_ty = Types.Int Types.U8 +let string_or_ptr t = + match t with + | Types.Ptr (_, t) -> is_string_ty t + | t -> is_string_ty t + +(* The String's (Vec u8), through a pointer to one too. *) +let string_vec loc (s : Tast.expr) = + let s = + match s.Tast.ty with + | Types.Ptr (_, t) when is_string_ty t -> mk loc t (Tast.Deref s) + | _ -> s + in + mk loc string_vec_ty (Tast.Field (s, 0)) + let box ?ctx loc (e : Tast.expr) : Tast.expr = let dyn sym args = rt loc Types.Dyn sym args in let structs = @@ -4053,6 +4077,9 @@ let box ?ctx loc (e : Tast.expr) : Tast.expr = in match e.Tast.ty with | Types.Dyn -> e + (* 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. *) + | t when is_string_ty t -> dyn "flan_dyn_from_string" [ string_vec loc 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 ] (* The ABI takes an [int32_t], because a C signature that says [_Bool] is a @@ -8021,6 +8048,7 @@ and generic_ctor ctx ~want loc name given = field it did not reach, and points at the spelling that does mean "zero the rest". Odin's positional literal takes the same line. *) and positional_struct ctx ~want loc name args = + if String.equal name "String" then refuse_string_inside loc; let s = Hashtbl.find ctx.env.structs name in let fields = s.Tast.fields in let n = List.length fields in @@ -8134,6 +8162,7 @@ and check_bare ctx ~want loc kvs = only in what is built at the end. Deciding here rather than in the parser is what lets the decision be made against the tables, exactly. *) and check_struct ctx ~want loc name kvs = + if String.equal name "String" then refuse_string_inside loc; match Hashtbl.find_opt ctx.env.structs name with | None when Hashtbl.mem ctx.env.gstructs name -> check_struct ctx ~want loc @@ -9637,6 +9666,10 @@ and fields_named env n : Tast.structure option = looks first for a dyn, whose [.name] is a map entry and not a field. *) and struct_of ctx (target : Ast.expr) (t : Tast.expr) : Tast.expr * string = let has n = fields_named ctx.env n <> None in + (match t.Tast.ty with + | Types.Named "String" | Types.Ptr (_, Types.Named "String") -> + refuse_string_inside target.Ast.loc + | _ -> ()); match t.Tast.ty with | Types.Named n when has n -> t, n | Types.Ptr (_, (Types.Named n)) when has n -> @@ -9894,6 +9927,8 @@ and indexed ?place ?(store = true) ctx (target : Tast.expr) (idx : Ast.expr list | Types.String -> if store then Option.iter (fun l -> refuse_string_place l ty) place; Types.Int Types.U8 + | Types.Named "String" -> + refuse_string_index i.Ast.loc ~store:(store && place <> None) | other -> fail i.Ast.loc "%s cannot be indexed" (tyname i.Ast.loc other) in @@ -10691,6 +10726,26 @@ and dup_elems ctx loc elem (src : Tast.expr) (a : Tast.expr) = checked first. Both the value form [(at v i)] and the place form [(set (at v i) x)] come through here, so they cannot drift apart — which is the asymmetry [nth] was removed for. *) +(* A new, empty (Vec elem) from the opened allocator [a]: (vec-new)'s lowering, + which (string-new) shares for the Vec under a String. *) +and vec_init ?note ctx loc elem (a : Tast.expr) = + let note = Option.value note ~default:elem in + let v = fresh_slot ctx (Types.Vec elem) in + let attempt = + rt loc (Types.Int Types.I8) "flan_vec_init" + [ mk loc (Types.Vec elem) (Tast.Local v); a; i64_at loc 0L; + size_of loc elem; align_of loc elem; here loc ] + in + mk loc (Types.Vec elem) + (Tast.Let ([ (v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))) ], + [ with_note loc (alloc_guard ctx loc attempt) + (reg_note loc "flan_dev_reg_note_vec" + (mk loc (Types.Vec elem) (Tast.Local v)) + [ size_of loc elem ] note); + region_check ctx.env loc + (mk loc (Types.Vec elem) (Tast.Local v)) + (mk loc (Types.Vec elem) (Tast.Local v)) ])) + and vec_at ctx loc (target : Tast.expr) (idx : Ast.expr list) = let elem = vec_elem loc "at" target.Tast.ty in match idx with @@ -10782,6 +10837,344 @@ and vec_slice ctx ~want loc (target : Tast.expr) elem (bounds : Ast.expr list) = (Tast.Zero (Types.Slice (Types.Mut, elem)))) ], [ fill; mk loc (Types.Slice (Types.Mut, elem)) (Tast.Local out) ]))) +(* ── String ─────────────────────────────────────────────────────────── + The prelude's (defstruct String [bytes (Vec u8)]) is valid UTF-8 because + nothing outside the prelude can reach the Vec: its field cannot be named + and the struct cannot be built ([refuse_string_inside]), and it is not + indexed ([refuse_string_index]). Every byte arrives through an arm below. + + Text the checker cannot prove valid is checked at run time, at the site + that stores it, and a bad byte stops the program there (flan_utf8_check, + flan_rune_check) — a str may hold any bytes, since (str b) does not check. + A string literal and an integer literal are checked here instead, so text + written in the source costs nothing at run time. A [const u8] is refused + rather than checked: bytes become text through (str b) or (bytes->string + v), which says at the call that a check is wanted. + + Positions are characters and lengths are bytes, the rule str has. The + character index is found by a walk (flan_string_index), which signals + BoundsError with the character count as the length. *) +and refuse_string_inside loc = + if not (String.equal loc.Loc.file Prelude.file) then begin + let fln = fln_source loc in + Loc.failk "check/string-private" loc + "a String keeps its bytes to itself, which is how they stay valid \ + UTF-8. Make one with %s, read it with %s or %s, and change it with \ + append, insert and remove" + (if fln then "string-new(text)" else "(string-new text)") + (if fln then "str(s)" else "(str s)") + (if fln then "bytes-view(s)" else "(bytes-view s)") + end + +and refuse_string_index loc ~store = + let fln = fln_source loc in + if store then + Loc.failk "check/string-set-index" loc + "a String cannot be changed one byte at a time. A character in UTF-8 \ + is one to four bytes, so writing a single byte can leave text that is \ + not valid. Change it by character position instead: %s, then %s" + (if fln then "remove(s, i)" else "(remove s i)") + (if fln then "insert(s, i, c)" else "(insert s i c)") + else + Loc.failk "check/string-index" loc + "a String is not indexed, because in UTF-8 a byte position and a \ + character position are different numbers. Read byte i with %s, or \ + walk the characters with %s" + (if fln then "str(s)[i]" else "(at (str s) i)") + (if fln then "runes(s)" else "(runes s)") + +(* An argument that may be a String: checked with no expectation when its + type does not depend on one — a name, a call, a field — and against + [otherwise] when it does, as the builtin always checked it. *) +and maybe_string ctx ~otherwise (x : Ast.expr) = + match x.Ast.e with + | Ast.Var _ | Ast.Call _ | Ast.Field _ -> + let e = check ctx x in + if string_or_ptr e.Tast.ty then e + else expect ctx x.Ast.loc ~want:(Some otherwise) e + | _ -> check ctx ~want:otherwise x + +(* A String's bytes as a [const u8]: a view of the Vec, costing nothing, and + good until the String next grows — (slice v)'s contract. *) +and string_bytes ctx loc (s : Tast.expr) = + let v = vec_slice ctx ~want:None loc (string_vec loc s) u8_ty [] in + { v with Tast.ty = Types.Slice (Types.Const, u8_ty) } + +(* A str, a String or a [const u8], as a [const u8]: what rune-count and + runes read. *) +and text_bytes ctx what (x : Ast.expr) = + let e = + match x.Ast.e with + | Ast.Str _ -> check ctx ~want:Types.String x + | _ -> check ctx x + in + let loc = x.Ast.loc in + match e.Tast.ty with + | Types.String -> + mk loc (Types.Slice (Types.Const, u8_ty)) (Tast.Prim (Tast.Bytes, [ e ])) + | t when string_or_ptr t -> string_bytes ctx loc e + | Types.Slice (_, Types.Int Types.U8) -> + { e with Tast.ty = Types.Slice (Types.Const, u8_ty) } + | other -> + fail loc "%s takes a str, a String or a [const u8], found %s" what + (tyname loc other) + +(* The String an operation changes, written as the String or a pointer to + one, and refused when it is reached through something read-only. *) +and string_target ctx loc what (t : Tast.expr) = + let t = + match t.Tast.ty with + | Types.Ptr (_, ty) when is_string_ty ty -> mk loc ty (Tast.Deref t) + | ty when is_string_ty ty -> t + | other -> + fail loc "%s takes a String to change, found %s" what (tyname loc other) + in + refuse_const_change ctx loc t; + t + +(* What append and insert were given to store: text, as a [const u8] and + whether it is known valid, or a code point. *) +and string_piece ctx what (x : Ast.expr) = + let loc = x.Ast.loc in + let rune e = + (match literal e with + | Some c when c < 0L || c > 0x10ffffL || (c >= 0xd800L && c <= 0xdfffL) -> + fail loc + "%Ld is not a Unicode scalar value, so it has no UTF-8 encoding and \ + a String cannot hold it" c + | _ -> ()); + `Rune e + in + match x.Ast.e with + | Ast.Str lit -> + if not (String.is_valid_utf_8 lit) then + fail loc + "this text is not valid UTF-8, and a String holds only valid UTF-8"; + let e = check ctx ~want:Types.String x in + `Text (mk loc (Types.Slice (Types.Const, u8_ty)) (Tast.Prim (Tast.Bytes, [ e ])), + true) + | Ast.Int _ | Ast.Byte _ -> rune (check ctx ~want:(Types.Int Types.I32) x) + | _ -> + let e = check ctx x in + match e.Tast.ty with + | Types.String -> + `Text (mk loc (Types.Slice (Types.Const, u8_ty)) (Tast.Prim (Tast.Bytes, [ e ])), + false) + | t when string_or_ptr t -> `Text (string_bytes ctx loc e, true) + | Types.Int Types.I32 -> rune e + | Types.Int k when Types.widens_to ~from:(Types.Int k) ~into:(Types.Int Types.I32) -> + rune (widen loc (Types.Int Types.I32) e) + | Types.Int _ -> + fail loc + "a code point is an i32, and this is %s. Write %s" + (tyname loc e.Tast.ty) + (if fln_source loc then "i32(c)" else "(i32 c)") + | Types.Slice (_, Types.Int Types.U8) -> + fail loc + "%s takes text, and bytes are not text until they are checked. \ + Write %s, which is checked when it is stored" + what (if fln_source loc then "str(b)" else "(str b)") + | other -> + fail loc "%s takes a str, a String or a code point, found %s" what + (tyname loc other) + +(* One allocating store into a String's Vec, under the retry guard, with the + dev registry told of the block it ends up in — push's shape. Every argument + is bound to a slot before the loop, so a retry re-attempts only the call. *) +and string_store ctx loc (v : Tast.expr) (binds : (int * Tast.expr) list) + (checks : Tast.expr list) (attempt : Tast.expr) = + mk loc Types.Unit + (Tast.Let + (binds, + checks + @ [ region_check ctx.env loc v + (with_note loc (alloc_guard ctx loc attempt) + (reg_note loc "flan_dev_reg_note_vec" v [ size_of loc u8_ty ] + string_ty)) ])) + +(* A text piece or a code point stored at byte offset [off] of the String's + Vec [v], -1 for the end. *) +and string_put ctx loc (v : Tast.expr) (off : Tast.expr) piece = + let i64 = Types.Int Types.I64 in + let o = fresh_slot ctx i64 in + let ov = mk loc i64 (Tast.Local o) in + let at_end = match off.Tast.e with Tast.Int (-1L, _) -> true | _ -> false in + match piece with + | `Rune c -> + let r = fresh_slot ctx (Types.Int Types.I32) in + string_store ctx loc v [ (r, c); (o, off) ] [] + (rt loc (Types.Int Types.I8) "flan_string_put_rune" + [ v; ov; mk loc (Types.Int Types.I32) (Tast.Local r); here loc ]) + | `Text (b, valid) -> + let bty = Types.Slice (Types.Const, u8_ty) in + let bs = fresh_slot ctx bty in + let bv = mk loc bty (Tast.Local bs) in + let checks = + if valid then [] else [ rt loc Types.Unit "flan_utf8_check" [ bv; here loc ] ] + in + string_store ctx loc v [ (bs, b); (o, off) ] checks + (if at_end then + rt loc (Types.Int Types.I8) "flan_vec_append" + [ v; bv; size_of loc u8_ty; align_of loc u8_ty; here loc ] + else + rt loc (Types.Int Types.I8) "flan_vec_insert" + [ v; ov; bv; size_of loc u8_ty; align_of loc u8_ty; here loc ]) + +(* A character position as a byte offset, signalling BoundsError when it is + not one. [past_end] admits the position after the last character. *) +and string_index ctx loc (v : Tast.expr) (i : Ast.expr) ~past_end = + let i = index_expr ctx i in + rt loc (Types.Int Types.I64) "flan_string_index" + [ v; i; mk loc (Types.Int Types.I32) + (Tast.Int ((if past_end then 1L else 0L), Types.I32)); + here loc ] + +(* A prelude function by the name it was written under, which a program's + own function of that name moves aside (see [shadow_prelude]). *) +and prelude_fn ctx name = + let moved = "prelude~/" ^ name in + if Hashtbl.mem ctx.env.fns moved then moved else name + +and string_call ctx ~want loc name args = + let i64 n = mk loc (Types.Int Types.I64) (Tast.Int (n, Types.I64)) in + match name, args with + (* (string-new), (string-new text), (string-new a), (string-new text a): + vec-new's shape, the text copied in — checked at run time when it is a + str, since a str may hold any bytes. *) + | "string-new", ([] | [ _ ] | [ _; _ ]) -> + let text, a = + match args with + | [] -> None, allocator_arg ctx loc [] + | [ x ] -> + (match x.Ast.e with + | Ast.Str _ -> Some (string_piece ctx name x), allocator_arg ctx loc [] + | _ -> + let e = check ctx x in + if Types.equal e.Tast.ty Types.Alloc then None, use_alloc ctx loc e + else + (* Checked already, so classified from what it turned out to be + and never checked a second time. *) + let piece = + match e.Tast.ty with + | Types.String -> + `Text (mk loc (Types.Slice (Types.Const, u8_ty)) + (Tast.Prim (Tast.Bytes, [ e ])), false) + | t when string_or_ptr t -> `Text (string_bytes ctx loc e, true) + | other -> + fail x.Ast.loc + "string-new takes a str or a String to copy, an allocator, \ + or both, found %s" (tyname loc other) + in + Some piece, allocator_arg ctx loc []) + | [ x; a ] -> + let piece = + match string_piece ctx name x with + | `Rune _ -> + fail x.Ast.loc "string-new copies a str or a String, not a code point" + | p -> p + in + Some piece, allocator_arg ctx loc [ a ] + | _ -> assert false + in + let sl = fresh_slot ctx string_ty in + let s = mk loc string_ty (Tast.Local sl) in + let v = vec_init ~note:string_ty ctx loc u8_ty a in + let fill = + match text with + | None -> [] + | Some p -> [ string_put ctx loc (string_vec loc s) (i64 (-1L)) p ] + in + expect ctx loc ~want + (mk loc string_ty + (Tast.Let ([ (sl, mk loc string_ty (Tast.Make ("String", [ v ]))) ], + fill @ [ s ]))) + | "string-new", _ -> + fail loc "string-new is (string-new), (string-new text), (string-new a) \ + or (string-new text a)" + (* (bytes->string v): the (Vec u8) becomes the String — the same block, no + copy — once its bytes are checked, here. *) + | "bytes->string", [ x ] -> + let v = check ctx ~want:string_vec_ty x in + let sl = fresh_slot ctx string_vec_ty in + let vv = mk loc string_vec_ty (Tast.Local sl) in + let view = vec_slice ctx ~want:None loc vv u8_ty [] in + expect ctx loc ~want + (mk loc string_ty + (Tast.Let ([ (sl, v) ], + [ rt loc Types.Unit "flan_utf8_check" [ view; here loc ]; + mk loc string_ty (Tast.Make ("String", [ vv ])) ]))) + | "bytes->string", _ -> fail loc "bytes->string is (bytes->string v), over a (Vec u8)" + | "append", [ target; x ] -> + let t = check_target ctx target in + (match t.Tast.ty with + (* A run of bytes onto a (Vec u8), or through a pointer to one: the + prelude's builders' tool, and raw bytes, so nothing is checked. The + runtime finds a run that lies inside the Vec's own block before it + grows it, so (append (addr b) (slice b)) reads what it meant to. *) + | Types.Vec (Types.Int Types.U8) + | Types.Ptr (_, Types.Vec (Types.Int Types.U8)) -> + let v = + match t.Tast.ty with + | Types.Ptr (_, ty) -> mk loc ty (Tast.Deref t) + | _ -> t + in + refuse_const_change ctx loc v; + note_grown ctx "append" loc v; + let bty = Types.Slice (Types.Const, u8_ty) in + let b = check ctx ~want:bty x in + let bs = fresh_slot ctx bty in + let attempt = + rt loc (Types.Int Types.I8) "flan_vec_append" + [ v; mk loc bty (Tast.Local bs); size_of loc u8_ty; + align_of loc u8_ty; here loc ] + in + expect ctx loc ~want + (mk loc Types.Unit + (Tast.Let + ([ (bs, b) ], + [ region_check ctx.env loc v + (with_note loc (alloc_guard ctx loc attempt) + (reg_note loc "flan_dev_reg_note_vec" v + [ size_of loc u8_ty ] u8_ty)) ]))) + | ty when string_or_ptr ty -> + let s = string_target ctx loc name t in + let piece = string_piece ctx name x in + expect ctx loc ~want (string_put ctx loc (string_vec loc s) (i64 (-1L)) piece) + | other -> + fail loc "append takes a String, or a (Vec u8) to add bytes to, found %s" + (tyname loc other)) + | "insert", [ target; i; x ] -> + let s = string_target ctx loc name (check_target ctx target) in + let v = string_vec loc s in + let piece = string_piece ctx name x in + let off = string_index ctx loc v i ~past_end:true in + expect ctx loc ~want (string_put ctx loc v off piece) + | "remove", [ target; i ] -> + let s = string_target ctx loc name (check_target ctx target) in + let v = string_vec loc s in + let off = string_index ctx loc v i ~past_end:false in + expect ctx loc ~want + (rt loc (Types.Int Types.I32) "flan_string_remove" [ v; off; here loc ]) + | "runes", [ x ] -> + let b = text_bytes ctx name x in + expect ctx loc ~want + (mk loc (Types.Named "Runes") (Tast.Make ("Runes", [ b ]))) + | "rune-count", [ x ] -> + let b = text_bytes ctx name x in + expect ctx loc ~want + (mk loc (Types.Int Types.I32) (Tast.Call (prelude_fn ctx "rune-count", [ b ]))) + | ("append" | "insert" | "remove" | "runes" | "rune-count"), _ -> + let shape = + match name with + | "append" -> "(append s x)" + | "insert" -> "(insert s i x)" + | "remove" -> "(remove s i)" + | "runes" -> "(runes s)" + | _ -> "(rune-count s)" + in + fail loc "%s is %s" name shape + | _ -> assert false + (* Every arm below is a name an editor can be asked about and no program ever wrote down, so each one needs a line in [builtins] further down this file. A new arm without an entry fails the build — test_flan reads both. *) @@ -11490,25 +11883,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = "(vec-new dyn) takes no allocator — its storage is the dyn \ runtime's"; expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_vec_new" []) - end else begin - let a = allocator_arg ctx loc args in - let v = fresh_slot ctx (Types.Vec elem) in - let attempt = - rt loc (Types.Int Types.I8) "flan_vec_init" - [ mk loc (Types.Vec elem) (Tast.Local v); a; i64_at loc 0L; - size_of loc elem; align_of loc elem; here loc ] - in - expect ctx loc ~want - (mk loc (Types.Vec elem) - (Tast.Let ([ (v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))) ], - [ with_note loc (alloc_guard ctx loc attempt) - (reg_note loc "flan_dev_reg_note_vec" - (mk loc (Types.Vec elem) (Tast.Local v)) - [ size_of loc elem ] elem); - region_check ctx.env loc - (mk loc (Types.Vec elem) (Tast.Local v)) - (mk loc (Types.Vec elem) (Tast.Local v)) ]))) - end + end else + expect ctx loc ~want (vec_init ctx loc elem (allocator_arg ctx loc args)) (* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *) | "push" -> arity ctx loc name 2 args; @@ -11636,6 +12012,19 @@ and named_call ?(qualified = false) ctx ~want loc name args = container is region-allocated or it does not exist, so there is always a [free-all] to point at. *) (match target.Tast.ty with + | t when is_string_ty t -> + (match args with + | [ _; _ ] -> + fail loc + "a String knows the allocator it came from, so free takes only \ + the String. Write %s" + (if fln_source loc then "free(" ^ spell_arg "s" (List.hd args) ^ ")" + else "(free " ^ spell_arg "s" (List.hd args) ^ ")") + | _ -> ()); + expect ctx loc ~want + (rt loc Types.Unit "flan_vec_free" + [ string_vec loc target; size_of loc u8_ty; align_of loc u8_ty; + here loc ]) | (Types.Vec _ | Types.Map _) when region_only ctx.env target.Tast.ty -> fail loc @@ -11749,6 +12138,26 @@ and named_call ?(qualified = false) ctx ~want loc name args = let target = check_target ctx target in let a = allocator_arg ctx loc rest in (match target.Tast.ty with + (* A String's copy is a copy of its bytes, which are valid already. *) + | t when is_string_ty t -> + let v = string_vec loc target in + let d = fresh_slot ctx string_vec_ty in + let attempt = + rt loc (Types.Int Types.I8) "flan_vec_clone" + [ mk loc string_vec_ty (Tast.Local d); v; a; + size_of loc u8_ty; align_of loc u8_ty; here loc ] + in + expect ctx loc ~want + (mk loc string_ty + (Tast.Make + ("String", + [ mk loc string_vec_ty + (Tast.Let ([ (d, mk loc string_vec_ty (Tast.Zero string_vec_ty)) ], + [ with_note loc (alloc_guard ctx loc attempt) + (reg_note loc "flan_dev_reg_note_vec" + (mk loc string_vec_ty (Tast.Local d)) + [ size_of loc u8_ty ] string_ty); + mk loc string_vec_ty (Tast.Local d) ])) ]))) (* The refusal that did *not* come down with the type-level ones, and the distinction is worth being exact about, because the sentence they all used to share bundled two different failures: that a clone @@ -11842,6 +12251,13 @@ and named_call ?(qualified = false) ctx ~want loc name args = mk loc (Types.Vec elem) (Tast.Local d) ])))) | _ -> fail loc "clone is (clone v) or (clone v allocator)") + (* ── String, the prelude's owned text ───────────────────────────── + Each is [string_call]'s, which says what each one checks. *) + | "string-new" | "bytes->string" | "append" | "insert" | "remove" -> + string_call ctx ~want loc name args + | "runes" | "rune-count" -> + string_call ctx ~want loc name args + (* ── (Map K V), spec-memory.md ─────────────────────────────────── *) (* Every one of these is a named call over the same type-erased runtime the Vec uses, with the two sizes and the key's hash and equality pair produced @@ -12422,6 +12838,12 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Types.Vec _ -> let n = rt loc (Types.Int Types.I64) "flan_vec_len" [ a; here loc ] in expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) + (* Bytes, as on a str (decision 107); rune-count counts characters. *) + | t when is_string_ty t -> + let n = + rt loc (Types.Int Types.I64) "flan_vec_len" [ string_vec loc a; here loc ] + in + expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) (* Extended rather than given a name of its own, for the reason [at] and [length] were extended over Vec: one question, one word. *) | Types.Map _ -> @@ -12437,7 +12859,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) | other -> fail loc - "length takes an array, a slice, a string, a Vec or a Map, found %s" + "length takes an array, a slice, a str, a String, a Vec or a Map, \ + found %s" (tyname loc other)) | "at" -> (match args with @@ -12751,8 +13174,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = every other comparison walks a string's bytes without copying them. *) | "bytes-view" -> arity ctx loc name 1 args; - prim Tast.Bytes (Types.Slice (Types.Const, Types.Int Types.U8)) - [ check ctx ~want:Types.String (List.hd args) ] + let a = maybe_string ctx ~otherwise:Types.String (List.hd args) in + if string_or_ptr a.Tast.ty then expect ctx loc ~want (string_bytes ctx loc a) + else prim Tast.Bytes (Types.Slice (Types.Const, Types.Int Types.U8)) [ a ] (* (bytes s) / (bytes s a): a *writable copy* of the string's bytes, from the context allocator or one named — never a hidden malloc, which is @@ -12805,7 +13229,15 @@ and named_call ?(qualified = false) ctx ~want loc name args = kept past the frame is cloned first. *) | "str" -> arity ctx loc name 1 args; - prim Tast.StrOfBytes Types.String [ byte_slice ctx (List.hd args) ] + (* A String's str is a view of its bytes, as (str (slice v)) is of a + Vec's: it costs nothing and lasts until the String next grows. *) + let a = + maybe_string ctx ~otherwise:(Types.Slice (Types.Const, Types.Int Types.U8)) + (List.hd args) + in + if string_or_ptr a.Tast.ty then + prim Tast.StrOfBytes Types.String [ string_bytes ctx loc a ] + else prim Tast.StrOfBytes Types.String [ a ] | "bytes->f64" -> arity ctx loc name 1 args; prim Tast.BytesToF64 (Types.Float Types.F64) [ byte_slice ctx (List.hd args) ] @@ -12965,6 +13397,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = match a.Tast.ty with | Types.String | Types.Slice (_, (Types.Int Types.U8)) -> [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ a ]))) ] + (* A String prints as its text, raw at the top as a str does. *) + | t when is_string_ty t -> + [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ string_bytes ctx loc a ]))) ] (* The walk names the value once per piece it reads — an option's tag and then its payload, each field of a struct — so anything but a plain variable is bound to a slot first, or [(println (pop! s))] @@ -14566,13 +15001,13 @@ let builtins : (string * string * string) list = "Makes room for n more. For a map the number is entries rather than \ slots — the block is sized so that n still sits under the load \ factor."); - ("free", "free [(Vec T)|(Map K V)|[T] Allocator?] ()", + ("free", "free [(Vec T)|(Map K V)|String|[T] Allocator?] ()", "Releases the container's block. It does not recurse into elements that \ own storage — such a container is refused here, and releasing its \ region with free-all is the answer. A slice (bytes s) or (clone xs) \ made goes back to the current allocator, or the one named; a dev build \ traps on a slice from another allocator or not from one at all."); - ("clone", "clone [(Vec T)|(Map K V)|[T] Allocator?] (Vec T)|(Map K V)|[T]", + ("clone", "clone [(Vec T)|(Map K V)|String|[T] Allocator?] (Vec T)|(Map K V)|String|[T]", "A deep, independent copy, from the current allocator or one named. \ A slice's copy is a slice over a new block, released by (free s) or by \ its allocator's free-all. Refused for elements that own \ @@ -14583,6 +15018,36 @@ let builtins : (string * string * string) list = elements own storage, because pushing them as they stand would share \ their blocks. Not meant to be written by hand."); + (* String *) + ("string-new", "string-new [(str|String)? Allocator?] String", + "A String: owned, growable text that is always valid UTF-8. Empty, or \ + a copy of the text given; from the current allocator or one named, and \ + released by (free s). A str is checked as it is copied in."); + ("bytes->string", "bytes->string [(Vec u8)] String", + "The Vec becomes a String over the same storage, once its bytes are \ + checked to be UTF-8 — here, at run time. Bytes that are not stop the \ + program at this call."); + ("append", "append [String str|String|i32] () append [(Vec u8) [const u8]] ()", + "Adds text or one code point to the end of a String. A str is checked \ + to be UTF-8 as it is stored and a code point to be a Unicode scalar \ + value; a literal is checked when the program is compiled. Onto a \ + (Vec u8), or a pointer to one, it adds raw bytes."); + ("insert", "insert [String i32 str|String|i32] ()", + "Stores text or a code point before the character at position i, \ + counting characters and not bytes; i may be the character count, \ + which is the end. Checked as append checks, and a position past the \ + end signals BoundsError."); + ("remove", "remove [String i32] i32", + "Takes out the character at position i, counting characters, and \ + answers its code point. A position past the end signals BoundsError."); + ("runes", "runes [str|String|[const u8]] Runes", + "A cursor over the text's code points: (runes-next (addr it)) answers \ + the next one, or None at the end. A malformed byte in a str comes back \ + as U+FFFD."); + ("rune-count", "rune-count [str|String|[const u8]] i32", + "How many characters — code points — the text holds, where length \ + counts bytes. A malformed byte counts as one."); + (* (Map K V) *) ("map-new", "map-new [K? V? Allocator?] (Map K V)", "An empty map. The key and value types are written at the call — \ @@ -14657,9 +15122,10 @@ let builtins : (string * string * string) list = the direction a handler can act on."); (* containers *) - ("length", "length [[n T]|[T]|str|(Vec T)|(Map K V)] i32", + ("length", "length [[n T]|[T]|str|String|(Vec T)|(Map K V)] i32", "How many elements. One question and one word across an array, a slice, \ - a string, a Vec and a Map."); + a string, a Vec and a Map. A str and a String count bytes; rune-count \ + counts characters."); ("at", "at [collection i32 ...] T", "The element at an index, bounds-checked — and for a Vec with the \ allocator's epoch checked first. On a string it is the byte, a u8. It \ @@ -14696,13 +15162,14 @@ let builtins : (string * string * string) list = StorageExhausted with retry — and (free b) releases it, through the \ current allocator or (free b a) through the one it came from. For reading without a copy, \ bytes-view."); - ("bytes-view", "bytes-view [str] [const u8]", + ("bytes-view", "bytes-view [str|String] [const u8]", "The string's own storage seen as a read-only byte slice. It costs \ nothing — both are a ptr and a length at run time — and it decodes \ nothing. A store through it is a compile error; bytes is the writable \ copy."); - ("str", "str [[const u8]] str", - "A byte slice seen as a str, and free at run time. It does not check \ + ("str", "str [[const u8]|String] str", + "A byte slice, or a String's text, seen as a str, and free at run time. \ + A String's str lasts until the String next changes. It does not check \ UTF-8, because `str` does not claim UTF-8 — valid-utf8? is an \ ordinary function you call when you care."); ("bytes->f64", "bytes->f64 [[const u8]] f64", "Parses a float out of the bytes."); diff --git a/lib/emit.ml b/lib/emit.ml index 97240c6e..9e97dad8 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4061,6 +4061,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) = this is where (at v i) gets what (at arr i) gets from [check_at]. *) let signals = String.equal sym "flan_vec_at" || String.equal sym "flan_vec_as_slice" + || String.equal sym "flan_string_index" in let vs = if signals then vs @ [ "ptr " ^ xfer_param ] else vs in let args' = String.concat ", " vs in @@ -5007,6 +5008,7 @@ declare i64 @flan_dyn_from_i64(i64) declare i64 @flan_dyn_from_f64(double) declare i64 @flan_dyn_from_bool(i32) declare i64 @flan_dyn_from_bytes(ptr, i64) +declare i64 @flan_dyn_from_string(ptr) declare i64 @flan_dyn_vec_new() declare i64 @flan_dyn_map_new() declare i64 @flan_dyn_map_new_class(i64, ptr, i64) @@ -5109,6 +5111,16 @@ declare i64 @flan_vec_len(ptr, ptr, i64) declare ptr @flan_vec_at(ptr, i32, i64, ptr, i64, ptr) declare void @flan_vec_as_slice(ptr, ptr, i32, i32, i64, ptr, i64, ptr) declare void @flan_vec_free(ptr, i64, i64, ptr, i64) +declare i8 @flan_vec_append(ptr, ptr, i64, i64, i64, ptr, i64) +declare i8 @flan_vec_insert(ptr, i64, ptr, i64, i64, i64, ptr, i64) +declare void @flan_vec_remove_range(ptr, i64, i64, i64, ptr, i64) +declare i64 @flan_string_index(ptr, i32, i32, ptr, i64, ptr) +declare i32 @flan_string_remove(ptr, i64, ptr, i64) +declare i8 @flan_string_put_rune(ptr, i64, i32, ptr, i64) +; String's run-time checks: a text or a code point the checker could not prove +; valid, checked at the site of the append that stores it. +declare void @flan_utf8_check(ptr, i64, ptr, i64) +declare void @flan_rune_check(i32, ptr, i64) ; (Map K V). The two ptr arguments before the location on put/get/clone are the ; hash and equality pair, which the checker emits per key type and passes here ; the way Odin hangs them off Map_Info. diff --git a/lib/inspect.ml b/lib/inspect.ml index 5e7b6880..c6114151 100644 --- a/lib/inspect.ml +++ b/lib/inspect.ml @@ -221,7 +221,9 @@ let rec walk c b depth addr (ty : Types.t) = (* An [i1] in memory is a byte, and a load keeps its low bit. *) | Types.Bool -> put b (if u8 c addr land 1 <> 0 then "true" else "false") | Types.Unit -> put b "()" - | Types.String | Types.Slice (_, Types.Int Types.U8) -> + (* The prelude's String is a (Vec u8), whose header starts with the same + pointer and length a str is. *) + | Types.String | Types.Slice (_, Types.Int Types.U8) | Types.Named "String" -> let p = ptr c addr and n = Int64.to_int (i64 c (addr + 8)) in (* Enough bytes to overrun the cap once quoted, and no more: a string of a million bytes is shown as its first few thousand either way. *) diff --git a/lib/prelude.ml b/lib/prelude.ml index b4d97d75..b8d8e2ed 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -1705,7 +1705,7 @@ let source = {flan| ;; rules that hold for all of it. ;; ;; **The result is owned and the caller frees it.** Each of these hands back a -;; (Vec u8) or a (Vec [u8]), which is move-only: it goes with the call that +;; String — or, for split, a (Vec [const u8]) — which is move-only: it goes with the call that ;; takes it, and nothing is released at scope exit — not at the end of a let, ;; not at the end of a function (spec-memory.md, "When storage is released"). ;; A caller writes (free v) or lets a (free-all a) take the whole region. @@ -1724,18 +1724,36 @@ let source = {flan| ;; (spec-memory.md, "Allocation failure"), so these signatures say what they ;; produce and nothing about how they might fail. -;; The builder. It is not a type: strings.Builder in Odin is a struct wrapping -;; a [dynamic]u8, and here the (Vec u8) *is* that, with push already on it — a -;; wrapper would be a move-only struct owning a Vec whose only method is the -;; one the Vec already has. What was actually missing is appending a run of -;; bytes rather than one, and that is this. +;; String: owned, growable, always valid UTF-8. The bytes live in a (Vec u8), +;; so the allocator, the free, the retry on exhaustion and the dev build's +;; registry are all the Vec's. What the struct adds is the promise, and the +;; checker keeps it (check.ml, [string_call]): outside this file the field +;; cannot be named and the struct cannot be built, so every byte arrives +;; through append, insert, string-new or bytes->string, each of which +;; checks text it cannot prove valid at the site that stores it. ;; -;; It takes a (Ptr (Vec u8)) and not a (Vec u8), and the difference is not -;; style: a Vec parameter *moves*, so (append b s) taking one by value would -;; consume the caller's builder on the first call and refuse the second. -(defn append [b (Ptr (Vec u8)) s [const u8]] () - (dotimes [i (length s)] - (push (deref b) (at s i)))) +;; A zeroed String is the empty one: a zeroed Vec adopts the context +;; allocator on its first append. +(defstruct String [bytes (Vec u8)]) + +;; A cursor over the code points of some UTF-8 bytes, which owns nothing: the +;; shape split-on-byte has. (runes s) makes one over a str, a String or a +;; [const u8], and runes-next hands back one code point at a time. A +;; malformed byte in a str or a [const u8] comes back as U+FFFD and counts +;; as one, as rune-count counts it; a String has none. +(defstruct Runes [rest [const u8]]) + +(defn runes-next [it (Ptr Runes)] (Option i32) + (if (= (length (.rest it)) 0) + None + (let [r (decode-rune (.rest it))] + (set (.rest it) (slice (.rest it) (.width r) (length (.rest it)))) + (Some (if (.ok r) (.code r) 0xfffd))))) + +;; append — onto a String, or a run of bytes onto a (Vec u8) — is the +;; checker's (check.ml, "append"), because what it takes decides what it +;; does: a str, a String or a code point onto a String, a [const u8] onto a +;; (Vec u8). ;; The two number appends. Outside the prelude i64->bytes and f64->bytes copy ;; their text into the temp allocator; inside it they answer a view of the @@ -1755,43 +1773,43 @@ let source = {flan| ;; join with an empty separator is concat, and concat is here anyway because ;; the empty (bytes-view "") a caller would have to write is the kind of argument ;; that reads like a mistake at the call site. -(defn concat [parts [const [const u8]]] (Vec u8) +(defn concat [parts [const [const u8]]] String (let [b (vec-new u8)] (dotimes [i (length parts)] (append (addr b) (at parts i))) - b)) + (bytes->string b))) ;; n parts yield n-1 separators, and the empty slice of parts yields the empty ;; result rather than a leading separator — which is the off-by-one a join ;; written as "append part then separator, then chop the tail" gets wrong on ;; exactly that input, because there is no tail to chop. -(defn join [parts [const [const u8]] sep [const u8]] (Vec u8) +(defn join [parts [const [const u8]] sep [const u8]] String (let [b (vec-new u8)] (dotimes [i (length parts)] (when (> i 0) (append (addr b) sep)) (append (addr b) (at parts i))) - b)) + (bytes->string b))) -(defn repeat-bytes [s [const u8] n i32] (Vec u8) +(defn repeat-bytes [s [const u8] n i32] String (let [b (vec-new u8)] (dotimes [i n] (append (addr b) s)) - b)) + (bytes->string b))) ;; The allocating halves of the ASCII case pair. The note above lower-ascii ;; says why there is no in-place one; these write only bytes of their own. -(defn to-lower [s [const u8]] (Vec u8) +(defn to-lower [s [const u8]] String (let [b (vec-new u8)] (dotimes [i (length s)] (push b (lower-ascii (at s i)))) - b)) + (bytes->string b))) -(defn to-upper [s [const u8]] (Vec u8) +(defn to-upper [s [const u8]] String (let [b (vec-new u8)] (dotimes [i (length s)] (push b (upper-ascii (at s i)))) - b)) + (bytes->string b))) ;; Every non-overlapping occurrence, left to right, which is the rule that ;; makes (replace-bytes (bytes-view "aaa") (bytes-view "aa") (bytes-view "b")) answer "ba" and @@ -1806,7 +1824,7 @@ let source = {flan| ;; choice: returning a Vec *moves* it, and the move analysis is a dead set over ;; the whole function, so a `return b` on one branch kills the binding for the ;; `b` at the foot of the other. One exit, one move. -(defn replace-bytes [s [const u8] from [const u8] to [const u8]] (Vec u8) +(defn replace-bytes [s [const u8] from [const u8] to [const u8]] String (let [b (vec-new u8) i 0] (if (= (length from) 0) @@ -1822,7 +1840,7 @@ let source = {flan| (do (append (addr b) (slice s i (length s))) (set i (length s)))))) - b)) + (bytes->string b))) ;; A (Vec [u8]) cannot be written at a let, and this one-line function is where ;; the type is said instead. (vec-new) takes its element type as a *bare @@ -1895,7 +1913,7 @@ let source = {flan| ;; ;; -0.0 prints as "0.00": the sign test is (< x 0.0), which -0.0 fails. A ;; caller that needs the sign of a zero should not be reading it out of text. -(defn format-f64 [x f64 prec i32] (Vec u8) +(defn format-f64 [x f64 prec i32] String (let [b (vec-new u8) p (clamp prec 0 9)] (cond @@ -1942,7 +1960,7 @@ let source = {flan| (dotimes [i (- p (length d))] (push b \0)) (append (addr b) d)))))))) - b)) + (bytes->string b))) ;; ── Still refused, and what the reason is now ───────────────────────── ;; @@ -1950,9 +1968,9 @@ let source = {flan| ;; that did not exist in its input, and there was no allocator. That sentence ;; stopped being true when `Vec` landed, and most of the list has moved up into ;; the building section above: join, concat, split, to-lower, to-upper, repeat -;; and replace are all written now, and `string-from-bytes` turned out to be -;; the `str` builtin all along — (str (slice v)) is the round trip, -;; and the layouts being identical is exactly why it is free. +;; and replace are all written now. Bytes become text two ways: (str (slice v)) +;; views them, free and unchecked, and (bytes->string v) takes the Vec over +;; as a String once it has checked the bytes are UTF-8. ;; ;; What is left is refused for four *different* reasons, which is why they are ;; named separately rather than under one heading. @@ -1975,12 +1993,7 @@ let source = {flan| ;; per *ordered pair* of types rather than per type, ;; which is where a per-type family stops being honest. ;; -;; Builder Not refused — declined. strings.Builder in Odin -;; wraps a [dynamic]u8; here the (Vec u8) *is* that and -;; already has push, so the struct would be a move-only -;; wrapper whose only method is the one it wraps. What -;; was missing was appending a run of bytes, and -;; `append` above is that. +;; Builder A String is one: append onto it. ;; ── Files: embedding, slurp and barf ────────────────────────────────── ;; ;; One entry per file in an (embed-dir "...") — Odin's Load_Directory_File diff --git a/lib/render.ml b/lib/render.ml index f9d5ecd9..d86a0c6b 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -320,6 +320,29 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis when List.exists (fun (u : Tast.structure) -> String.equal u.Tast.sname n) c.unions -> [ lit ("<" ^ n ^ " union>") ] + (* The prelude's String prints as the text it holds, quoted as a str is + inside a structure, rather than as the Vec its one field is. The view + is flan_vec_as_slice's, into a slot of the caller's frame. *) + | Types.Named "String" -> + let u8 = Types.Int Types.U8 in + let bty = Types.Slice (Types.Mut, u8) in + let out = c.alloc bty in + let outv = { Tast.e = Tast.Local out; ty = bty; loc } in + let i64 p = { Tast.e = Tast.Prim (p, []); ty = Types.Int Types.I64; loc } in + let fill = + { Tast.e = + Tast.Prim + (Tast.Rt "flan_vec_as_slice", + [ { Tast.e = Tast.Field (e, 0); ty = Types.Vec u8; loc }; + { Tast.e = Tast.Prim (Tast.AddrOf, [ outv ]); + ty = Types.Ptr (Types.Mut, bty); loc }; + i32 0; i32 (-1); i64 (Tast.SizeOf u8); + { Tast.e = Tast.Str (Loc.to_string loc); ty = Types.String; loc } ]); + ty = Types.Unit; loc } + in + [ unit_ + (Tast.Let ([ (out, { Tast.e = Tast.Zero bty; ty = bty; loc }) ], + [ fill; c.emit.estr outv ])) ] | Types.Named n -> (match List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n) diff --git a/lib/x86.ml b/lib/x86.ml index 8a512401..9acd192e 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -3170,6 +3170,7 @@ and clear_at f = is where [(at v i)] gets what [(at arr i)] gets from [check_at]. *) and rt_signals sym = String.equal sym "flan_vec_at" || String.equal sym "flan_vec_as_slice" + || String.equal sym "flan_string_index" and call_rt f ~sym ~args ~rty dst = call_native f ~sym ~chan:(rt_signals sym) ~args ~rty dst; diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 8c2a24e6..f5524a45 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -1673,6 +1673,13 @@ flan_dyn flan_dyn_from_bytes(const uint8_t *p, int64_t n) { return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } +/* A String crossing into dyn: its (Vec u8), by address, copied into dyn text. + * A copy and not a view, because dyn text is immutable and a String is not. */ +flan_dyn flan_dyn_from_string(const void *vec) { + const flan_dyn_vec_hdr *v = (const flan_dyn_vec_hdr *)vec; + return flan_dyn_from_bytes((const uint8_t *)v->ptr, v->len); +} + flan_dyn flan_dyn_vec_new(void) { flan_obj *o = gc_alloc(OBJ_VEC, 0); o->len = 0; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 5e6a118b..e7d90eaf 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -94,6 +94,8 @@ flan_dyn flan_dyn_from_bool(uint8_t b); * anywhere — a literal in .rodata, a frame slot, a slice the caller is about * to drop — because the bytes are copied before this returns. */ flan_dyn flan_dyn_from_bytes(const uint8_t *p, int64_t n); +/* A String's (Vec u8), by address, copied into dyn text. */ +flan_dyn flan_dyn_from_string(const void *vec); flan_dyn flan_dyn_vec_new(void); flan_dyn flan_dyn_map_new(void); diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index b841fec7..4232b07f 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2796,6 +2796,208 @@ void flan_vec_as_slice(flan_vec *v, void *out, int32_t lo, int32_t hi, memcpy(out, &s, sizeof s); } +/* ── String: the prelude's owned text, always valid UTF-8 ────────────── + * + * A String is a (Vec u8) the checker keeps valid (check.ml, [string_call]). + * These are the run-time halves of that: a text or a code point that could + * not be proved valid when the program was compiled is checked here, at the + * site of the append that would have stored it, and a bad one stops the + * program there. A trap and not a condition: nothing a handler could do + * makes the bytes valid, and storing them anyway is the one outcome the type + * exists to rule out. */ + +/* The index of the first byte that does not begin a well-formed UTF-8 + * sequence, or -1. The rules are the prelude's decode-rune's: no overlong + * forms, no surrogates, nothing past U+10FFFF. */ +static int64_t utf8_bad_at(const uint8_t *p, int64_t n) { + int64_t i = 0; + while (i < n) { + uint8_t b0 = p[i]; + int size; + uint8_t lo = 0x80, hi = 0xbf; + if (b0 < 0x80) { i++; continue; } + if (b0 < 0xc2) return i; + else if (b0 <= 0xdf) size = 2; + else if (b0 == 0xe0) { size = 3; lo = 0xa0; } + else if (b0 <= 0xec) size = 3; + else if (b0 == 0xed) { size = 3; hi = 0x9f; } + else if (b0 <= 0xef) size = 3; + else if (b0 == 0xf0) { size = 4; lo = 0x90; } + else if (b0 <= 0xf3) size = 4; + else if (b0 == 0xf4) { size = 4; hi = 0x8f; } + else return i; + if (i + size > n) return i; + if (p[i + 1] < lo || p[i + 1] > hi) return i; + if (size > 2 && (p[i + 2] < 0x80 || p[i + 2] > 0xbf)) return i; + if (size > 3 && (p[i + 3] < 0x80 || p[i + 3] > 0xbf)) return i; + i += size; + } + return -1; +} + +void flan_utf8_check(const uint8_t *p, int64_t n, const uint8_t *loc, + int64_t loclen) { + int64_t at = utf8_bad_at(p, n); + if (at < 0) return; + flan_say(loc, loclen, + "this text is not valid UTF-8 — byte %lld is 0x%02x — and a String " + "holds only valid UTF-8", + (long long)at, (unsigned)p[at]); + rt_trap((const uint8_t *)"InvalidUtf8", 11); +} + +void flan_rune_check(int32_t c, const uint8_t *loc, int64_t loclen) { + if (c >= 0 && c <= 0x10ffff && !(c >= 0xd800 && c <= 0xdfff)) return; + flan_say(loc, loclen, + "%lld is not a Unicode scalar value, so it has no UTF-8 encoding " + "and a String cannot hold it", + (long long)c); + rt_trap((const uint8_t *)"InvalidRune", 11); +} + +/* [n] elements from [src] onto the end of a Vec, growing it once. [src] may + * point into the Vec's own block — (append s (str s)) — so where it lies is + * found before the grow and read again after it: the grow frees the old + * block. 1 when it fit, 0 when the allocator refused, as flan_vec_push. */ +int8_t flan_vec_append(flan_vec *v, const void *src, int64_t n, int64_t size, + int64_t align, const uint8_t *loc, int64_t loclen) { + flan_vec_check(v, loc, loclen); + if (n <= 0) return 1; + if (v->len + n > v->cap) { + uintptr_t base = (uintptr_t)v->ptr, at = (uintptr_t)src; + int inside = v->ptr != NULL && at >= base + && at < base + (uintptr_t)(v->cap * size); + uintptr_t off = at - base; + if (!flan_vec_grow(v, v->len + n, size, align)) return 0; + if (inside) src = (uint8_t *)v->ptr + off; + } + memmove((uint8_t *)v->ptr + v->len * size, src, (size_t)(n * size)); + v->len += n; + return 1; +} + +static void rt_reverse(uint8_t *p, int64_t n) { + int64_t i = 0, j = n - 1; + while (i < j) { + uint8_t t = p[i]; + p[i++] = p[j]; + p[j--] = t; + } +} + +/* The same, stored at element [at] with the tail moved up. Appended and then + * rotated into place, three reversals, so a [src] inside the Vec's own block + * is never read after it has been moved. */ +int8_t flan_vec_insert(flan_vec *v, int64_t at, const void *src, int64_t n, + int64_t size, int64_t align, const uint8_t *loc, + int64_t loclen) { + int64_t old; + uint8_t *b; + flan_vec_check(v, loc, loclen); + if (at < 0 || at > v->len) at = v->len; + old = v->len; + if (!flan_vec_append(v, src, n, size, align, loc, loclen)) return 0; + if (n <= 0 || at == old) return 1; + b = (uint8_t *)v->ptr + at * size; + rt_reverse(b, (old - at) * size); + rt_reverse(b + (old - at) * size, n * size); + rt_reverse(b, (old - at + n) * size); + return 1; +} + +/* [n] elements from [at] out of a Vec, the rest moved down over them. Nothing + * is allocated, so nothing can fail but the stale-allocator check. */ +void flan_vec_remove_range(flan_vec *v, int64_t at, int64_t n, int64_t size, + const uint8_t *loc, int64_t loclen) { + flan_vec_check(v, loc, loclen); + if (at < 0 || n <= 0 || at >= v->len) return; + if (n > v->len - at) n = v->len - at; + memmove((uint8_t *)v->ptr + at * size, (uint8_t *)v->ptr + (at + n) * size, + (size_t)((v->len - at - n) * size)); + v->len -= n; +} + +/* The width of the sequence a lead byte begins, for bytes already known to + * be valid UTF-8. */ +static int64_t utf8_width(uint8_t b) { + return b < 0x80 ? 1 : b < 0xe0 ? 2 : b < 0xf0 ? 3 : 4; +} + +/* A character position in a String, as a byte offset. [past_end] says + * whether the position one past the last character is one — it is for an + * insert and not for a remove. Out of range signals BoundsError with the + * character count as the length, which is what the position was counted + * against, and with [xfer] for the caller's guard; with nothing answering it + * the program stops here. */ +int64_t flan_string_index(flan_vec *v, int32_t i, int32_t past_end, + const uint8_t *loc, int64_t loclen, void *xfer) { + const uint8_t *p = (const uint8_t *)v->ptr; + int64_t off = 0, count = 0, want = i, found = -1; + flan_vec_check(v, loc, loclen); + while (off < v->len) { + if (count == want) found = off; + off += utf8_width(p[off]); + count++; + } + if (want == count && past_end) found = v->len; + if (want < 0 || found < 0) { + if (flan_bounds_signal(loc, loclen, xfer, BOUNDS_AT, want, want, count)) + return 0; + flan_vec_bounds_fail(loc, loclen, want, count); + } + return found; +} + +/* The code point at byte [off] of a String, removed. [off] came from + * flan_string_index, so it begins a sequence and the bytes are valid. */ +int32_t flan_string_remove(flan_vec *v, int64_t off, const uint8_t *loc, + int64_t loclen) { + const uint8_t *p; + int64_t w; + int32_t c; + flan_vec_check(v, loc, loclen); + if (off < 0 || off >= v->len) return 0; + p = (const uint8_t *)v->ptr + off; + w = utf8_width(p[0]); + if (w == 1) c = p[0]; + else if (w == 2) c = ((p[0] & 0x1f) << 6) | (p[1] & 0x3f); + else if (w == 3) + c = ((p[0] & 0x0f) << 12) | ((p[1] & 0x3f) << 6) | (p[2] & 0x3f); + else + c = ((p[0] & 0x07) << 18) | ((p[1] & 0x3f) << 12) | ((p[2] & 0x3f) << 6) + | (p[3] & 0x3f); + flan_vec_remove_range(v, off, w, 1, loc, loclen); + return c; +} + +/* A code point into a String at byte [off], -1 for the end: checked, encoded + * and stored. 1 when it fit, 0 when the allocator refused. */ +int8_t flan_string_put_rune(flan_vec *v, int64_t off, int32_t c, + const uint8_t *loc, int64_t loclen) { + uint8_t b[4]; + int64_t n; + flan_rune_check(c, loc, loclen); + if (c < 0x80) { b[0] = (uint8_t)c; n = 1; } + else if (c < 0x800) { + b[0] = (uint8_t)(0xc0 | (c >> 6)); + b[1] = (uint8_t)(0x80 | (c & 0x3f)); + n = 2; + } else if (c < 0x10000) { + b[0] = (uint8_t)(0xe0 | (c >> 12)); + b[1] = (uint8_t)(0x80 | ((c >> 6) & 0x3f)); + b[2] = (uint8_t)(0x80 | (c & 0x3f)); + n = 3; + } else { + b[0] = (uint8_t)(0xf0 | (c >> 18)); + b[1] = (uint8_t)(0x80 | ((c >> 12) & 0x3f)); + b[2] = (uint8_t)(0x80 | ((c >> 6) & 0x3f)); + b[3] = (uint8_t)(0x80 | (c & 0x3f)); + n = 4; + } + if (off < 0) return flan_vec_append(v, b, n, 1, 1, loc, loclen); + return flan_vec_insert(v, off, b, n, 1, 1, loc, loclen); +} + /* spec-memory.md's first release point. The Vec is left zeroed rather than * dangling: a later use of it is then a null deref rather than a * use-after-free, and a slice taken of it before the free is the dev diff --git a/test/programs/algorithms.flan b/test/programs/algorithms.flan index 7b5a56d3..ad1b38c8 100644 --- a/test/programs/algorithms.flan +++ b/test/programs/algorithms.flan @@ -114,7 +114,7 @@ (let [f (split (bytes-view "delta,alpha,charlie,bravo") \,)] (sort-bytes (slice f)) (let [j (join (slice f) (bytes-view " < "))] - (println (str (slice j))) ; alpha < bravo < charlie < delta + (println j) ; alpha < bravo < charlie < delta (free j)) (free f)) 0) diff --git a/test/programs/const-slice.flan b/test/programs/const-slice.flan index 2edd3d7f..f13ccda7 100644 --- a/test/programs/const-slice.flan +++ b/test/programs/const-slice.flan @@ -54,7 +54,7 @@ (println (str a))) (let [f (split (bytes-view "b,a,c") \,)] (sort-bytes (slice f)) - (println (str (slice (join (slice f) (bytes-view "-")))))) + (println (join (slice f) (bytes-view "-")))) (println (at r 0)) (println (call-rd rd) (call-bare rd) (call-mk mk)) (let [b (bytes "q")] diff --git a/test/programs/format.flan b/test/programs/format.flan index e558b84b..2f6bc23b 100644 --- a/test/programs/format.flan +++ b/test/programs/format.flan @@ -11,7 +11,7 @@ (defn show [x f64 p i32] () (let [v (format-f64 x p)] - (println (str (slice v))) + (println v) (free v))) (defn main [] i32 @@ -86,15 +86,14 @@ ;; And the thing it is for: a formatted number inside a built string, which ;; needs the integer part copied out before the fraction is rendered, because ;; both come through the runtime's one shared scratch buffer. - (let [b (vec-new u8)] - (append (addr b) (bytes-view "fps ")) + (let [b (string-new "fps ")] (let [f (format-f64 59.94 1)] - (append (addr b) (slice f)) + (append b f) (free f)) - (append (addr b) (bytes-view " / frame ")) + (append b " / frame ") (let [f (format-f64 0.0166667 4)] - (append (addr b) (slice f)) + (append b f) (free f)) - (println (str (slice b))) ; fps 59.9 / frame 0.0167 + (println b) ; fps 59.9 / frame 0.0167 (free b)) 0) diff --git a/test/programs/string-eq.flan b/test/programs/string-eq.flan index 81bacf53..f91da7af 100644 --- a/test/programs/string-eq.flan +++ b/test/programs/string-eq.flan @@ -22,7 +22,7 @@ ;; fire -- what answers here is the byte loop, or the length check first ;; ruling nothing out since both are three bytes. (let [heap (to-lower (bytes-view "ABC"))] - (let [h (str (slice heap))] + (let [h (str heap)] (println (= "abc" h)) ; true (println (!= "abc" h))) (free heap)) diff --git a/test/programs/string-leak.flan b/test/programs/string-leak.flan new file mode 100644 index 00000000..bbb4c628 --- /dev/null +++ b/test/programs/string-leak.flan @@ -0,0 +1,9 @@ +;;;; A dev build's registry names a String's block by its type: the one freed +;;;; is gone from the report at exit, the one kept is listed under String. +(defn main [] i32 + (let [kept (string-new "kept") + gone (string-new "gone")] + (append kept " for good") + (free gone) + (println kept)) + 0) diff --git a/test/programs/string-owned.flan b/test/programs/string-owned.flan new file mode 100644 index 00000000..bf3b5c5c --- /dev/null +++ b/test/programs/string-owned.flan @@ -0,0 +1,64 @@ +;;;; String: owned, growable, always valid UTF-8. Multi-byte append, insert +;;;; and remove by character position, iteration by runes, the byte length +;;;; beside the character count, a copy, printing inside a structure, and a +;;;; String crossing into dyn as a copy of its text. + +(defstruct Named [label String n i32]) + +(defn as-dyn [d] dyn d) + +(defn main [] i32 + (let [s (string-new "héllo")] + (append s " wörld") + (append s 0x65e5) ; 日, three bytes + (append s \!) + (println s) + (println (length s) (rune-count s)) + ;; Positions are characters: 1 is after the h, whatever é takes. + (insert s 1 "→") + (insert s 0 0x1f600) ; four bytes at the front + (println s) + (println (remove s 2)) ; the → that was inserted, as a code point + (println (remove s 0)) ; the emoji + (println s) + ;; Appending a String to itself reads the bytes it had before growing. + (let [t (string-new "ab")] + (append t t) + (append t t) + (println t (length t)) + (free t)) + ;; Iteration by runes. + (let [it (runes s) + going true + n 0] + (while going + (match (runes-next (addr it)) + (Some c) (do (when (> c 127) (print c "")) (set n (+ n 1))) + None (set going false))) + (println n)) + ;; A copy is independent of the original. + (let [c (clone s)] + (append c "?") + (println (length s) (length c)) + (free c)) + ;; The str view and the byte view cost nothing. + (println (= (str s) "héllo wörld日!")) + (println (length (bytes-view s))) + ;; Inside a structure it prints quoted, as a str field does. + (let [m (Named {.label (string-new "x") .n 3})] + (println m) + (free (.label m))) + ;; Crossing into dyn copies the text, which the dyn side then owns. + (let [d (as-dyn s)] + (append s "tail") + (println d) + (println (type-of d))) + ;; The builders answer Strings. + (let [j (join (slice [(bytes-view "a") (bytes-view "b")]) (bytes-view "-"))] + (println j) + (free j)) + (let [e (string-new)] + (println (length e) (rune-count e)) + (free e)) + (free s)) + 0) diff --git a/test/programs/string-traps.flan b/test/programs/string-traps.flan new file mode 100644 index 00000000..c444b3f9 --- /dev/null +++ b/test/programs/string-traps.flan @@ -0,0 +1,21 @@ +;;;; What a String refuses at run time, one per run: the argument chooses. +;;;; Bytes that are not UTF-8, reached through a str, stop the program at the +;;;; append; so does a code point with no encoding; a character position past +;;;; the end signals BoundsError counted in characters. The test asserts the +;;;; line and column of each. +(defonce bad [2 u8]) + +(defn main [args [str]] i32 + (let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0) + s (string-new "日本")] + (set (at bad 0) 0xc3) + (set (at bad 1) 0x28) + (println "before") + (cond + (= which 0) (append s (str (slice bad))) + (= which 1) (append s (+ 0xd800 which -1)) + (= which 2) (insert s 3 "x") + (= which 3) (println (remove s 2)) + :else (append s (bytes->string (let [v (vec-new u8)] (push v 0xff) v)))) + (println s)) + 0) diff --git a/test/programs/strings.flan b/test/programs/strings.flan index f2120be5..b6220247 100644 --- a/test/programs/strings.flan +++ b/test/programs/strings.flan @@ -2,7 +2,8 @@ ;;;; ;;;; Every one of these was refused by name in prelude.ml until there was an ;;;; allocator to return a Vec from, and this file is the corpus that says the -;;;; refusals are lifted. The cases are chosen the way the slice-algorithm +;;;; refusals are lifted. The text builders answer a String; the builder at +;;;; the top is a (Vec u8) of raw bytes. The cases are chosen the way the slice-algorithm ;;;; tests were: each is an input a plausible wrong version gets wrong. ;;;; ;;;; Everything allocated here is freed, even though leaking is defined @@ -30,7 +31,7 @@ ;; trap. (let [parts [(bytes-view "one") (bytes-view "") (bytes-view "two")]] (let [c (concat (slice parts 0 3))] - (show (addr c)) ; onetwo + (println c) ; onetwo (free c))) (let [parts [(bytes-view "unused")]] (let [c (concat (slice parts 0 0))] @@ -42,22 +43,22 @@ ;; chop the tail" join gets wrong because there is no tail. (let [parts [(bytes-view "a") (bytes-view "b") (bytes-view "c")]] (let [j (join (slice parts 0 3) (bytes-view ", "))] - (show (addr j)) ; a, b, c + (println j) ; a, b, c (free j)) (let [j (join (slice parts 0 1) (bytes-view ", "))] - (show (addr j)) ; a + (println j) ; a (free j)) (let [j (join (slice parts 0 0) (bytes-view ", "))] (println (length j)) ; 0 (free j)) ;; An empty separator is concat. (let [j (join (slice parts 0 3) (bytes-view ""))] - (show (addr j)) ; abc + (println j) ; abc (free j))) ;; repeat, including zero times. (let [r (repeat-bytes (bytes-view "ab") 3)] - (show (addr r)) ; ababab + (println r) ; ababab (free r)) (let [r (repeat-bytes (bytes-view "ab") 0)] (println (length r)) ; 0 @@ -69,31 +70,31 @@ ;; through untouched, which is the range check a table-free version gets ;; wrong by shifting every byte. (let [l (to-lower (bytes-view "Hello, World 42!"))] - (show (addr l)) ; hello, world 42! + (println l) ; hello, world 42! (free l)) (let [u (to-upper (bytes-view "Hello, World 42!"))] - (show (addr u)) ; HELLO, WORLD 42! + (println u) ; HELLO, WORLD 42! (free u)) ;; replace. "aaa" with "aa" -> "b" is the non-overlapping rule: the answer is ;; "ba", because the match consumes both a's and the scan resumes after them. (let [r (replace-bytes (bytes-view "aaa") (bytes-view "aa") (bytes-view "b"))] - (show (addr r)) ; ba + (println r) ; ba (free r)) ;; A replacement longer than what it replaces, and one that is empty. (let [r (replace-bytes (bytes-view "a,b,c") (bytes-view ",") (bytes-view " -- "))] - (show (addr r)) ; a -- b -- c + (println r) ; a -- b -- c (free r)) (let [r (replace-bytes (bytes-view "a,b,c") (bytes-view ",") (bytes-view ""))] - (show (addr r)) ; abc + (println r) ; abc (free r)) ;; No occurrence is a copy, and an empty `from` is a copy -- the reading ;; where it matches everywhere is an infinite loop. (let [r (replace-bytes (bytes-view "abc") (bytes-view "z") (bytes-view "!"))] - (show (addr r)) ; abc + (println r) ; abc (free r)) (let [r (replace-bytes (bytes-view "abc") (bytes-view "") (bytes-view "!"))] - (show (addr r)) ; abc + (println r) ; abc (free r)) ;; split. n separators, n+1 fields, always -- so the trailing empty field is @@ -128,7 +129,7 @@ ;; would print the original string. (let [f (split (bytes-view "a,b,c") \,)] (let [j (join (slice f) (bytes-view "/"))] - (show (addr j)) ; a/b/c + (println j) ; a/b/c (free j)) (free f)) @@ -140,7 +141,7 @@ (with-allocator a (let [parts [(bytes-view "in") (bytes-view "arena")]] (let [j (join (slice parts 0 2) (bytes-view "-"))] - (show (addr j)) ; in-arena + (println j) ; in-arena ;; The free is written because the binding is dead after it either ;; way, and it keeps the block: an arena cannot release one, which ;; is the difference the capability set exists to state. free-all diff --git a/test/syntax/handwritten/words.fln b/test/syntax/handwritten/words.fln index 90da8830..a36a901c 100644 --- a/test/syntax/handwritten/words.fln +++ b/test/syntax/handwritten/words.fln @@ -18,7 +18,8 @@ fn letter?(c: u8) -> bool ; The words of text, lowercased, in order. fn words(text: [const u8]) -> Vec([const u8]) let out = vec-new([const u8]) - let lower = to-lower(text) + let lowered = to-lower(text) + let lower = bytes-view(lowered) let i = 0 let n = length(lower) while :scan i < n diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index ff0185a4..c1d0fe3e 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -1942,6 +1942,74 @@ let () = strings_out; outputs ~dev:true "string building, dev" "programs/strings.flan" strings_out; + (* String, the owned text: multi-byte append, insert and remove by + character position, runes, a copy, printing inside a struct, and the + crossing into dyn as a copy — the dyn value keeps the text it was given + while the String goes on growing. Every row prints the same bytes. *) + let owned_out = + "héllo wörld日!\n17 13\n😀h→éllo wörld日!\n8594\n128512\n\ + héllo wörld日!\nabababab 8\n233 246 26085 13\n17 18\ntrue\n17\n\ + (Named {.label \"x\" .n 3})\nhéllo wörld日!\n:text\na-b\n0 0\n" + in + outputs "an owned String" "programs/string-owned.flan" owned_out; + outputs ~opt:"-O0" "an owned String, -O0" "programs/string-owned.flan" + owned_out; + outputs ~x86:true "an owned String, --x86" "programs/string-owned.flan" + owned_out; + outputs ~dev:true "an owned String, dev" "programs/string-owned.flan" + owned_out; + (* What a String stops on at run time, at the site that would have stored + it: bytes that are not UTF-8 through a str and through bytes->string, a + code point with no encoding, and a character position past the end, + which is a BoundsError counted in characters. *) + let string_trap ?x86 () = + let exe = compile ?x86 "programs/string-traps.flan" in + List.iter + (fun (arg, want) -> + let code, text = run exe (Some arg) in + if code <> 134 || not (contains text want) then begin + incr failures; + Printf.printf + "FAIL a String's run-time refusal %s%s\n got: %S (exit \ + %d)\n wanted: %S (exit 134)\n" + arg (match x86 with Some true -> ", --x86" | _ -> "") + text code want + end) + [ ("0", "string-traps.flan:15:19: this text is not valid UTF-8 — byte 0 \ + is 0xc3"); + ("1", "string-traps.flan:16:19: 55296 is not a Unicode scalar value"); + ("2", "string-traps.flan:17:19: index 3 is out of bounds for length 2"); + ("3", "string-traps.flan:18:28: index 2 is out of bounds for length 2"); + ("4", "string-traps.flan:19:23: this text is not valid UTF-8 — byte 0 \ + is 0xff") ]; + (try Sys.remove exe with Sys_error _ -> ()) + in + string_trap (); + string_trap ~x86:true (); + (* A dev build's registry reports a String kept to the end under its own + name, and the one freed not at all. *) + let string_leak ?x86 () = + let exe = compile ~dev:true ?x86 "programs/string-leak.flan" in + let out = exe ^ ".out" in + let code = + Sys.command + (Printf.sprintf "FLAN_DEV_LEAKS=1 %s > %s 2>&1" (Filename.quote exe) + (Filename.quote out)) + in + let text = In_channel.with_open_bin out In_channel.input_all in + (try Sys.remove out; Sys.remove exe with Sys_error _ -> ()); + let want = + "kept for good\nflan: 1 block still held at exit, 16 bytes\n\ + flan: 1 16 String\n" + in + if code <> 0 || text <> want then begin + incr failures; + Printf.printf "FAIL a String's leak report%s\n got: %S\n wanted: %S\n" + (match x86 with Some true -> ", --x86" | _ -> "") text want + end + in + string_leak (); + string_leak ~x86:true (); (* Typed = and != on strings -- M2 queue item 5. Bytewise, with a length-mismatch fast path and a same-pointer fast path ahead of the byte loop (runtime/flan_rt.c, flan_str_eq), on both backends. Ordering diff --git a/test/test_flan.ml b/test/test_flan.ml index 6b853e5f..cfba293c 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2245,6 +2245,33 @@ let () = "(defn g [b [u8]] i32 (length b)) (defn f [s str] i32 (g (slice s)))" ~needle:"expected [u8], found str"; + (* String keeps its bytes valid UTF-8, so every route to one byte of it is + refused, and each refusal names the character-position operations. *) + rejects_check "a String is not set by index" + "(defn f [s String] () (set (at s 0) 65))" + ~needle:"a String cannot be changed one byte at a time"; + rejects_check "a String's set by index names remove and insert" + "(defn f [s String] () (set (at s 0) 65))" + ~needle:"(remove s i), then (insert s i c)"; + rejects_check "a String is not read by index" + "(defn f [s String] u8 (at s 0))" ~needle:"(at (str s) i)"; + rejects_check "a String's field is not reachable" + "(defn f [s String] i32 (length (.bytes s)))" + ~needle:"a String keeps its bytes to itself"; + rejects_check "a String is not built as a struct" + "(defn f [v (Vec u8)] String (String {.bytes v}))" + ~needle:"a String keeps its bytes to itself"; + rejects_check "bytes are not appended to a String unchecked" + "(defn f [s String b [u8]] () (append s b))" ~needle:"Write (str b)"; + rejects_check "a literal surrogate is not a code point" + "(defn f [s String] () (append s 0xd800))" + ~needle:"55296 is not a Unicode scalar value"; + rejects_check "a String through a const pointer is not changed" + "(defn f [s (Ptr const String)] () (append s \"x\"))" + ~needle:"can only be read"; + accepts "a String through a pointer is changed" + "(defn f [s (Ptr String)] () (append s \"x\") (insert s 0 \\a))"; + (* [const T]: a view that can only be read. Every route to a store through one is refused, and none of the reads is. *) infers "a const slice slices to a const slice"