diff --git a/TODO.org b/TODO.org index f8f6f39d..0a4bd539 100644 --- a/TODO.org +++ b/TODO.org @@ -30,10 +30,25 @@ index out of range (negative included), one index per dimension. Both typed and Decided 2026-09-25: the typed read-only text is =str= (the rename from =string= is done; =string= is refused with the fix); =String= is new, owned, growable, always valid UTF-8, through an allocator. The prelude's text builders return =String=; =(Vec u8)= stays for raw bytes. Text is UTF-8 everywhere and -a character is a code point; dyn gets a character tag, so \\I prints as \\I. -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. +a character is a code point; length and indexing count bytes on str. Waits on the +dyn-unless-annotated design. + +** DONE Dyn has a char, and dyn text counts characters +CLOSED: [2026-09-26] +Only a char literal, =at= on a text and =chars= make one, and it prints as its +literal, bare too, a control character as \\uXXXX. Into any integer width it gives its +code point where that fits, into a byte only when ASCII; a dyn int into any width is +range-checked, while a cast on either wraps as a typed cast does. length, at and slice +on dyn text count code points, a malformed byte counting as one U+FFFD. A non-ASCII +literal defaults to i32 and is refused where a byte is wanted. Rules out char +arithmetic, a typed code point turning into a char, and byte offsets on dyn text. + +** 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); a prelude builder's String is checked at the caller's call. = and != compare bytes. +Rules out a String type in the backends, s[i] = c, a String map key, and a byte path that skips the check. ** DONE Any typed container crosses into dyn as a view CLOSED: [2026-09-26] diff --git a/docs/BUILT.md b/docs/BUILT.md index 160ab549..d16022d7 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -7524,3 +7524,30 @@ 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. A direct call to a prelude function that answers a String has its text +arguments checked before the call, at the caller's line (`prechecked_call`); +each builder still ends in `(bytes->string b)`, the backstop for one reached +through a function value, which stops at the prelude's line. +`=` and `!=` compare a String with a String or a str through their str views; +`peeks_string` decides that from the operands' declared types without checking +them twice. Ordering and map keys are refused with the fix named. + +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 f9d35cee..df3ab8f8 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -1888,7 +1888,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-inspect.el b/emacs/flan-inspect.el index e009669e..e5efa239 100644 --- a/emacs/flan-inspect.el +++ b/emacs/flan-inspect.el @@ -165,6 +165,10 @@ reply without a daemon behind them, and so that this file names (defun flan-inspect--read-atom (s i) "Read a bare token at I: a number, a keyword, `true', `none', `...'." (let ((start i)) + ;; A char, \x: the character after the backslash is taken whatever it + ;; is, so \) and \] do not close the sequence they sit in. + (when (and (eq (aref s i) ?\\) (< (1+ i) (length s))) + (setq i (+ i 2))) (while (and (< i (length s)) (not (memq (aref s i) '(?\s ?\n ?\t ?\) ?\] ?\})))) (setq i (1+ i))) diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 5c49844c..fba945f6 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -166,6 +166,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 @@ -255,7 +257,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/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 7c27f106..69cce32f 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -98,6 +98,14 @@ (test-flan--check "indexed from zero" (equal (mapcar #'car (plist-get n :children)) '(0 1 2)))) +;; A dyn vec of chars, as runtime/flan_dyn.c's [char_spell] writes one: \) +;; and \] are chars, not closers. +(let ((n (flan-inspect-parse "[\\a \\) \\] \\日 \\space]"))) + (test-flan--check "a char is one element, whatever follows the backslash" + (equal (mapcar (lambda (k) (plist-get (cdr k) :text)) + (plist-get n :children)) + '("\\a" "\\)" "\\]" "\\日" "\\space")))) + ;; [[0 0] [1 ...] ...] — span truncation at both levels, which is what ;; sand's [100 [100 u32]] actually produces. (let* ((n (flan-inspect-parse "[[0 0] [1 ...] ...]")) diff --git a/lib/check.ml b/lib/check.ml index fb6c733a..c5575e9c 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4311,6 +4311,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 = @@ -4318,6 +4342,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 @@ -4450,34 +4477,34 @@ let mismatch_found : Types.t Found.t = Found.create 16 let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr = let need sym ty = rt loc ty sym [ e ] in match want with - | Types.Int Types.I64 -> need "flan_dyn_need_i64" dyn_i64 | Types.Float Types.F64 -> need "flan_dyn_need_f64" dyn_f64 | Types.Bool -> (* The ABI answers an [int32_t]; [bool] is an [i1]. The narrowing is the language's own cast and cannot fail — the runtime already decided the value was a bool, so what comes back is 0 or 1. *) widen loc Types.Bool (need "flan_dyn_need_bool" (Types.Int Types.I32)) - (* Every other width is refused rather than served by a need_i64 and a - truncation. Narrowing is written or it does not happen — that survives - widening becoming implicit (TODO.org, "Implicit numeric widening is - legal; narrowing stays a hard error") untouched, and this is the - boundary where it matters most: the value's type was *already* uncertain - here, so an annotation that quietly discarded the high bits would read as - a check and be the opposite of one. - - Nor does widening reach this arm from the other side. The box carries one - integer width and one float width, so there is no narrower source here to - widen from — a u32 want is asking the i64 in the box to fit in half of - itself, which is the refusal above and not a conversion the lattice has. - The ABI grows a per-width entry point when there is a reason to; until - then the spelling that works is an i64 and a written conversion after - it. *) - | Types.Int _ | Types.Float _ -> - no_dyn_yet loc ~into:false want - (Printf.sprintf - " — take it as %s and convert" - (if Types.is_numeric want && (match want with Types.Float _ -> true | _ -> false) - then "f64" else "i64")) + (* Any integer width, checked at run time at this site (TODO.org, "Dyn + unless annotated"): an int in the width's range, or a char's code point + where it fits — ASCII only into a byte, since a byte past ASCII is not + that char in UTF-8. The runtime answers an i64 it has already checked, + so the narrowing after it cannot lose a bit. *) + | Types.Int k -> + let code = + match k with + | Types.I8 -> 0L | Types.U8 -> 1L | Types.I16 -> 2L | Types.U16 -> 3L + | Types.I32 -> 4L | Types.U32 -> 5L | Types.I64 -> 6L | Types.U64 -> 7L + in + let n = + rt loc dyn_i64 "flan_dyn_need_int" + [ e; mk loc (Types.Int Types.I32) (Tast.Int (code, Types.I32)); here loc ] + in + if k = Types.I64 then n else mk loc want (Tast.Prim (Tast.Cast want, [ n ])) + (* An f32 is refused rather than served by a need_f64 and a rounding: the + box carries one float width, and narrowing is written or it does not + happen (TODO.org, "Implicit numeric widening is legal; narrowing stays a + hard error"). *) + | Types.Float _ -> + no_dyn_yet loc ~into:false want " — take it as f64 and convert" | _ -> no_dyn_yet loc ~into:false want "" (* A dyn where a str, a slice, a fixed array or a struct was written: @@ -4586,7 +4613,7 @@ let cast_dyn ctx loc (target : Types.t) (got : Tast.expr) : Tast.expr = [ mk loc target (Tast.If (is_float, arm "flan_dyn_need_f64" dyn_f64, - arm "flan_dyn_need_i64" dyn_i64)) ])) + arm "flan_dyn_int_of" dyn_i64)) ])) (* nil is written [nil] and nothing else produces it, so this is the whole of "the checker can see a nil reaching here" — a name, not a dataflow fact. @@ -5218,6 +5245,13 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = | Types.String -> Tast.Rtfn "flan_hash_str", Tast.Rtfn "flan_eq_str" | t when bytewise_key t -> Tast.Rtfn "flan_hash_flat", Tast.Rtfn "flan_eq_flat" + | t when is_string_ty t -> + fail loc + "a String owns its bytes, and a map would share them with it rather \ + than copy them, so a String is not a map key. Key the map by str and \ + put %s, which is the String's text for as long as the String is not \ + changed" + (if fln_source loc then "str(s)" else "(str s)") | Types.Named n when Hashtbl.mem env.structs n -> struct_key_pair env loc n (* A data type key would have to hash the tag and then only the bytes the case in hand actually uses — the rest of the payload is indeterminate, @@ -6007,8 +6041,39 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = n (tyname loc t) gname var (Int64.neg n) n | Ast.Int n -> int_literal loc ~want ~preds:ctx.env.tvpreds n | Ast.UInt (n, s) -> wide_literal loc ~want n s + (* A char literal that ends up dyn is a dyn char, never an int; a typed code + point that crosses later is an int, because only the literal says char. *) + | Ast.Byte b when want = Some Types.Dyn -> + rt loc Types.Dyn "flan_dyn_from_char" + [ mk loc (Types.Int Types.I32) (Tast.Int (Int64.of_int b, Types.I32)) ] + (* A char literal is a code point, and a byte type holds one only when it + is ASCII: \é as a u8 would be 0xE9, which is not é in UTF-8 and never + equals a byte of it. Refused by the char's name, not its number. *) + | Ast.Byte b + when (match want with + | Some (Types.Int (Types.U8 | Types.I8)) -> b > 127 + | Some (Types.Int Types.I16) -> b > 32767 + | Some (Types.Int Types.U16) -> b > 65535 + | _ -> false) -> + let t = tyname loc (Option.get want) in + let c = Form.byte_repr b in + if (match want with + | Some (Types.Int (Types.U8 | Types.I8)) -> true + | _ -> false) + then + Loc.failk literal_at_want loc + "%s is %d bytes in UTF-8, not one, so it is not a %s. Write the str \ + \"%s\" for its bytes, or take its code point as an i32" + c (String.length (Form.utf8 b)) t (Form.utf8 b) + else + Loc.failk literal_at_want loc + "%s is code point %d, which does not fit in a %s. Take its code point \ + as an i32" c b t + (* A non-ASCII literal is a code point, which a u8 cannot hold as itself: + its default is the prelude's rune, an i32. *) | Ast.Byte b -> - int_literal loc ~want ~preds:ctx.env.tvpreds ~default:Types.U8 + int_literal loc ~want ~preds:ctx.env.tvpreds + ~default:(if b > 127 then Types.I32 else Types.U8) (Int64.of_int b) (* The float literal's own dyn case, for the reason the integer's has one: the ABI carries one width and the literal is built at it. f64 is already @@ -8587,6 +8652,7 @@ and generic_ctor ctx ~want loc name given = match a.Ast.e with | Ast.Float _ -> Types.Float (float_default ()) | Ast.UInt _ -> Types.Int Types.U64 + | Ast.Byte b when b > 127 -> Types.Int Types.I32 | Ast.Byte _ -> Types.Int Types.U8 | _ -> Types.Int Types.I32 in @@ -8723,6 +8789,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 @@ -8836,6 +8903,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 @@ -9617,8 +9685,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = if p >= 17 || float_of_string t = x then t else go (p + 1) in go 1 - | Ast.Byte b when b > 32 && b < 127 -> Printf.sprintf "\\%c" (Char.chr b) - | Ast.Byte b -> string_of_int b + | Ast.Byte b -> Form.byte_repr b | Ast.Str t -> Printf.sprintf "%S" t | Ast.Kw k -> ":" ^ k | Ast.Var b -> b @@ -10341,6 +10408,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 -> @@ -10598,6 +10669,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 @@ -11487,6 +11560,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 @@ -11578,6 +11671,485 @@ 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 + +(* Whether [name] is the prelude's own function. *) +and prelude_defined ctx name = + match Hashtbl.find_opt ctx.env.fn_locs name with + | Some at -> String.equal at.Loc.file Prelude.file + | None -> false + +(* A call to a prelude function that answers a String, its text arguments + checked here, at the call the program wrote, before the call is made. The + builders — (to-lower b), (join parts sep) — take bytes, and their answer is + valid exactly when every piece of text they were given is (UTF-8 is + self-synchronising, so a valid [from] matches a valid [s] only on + character boundaries). Each builder also checks its own answer, the + backstop for a builder reached through a function value; on this path that + check has nothing left to find, and stops nobody at the prelude's line. *) +and prechecked_call ctx loc name ret (args : Tast.expr list) = + let bytes = function + | Types.Slice (_, Types.Int Types.U8) | Types.String -> true + | _ -> false + in + let binds, checks, uses = + List.fold_right + (fun (a : Tast.expr) (bs, cs, us) -> + let check = + match a.Tast.ty with + | t when bytes t -> Some "flan_utf8_check" + | Types.Slice (_, t) when bytes t -> Some "flan_utf8_check_parts" + | _ -> None + in + match check with + | None -> (bs, cs, a :: us) + | Some sym -> + let sl = fresh_slot ctx a.Tast.ty in + let v = mk a.Tast.loc a.Tast.ty (Tast.Local sl) in + ((sl, a) :: bs, rt loc Types.Unit sym [ v; here loc ] :: cs, v :: us)) + args ([], [], []) + in + let call = mk loc ret (Tast.Call (name, uses)) in + if checks = [] then call + else mk loc ret (Tast.Let (binds, checks @ [ call ])) + +(* Whether an operand is a String, read off what the operand is without + checking it: a local or a global of that type, a call to a function that + answers one, a field of that type, or one of the builtins that make one. A + comparison asks this of every operand, so it must not walk them. *) +and peeks_string ctx (a : Ast.expr) = + let rec ty (a : Ast.expr) = + match a.Ast.e with + | Ast.Var n -> + (match lookup ctx n with + | Some b -> Some b.bty + | None -> + (match Hashtbl.find_opt ctx.env.globals n with + | Some (t, _) -> Some t + | None -> None)) + | Ast.Call ({ Ast.e = Ast.Var ("string-new" | "bytes->string"); _ }, _) -> + Some string_ty + | Ast.Call ({ Ast.e = Ast.Var "deref"; _ }, [ p ]) -> + (match ty p with Some (Types.Ptr (_, t)) -> Some t | _ -> None) + | Ast.Call ({ Ast.e = Ast.Var f; _ }, _) -> + (match Hashtbl.find_opt ctx.env.fns f with + | Some (_, ret) -> Some ret + | None -> None) + | Ast.Field (t, name) -> + (match ty t with + | Some (Types.Named n | Types.Ptr (_, Types.Named n)) -> + (match fields_named ctx.env n with + | Some st -> + (match Tast.field_index st name with + | Some i -> Some (List.nth st.Tast.fields i).Tast.fty + | None -> None) + | None -> None) + | _ -> None) + | _ -> None + in + match ty a with Some t -> string_or_ptr t | None -> false + +(* = and != over a String and a String or a str: the texts' bytes compared, + through the str view each has, which is the comparison str already has. + The orderings are refused as they are on a str, naming bytes () + | _ -> + fail loc + "%s orders machine numbers and enums, and a String is neither. Text is \ + ordered by its bytes with %s" + name + (if fln_source loc then "bytes check ctx ~want:Types.String x + | _ -> check ctx x + in + match e.Tast.ty with + | Types.String -> e + | t when string_or_ptr t -> + mk x.Ast.loc Types.String + (Tast.Prim (Tast.StrOfBytes, [ string_bytes ctx x.Ast.loc e ])) + | other -> + fail x.Ast.loc "%s compares a String with a String or a str, found %s" + name (tyname x.Ast.loc other) + in + let ops = List.map as_str args in + let link u v = mk loc Types.Bool (Tast.Prim (p, [ u; v ])) in + match ops with + | [ a; b ] -> expect ctx loc ~want (link a b) + | _ -> + let pairs = if String.equal name "!=" then all_pairs else adjacent_pairs in + expect ctx loc ~want (cmp_over ctx loc Types.String ~pairs ~link ops) + +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) and (bytes->string v a): the bytes of a (Vec u8) copied + into a new String once they are checked, here. A copy, because v — and + any slice taken of it — could otherwise go on writing into the String's + block; v is untouched and still the caller's to free. + + The prelude's builders are the one exception: each hands over a Vec + nothing else can reach, so there the Vec becomes the String with no copy, + still checked, and re-noted so a dev build's registry calls the block a + String. *) + | "bytes->string", (x :: rest) when List.length rest <= 1 -> + let v = check ctx ~want:string_vec_ty x in + if String.equal loc.Loc.file Prelude.file && rest = [] then begin + 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 ]; + reg_note loc "flan_dev_reg_note_vec" vv + [ size_of loc u8_ty ] string_ty; + mk loc string_ty (Tast.Make ("String", [ vv ])) ]))) + end else begin + let a = allocator_arg ctx loc rest in + let src = fresh_slot ctx string_vec_ty in + let view = + vec_slice ctx ~want:None loc (mk loc string_vec_ty (Tast.Local src)) u8_ty [] + in + let sl = fresh_slot ctx string_ty in + let s = mk loc string_ty (Tast.Local sl) in + let bytes = { view with Tast.ty = Types.Slice (Types.Const, u8_ty) } in + expect ctx loc ~want + (mk loc string_ty + (Tast.Let + ([ (src, v); + (sl, mk loc string_ty + (Tast.Make ("String", [ vec_init ~note:string_ty ctx loc u8_ty a ]))) ], + [ string_put ctx loc (string_vec loc s) (i64 (-1L)) (`Text (bytes, false)); + s ]))) + end + | "bytes->string", _ -> + fail loc "bytes->string is (bytes->string v) or (bytes->string v a), 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. *) @@ -11673,6 +12245,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = let x, y, rest = match args with x :: y :: rest -> x, y, rest | _ -> assert false in + if List.exists (fun a -> peeks_string ctx a) args then + string_compare ctx ~want loc name p args + else (* The first pair decides the type, and whether this is a dyn comparison at all, exactly as it does for the folding operators: [binary] joins the two, and every operand after them is checked against the answer. @@ -12323,25 +12898,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; @@ -12469,6 +13027,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 @@ -12583,6 +13154,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 @@ -12676,6 +13267,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 @@ -12840,6 +13438,15 @@ and named_call ?(qualified = false) ctx ~want loc name args = (rt loc Types.Dyn "flan_dyn_type_of" [ check ctx ~want:Types.Dyn v ]) | _ -> assert false) + (* (chars t) and (text x): a dyn text as a vec of its chars, and back. A + dyn text is immutable, so a vec of chars is how one is edited. *) + | "chars" | "text" -> + arity ctx loc name 1 args; + let sym = if name = "chars" then "flan_dyn_chars" else "flan_dyn_text" in + expect ctx loc ~want + (rt loc Types.Dyn sym + [ check ctx ~want:Types.Dyn (List.hd args); here loc ]) + (* (map-remove m k) -> (Option V): the value that was there, or None when the key was not. The same answer [get] gives, for the same reason — a key that is not in the map is an answer and not a failure — and the value @@ -13256,6 +13863,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 _ -> @@ -13271,7 +13884,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 @@ -13587,8 +14201,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 @@ -13641,7 +14256,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) ] @@ -13801,6 +14424,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))] @@ -14030,7 +14656,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = 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 = + let operand_want = match (List.hd args).Ast.e, target with | Ast.Int n, (Types.Int _ | Types.Float _) when Int64.compare n (-2147483648L) < 0 @@ -14043,7 +14669,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = Some (Types.Float Types.F64) | _ -> None in - let a = check ctx ?want (List.hd args) in + let a = check ctx ?want:operand_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 @@ -14061,7 +14687,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = ~what:"a number or an enum" ~is:"a number" v | t -> fail loc "%s converts a number, found %s" name (tyname loc t)); (match a.Tast.ty with - | Types.Dyn -> cast_dyn ctx loc target a + | Types.Dyn -> expect ctx loc ~want (cast_dyn ctx loc target a) | _ -> prim (Tast.Cast target) target [ a ]) (* ── ordinary calls ────────────────────────────────────────────── *) @@ -14166,7 +14792,13 @@ and ordinary_call ctx ~want loc name args = (temps, [ rt loc Types.Unit "flan_dyn_ctor_site" [ here loc ]; mk loc ret (Tast.Call (name, uses)) ]))) - | None -> expect ctx loc ~want (mk loc ret (Tast.Call (name, args)))) + | None -> + let call = mk loc ret (Tast.Call (name, args)) in + expect ctx loc ~want + (if is_string_ty ret && prelude_defined ctx name + && not (String.equal loc.Loc.file Prelude.file) + then prechecked_call ctx loc name ret args + else call)) | None -> if Hashtbl.mem ctx.env.datas name then fail loc @@ -15474,13 +16106,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 \ @@ -15491,6 +16123,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) Allocator?] String", + "A new String holding a copy of the Vec's bytes, once they are checked \ + to be UTF-8 — here, at run time. Bytes that are not stop the program \ + at this call. The Vec is untouched and is still yours to free."); + ("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 — \ @@ -15522,9 +16184,15 @@ let builtins : (string * string * string) list = is the same generic function written the other way."); ("type-of", "type-of [dyn] dyn", "The value's kind as a keyword — :nil :bool :int :float :text :vec \ - :keyword :map — or, for a value built by a defclass constructor, the \ + :keyword :map :char — or, for a value built by a defclass constructor, the \ class's name as class-of answers it. A typed value answers the kind it \ has as a dyn value: an i32 is :int."); + ("chars", "chars [dyn] dyn", + "A dyn text's characters, as a new dyn vector of chars. A dyn text \ + counts characters, not bytes, in length, at and slice."); + ("text", "text [dyn] dyn", + "The dyn text a dyn vector of chars, or a single char, spells: \ + (text (chars t)) is t."); ("keyword", "keyword [str|[const u8]] dyn", "The interned dyn keyword named by the bytes, for a name that only \ exists at run time — a reader building :texture-path out of a token's \ @@ -15565,9 +16233,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, as rune-count \ + does not; a dyn text 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 \ @@ -15604,13 +16273,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 7d6c2c4b..5b8950fc 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4089,6 +4089,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 @@ -5055,6 +5056,10 @@ 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_char(i32) +declare i64 @flan_dyn_chars(i64, ptr, i64) +declare i64 @flan_dyn_text(i64, 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) @@ -5125,6 +5130,9 @@ declare ptr @flan_dev_literal(ptr, i64) declare i64 @flan_dyn_need_i64(i64) declare double @flan_dyn_need_f64(i64) declare i32 @flan_dyn_need_bool(i64) +declare i32 @flan_dyn_need_i32(i64, ptr, i64) +declare i64 @flan_dyn_need_int(i64, i32, ptr, i64) +declare i64 @flan_dyn_int_of(i64) ; A numeric cast written on a dyn answers which numeric tag the box holds; ; check.ml's [cast_dyn] branches on it and each arm is an ordinary need plus ; the ordinary cast. The two slices are the site's location and the target's @@ -5169,6 +5177,17 @@ 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_utf8_check_parts(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/expand.ml b/lib/expand.ml index e1319623..c9a486bd 100644 --- a/lib/expand.ml +++ b/lib/expand.ml @@ -191,7 +191,10 @@ let rec unmarshal ~(sites : sites) ~loc (p : Dynload.addr) : Form.t = | _ -> Form.make (Form.Int i) loc) | TFloat -> Form.make (Form.Float (Dynload.peek_f64 p payload)) loc | TByte -> - Form.make (Form.Byte (Int32.to_int (Dynload.peek_i32 p payload) land 0xff)) loc + (* A char is a code point; anything that is not a scalar value keeps the + byte it always was. *) + let b = Int32.to_int (Dynload.peek_i32 p payload) in + Form.make (Form.Byte (if Uchar.is_valid b then b else b land 0xff)) loc | TSym -> Form.make (Form.Sym (str ())) (here ()) | TKw -> Form.make (Form.Kw (str ())) (here ()) | TStr -> Form.make (Form.Str (str ())) (here ()) diff --git a/lib/form.ml b/lib/form.ml index 2eda0357..e14f770b 100644 --- a/lib/form.ml +++ b/lib/form.ml @@ -18,7 +18,7 @@ and value = | UInt of int64 * string | Float of float (* 0.05 *) | Str of string (* "SAND" *) - | Byte of int (* \space \0 \( (0..255) *) + | Byte of int (* \space \0 \( \é a code point, a char *) | List of t list (* (f x) *) | Vec of t list (* [1 2 3] and every binding/type bracket *) | Map of t list (* {.field v} a struct value, and a defn's @@ -28,6 +28,29 @@ and value = let make v loc = { v; loc } +(* A code point's UTF-8 bytes. *) +let utf8 b = + let buf = Buffer.create 4 in + Buffer.add_utf_8_uchar buf (Uchar.of_int b); + Buffer.contents buf + +(* A char's spelling, the one [Reader.read_byte] reads back as the same code + point: a name where the reader has one, Clojure's \uXXXX for every other + control character (C0, DEL and C1), and the character itself otherwise. + runtime/flan_dyn.c's [char_spell] writes the same table. *) +let byte_repr b = + match b with + | 32 -> "\\space" + | 9 -> "\\tab" + | 10 -> "\\newline" + | 13 -> "\\return" + | 0 -> "\\nul" + | 8 -> "\\backspace" + | 12 -> "\\formfeed" + | b when b < 32 || (b >= 127 && b <= 0x9F) -> Printf.sprintf "\\u%04X" b + | b when b < 127 -> Printf.sprintf "\\%c" (Char.chr b) + | b -> "\\" ^ utf8 b + let rec to_string f = let seq l = String.concat " " (List.map to_string l) in match f.v with @@ -37,12 +60,7 @@ let rec to_string f = | UInt (_, s) -> s | Float x -> Printf.sprintf "%g" x | Str s -> Printf.sprintf "%S" s - | Byte b -> - (match Char.chr b with - | ' ' -> "\\space" - | '\t' -> "\\tab" - | '\n' -> "\\newline" - | c -> Printf.sprintf "\\%c" c) + | Byte b -> byte_repr b | List l -> "(" ^ seq l ^ ")" | Vec l -> "[" ^ seq l ^ "]" | Map l -> "{" ^ seq l ^ "}" @@ -70,9 +88,8 @@ let rec to_string f = - [%S] is OCaml's escaping. The reader takes exactly six escapes — newline, tab, return, backslash, quote and nul — and every other byte literally, so the three-digit decimal escape [%S] writes would not read back. - - [Byte] falls through to \, which spells 0 and 13 as a NUL and a - carriage return sitting in the middle of the source. The reader has names - for those and this uses them. *) + - A control character written as itself is a raw byte in the middle of + the source. [byte_repr] names it, or writes \uXXXX. *) let escape s = let b = Buffer.create (String.length s + 2) in @@ -110,20 +127,6 @@ let float_repr x = in if plain then s ^ ".0" else s -let byte_repr b = - match b with - | 32 -> "\\space" - | 9 -> "\\tab" - | 10 -> "\\newline" - | 13 -> "\\return" - | 0 -> "\\nul" - (* Printable ASCII is written as itself. Anything else has no spelling in - the reader at all — [read_byte] takes a name or a single character — so - it is written as the decimal the reader would have to grow, rather than - as a byte that would corrupt the line it is on. *) - | b when b > 32 && b < 127 -> Printf.sprintf "\\%c" (Char.chr b) - | b -> Printf.sprintf "\\%d" b - (** One line, and a reader reads it back. *) let rec to_source f = let seq l = String.concat " " (List.map to_source l) in 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..3997843c 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. @@ -1719,23 +1719,47 @@ let source = {flan| ;; writes (with-allocator a (join parts sep)) and the Vec records the arena, so ;; the free and the clone never need it named again. ;; +;; **The text builders check what they answer**, with (bytes->string b), and +;; that check stops the program at this file's line. A call the program writes +;; is checked first, at its own line, on the text it passes (check.ml, +;; [prechecked_call]); the check here is for a builder reached through a +;; function value, which has no call site to check at. +;; ;; **No Result, anywhere.** Running out of storage signals StorageExhausted ;; under a `retry` restart and no allocating operation returns an error ;; (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 +1779,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 +1830,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 +1846,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 +1919,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 +1966,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 +1974,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 +1999,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/reader.ml b/lib/reader.ml index 6e50b465..8c323e1c 100644 --- a/lib/reader.ml +++ b/lib/reader.ml @@ -113,7 +113,8 @@ let read_string st = go (); spanned st loc (Form.Str (Buffer.contents buf)) -(* \space \tab \newline \return \nul, or \ *) +(* \space \tab \newline \return \nul \backspace \formfeed, Clojure's \uXXXX + (four hex digits), or \ *) let read_byte st = let loc = here st in advance st; (* backslash *) @@ -128,7 +129,23 @@ let read_byte st = | "newline" -> 10 | "return" -> 13 | "nul" -> 0 + | "backspace" -> 8 + | "formfeed" -> 12 | n when String.length n = 1 -> Char.code n.[0] + | n when String.length n = 5 && n.[0] = 'u' + && String.for_all + (function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false) + (String.sub n 1 4) -> + let c = int_of_string ("0x" ^ String.sub n 1 4) in + if not (Uchar.is_valid c) then + Loc.failk "reader/unknown-character" loc + "\\%s is a surrogate, which is not a character" n; + c + (* One code point written as itself, UTF-8 in the source: \é \日. *) + | n when (let d = String.get_utf_8_uchar n 0 in + Uchar.utf_decode_is_valid d + && Uchar.utf_decode_length d = String.length n) -> + Uchar.to_int (Uchar.utf_decode_uchar (String.get_utf_8_uchar n 0)) | n -> Loc.failk "reader/unknown-character" loc "unknown character literal \\%s" n in spanned st loc (Form.Byte code) 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 78119d26..c8d053e0 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -3196,6 +3196,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 83ac74d8..32d05937 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -211,6 +211,9 @@ typedef struct flan_desc { * name are the same word, so equality is the identity compare [dyn_equal] * already opens with, never a memcmp. */ #define BOX_KW 4u +/* A character: the payload is its code point, a Unicode scalar value, so two + * equal chars are the same word and nothing about one is ever allocated. */ +#define BOX_CHAR 5u /* Restated from flan_dyn.h — a view's element kind. */ #define FLAN_VIEW_I64 0 @@ -526,7 +529,8 @@ static unsigned ring_at; * somebody can act on and "tag 2 and tag 4" is a puzzle. */ static const char *const tag_words[] = { "nil", "bool", "int", "float", - "text", "vec", "keyword", "map" }; + "text", "vec", "keyword", "map", + "char" }; #define FLAN_DYN_TAG_NIL 0 #define FLAN_DYN_TAG_BOOL 1 @@ -536,6 +540,8 @@ static const char *const tag_words[] = { "nil", "bool", "int", "float", #define FLAN_DYN_TAG_VEC 5 #define FLAN_DYN_TAG_KEYWORD 6 #define FLAN_DYN_TAG_MAP 7 +#define FLAN_DYN_TAG_CHAR 8 +#define FLAN_DYN_TAG_LAST FLAN_DYN_TAG_CHAR static inline flan_obj *dyn_obj(flan_dyn v) { return (flan_obj *)(uintptr_t)dyn_payload(v); @@ -562,6 +568,7 @@ int32_t flan_dyn_tag(flan_dyn v) { case BOX_BOOL: return FLAN_DYN_TAG_BOOL; case BOX_INT: return FLAN_DYN_TAG_INT; case BOX_KW: return FLAN_DYN_TAG_KEYWORD; + case BOX_CHAR: return FLAN_DYN_TAG_CHAR; default: { flan_obj *o = dyn_obj(v); if (o == NULL) return FLAN_DYN_TAG_NIL; @@ -582,7 +589,7 @@ int32_t flan_dyn_tag(flan_dyn v) { } const char *flan_dyn_tag_name(int32_t tag) { - if (tag < 0 || tag > FLAN_DYN_TAG_MAP) return "?"; + if (tag < 0 || tag > FLAN_DYN_TAG_LAST) return "?"; return tag_words[tag]; } @@ -677,6 +684,119 @@ static void emit_escaped(dyn_sink w, const uint8_t *p, int64_t n) { emit(w, "\""); } +/* ── Characters ──────────────────────────────────────────────────────── + * + * Text is UTF-8 and a char is one code point. A text's length and its + * indices count code points, so a byte that does not start a well-formed + * sequence — possible, because a text can be made from any typed bytes — + * counts as one char and reads as U+FFFD: the prelude's decode-rune refusal, + * width 1, given the replacement character as its value. */ + +static int utf8_encode(uint32_t cp, uint8_t out[4]) { + if (cp < 0x80) { out[0] = (uint8_t)cp; return 1; } + if (cp < 0x800) { + out[0] = (uint8_t)(0xC0 | (cp >> 6)); + out[1] = (uint8_t)(0x80 | (cp & 0x3F)); + return 2; + } + if (cp < 0x10000) { + out[0] = (uint8_t)(0xE0 | (cp >> 12)); + out[1] = (uint8_t)(0x80 | ((cp >> 6) & 0x3F)); + out[2] = (uint8_t)(0x80 | (cp & 0x3F)); + return 3; + } + out[0] = (uint8_t)(0xF0 | (cp >> 18)); + out[1] = (uint8_t)(0x80 | ((cp >> 12) & 0x3F)); + out[2] = (uint8_t)(0x80 | ((cp >> 6) & 0x3F)); + out[3] = (uint8_t)(0x80 | (cp & 0x3F)); + return 4; +} + +/* The code point at [p], of the [n] bytes left, and its width. Overlong + * forms, surrogates and anything past U+10FFFF are malformed. */ +static uint32_t utf8_decode(const uint8_t *p, int64_t n, int *w) { + uint32_t c = p[0], cp; + int k, i; + *w = 1; + if (c < 0x80) return c; + if (c >= 0xC2 && c <= 0xDF) { k = 2; cp = c & 0x1F; } + else if (c >= 0xE0 && c <= 0xEF) { k = 3; cp = c & 0x0F; } + else if (c >= 0xF0 && c <= 0xF4) { k = 4; cp = c & 0x07; } + else return 0xFFFD; + if (n < k) return 0xFFFD; + for (i = 1; i < k; i++) { + if ((p[i] & 0xC0) != 0x80) return 0xFFFD; + cp = (cp << 6) | (p[i] & 0x3F); + } + if ((k == 3 && cp < 0x800) || (k == 4 && cp < 0x10000) || cp > 0x10FFFF || + (cp >= 0xD800 && cp <= 0xDFFF)) + return 0xFFFD; + *w = k; + return cp; +} + +static int is_scalar(int64_t cp) { + return cp >= 0 && cp <= 0x10FFFF && !(cp >= 0xD800 && cp <= 0xDFFF); +} + +/* A char's spelling, as lib/reader.ml's [read_byte] reads it back and + * lib/form.ml's [byte_repr] writes it: a name where there is one, \uXXXX + * for every other control character (C0, DEL and C1), the character itself after the + * backslash otherwise. */ +static void char_spell(uint32_t cp, char buf[16]) { + uint8_t u[4]; + int n, i; + switch (cp) { + case 32: strcpy(buf, "\\space"); return; + case 9: strcpy(buf, "\\tab"); return; + case 10: strcpy(buf, "\\newline"); return; + case 13: strcpy(buf, "\\return"); return; + case 0: strcpy(buf, "\\nul"); return; + case 8: strcpy(buf, "\\backspace"); return; + case 12: strcpy(buf, "\\formfeed"); return; + default: break; + } + if (cp < 32 || (cp >= 127 && cp <= 0x9F)) { + snprintf(buf, 16, "\\u%04X", (unsigned)cp); + return; + } + n = utf8_encode(cp, u); + buf[0] = '\\'; + for (i = 0; i < n; i++) buf[1 + i] = (char)u[i]; + buf[1 + n] = '\0'; +} + +/* A text is immutable, so its char count is taken once, when it is made, and + * kept in the header's [u.i], which a text does not otherwise use. A count + * equal to the byte length means every byte is ASCII, and an index is then a + * byte offset. [gen] is not touched: on a text it is [pin_text]'s stamp. */ +static void text_measure(flan_obj *o) { + const uint8_t *p = obj_text_bytes(o); + int64_t i = 0, n = 0; + int w; + while (i < o->len) { + if (p[i] < 0x80) { i++; n++; continue; } + utf8_decode(p + i, o->len - i, &w); + i += w; + n++; + } + o->u.i = n; +} + +/* The byte offset of char [k], 0 <= k <= the char count. */ +static int64_t text_offset(flan_obj *o, int64_t k) { + const uint8_t *p = obj_text_bytes(o); + int64_t i = 0; + int w; + if (o->u.i == o->len) return k; + while (k > 0 && i < o->len) { + utf8_decode(p + i, o->len - i, &w); + i += w; + k--; + } + return i; +} + static int64_t dyn_int_value(flan_dyn v); /* forward: both int shapes */ static double dyn_num_value(flan_dyn v); @@ -735,6 +855,11 @@ static void render(dyn_sink w, flan_dyn v, int depth, int nested) { else emit_n(w, obj_text_bytes(o), o->len); return; } + /* A char prints as the literal that reads back as it, at every depth. */ + case FLAN_DYN_TAG_CHAR: + char_spell((uint32_t)dyn_payload(v), buf); + emit(w, buf); + return; /* A keyword prints with its colon, bare, at every depth: :a is its own * spelling the way true is, and quoting it would make it a text. */ case FLAN_DYN_TAG_KEYWORD: { @@ -866,6 +991,9 @@ static void say_render(sayer *s, flan_dyn v, int depth) { if (d != d) snprintf(buf, sizeof buf, "nan"); else snprintf(buf, sizeof buf, "%g", d); say_puts(s, buf); + /* A trap's sentence says 2.0 for a float of 2, so it cannot be read as + the int 2; inf and an exponent already say float. */ + if (strspn(buf, "-0123456789") == strlen(buf)) say_puts(s, ".0"); return; } case FLAN_DYN_TAG_TEXT: { @@ -882,6 +1010,10 @@ static void say_render(sayer *s, flan_dyn v, int depth) { say_puts(s, i < o->len ? "...\"" : "\""); return; } + case FLAN_DYN_TAG_CHAR: + char_spell((uint32_t)dyn_payload(v), buf); + say_puts(s, buf); + return; case FLAN_DYN_TAG_KEYWORD: { kw_entry *k = dyn_kw(v); int64_t i; @@ -1546,8 +1678,9 @@ static void mark_desc(char *base, const flan_desc *d) { * allocator put there next. * * A text is pinned once per stamp, however often it crosses: the stamp's - * number is written into the text's [gen], which nothing else reads for a - * text, so a program that never calls free-temp and passes the same texts + * number is written into the text's [gen], which nothing else reads or + * writes for a text — its char count is in [u.i], and whether it is ASCII is + * that count against its length ([text_measure]) — so a program that never calls free-temp and passes the same texts * in a loop keeps a flat list. Distinct texts cost one pointer each here, * and each keeps its own object alive until the stamp ends — heavier than * i64->bytes's few bytes of arena, since the object has a header. The pins @@ -1790,9 +1923,26 @@ flan_dyn flan_dyn_from_bytes(const uint8_t *p, int64_t n) { o = gc_alloc(OBJ_TEXT, n); o->len = n; if (n > 0) memcpy(obj_text_bytes(o), p, (size_t)n); + text_measure(o); return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } +/* Only a scalar value is a char; the reader and [chars] make nothing else, + * so a refusal here is a compiler bug and not a program's. */ +flan_dyn flan_dyn_from_char(int32_t cp) { + if (!is_scalar(cp)) + trap1(NULL, 0, TYPE_TRAP, "char", "a char is a Unicode scalar value", + flan_dyn_from_i64(cp)); + return dyn_make(BOX_CHAR, (uint64_t)(uint32_t)cp); +} + +/* 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; @@ -2524,17 +2674,15 @@ flan_dyn flan_dyn_class_of(flan_dyn v) { /* The kind of a value as a keyword named by [tag_words], or a class instance's * class name as [flan_dyn_class_of] answers it. A class may not be named like * a kind (the parser refuses it), so :map always means a plain map. Keywords - * are immortal, so each kind's keyword is interned once and kept. When dyn - * gains a char, its tag gets a word in [tag_words] and :char falls out here - * with no change to this function. */ + * are immortal, so each kind's keyword is interned once and kept. */ flan_dyn flan_dyn_type_of(flan_dyn v) { - static flan_dyn kinds[FLAN_DYN_TAG_MAP + 1]; + static flan_dyn kinds[FLAN_DYN_TAG_LAST + 1]; static int interned; int32_t t = flan_dyn_tag(v); if (t == FLAN_DYN_TAG_MAP && dyn_obj(v)->u.v.klass != NULL) return flan_dyn_class_of(v); if (!interned) { - for (int i = 0; i <= FLAN_DYN_TAG_MAP; i++) + for (int i = 0; i <= FLAN_DYN_TAG_LAST; i++) kinds[i] = flan_dyn_kw((const uint8_t *)tag_words[i], (int64_t)strlen(tag_words[i])); interned = 1; @@ -2652,6 +2800,81 @@ double flan_dyn_need_f64(flan_dyn v) { return dyn_num_value(v); } +static const char *an(const char *w); /* forward: "a" or "an" */ + +/* A dyn into a typed integer of width [kind] — 0..7 for i8 u8 i16 u16 i32 + * u32 i64 u64, check.ml's [unbox] — answered as an i64 the caller narrows: + * an int in the width's range, or a char's code point where it fits. A byte + * takes only an ASCII char, because a byte past ASCII is not that char in + * UTF-8. A dyn int is an i64, so a u64 takes 0 up to the largest i64. The + * sentence names what was found and what would do, and no call: the site in + * front of it is the one that failed. */ +static const char *const int_names[8] = { "i8", "u8", "i16", "u16", + "i32", "u32", "i64", "u64" }; + +int64_t flan_dyn_need_int(flan_dyn v, int32_t kind, const uint8_t *loc, + int64_t loclen) { + static const int64_t lo[8] = { -128, 0, -32768, 0, INT32_MIN, 0, INT64_MIN, 0 }; + static const int64_t hi[8] = { 127, 255, 32767, 65535, INT32_MAX, + 4294967295LL, INT64_MAX, INT64_MAX }; + int32_t t = flan_dyn_tag(v); + const char *name; + char sv[SAY_MAX]; + if (kind < 0 || kind > 7) kind = 6; + name = int_names[kind]; + if (t == FLAN_DYN_TAG_CHAR) { + int64_t cp = (int64_t)dyn_payload(v); + int64_t top = kind <= 1 ? 127 : hi[kind]; + char cs[16]; + if (cp <= top) return cp; + char_spell((uint32_t)cp, cs); + if (kind <= 1) + flan_say(loc, loclen, + "dyn: %s %s is wanted here, and the char %s is more than one " + "byte in UTF-8. Take its code point as an i32", + an(name), name, cs); + else + flan_say(loc, loclen, + "dyn: %s %s is wanted here, and the char %s, code point %lld, " + "is outside %s %s's range", an(name), name, cs, (long long)cp, + an(name), name); + flan_trap((const uint8_t *)"DynRange", 8); + } + if (t == FLAN_DYN_TAG_INT) { + int64_t x = dyn_int_value(v); + if (x >= lo[kind] && x <= hi[kind]) return x; + flan_say(loc, loclen, + "dyn: %s %s is wanted here, and the int %lld is outside %s %s's " + "range", an(name), name, (long long)x, an(name), name); + flan_trap((const uint8_t *)"DynRange", 8); + } + if (t == FLAN_DYN_TAG_NIL) sv[0] = '\0'; + else say(sv, SAY_MAX, v); + flan_say(loc, loclen, + "dyn: %s %s is wanted here, and this is %s%s%s%s%s. %s %s takes an " + "int or a char's code point%s%s%s", + an(name), name, t == FLAN_DYN_TAG_NIL ? "" : an(tag_of(v)), + t == FLAN_DYN_TAG_NIL ? "" : " ", tag_of(v), t == FLAN_DYN_TAG_NIL ? "" : ", ", sv, + name[0] == 'i' ? "An" : "A", name, + t == FLAN_DYN_TAG_FLOAT ? "; convert a float with (" : "", + t == FLAN_DYN_TAG_FLOAT ? name : "", + t == FLAN_DYN_TAG_FLOAT ? " x)" : ""); + flan_trap((const uint8_t *)"DynType", 7); +} + +int32_t flan_dyn_need_i32(flan_dyn v, const uint8_t *loc, int64_t loclen) { + return (int32_t)flan_dyn_need_int(v, 4, loc, loclen); +} + +/* The int arm of a numeric cast written on a dyn ([check.ml]'s [cast_dyn]), + * reached once [flan_dyn_cast_kind] has said the box is not a float: an + * int's value, or a char's code point, so (i32 c) is the code point the + * implicit crossing into an i32 gives. */ +int64_t flan_dyn_int_of(flan_dyn v) { + if (flan_dyn_tag(v) == FLAN_DYN_TAG_CHAR) return (int64_t)dyn_payload(v); + return flan_dyn_need_i64(v); +} + uint8_t flan_dyn_need_bool(flan_dyn v) { if (flan_dyn_tag(v) != FLAN_DYN_TAG_BOOL) trap1(NULL, 0, TYPE_TRAP, "bool", "a bool was wanted", v); @@ -2741,6 +2964,19 @@ int32_t flan_dyn_cast_kind(flan_dyn v, const uint8_t *loc, int64_t loc_len, const uint8_t *target, int64_t target_len, int32_t want_float) { int32_t tag = flan_dyn_tag(v); + /* A char casts as its code point, an int: the arm after this reads it + through [flan_dyn_int_of], so (i32 c) is what passing c to an i32 is. */ + if (tag == FLAN_DYN_TAG_CHAR) { + if (want_float && site_first_time(loc, loc_len)) { + fflush(stdout); + fprintf(stderr, + "%.*s: (%.*s x) found a dyn holding a char, and converted its " + "code point to %.*s — warned once for this site\n", + (int)loc_len, (const char *)loc, (int)target_len, + (const char *)target, (int)target_len, (const char *)target); + } + return 0; + } if (tag != FLAN_DYN_TAG_INT && tag != FLAN_DYN_TAG_FLOAT) { /* [trap1] takes the operation as a C string and the target is a Flan * slice, so it is copied out. Every cast name is two or three bytes; the @@ -3055,8 +3291,14 @@ static int order(const uint8_t *loc, int64_t loclen, const char *op, if (c != 0) return c < 0 ? -1 : 1; return x->len < y->len ? -1 : (x->len > y->len ? 1 : 0); } + if (flan_dyn_tag(a) == FLAN_DYN_TAG_CHAR && + flan_dyn_tag(b) == FLAN_DYN_TAG_CHAR) { + uint64_t x = dyn_payload(a), y = dyn_payload(b); + return x < y ? -1 : (x > y ? 1 : 0); + } trap2(loc, loclen, TYPE_TRAP, op, - "it compares two numbers or two texts, and these are neither", a, b); + "it compares two numbers, two texts or two chars, and these are " + "neither", a, b); } flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b, const uint8_t *loc, @@ -3830,6 +4072,27 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, desc_spell(d, ty, sizeof ty); if (int_range(*d, &lo, &hi)) { int64_t n; + /* A char is written as its code point where it fits, [into_put]'s rule: + into a byte only when ASCII, since a byte past ASCII is not that char + in UTF-8. */ + if (flan_dyn_tag(x) == FLAN_DYN_TAG_CHAR) { + char cs[16]; + int byte = *d == 'b' || *d == 'B'; + n = (int64_t)dyn_payload(x); + if (n <= (byte ? 127 : hi)) goto store; + char_spell((uint32_t)n, cs); + if (byte) + snprintf(why, sizeof why, ", and the char %s is more than one byte in " + "UTF-8. Take its code point as an i32", cs); + else + snprintf(why, sizeof why, ", which holds %lld to %lld, and the char " + "%s, code point %lld, does not fit", (long long)lo, + (long long)hi, cs, (long long)n); + if (field) field_refuse(loc, loclen, op, v, key, d, x, "DynRange", why); + flan_say(loc, loclen, "dyn %s: this element is %s %s%s", op, an(ty), ty, + why); + dyn_trap((const uint8_t *)"DynRange", 8); + } if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT) { if (field) { value_is(why, sizeof why, x); @@ -3861,6 +4124,7 @@ static void view_write(const uint8_t *loc, int64_t loclen, const char *op, (long long)hi); dyn_trap((const uint8_t *)"DynRange", 8); } + store: switch (*d) { case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; } case 'h': case 'H': { uint16_t h = (uint16_t)n; memcpy(p, &h, 2); return; } @@ -4302,6 +4566,23 @@ static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p) { int64_t lo, hi; if (int_range(*d, &lo, &hi)) { int64_t n; + /* A char goes in as its code point where it fits, as it does into a + typed parameter ([flan_dyn_need_int]): into a byte only when ASCII, + since a byte past ASCII is not that char in UTF-8. */ + if (flan_dyn_tag(x) == FLAN_DYN_TAG_CHAR) { + char cs[16]; + n = (int64_t)dyn_payload(x); + if (n <= ((*d == 'b' || *d == 'B') ? 127 : hi)) goto store; + char_spell((uint32_t)n, cs); + desc_spell(d, ty, sizeof ty); + if (*d == 'b' || *d == 'B') + into_trap(s, "DynRange", "%s is the char %s, which is more than one " + "byte in UTF-8, so it is not %s %s. Take its code point as " + "an i32", into_who(s), cs, an(ty), ty); + into_trap(s, "DynRange", "%s is the char %s, code point %lld, and %s %s " + "holds %lld to %lld", into_who(s), cs, (long long)n, an(ty), + ty, (long long)lo, (long long)hi); + } if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT) { into_wanted(why, sizeof why, d); into_wrong(s, x, why); @@ -4316,6 +4597,7 @@ static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p) { into_who(s), (long long)n, an(ty), ty, (long long)lo, (long long)hi); } + store: switch (*d) { case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; } case 'h': case 'H': { uint16_t h = (uint16_t)n; memcpy(p, &h, 2); return; } @@ -4578,7 +4860,7 @@ void flan_dyn_need_as(flan_dyn v, const uint8_t *want, int64_t wantlen, } static flan_dyn len_walk(flan_dyn v) { - if (is_text(v)) return flan_dyn_from_i64(dyn_obj(v)->len); + if (is_text(v)) return flan_dyn_from_i64(dyn_obj(v)->u.i); /* A map's length is its slot count, so a stale instance would answer the count of a definition that no longer exists. Migrated first for the same reason [get] is. */ @@ -4607,9 +4889,8 @@ static int64_t need_index(const uint8_t *loc, int64_t loclen, const char *op, return dyn_int_value(i); } -/* A text answers a byte, as an int. That is what [(at s i)] on a - * [(Slice u8)] does in the typed language, and a text is a run of bytes in - * both. Codepoints are utf8's job and stay there. */ +/* A text answers its [i]th char, counting code points: O(1) on an ASCII + * text, a walk from the front on any other. A typed str counts bytes. */ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, int64_t loclen) { int64_t k; @@ -4635,8 +4916,15 @@ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, } } } + if (o->kind == OBJ_TEXT) { + int64_t off; + int w; + if (k < 0 || k >= o->u.i) trap_range(loc, loclen, "at", v, k, o->u.i); + off = text_offset(o, k); + return dyn_make(BOX_CHAR, + utf8_decode(obj_text_bytes(o) + off, o->len - off, &w)); + } if (k < 0 || k >= o->len) trap_range(loc, loclen, "at", v, k, o->len); - if (o->kind == OBJ_TEXT) return flan_dyn_from_i64(obj_text_bytes(o)[k]); return o->u.v.items[k]; } @@ -4652,7 +4940,8 @@ flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, if (!is_text(v)) trap2(loc, loclen, TYPE_TRAP, "slice", "only a text is sliced", v, lo); o = dyn_obj(v); - len = o->len; + /* The bounds count chars, as [length] and [at] do. */ + len = o->u.i; a = need_index(loc, loclen, "slice", v, lo); b = flan_dyn_tag(hi) == FLAN_DYN_TAG_NIL ? len : need_index(loc, loclen, "slice", v, hi); @@ -4664,9 +4953,67 @@ flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, "— %s", (long long)a, (long long)b, (long long)len, sv); dyn_trap((const uint8_t *)"DynRange", 8); } + a = text_offset(o, a); + b = text_offset(o, b); return flan_dyn_from_bytes(obj_text_bytes(o) + a, b - a); } +/* (chars t): a text's chars, a fresh vec of them. */ +flan_dyn flan_dyn_chars(flan_dyn v, const uint8_t *loc, int64_t loclen) { + flan_obj *o; + flan_dyn out; + int64_t i = 0; + int w; + if (!is_text(v)) + trap1(loc, loclen, TYPE_TRAP, "chars", "only a text has chars", v); + out = flan_dyn_vec_new(); + o = dyn_obj(v); + while (i < o->len) { + uint32_t cp = utf8_decode(obj_text_bytes(o) + i, o->len - i, &w); + flan_dyn_push(out, dyn_make(BOX_CHAR, cp), loc, loclen); + i += w; + } + return out; +} + +/* (text x): a vec of chars, or one char, as a text — [chars] undone. */ +flan_dyn flan_dyn_text(flan_dyn v, const uint8_t *loc, int64_t loclen) { + uint8_t u[4]; + int64_t i, n, total = 0; + flan_obj *src, *o; + if (flan_dyn_tag(v) == FLAN_DYN_TAG_CHAR) { + int k = utf8_encode((uint32_t)dyn_payload(v), u); + return flan_dyn_from_bytes(u, k); + } + if (!is_vec(v)) + trap1(loc, loclen, TYPE_TRAP, "text", + "text is made from a vec of chars or from one char", v); + src = dyn_obj(v); + n = vecish_len(src); + for (i = 0; i < n; i++) { + flan_dyn c = vecish_at(src, i); + if (flan_dyn_tag(c) != FLAN_DYN_TAG_CHAR) { + char sc[SAY_MAX]; + say(sc, SAY_MAX, c); + flan_say(loc, loclen, + "dyn text: element %lld is %s %s, and text is made from chars " + "only", (long long)i, an(tag_of(c)), sc); + flan_trap((const uint8_t *)"DynType", 7); + } + total += utf8_encode((uint32_t)dyn_payload(c), u); + } + o = gc_alloc(OBJ_TEXT, total); + o->len = total; + total = 0; + for (i = 0; i < n; i++) { + int k = utf8_encode((uint32_t)dyn_payload(vecish_at(src, i)), u); + memcpy(obj_text_bytes(o) + total, u, (size_t)k); + total += k; + } + text_measure(o); + return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); +} + void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc, int64_t loclen) { int64_t k; diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index a835efea..5579dd26 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -94,6 +94,11 @@ 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); + +/* A char, by its code point. Anything but a Unicode scalar value traps. */ +flan_dyn flan_dyn_from_char(int32_t cp); flan_dyn flan_dyn_vec_new(void); flan_dyn flan_dyn_map_new(void); @@ -134,7 +139,7 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, flan_dyn flan_dyn_class_of(flan_dyn v); /* The value's kind as a keyword — :nil :bool :int :float :text :vec :keyword - * :map — or, for a class instance, its class name as [flan_dyn_class_of] + * :map :char — or, for a class instance, its class name as [flan_dyn_class_of] * answers it. Never traps. */ flan_dyn flan_dyn_type_of(flan_dyn v); @@ -219,8 +224,8 @@ flan_dyn flan_dyn_popcount(flan_dyn a, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_clz(flan_dyn a, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_ctz(flan_dyn a, const uint8_t *loc, int64_t loclen); -/* Answer a bool dyn. Numbers compare as numbers and text compares bytewise; - * a mixture of the two, or anything else, traps. */ +/* Answer a bool dyn. Numbers compare as numbers and text compares bytewise, + * chars by code point; a mixture, or anything else, traps. */ flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_le(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); flan_dyn flan_dyn_gt(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen); @@ -230,20 +235,26 @@ flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen) * of unrelated tags are not an error, they are unequal. */ flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b); -/* Bytes of a text, elements of a vec. Anything else traps. */ +/* Chars of a text, elements of a vec. Anything else traps. */ flan_dyn flan_dyn_len(flan_dyn v); -/* Element of a vec, or the byte of a text as an int. Out of range traps. +/* Element of a vec, or the char of a text. A text counts code points. Out of + * range traps. * [loc] is where the call was written, printed ahead of a trap's sentence; NULL * prints none. The same pair [flan_dyn_add] takes. */ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, int64_t loclen); -/* A copy of the text's bytes [lo, hi); nil for [hi] is the length. A vec, or +/* A copy of the text's chars [lo, hi); nil for [hi] is the length. A vec, or * any other value, traps: see the definition. */ flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi, const uint8_t *loc, int64_t loclen); +/* (chars t): a new vec of the text's chars. (text x): the text a vec of + * chars, or one char, spells. Anything else traps at [loc]. */ +flan_dyn flan_dyn_chars(flan_dyn v, const uint8_t *loc, int64_t loclen); +flan_dyn flan_dyn_text(flan_dyn v, const uint8_t *loc, int64_t loclen); + /* Vec only — a text is immutable and says so rather than being copied. */ void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc, int64_t loclen); @@ -284,6 +295,15 @@ void flan_dyn_emit_watch(flan_dyn v); int64_t flan_dyn_need_i64(flan_dyn v); double flan_dyn_need_f64(flan_dyn v); uint8_t flan_dyn_need_bool(flan_dyn v); +/* For a typed integer of width [kind], 0..7 for i8 u8 i16 u16 i32 u32 i64 + * u64: an int in range, or a char's code point where it fits (ASCII only + * into a byte), as an i64 the caller narrows. Anything else traps at [loc]. + * [flan_dyn_need_i32] is kind 4. */ +int64_t flan_dyn_need_int(flan_dyn v, int32_t kind, const uint8_t *loc, + int64_t loclen); +int32_t flan_dyn_need_i32(flan_dyn v, const uint8_t *loc, int64_t loclen); +/* A numeric cast's int arm: an int's value or a char's code point. */ +int64_t flan_dyn_int_of(flan_dyn v); /* A numeric cast written on a dyn — [(f64 d)], [(u32 d)] — TODO.org, * "A numeric cast opens a dyn box". Unlike the parameter boundary above this @@ -516,6 +536,7 @@ void flan_dyn_root_globals_end(void); #define FLAN_DYN_TAG_VEC 5 #define FLAN_DYN_TAG_KEYWORD 6 #define FLAN_DYN_TAG_MAP 7 +#define FLAN_DYN_TAG_CHAR 8 int32_t flan_dyn_tag(flan_dyn v); const char *flan_dyn_tag_name(int32_t tag); diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 098a9724..db440528 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2908,6 +2908,230 @@ 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); +} + +/* The same over a slice of byte slices, each a (ptr, len) pair: the parts a + * join or a concat is handed. */ +void flan_utf8_check_parts(const void *parts, int64_t n, const uint8_t *loc, + int64_t loclen) { + const struct { const uint8_t *p; int64_t n; } *ps = parts; + int64_t i; + for (i = 0; i < n; i++) flan_utf8_check(ps[i].p, ps[i].n, loc, loclen); +} + +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); + /* Stops at the position, so an insert near the front costs what it walks + * and not the whole text. The count is finished only for the message. A + * width that would run past the end is taken as 1, so a String whose bytes + * were ever wrong is never read beyond its length. */ + while (off < v->len) { + int64_t w; + if (count == want) { found = off; break; } + w = utf8_width(p[off]); + off += (w <= v->len - off) ? w : 1; + count++; + } + if (found < 0 && want == count && past_end) found = v->len; + if (want < 0 || found < 0) { + while (off < v->len) { + int64_t w = utf8_width(p[off]); + off += (w <= v->len - off) ? w : 1; + count++; + } + 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]); + /* Never past the length, however the bytes came to be what they are. */ + if (w > v->len - off) w = 1; + 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/dev_limits.c b/test/dev_limits.c index 33480c7f..1f159307 100644 --- a/test/dev_limits.c +++ b/test/dev_limits.c @@ -435,14 +435,44 @@ static int race(void) { return 0; } +/* A String's character walk over bytes that are not valid UTF-8, which no + * Flan program can make: a lead byte promising three bytes where the length + * leaves one. The header is flan_rt.c's flan_vec, restated; a null allocator + * skips the epoch check. The bytes past the length are valid continuation + * bytes, so a walk that read past the end would count and decode them. */ +typedef struct { + void *ptr; + int64_t len, cap; + void *alloc; + int64_t epoch; +} limits_vec; +int64_t flan_string_index(void *v, int32_t i, int32_t past_end, + const uint8_t *loc, int64_t loclen, void *xfer); +int32_t flan_string_remove(void *v, int64_t off, const uint8_t *loc, + int64_t loclen); + +static int string_walk(void) { + static uint8_t lead_last[4] = { 0x61, 0xe6, 0x80, 0x80 }; + static uint8_t lead_first[4] = { 0xe6, 0x61, 0x80, 0x80 }; + limits_vec a = { lead_last, 2, 4, NULL, 0 }; + limits_vec b = { lead_first, 2, 4, NULL, 0 }; + const uint8_t *loc = (const uint8_t *)"dev_limits.c"; + printf("index %lld\n", (long long)flan_string_index(&b, 1, 0, loc, 12, NULL)); + printf("end %lld\n", (long long)flan_string_index(&a, 2, 1, loc, 12, NULL)); + printf("removed %d len %lld\n", flan_string_remove(&a, 1, loc, 12), + (long long)a.len); + return 0; +} + int main(int argc, char **argv) { flan_rt_init(argc, argv); if (argc < 2) { fprintf(stderr, - "usage: %s cap|race|names|regfull|regchurn|regrace|regoverflow\n", + "usage: %s cap|race|string|names|regfull|regchurn|regrace|regoverflow\n", argv[0]); return 2; } + if (strcmp(argv[1], "string") == 0) return string_walk(); if (strcmp(argv[1], "cap") == 0) return cap(); if (strcmp(argv[1], "race") == 0) return race(); if (strcmp(argv[1], "names") == 0) return names(); diff --git a/test/dyn_ops.c b/test/dyn_ops.c index 04c8efd5..74061b11 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -139,6 +139,28 @@ static void ops(void) { check(flan_dyn_tag(flan_dyn_from_f64(1.5)) == FLAN_DYN_TAG_FLOAT, "tag float"); check(flan_dyn_tag(text("x")) == FLAN_DYN_TAG_TEXT, "tag text"); check(flan_dyn_tag(flan_dyn_vec_new()) == FLAN_DYN_TAG_VEC, "tag vec"); + check(flan_dyn_tag(flan_dyn_from_char(0x65E5)) == FLAN_DYN_TAG_CHAR, "tag char"); + check(strcmp(flan_dyn_tag_name(FLAN_DYN_TAG_CHAR), "char") == 0, "word char"); + check(flan_dyn_need_i32(flan_dyn_from_char(0x1F600), NULL, 0) == 0x1F600, + "need-i32 answers a char's code point"); + check(flan_dyn_need_i32(flan_dyn_from_i64(-7), NULL, 0) == -7, + "need-i32 answers an int that fits"); + check(flan_dyn_int_of(flan_dyn_from_char('a')) == 97, + "a cast's int arm reads a char's code point"); + { + /* "é日😀" is 2 + 3 + 4 bytes and three chars, and chars/text round-trip. */ + flan_dyn t = text("\xC3\xA9\xE6\x97\xA5\xF0\x9F\x98\x80"); + check(num(flan_dyn_len(t)) == 3, "len counts chars"); + check(flan_dyn_need_i32(FDYN_at(t, flan_dyn_from_i64(1)), NULL, 0) == 0x65E5, + "at answers a char"); + check(truth(flan_dyn_eq(flan_dyn_text(flan_dyn_chars(t, NULL, 0), NULL, 0), t)), + "text undoes chars"); + check(truth(flan_dyn_lt(flan_dyn_from_char('a'), flan_dyn_from_char(0xE9), + NULL, 0)), + "chars order by code point"); + check(!truth(flan_dyn_eq(flan_dyn_from_char('a'), flan_dyn_from_i64('a'))), + "a char is not an int"); + } check(strcmp(flan_dyn_tag_name(FLAN_DYN_TAG_NIL), "nil") == 0, "word nil"); check(strcmp(flan_dyn_tag_name(FLAN_DYN_TAG_BOOL), "bool") == 0, "word bool"); check(strcmp(flan_dyn_tag_name(FLAN_DYN_TAG_INT), "int") == 0, "word int"); @@ -249,14 +271,14 @@ static void ops(void) { check(!truth(flan_dyn_eq(a, c)), "= text sees the last byte"); check(truth(flan_dyn_eq(a, a)), "= text against itself"); check(num(flan_dyn_len(a)) == 5, "len text"); - check(num(FDYN_at(a, flan_dyn_from_i64(0))) == 'h', "at text"); - check(num(FDYN_at(a, flan_dyn_from_i64(4))) == 'o', "at text last"); + check(flan_dyn_need_i32(FDYN_at(a, flan_dyn_from_i64(0)), NULL, 0) == 'h', "at text"); + check(flan_dyn_need_i32(FDYN_at(a, flan_dyn_from_i64(4)), NULL, 0) == 'o', "at text last"); { /* Embedded NUL, because a length-prefixed text is the claim and strlen is how that claim gets quietly broken. */ flan_dyn z = flan_dyn_from_bytes((const uint8_t *)"a\0b", 3); check(num(flan_dyn_len(z)) == 3, "len counts past a NUL"); - check(num(FDYN_at(z, flan_dyn_from_i64(2))) == 'b', "at past a NUL"); + check(flan_dyn_need_i32(FDYN_at(z, flan_dyn_from_i64(2)), NULL, 0) == 'b', "at past a NUL"); check(!truth(flan_dyn_eq(z, text("a"))), "= does not stop at a NUL"); } { 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/dyn-char-pinned.flan b/test/programs/dyn-char-pinned.flan new file mode 100644 index 00000000..3801c28a --- /dev/null +++ b/test/programs/dyn-char-pinned.flan @@ -0,0 +1,25 @@ +;;;; A non-ASCII text that has crossed into a str still counts characters, +;;;; however many times it crosses; and a char is written through a dyn view of +;;;; typed storage as its code point where it fits. With an argument, \é +;;;; written into a view of bytes traps. + +(defn byte-len [s str] i32 (length s)) + +(defn main [args [str]] i32 + (let [t (the dyn "é日😀")] + (dotimes [i 3] (println (byte-len t))) + (println (length t)) + (println (at t 1)) + (println (slice t 0 2))) + (let [a (the [3 i32] [1 2 3]) + v (the dyn a)] + (set (at v 0) \z) + (set (at v 1) \日) + (println (at a 0) (at a 1) (at a 2))) + (let [b (the [2 u8] [1 2]) + w (the dyn b)] + (set (at w 0) \a) + (println (at b 0) (at b 1)) + (when (> (length args) 1) + (set (at w 1) \é))) + 0) diff --git a/test/programs/dyn-char-spell.flan b/test/programs/dyn-char-spell.flan new file mode 100644 index 00000000..c61cac62 --- /dev/null +++ b/test/programs/dyn-char-spell.flan @@ -0,0 +1,19 @@ +;;;; Every ASCII code point, the C1 controls, and a few past them, as dyn chars printed one per +;;;; line. The test reads each line back with the reader and wants the same +;;;; code point, so what a char prints as is what reads as it. + +(defn main [] i32 + (let [v (vec-new u8)] + (dotimes [i 128] (push v (u8 i))) + (let [t (the dyn (str (slice v)))] + (dotimes [i (length t)] (println (at t i)))) + ;; the C1 controls, U+0080 to U+009F, and U+00A0, each C2 then one byte + (let [w (vec-new u8)] + (dotimes [i 33] (push w (u8 0xC2)) (push w (u8 (+ 0x80 i)))) + (let [c1 (the dyn (str (slice w)))] + (dotimes [i (length c1)] (println (at c1 i)))) + (free w)) + (let [u (the dyn "é日😀")] + (dotimes [i (length u)] (println (at u i)))) + (free v)) + 0) diff --git a/test/programs/dyn-char-string.flan b/test/programs/dyn-char-string.flan new file mode 100644 index 00000000..eedd5f9e --- /dev/null +++ b/test/programs/dyn-char-string.flan @@ -0,0 +1,23 @@ +;;;; A String, and a str made from one, crossing into dyn: the dyn text counts +;;;; characters and indexes by them, ASCII or not. A char literal appends to a +;;;; String as its code point. + +(defn as-dyn [d] dyn d) + +(defn main [] i32 + (let [s (string-new "ab") + u (string-new "é")] + (append u \日) + (append u \😀) + (append u \!) + (let [a (as-dyn s) + d (as-dyn u) + e (as-dyn (str u))] + (println a (length a) (at a 1)) + (println d (length d) (at d 1) (at d 3)) + (println (slice d 1 3) (chars d)) + (println e (length e) (at e 2) (= d e))) + (println (length u) (rune-count u)) + (free s) + (free u)) + 0) diff --git a/test/programs/dyn-char.flan b/test/programs/dyn-char.flan new file mode 100644 index 00000000..a89d878a --- /dev/null +++ b/test/programs/dyn-char.flan @@ -0,0 +1,51 @@ +;;;; Dyn chars: a char literal that ends up dyn is a char and prints as its +;;;; literal; a dyn text counts characters, not bytes; chars and text convert +;;;; between a text and a vec of chars. With an argument, a dyn text handed to +;;;; an i32 traps at the call, and with "big" an int past an i32's range does. + +(defn show [x] () (println x)) +(defn code-point [c i32] i32 c) + +(defn main [args [str]] i32 + (let [t (the dyn "é日😀 ok") + cs (chars t)] + ;; literals, printed + (show \I) + (show \é) + (show \日) + (show \😀) + (show [\a \space \( \newline]) + (show (type-of \é)) + ;; length and indexing count characters + (show (length t)) + (show (at t 0)) + (show (at t 1)) + (show (at t 2)) + (show (at t 4)) + (show (slice t 1 3)) + ;; chars and text + (show cs) + (show (length cs)) + (show (text cs)) + (show (= (text cs) t)) + (show (text \日)) + (show (text [\o \k])) + ;; equality, ordering, and a char as a map key + (show (= (at t 1) \日)) + (show (= (at t 0) \e)) + (show (= (at t 4) (the dyn "o"))) + (show (= (at t 4) (the dyn 111))) + (show (< (at t 0) (at t 1))) + (show (> (at t 1) (at t 2))) + (show (< (at t 4) \é)) + (show (get {\é 1 \日 2} (at t 1))) + ;; into typed code: the code point + (show (code-point (at t 2))) + ;; an int that fits goes in too, and a cast agrees with the crossing + (show (code-point (the dyn 5))) + (show (i32 (the dyn \a))) + (when (> (length args) 1) + (if (= (at args 1) "big") + (show (code-point (the dyn 5000000000))) + (show (code-point (the dyn "x")))))) + 0) diff --git a/test/programs/dyn-int-widths.flan b/test/programs/dyn-int-widths.flan new file mode 100644 index 00000000..63857a26 --- /dev/null +++ b/test/programs/dyn-int-widths.flan @@ -0,0 +1,66 @@ +;;;; A dyn into a typed integer of every width: an int in the width's range +;;;; passes, and so does a char's code point where it fits (ASCII only into a +;;;; byte). A cast on a dyn is the typed cast after an unbox, so it takes a +;;;; char too and wraps as a typed cast does. With an argument, one crossing +;;;; out of range traps at its call. + +(defn to-i8 [x i8] i64 (i64 x)) +(defn to-u8 [x u8] i64 (i64 x)) +(defn to-i16 [x i16] i64 (i64 x)) +(defn to-u16 [x u16] i64 (i64 x)) +(defn to-i32 [x i32] i64 (i64 x)) +(defn to-u32 [x u32] i64 (i64 x)) +(defn to-i64 [x i64] i64 x) +(defn to-u64 [x u64] u64 x) + +(defn d [x] dyn x) + +(defn main [args [str]] i32 + (do + ;; the edges of each width, both ends, and a char at each + (println (to-i8 (d -128)) (to-i8 (d 127)) (to-i8 (d \a))) + (println (to-u8 (d 0)) (to-u8 (d 255)) (to-u8 (d \a))) + (println (to-i16 (d -32768)) (to-i16 (d 32767)) (to-i16 (d \é))) + (println (to-u16 (d 0)) (to-u16 (d 65535)) (to-u16 (d \日))) + (println (to-i32 (d -2147483648)) (to-i32 (d 2147483647)) (to-i32 (d \😀))) + (println (to-u32 (d 0)) (to-u32 (d 4294967295)) (to-u32 (d \😀))) + (println (to-i64 (d -9223372036854775807)) (to-i64 (d 9223372036854775807)) + (to-i64 (d \😀))) + (println (to-u64 (d 0)) (to-u64 (d 9223372036854775807)) (to-u64 (d \😀))) + ;; casts: a char at every width, and the typed cast's wrap + (println (i8 (d \a)) (u8 (d \a)) (i16 (d \a)) (u16 (d \a)) + (i32 (d \a)) (u32 (d \a)) (i64 (d \a)) (u64 (d \a))) + (println (u32 (d -1)) (u32 (the i64 -1)) (u8 (d 256)) (u8 (the i64 256))) + ;; into a typed array and a struct, chars by the same rule + (println (sum (d [\a \b])) (pair-sum (d {:a \a :b \日}))) + (when (> (length args) 1) + (let [w (at args 1)] + (cond + (= w "u8-256") (println (to-u8 (d 256))) + (= w "u8-neg") (println (to-u8 (d -1))) + (= w "i8-128") (println (to-i8 (d 128))) + (= w "i16-big") (println (to-i16 (d 32768))) + (= w "u16-big") (println (to-u16 (d 65536))) + (= w "i32-big") (println (to-i32 (d 2147483648))) + (= w "u32-neg") (println (to-u32 (d -1))) + (= w "u64-neg") (println (to-u64 (d -1))) + (= w "u8-char") (println (to-u8 (d \é))) + (= w "u16-char") (println (to-u16 (d \😀))) + (= w "float") (println (to-i64 (d 2.0))) + (= w "elem-char") (println (bytes-sum (d [\a \é]))) + (= w "field-char") (println (pair-sum (d {:a \é :b 1}))) + :else (println (to-i64 (d "x"))))))) + 0) + +(defn sum [xs [const i32]] i64 + (let [t (the i64 0)] + (dotimes [i (length xs)] (set t (+ t (i64 (at xs i))))) + t)) + +(defn bytes-sum [xs [const u8]] i64 + (let [t (the i64 0)] + (dotimes [i (length xs)] (set t (+ t (i64 (at xs i))))) + t)) + +(defstruct Pair [a u8 b i32]) +(defn pair-sum [p Pair] i64 (+ (i64 (.a p)) (i64 (.b p)))) 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..7842406e --- /dev/null +++ b/test/programs/string-leak.flan @@ -0,0 +1,16 @@ +;;;; A dev build's registry names a String's block by its type: the one freed +;;;; is gone from the report at exit, and the ones kept — made by string-new, by +;;;; a prelude builder and by bytes->string — are listed under String. +(defn main [] i32 + (let [kept (string-new "kept") + gone (string-new "gone")] + (append kept " for good") + (free gone) + (println kept) + ;; A builder's answer and a checked copy are Strings in the report too. + (println (to-upper (bytes-view "loud"))) + (let [v (vec-new u8)] + (push v 0x61) + (println (bytes->string v)) + (free v))) + 0) diff --git a/test/programs/string-owned.flan b/test/programs/string-owned.flan new file mode 100644 index 00000000..7b1bc099 --- /dev/null +++ b/test/programs/string-owned.flan @@ -0,0 +1,90 @@ +;;;; 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)) + ;; = and != compare bytes, against a String or a str, either side first. + (let [a (string-new "日本") + b (string-new "日")] + (append b 0x672c) + (println (= a b) (!= a b) (= a "日本") (= "日本" a) (= a "日") (!= b "x")) + (println (= a b (to-upper (bytes-view "日本")))) + (free a) + (free b)) + ;; bytes->string copies: a write through the Vec afterwards, or through a + ;; slice taken of it before, does not reach the String. + (let [v (vec-new u8)] + (push v 0xc3) + (push v 0xa9) + (let [early (slice v) + t (bytes->string v)] + (set (at v 0) 0xff) + (set (at early 1) 0xe6) + (println t (length t) (rune-count t)) + (free t)) + (free v)) + ;; A remove near the front and an insert at the front, on a long text. + (let [long (string-new "é")] + (dotimes [i 1000] (append long "ab")) + (insert long 0 "x") + (println (remove long 1) (length long)) + (free long)) + (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..3f951715 --- /dev/null +++ b/test/programs/string-traps.flan @@ -0,0 +1,25 @@ +;;;; 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; and a text builder +;;;; given bytes that are not UTF-8 stops at the call that asked for it, or, +;;;; called through a function value, at its own check in the prelude. 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)) + (= which 5) (println (to-lower (slice bad))) + (= which 6) (let [f to-lower] (println (f (slice bad)))) + :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 97f591c1..b70e5e25 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]) - lower = to-lower(text) + lowered = to-lower(text) + lower = bytes-view(lowered) i = 0 n = length(lower) while :scan i < n diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 0e71bb29..6b13cab9 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2029,6 +2029,85 @@ 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\n\ + true false true true false true\ntrue\né 2 1\n233 2001\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:17:19: this text is not valid UTF-8 — byte 0 \ + is 0xc3"); + ("1", "string-traps.flan:18:19: 55296 is not a Unicode scalar value"); + ("2", "string-traps.flan:19:19: index 3 is out of bounds for length 2"); + ("3", "string-traps.flan:20:28: index 2 is out of bounds for length 2"); + (* A builder called by name is checked at the call, before it runs. *) + ("5", "string-traps.flan:21:28: this text is not valid UTF-8 — byte 0 \ + is 0xc3"); + (* Called through a function value, it has no call site to check at, + and its own check in the prelude stops it: the site is the + prelude's, and the line is not pinned here so that editing the + prelude does not move this row. *) + ("6", ":"); + ("6", ": this text is not valid UTF-8 — byte 0 is 0xc3"); + ("4", "string-traps.flan:23: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 — string-new's, a builder's and bytes->string's alike — 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\nLOUD\na\nflan: 3 blocks still held at exit, 24 bytes\n\ + flan: 3 24 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 @@ -5433,6 +5512,167 @@ level "1" "programs/dyn-type-of.flan" dyn_type_of_out; outputs ~x86:true "dyn: type-of, --x86" "programs/dyn-type-of.flan" dyn_type_of_out; + (* Dyn chars: literals printed as literals, non-ASCII included; a text's + length, at and slice counting characters; chars and text round trips; + equality and ordering by code point; a char as a map key; a char's + code point in a typed i32. With an argument, a dyn int at the i32 + traps at the call. *) + let dyn_char_out = + "\\I\n\\é\n\\日\n\\😀\n[\\a \\space \\( \\newline]\n:char\n\ + 6\n\\é\n\\日\n\\😀\n\\o\n日😀\n\ + [\\é \\日 \\😀 \\space \\o \\k]\n6\né日😀 ok\ntrue\n日\nok\n\ + true\nfalse\nfalse\nfalse\ntrue\nfalse\ntrue\n2\n128512\n5\n97\n" + in + outputs "dyn: chars" "programs/dyn-char.flan" dyn_char_out; + outputs ~opt:"-O0" "dyn: chars, -O0" "programs/dyn-char.flan" dyn_char_out; + outputs ~x86:true "dyn: chars, --x86" "programs/dyn-char.flan" dyn_char_out; + (* A String, and a str made from one, cross into dyn as text measured + like any other: characters counted, ASCII or not. *) + let string_char_out = + "ab 2 \\b\né日😀! 4 \\日 \\!\n日😀 [\\é \\日 \\😀 \\!]\n\ + é日😀! 4 \\😀 true\n10 4\n" + in + outputs "dyn: a String crossing counts chars" + "programs/dyn-char-string.flan" string_char_out; + outputs ~opt:"-O0" "dyn: a String crossing counts chars, -O0" + "programs/dyn-char-string.flan" string_char_out; + outputs ~x86:true "dyn: a String crossing counts chars, --x86" + "programs/dyn-char-string.flan" string_char_out; + (* A text pinned by crossing into a str keeps counting characters (the + pin's stamp and the text's measure live in different header fields), + and a char writes through a view of typed storage. *) + let pinned_out = "9\n9\n9\n3\n\\日\né日\n122 26085 3\n97 2\n" in + outputs "dyn: a pinned text counts chars" "programs/dyn-char-pinned.flan" + pinned_out; + outputs ~opt:"-O0" "dyn: a pinned text counts chars, -O0" + "programs/dyn-char-pinned.flan" pinned_out; + outputs ~x86:true "dyn: a pinned text counts chars, --x86" + "programs/dyn-char-pinned.flan" pinned_out; + List.iter + (fun x86 -> + let exe = compile ~x86 "programs/dyn-char-pinned.flan" in + let code, text = run exe (Some "x") in + let want = "programs/dyn-char-pinned.flan:24:7: dyn set-at: this \ + element is a u8, and the char \\é is more than one byte" in + if code <> 134 || not (contains text want) then begin + incr failures; + Printf.printf "FAIL dyn: \\é into a byte view traps%s\n \ + got: %S (exit %d)\n" + (if x86 then ", --x86" else "") text code + end) + [ false; true ]; + (* A dyn into every integer width: both edges pass, a char passes where + it fits, a cast takes a char and wraps as the typed cast beside it + does; then one trap per width past its range, a char too wide, and a + text, each at its own call. *) + let widths_out = + "-128 127 97\n0 255 97\n-32768 32767 233\n0 65535 26085\n\ + -2147483648 2147483647 128512\n0 4294967295 128512\n\ + -9223372036854775807 9223372036854775807 128512\n\ + 0 9223372036854775807 128512\n97 97 97 97 97 97 97 97\n\ + 4294967295 4294967295 0 0\n195 26182\n" + in + outputs "dyn: every integer width" "programs/dyn-int-widths.flan" widths_out; + outputs ~opt:"-O0" "dyn: every integer width, -O0" + "programs/dyn-int-widths.flan" widths_out; + outputs ~x86:true "dyn: every integer width, --x86" + "programs/dyn-int-widths.flan" widths_out; + List.iter + (fun x86 -> + let exe = compile ~x86 "programs/dyn-int-widths.flan" in + List.iter + (fun (arg, want) -> + let want = "programs/dyn-int-widths.flan:" ^ want in + let code, text = run exe (Some arg) in + if code <> 134 || not (contains text want) then begin + incr failures; + Printf.printf + "FAIL dyn: %s traps%s\n got: %S (exit %d)\n \ + wanted: %S (exit 134)\n" + arg (if x86 then ", --x86" else "") text code want + end) + [ ("u8-256", "39:42: dyn: a u8 is wanted here, and the int 256 is \ + outside a u8's range"); + ("u8-neg", "40:42: dyn: a u8 is wanted here, and the int -1 is \ + outside a u8's range"); + ("i8-128", "41:42: dyn: an i8 is wanted here, and the int 128 is \ + outside an i8's range"); + ("i16-big", "42:44: dyn: an i16 is wanted here, and the int 32768"); + ("u16-big", "43:44: dyn: a u16 is wanted here, and the int 65536"); + ("i32-big", "44:44: dyn: an i32 is wanted here, and the int \ + 2147483648"); + ("u32-neg", "45:44: dyn: a u32 is wanted here, and the int -1 is \ + outside a u32's range"); + ("u64-neg", "46:44: dyn: a u64 is wanted here, and the int -1"); + ("u8-char", "47:43: dyn: a u8 is wanted here, and the char \\é is \ + more than one byte in UTF-8"); + ("u16-char", "48:45: dyn: a u16 is wanted here, and the char \ + \\😀, code point 128512, is outside a u16's range"); + ("float", "49:42: dyn: an i64 is wanted here, and this is a \ + float, 2.0."); + ("elem-char", "50:49: dyn into [const u8]: element 1 is the \ + char \\é, which is more than one byte in UTF-8"); + ("field-char", "51:49: dyn into Pair: field :a is the char \\é, \ + which is more than one byte in UTF-8"); + ("x", "52:34: dyn: an i64 is wanted here, and this is a text, \ + \"x\". An i64 takes an int or a char's code point") ]) + [ false; true ]; + (* Print, then read: each char dyn-char-spell.flan prints — every ASCII + code point, the C1 controls, then four past them — reads back as the code point it was, + and so does the compiler's own spelling of the same literal, which is + what flan convert writes. *) + let spelled = + List.init 128 Fun.id @ List.init 32 (fun i -> 0x80 + i) + @ [ 0xA0; 0xE9; 0x65E5; 0x1F600 ] + in + let read_char s = + match Reader.read_all ~file:"" s with + | [ { Form.v = Form.Byte b; _ } ] -> Some b + | _ | (exception Loc.Error _) -> None + in + List.iter + (fun cp -> + let s = Form.byte_repr cp in + if read_char s <> Some cp then begin + incr failures; + Printf.printf "FAIL char %d is written %S, which does not read \ + back as it\n" cp s + end) + spelled; + List.iter + (fun x86 -> + let exe = compile ~x86 "programs/dyn-char-spell.flan" in + let code, text = run exe None in + let lines = String.split_on_char '\n' text in + let lines = List.filteri (fun i _ -> i < List.length spelled) lines in + let got = List.map read_char lines in + if code <> 0 || got <> List.map Option.some spelled then begin + incr failures; + Printf.printf "FAIL dyn chars read back as printed%s\n \ + got: %S (exit %d)\n" + (if x86 then ", --x86" else "") text code + end) + [ false; true ]; + List.iter + (fun x86 -> + let exe = compile ~x86 "programs/dyn-char.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 dyn: a dyn %s at an i32 traps%s\n got: %S \ + (exit %d)\n wanted: %S (exit 134)\n" + arg (if x86 then ", --x86" else "") text code want + end) + [ ("x", "programs/dyn-char.flan:50:27: dyn: an i32 is wanted \ + here, and this is a text, \"x\". An i32 takes an int or \ + a char's code point"); + ("big", "programs/dyn-char.flan:49:27: dyn: an i32 is wanted \ + here, and the int 5000000000 is outside an i32's \ + range") ]) + [ false; true ]; (* (watch "name" v) with nothing arming the table: a struct, an array, a slice, a dyn map and a string all compile against flan_dev.c's watch entry points on both backends, write nothing, and evaluate the value @@ -5584,7 +5824,7 @@ level "1" Matched on the half that carries the meaning rather than on the whole sentence, so the row is about the trap being reached with the right two things in hand and not about punctuation. *) - || not (contains text "float, and an int was wanted") + || not (contains text "an i64 is wanted here, and this is a float, 1.5") then begin incr failures; Printf.printf @@ -5632,7 +5872,7 @@ level "1" in if code <> 134 || not (contains text nil_option_out) - || not (contains text "int was wanted") + || not (contains text "an i64 is wanted here, and this is nil.") then begin incr failures; Printf.printf diff --git a/test/test_dev.ml b/test/test_dev.ml index b0d74d17..b856d62e 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -253,6 +253,9 @@ let eval_in_frame_checks ~backend ask = expect "(+ n 1)" "4"; expect "(.y p)" "2.5"; expect "label" "\"inner\""; + (* A dyn char answers as the literal that reads back as it. *) + expect "(at (chars \"a b\") 1)" "\\space"; + expect "[\\x (at (chars \"hi\") 1)]" "[\\x \\i]"; expect "(do (set flag false) flag)" "false"; (match Wire.field (ask "(:op \"locals\" :frame 0)") "locals" diff --git a/test/test_flan.ml b/test/test_flan.ml index 1dedf61e..48c10224 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -113,6 +113,10 @@ let () = reads "byte named" "\\space" "\\space"; reads "byte digit" "\\0" "\\0"; reads "byte paren" "\\(" "\\("; + reads "char by \\uXXXX" "\\u0041" "\\A"; + reads "control char" "\\u0007" "\\u0007"; + reads "char named" "\\backspace" "\\backspace"; + reads "non-ASCII char" "\\日" "\\日"; reads "byte dot" "\\." "\\."; (* ── Sequences ─────────────────────────────────────────────────── *) @@ -2377,6 +2381,44 @@ 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"; + rejects_check "a String is not ordered" + "(defn f [a String b String] bool (< a b))" + ~needle:"(bytes 0 || out <> want_string then + fail "a String's walk past its length\n got: %S (exit %d, err %S)\n wanted: %S" + out code err want_string; let code, out, _ = mode "cap" in let want_cap = "len 4096\ntail ...\nmid b\nhead a\ngen 1\nagain 12\n" in if code <> 0 || out <> want_cap then diff --git a/test/test_syntax.ml b/test/test_syntax.ml index 5d22b71e..f2c48bf9 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -495,6 +495,9 @@ let () = (* Characters, lexed before brackets and separators. *) reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])"; reads "character arguments" "f(\\,, \\))" "(f \\, \\))"; + reads "character spellings" + "x = [\\u0041 \\u0007 \\backspace \\formfeed \\日]" + "(set x [\\A \\u0007 \\backspace \\formfeed \\日])"; (* Keywords and annotations. *) reads "keyword" "let k = :else" "(def k dyn :else)"; reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])";