diff --git a/TODO.org b/TODO.org index e0362f36..b0b835fe 100644 --- a/TODO.org +++ b/TODO.org @@ -10,15 +10,30 @@ pointing at it. A CANCELLED entry carries the one-line reason, because an idea rejected without a record is an idea that gets re-proposed. * Language surface -** NEXT if let -Decided 2026-09-26 (126), Rust's spelling: =if let Some(g) = left= plus a block tests -the pattern and binds =g= in that block only; =elif=/=else= follow as for =if=. Any -=match= pattern may stand where =Some(g)= is. Reads to a two-arm =match=. -** NEXT when as a value, and get as a checked lookup -Decided 2026-09-26 (125): a =when= whose value is used gives =Option(T)=, =Some= of its -body when the test holds and =None= otherwise; as a statement it is unchanged. -=get(xs, i, …)= on an array, slice or Vec gives =Option(T)= instead of trapping on an -index out of range (negative included), one index per dimension. Both typed and dyn. +** NEXT .fln is the only source language +Decided 2026-09-26 (130): the .flan syntax is retired. .fln names carry no =?= or =!=; +predicates are =is-=/=has-=, and the raylib generator emits =is-key-pressed=. Swift +optionals: =T?= for =Option(T)=, =x ?? d=, =x!= (traps when absent), =if let g = x= +(binds the payload), and chaining =a?.b=. Order: optionals and the name rule; the +prelude and vendor rewritten in .fln; tests and examples converted with =flan convert=; +then =flan convert=, the .flan source path and =flan-mode= removed. Nothing tracks what +.flan can no longer say. +** WAIT A cheap front for dyn sequences +Decided 2026-09-26 (128) to pause: dyn vectors are mutable, so taking from the front +shifts every element. Options were a linked list (cons/first/rest) or storing the dyn +vector as a ring buffer with a cheap read-only rest view; the ring buffer was +recommended. Waits on a program that needs it. +** DONE if let +CLOSED: [2026-09-26] +=(if-let [P v] then else)= in paren syntax; an elif chain is the else. With no else it +is a statement unless kept, when it is an Option as =when= is. Rules out a plain name or +=_= as the pattern (use =let=). +** DONE when as a value, and get as a checked lookup +CLOSED: [2026-09-26] +Every one-armed =if= (and a =cond= with no =:else=) is a =when=; kept — a =let= value, a +call's argument, a lambda's return — it is =Option(T)=, nested over an Option body +(Rust's =bool::then=), and body-or-nil where a dyn is wanted. A =_=-inferred return's +last form is not kept. =get= over dyn text or vec is nil when out of range; =.field= still traps. ** NEXT str and String Decided 2026-09-25: the typed read-only text is =str= (the rename from =string= is @@ -766,7 +781,8 @@ One spelling for one operation; != stays, and not= is refused with a suggestion of !=. * Checker -** TODO Checking a wide fold of let operands is slow +** WAIT Checking a wide fold of let operands is slow +Parked 2026-09-26: design first; remeasure on a quiet machine, it was timed under load 20. A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators); 2000 plain names take 0.03 s. Something per operand is quadratic or worse. @@ -1570,7 +1586,8 @@ are a dyn vector, except numbers with no common type, which are refused. Rules out the first element typing the rest. * Dev loop -** TODO --dev bookkeeping per temp allocation grows without free-temp +** WAIT --dev bookkeeping per temp allocation grows without free-temp +Parked 2026-09-26: design first. Under --dev each temp allocation (i64->bytes, dyn text crossing into str) costs about 340 bytes of registry notes until free-temp; a loop passing dyn text as str 4M times without free-temp reaches 2.7 GB. Release stays flat. A CLI that never frees temp hits it. @@ -2091,6 +2108,9 @@ default is left alone. Rules out relabelling a note as a warning to make it navigable. * Docs and the repository +** WAIT dune test runs slowly and is not grouped by module +Parked 2026-09-26: design first. Time each test by CPU on a quiet machine, speed up the +slowest ten, and group tests under per-module aliases so a lane runs only its own. ** DONE The reference page says what the language is CLOSED: [2026-09-21] diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 7ec7ed3b..02970bff 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -103,7 +103,7 @@ fine here. Brackets and strings are still paired." ;; `header_follow' in lib/indent_reader.ml: the words a statement starts with. (defconst flan-fln--header-words '("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import" - "if" "elif" "else" "while" "until" "for" "match" "let" "return" "break" + "if" "when" "elif" "else" "while" "until" "for" "match" "let" "return" "break" "continue" "defer" "handler-case" "handler-bind" "restart-case" "on" "restart" "quote" "macro" "type" "class" "generic" "multi" "method")) @@ -112,7 +112,7 @@ fine here. Brackets and strings are still paired." ;; when it is the one-line `fn f(x) = e'; `if' does not when it is the one-line ;; `if c then a else b'. (defconst flan-fln--opener-words - '("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while" + '("fn" "fn-" "struct" "union" "data" "enum" "if" "when" "elif" "else" "while" "until" "for" "match" "defer" "handler-case" "handler-bind" "restart-case" "on" "restart" "quote" "macro" "class" "multi" "method")) @@ -410,7 +410,7 @@ and a call ending in `:'." (save-excursion (goto-char v) (or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\)\\(?:[ \t]\\|$\\)") - (and (looking-at "if[ \t]") (not (flan-fln--then l))) + (and (looking-at "\\(?:if\\|when\\)[ \t]") (not (flan-fln--then l))) (flan-fln--lambda-header-p v end)))))) ;;; Statements @@ -1308,7 +1308,7 @@ Before it at the same level, else out to the line that owns this block." (not (save-excursion (goto-char w-end) (looking-at "[ \t]+[^][ \t\n(){},;\":]+(")))) - ((member w '("if" "elif")) (not (flan-fln--then start))) + ((member w '("if" "when" "elif")) (not (flan-fln--then start))) (t t))))) ;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda ;; header: the value goes on under the line. @@ -1877,6 +1877,9 @@ lambda or a `Fn(...)' type, and not after a match arm's." ;; The words inside a line: `for i in range(n)', `if c then a else b', a ;; `where' constraint. ("[ \t]\\(then\\|else\\|in\\|where\\)[ \t]" 1 font-lock-keyword-face) + ;; `if let Some(g) = x', and a value's `if' or `when', `x = when c then a'. + ("\\_" 1 font-lock-keyword-face) (,(concat "\\_<" (regexp-opt flan--constants t) "\\_>") diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 39431c5a..4388b506 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -128,7 +128,7 @@ "Forms that introduce a top-level name.") (defconst flan--special - '("quote" "do" "let" "if" "when" "cond" "and" "or" + '("quote" "do" "let" "if" "if-let" "when" "cond" "and" "or" "while" "until" "break" "continue" "return" "set" "array" "array-fill" "array-gen" "the" "match" "fn" "dotimes" "loop" "recur" "defer" "some" "try" "signal" "error" @@ -584,6 +584,7 @@ For `syntax-propertize-function'." ("handler-case" . 1) ;; Test first, body after. ("if" . 1) + ("if-let" . 1) ("when" . 1) ("unless" . 1) ("while" . 1) diff --git a/emacs/flan.el b/emacs/flan.el index b96b6eda..1ab1531b 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -900,6 +900,62 @@ It builds the program first, which for a cold project is most of this." (message "flan dev: the daemon exited (%s); see %s" (string-trim (or event "")) flan-daemon-buffer)))) +(defun flan--close-daemon () + "Ask the daemon this Emacs started to end, and give it a moment to. +For `kill-buffer-hook' on its buffer and for `kill-emacs-hook': either +deletes the process outright, and a daemon killed that way never runs its +own cleanup -- its socket, its temporary directory, and under +--two-process the program it started. `close' is its own way out. Never +signals, so the kill that called it always goes ahead." + (let ((proc flan--daemon) + (sock flan--daemon-socket)) + (when (and (process-live-p proc) sock) + (if (and (process-live-p flan--connection) + (equal flan--socket sock)) + ;; Connected to it: `flan-quit' is exactly this, with its state + ;; cleared as well. + (ignore-errors (flan-quit)) + ;; Not connected, or connected to another session: a connection of + ;; its own, so the other session is left alone. + (ignore-errors + (let ((c (make-network-process + :name "flan-close" :family 'local + :service (flan--short-socket sock) + :coding 'binary :noquery t))) + (unwind-protect + (progn + (flan--send c '(:op "close")) + (let ((deadline (+ (float-time) 2))) + (while (and (process-live-p proc) + (< (float-time) deadline)) + (accept-process-output proc 0.05)))) + (delete-process c)))))))) + +(add-hook 'kill-emacs-hook #'flan--close-daemon) + +(defun flan--daemon-of-this-buffer-p () + "Whether the live daemon this Emacs started writes to the current buffer." + (and (process-live-p flan--daemon) + (eq (process-buffer flan--daemon) (current-buffer)))) + +(defun flan--query-kill-daemon () + "Ask before killing the buffer of a live daemon, as CIDER does for nREPL. +For `kill-buffer-query-functions'. A yes clears the process's own query, +so Emacs does not ask a second time, and `flan--kill-daemon-buffer' then +stops the daemon cleanly." + (or (not (flan--daemon-of-this-buffer-p)) + (when (y-or-n-p + (format "flan dev is running %s; stop it and kill the buffer? " + (file-name-nondirectory + (or flan--file flan--daemon-socket "the program")))) + (set-process-query-on-exit-flag flan--daemon nil) + t))) + +(defun flan--kill-daemon-buffer () + "Stop the daemon cleanly when its buffer is killed; see `flan--close-daemon'." + (when (flan--daemon-of-this-buffer-p) + (flan--close-daemon))) + (defun flan--start-daemon (file socket) "Start `flan dev' on FILE listening on SOCKET, and return the process." (let* ((buf (get-buffer-create flan-daemon-buffer)) @@ -947,13 +1003,19 @@ It builds the program first, which for a cold project is most of this." ;; program runs, and `compilation-mode' would claim it as the output of ;; one finished command — killing the process on a `recompile', among ;; other things it has no business doing to a live session. - (flan--daemon-buffer-setup)) + (flan--daemon-buffer-setup) + ;; Killing this buffer deletes its process, so the kill asks first and + ;; then tells the daemon to close. + (add-hook 'kill-buffer-query-functions #'flan--query-kill-daemon nil t) + (add-hook 'kill-buffer-hook #'flan--kill-daemon-buffer nil t)) (make-process :name "flan-daemon" :buffer buf :command args ;; The daemon writes its ready line and the program's stderr to stderr, ;; and both belong in the same buffer in the order they happened. - :connection-type 'pipe :noquery t + ;; No :noquery: exiting Emacs with a session running asks once, through + ;; the usual list of live processes, and `kill-emacs-hook' then closes it. + :connection-type 'pipe :sentinel #'flan--daemon-sentinel))) (defun flan--connect-when-ready (socket proc) diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index 07d8bc01..47f8d033 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -907,6 +907,20 @@ defconst(k, 3) (test-flan-fln--tabs "let colors =\n|" 1) 2) (test-flan-fln--is "but not after a one-line fn" (test-flan-fln--tabs "fn f() -> i32 = 1\n|" 1) 0) +(test-flan-fln--is "after if let, one level deeper" + (test-flan-fln--tabs "fn f() -> ()\n if let Some(g) = o\n|" 1) 4) +(test-flan-fln--is "and after a when with a block" + (test-flan-fln--tabs "fn f() -> ()\n when a > 1\n|" 1) 4) +(test-flan-fln--is "but not after a one-line when" + (test-flan-fln--tabs "fn f() -> ()\n when a then b()\n|" 1) 2) +(test-flan-fln--in "fn f() -> ()\n if let Some(g) = o\n g\n let w = when a then 1\n when b\n c()\n" + (font-lock-ensure) + (let ((face (lambda (needle) + (save-excursion (goto-char (point-min)) (search-forward needle) + (get-text-property (match-beginning 0) 'face))))) + (test-flan-fln--is "if let's let is a keyword" (funcall face "let Some") 'font-lock-keyword-face) + (test-flan-fln--is "a value's when is a keyword" (funcall face "when a") 'font-lock-keyword-face) + (test-flan-fln--is "and so is a statement's" (funcall face "when b") 'font-lock-keyword-face))) (test-flan-fln--is "else goes to its if's column, whatever the depth" (test-flan-fln--tabs "if a\n if b\n c\n |else" 1) 2) (test-flan-fln--is "and a second TAB to the outer if's" diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 7712e455..a2d6251f 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -47,6 +47,11 @@ already rely on it — so nothing here is a stand-in for the real thing." (setq test-flan--failures (1+ test-flan--failures)) (message " FAIL %s" name))) +;; Taken from `command-line-args', and the leftovers cleared: whatever is +;; still in `command-line-args-left' when this file finishes, Emacs visits as +;; a file, and visiting the compiler binary asks a yes-or-no question about +;; its size that a batch Emacs waits on forever. +(setq command-line-args-left nil) (let* ((args (cdr (member "--" command-line-args))) (socket (nth 0 args)) (file (nth 1 args)) @@ -1592,7 +1597,63 @@ already rely on it — so nothing here is a stand-in for the real thing." ;; claim seen from the other side. (test-flan--check "and takes its socket with it" (not (file-exists-p socket2)))) - (ignore-errors (delete-file socket2))) + (ignore-errors (delete-file socket2)) + + ;; Killing the daemon's buffer asks first, as CIDER does, and a yes stops + ;; the daemon the way `flan-quit' does rather than deleting the process: + ;; the daemon, its program (--two-process, so it is a process of its own) + ;; and the socket all go. A no leaves both the buffer and the daemon. + (let ((socket3 (concat socket "-killed-buffer")) + (asked 0) + (answer nil)) + (ignore-errors (delete-file socket3)) + (let ((flan-daemon-args (append flan-daemon-args '("--two-process")))) + (flan program socket3)) + (let* ((proc flan--daemon) + (pid (process-id proc)) + (kids (ignore-errors + (mapcar #'string-to-number + (split-string + (with-temp-buffer + (insert-file-contents + (format "/proc/%d/task/%d/children" pid pid)) + (buffer-string)))))) + (gone (lambda (p) + (let ((stat (format "/proc/%d/stat" p))) + (or (not (file-exists-p stat)) + (with-temp-buffer + (insert-file-contents stat) + (re-search-forward ") \\(.\\)" nil t) + (equal (match-string 1) "Z"))))))) + (cl-letf (((symbol-function 'y-or-n-p) + (lambda (&rest _) (setq asked (1+ asked)) answer))) + (test-flan--check "the daemon's program is a process of its own" + kids) + (setq answer nil) + (kill-buffer flan-daemon-buffer) + (test-flan--check "killing the daemon's buffer asks, and no keeps both" + (and (= asked 1) + (get-buffer flan-daemon-buffer) + (process-live-p proc))) + (setq answer t) + (kill-buffer flan-daemon-buffer) + (let ((deadline (+ (float-time) 5))) + (while (and (< (float-time) deadline) + (not (and (funcall gone pid) + (cl-every gone kids)))) + (sleep-for 0.05))) + (test-flan--check "and yes stops the daemon and its program" + (and (= asked 2) + (not (get-buffer flan-daemon-buffer)) + (null flan--daemon) + (funcall gone pid) + (cl-every gone kids))) + (test-flan--check "and removes its socket" + (not (file-exists-p socket3))) + (setq asked 0) + (with-temp-buffer + (test-flan--check "no daemon, no question" + (and (flan--query-kill-daemon) (= asked 0)))))))) ;; ── One command, one session ────────────────────────────────────────── ;; diff --git a/lib/ast.ml b/lib/ast.ml index 8850fd71..cb55e80e 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -79,6 +79,10 @@ and expr_kind = | Field of expr * string (* (.pos c) — auto-derefs one level *) | Call of expr * expr list | Match of expr * arm list + (* (if-let [(Some g) left] then else) — [if let Some(g) = left] in .fln. + A two-arm [match]: the arm is the pattern with [then] as its body, and + the else is the [_] arm. With no else it is a statement. *) + | IfLet of expr * arm * expr option | Struct of string * (string * expr) list (* (Cursor {.src s}) *) (* {.src s .pos 0} with no type written in front of it. The fields alone do not name a type, so this node carries no name and is only checkable where @@ -465,6 +469,7 @@ let map_children f (e : expr) : expr = | Field (x, n) -> Field (ex x, n) | Call (fn, args) -> Call (ex fn, List.map ex args) | Match (s, arms) -> Match (ex s, List.map arm arms) + | IfLet (s, a, e) -> IfLet (ex s, arm a, Option.map ex e) | Struct (n, fs) -> Struct (n, List.map (fun (n, v) -> (n, ex v)) fs) | Bare fs -> Bare (List.map (fun (n, v) -> (n, ex v)) fs) | MapLit (tag, kvs) -> MapLit (tag, List.map (fun (k, v) -> (ex k, ex v)) kvs) @@ -538,6 +543,8 @@ and step_expr fn (e : expr) : expr = | Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body fn es) } | Match (sc, arms) -> { e with e = Match (sc, List.map (fun a -> { a with body = step_body fn a.body }) arms) } + | IfLet (sc, a, b) -> + { e with e = IfLet (sc, { a with body = step_body fn a.body }, Option.map branch b) } | _ -> e let instrument_step ?(fn = "step-point") (ds : decl list) : decl list option = diff --git a/lib/check.ml b/lib/check.ml index 9a6c0104..b19f1553 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -942,6 +942,17 @@ type ctx = { and a [match] arm. Everything else is therefore non-tail by construction, and no walk has to enumerate the cases that are not. *) mutable tail : bool; + (* True where this form's value is kept: a [let] binding's value, and what + a block's last form, an [if]'s arms and a [match]'s arms inherit from + the form they stand in. Read and withdrawn at the top of [check] as + [tail] is. Only a one-armed [if] ([when]) asks: used, it answers an + Option; not, it is a statement. [want] alone cannot say, since a + statement and an unannotated [let] value both arrive with none. *) + mutable used : bool; + (* The arguments of the call being checked: each is kept, whatever the + callee wants of it, so a [when] written as an operand answers its Option + there rather than a Unit the other operands are then blamed against. *) + mutable kept : Ast.expr list; (* True inside a [defer]'s forms. A defer is the cleanup a transfer runs on its way out (§5), so a transfer *starting* there has no answer: this function's defers are already half run and the first transfer's target is @@ -5151,7 +5162,7 @@ let with_recovery env ~on f = let invented_ctx env ret = { env; ret; lits = None; slots = 0; slot_tys = []; slot_names = []; scope = []; - defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false; + defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false; used = false; kept = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "" } @@ -5807,7 +5818,8 @@ let truthy_depth = ref 0 it — the square of a refused or/and chain's length. *) let if_failed : (Loc.t, - Ast.expr * ((string * binding) list * Types.t) * Types.t option * Loc.diag) + Ast.expr * ((string * binding) list * Types.t) * (Types.t option * bool) + * Loc.diag) Hashtbl.t = Hashtbl.create 16 let if_depth = ref 0 @@ -6036,6 +6048,8 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = it unless the arm below hands it on deliberately. *) let tail = ctx.tail in ctx.tail <- false; + let used = ctx.used || List.memq e ctx.kept in + ctx.used <- false; match e.Ast.e with (* A negative literal in a generic body, at an instantiation that made it unsigned. The cast the ordinary refusal names would be wrong at every @@ -6262,13 +6276,13 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = in check ctx ?want { e with Ast.e = Ast.Int n } | Ast.Var name -> var ctx loc ~want name - | Ast.Do body -> ctx.tail <- tail; block ctx ?want loc body + | Ast.Do body -> ctx.tail <- tail; ctx.used <- used; block ctx ?want loc body (* [defer_ok] rides through: a [let] at the top level of a function body has exactly the function's extent, and so does a [let] nested inside one. [tail] rides through for the same shape of reason: a [recur] written as the last form of a [let] inside a loop body is in the loop's tail. *) - | Ast.Let (bs, body) -> check_let ctx ~tail ?want ~defer_ok loc bs body - | Ast.If (c, t, e') -> check_if ctx ~tail ?want loc c t e' + | Ast.Let (bs, body) -> check_let ctx ~tail ~used ?want ~defer_ok loc bs body + | Ast.If (c, t, e') -> check_if ctx ~tail ~used ?want loc c t e' | Ast.While (label, c, body) -> (* The condition is part of the loop even though it is written outside the braces — emit puts it in the header block, so it is re-evaluated at the @@ -6471,7 +6485,9 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | Ast.ArrayFill (dims, v) -> check_array_fill ctx ~want loc dims v | Ast.ArrayGen (dims, f) -> check_array_gen ctx ~want loc dims f | Ast.The (t, v) -> check_the ctx ~want loc t v - | Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms + | Ast.Match (scrutinee, arms) -> check_match ctx ~tail ~used ?want loc scrutinee arms + | Ast.IfLet (scrutinee, arm, els) -> + check_if_let ctx ~tail ~used ?want loc scrutinee arm els (* Constant integer arithmetic where a type variable is wanted is folded to the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever [(+ x 3)] is. The instantiation re-checks the form unfolded, at a concrete @@ -6480,7 +6496,15 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = when (match want with Some (Types.Var _) -> true | _ -> false) && literal_arith e <> None -> int_literal loc ~want ~preds:ctx.env.tvpreds (Option.get (literal_arith e)) - | Ast.Call (head, args) -> check_call ctx ~want loc head args + | Ast.Call (head, args) -> + let outer = ctx.kept in + (* A with-allocator's arguments after the first are a body, run in + order, and not values. *) + (match head.Ast.e with + | Ast.Var ("with-allocator" | "builtin/with-allocator") -> ctx.kept <- [] + | _ -> ctx.kept <- args); + Fun.protect ~finally:(fun () -> ctx.kept <- outer) + (fun () -> check_call ctx ~want loc head args) | Ast.Unwrap (Ast.Usome, v) -> (* Unwrap Some, else early-return None from the enclosing function, so the enclosing function must itself return an Option (plan.org). *) @@ -6953,20 +6977,24 @@ and block ctx ?want ?(defer_ok = false) loc body = match body with (* Withdrawn here too. An empty body has no last form to be the tail, so leaving the permission set would hand it to whatever is checked next. *) - | [] -> ctx.tail <- false; expect ctx loc ~want (unit_at loc) + | [] -> ctx.tail <- false; ctx.used <- false; expect ctx loc ~want (unit_at loc) | _ -> (* A block's tail is its last form and nothing else. Callers that must not pass one on need do nothing: [check] withdrew it before they were reached, so [tail] is already false here for all of them. *) let tail = ctx.tail in + let used = ctx.used in + ctx.used <- false; let rec go = function | [ last ] -> ctx.defer_ok <- defer_ok; ctx.tail <- tail; + ctx.used <- used; let l = check ctx ?want last in [ l ], l.Tast.ty | x :: rest -> ctx.defer_ok <- defer_ok; ctx.tail <- false; + ctx.used <- false; let x = check ctx x in let rest, ty = go rest in x :: rest, ty | [] -> assert false @@ -7051,7 +7079,20 @@ and check_fn ctx ~want ?gen loc (params : string list) body = in List.iter2 (fun n t -> ignore (bind fctx n t ~assignable:false)) params pts; - let fbody = map_lr (fun e -> check fctx e) body in + (* The last form is checked at the return type the position wants, as a + defn's is at its declared one, so a value that takes its type from what + is asked of it — a kept [when], [None], a bare struct — gets it here. *) + let last_want = + match ret0 with + | Some r when not (Types.equal r Types.Unit) -> Some r + | _ -> None + in + let n = List.length body in + let fbody = + map_lr + (fun (i, e) -> if i = n - 1 then check fctx ?want:last_want e else check fctx e) + (List.mapi (fun i e -> (i, e)) body) + in (* The same rule an ordinary defn's body follows: the last form is the answer, and it has to be the declared return type — or, when nothing declared one ([ret0] is [None]), the last form's own type *is* the @@ -7864,7 +7905,7 @@ and lit_conflict (k : Ast.expr) name t1 l1 t2 l2 = one it should have: %s" name (tyname l1 t1) (tyname l2 t2) lit fix -and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = +and check_let ctx ?(tail = false) ?(used = false) ?want ?(defer_ok = false) loc bs body = with_lits ctx loc (List.filter_map (fun (b : Ast.binding) -> if b.Ast.bty = None then Some b.Ast.bval else None) @@ -7876,6 +7917,7 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = (fun (b : Ast.binding) -> let want = Option.map (resolve ctx.env) b.Ast.bty in let lit = if b.Ast.bty = None then lit_local ctx b.Ast.bname b.Ast.bval else None in + ctx.used <- true; let v = match lit with | Some t -> lit_init ctx t b.Ast.bval @@ -7899,6 +7941,7 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = in (* After the bindings, because checking each of them withdrew it. *) ctx.tail <- tail; + ctx.used <- used; let body = block ctx ?want ~defer_ok loc body in mk loc body.Tast.ty (Tast.Let (bs, [ body ]))) @@ -8386,14 +8429,14 @@ and check_truthy_once ctx c = with Loc.Error d -> refuse_or_poison ctx.env loc d)) | exception Loc.Error _ -> check ctx ~want:Types.Bool c -and check_if ctx ?(tail = false) ?want loc c t e = +and check_if ctx ?(tail = false) ?(used = false) ?want loc c t e = if ctx.env.recovering && ctx.env.speculating = 0 then - check_if_once ctx ~tail ?want loc c t e + check_if_once ctx ~tail ~used ?want loc c t e else match List.find_opt (fun (n, (sc, r), w, _) -> - n == c && r == ctx.ret && w = want && same_scope sc ctx.scope) + n == c && r == ctx.ret && w = (want, used) && same_scope sc ctx.scope) (Hashtbl.find_all if_failed c.Ast.loc) with | Some (_, _, _, d) -> raise (Loc.Error d) @@ -8405,23 +8448,56 @@ and check_if ctx ?(tail = false) ?want loc c t e = decr if_depth; if !if_depth = 0 then Hashtbl.reset if_failed) (fun () -> - try check_if_once ctx ~tail ?want loc c t e + try check_if_once ctx ~tail ~used ?want loc c t e with Loc.Error d as ex -> - if !lit_recording = 0 then Hashtbl.add if_failed c.Ast.loc (c, (scope, ctx.ret), want, d); + if !lit_recording = 0 then Hashtbl.add if_failed c.Ast.loc (c, (scope, ctx.ret), (want, used), d); raise ex) -and check_if_once ctx ~tail ?want loc c t e = +and check_if_once ctx ~tail ~used ?want loc c t e = let c = check_truthy ctx c in (* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))] is how nearly every loop is written, and the branch is still the last - thing the body does. *) - let in_tail f = ctx.tail <- tail; f () in + thing the body does. Both arms are kept when the [if] is. *) + let in_tail f = ctx.tail <- tail; ctx.used <- used; f () in match e with - | None -> - (* A one-armed if produces Unit whatever the branch evaluates to: there is - no value on the missing side. `when` desugars to this. *) - let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in - expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) + | None -> check_when ctx ~used ?want loc c (fun ?want () -> + branch ctx (fun () -> in_tail (fun () -> check ctx ?want t))) + (* A kept chain whose last else is missing — a [cond] with no [:else], + whose fallthrough is [(do)], or an [if] whose else is a [when] — is one + [when] spread over several tests: an Option, [None] when no test holds, + and [Some] of the arm that ran. *) + | Some e when kept_open ~used want e -> + (match e.Ast.e with + | Ast.Do [] -> + check_when ctx ~used:true ?want loc c (fun ?want () -> + branch ctx (fun () -> in_tail (fun () -> check ctx ?want t))) + | _ -> + let tw = + match want with + | Some (Types.Option i) -> Some i + | Some Types.Dyn -> Some Types.Dyn + | _ -> None + in + let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:tw t)) in + let rest ~used ?want () = + branch ctx (fun () -> + ctx.tail <- tail; ctx.used <- used; check ctx ?want e) + in + match t.Tast.ty with + | Types.Unit -> + expect ctx loc ~want + (mk loc Types.Unit (Tast.If (c, t, rest ~used:false ()))) + | Types.Never -> + let e = rest ~used:true ?want () in + mk loc e.Tast.ty (Tast.If (c, t, e)) + | Types.Dyn -> + let e = rest ~used:true ~want:Types.Dyn () in + expect ctx loc ~want (mk loc Types.Dyn (Tast.If (c, t, e))) + | ty -> + let oty = Types.Option ty in + let e = rest ~used:true ~want:oty () in + expect ctx loc ~want + (mk loc oty (Tast.If (c, mk loc oty (Tast.Some_ t), e)))) (* Two literal arms meet at the wider of their own types, as two literal elements of an array do: [(if c 1 2.5)] is an f64. *) | Some e @@ -8616,6 +8692,65 @@ and check_if_once ctx ~tail ?want loc c t e = in mk loc ty (Tast.If (c, t, e)) +(* A one-armed [if], which [when] is. As a statement it is Unit whatever its + branch evaluates to. Kept — a [let]'s value, an argument, a return, or + anything else with a type wanted of it — it answers (Option T): [Some] of + the branch when the test held and [None] when it did not. A branch that + is already an Option is not flattened: the answer is (Option (Option T)), + Rust's [bool::then], so [None] from the branch and a failed test stay two + answers. + + Dyn has no Option. Where a dyn is wanted, or the branch is a dyn, a false + test answers nil and a true one the branch's value — one absence, as a + dyn map's [get] has. + + A branch with no value (Unit) or none at all (Never) keeps the statement's + Unit, so what is refused about binding one is refused as before. *) +and check_when ctx ~used ?want loc c + (branch_at : ?want:Types.t -> unit -> Tast.expr) = + let stmt t = expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) in + let nil () = rt loc Types.Dyn "flan_dyn_nil" [] in + let valueless (t : Tast.expr) = + match t.Tast.ty with Types.Unit | Types.Never -> true | _ -> false + in + match want with + | Some (Types.Unit | Types.Never) -> stmt (branch_at ()) + | Some Types.Dyn -> + let t = branch_at ~want:Types.Dyn () in + mk loc Types.Dyn (Tast.If (c, t, nil ())) + | Some (Types.Option inner) -> + let t = branch_at ~want:inner () in + let oty = Types.Option inner in + let some = if t.Tast.ty = Types.Never then t else mk loc oty (Tast.Some_ t) in + mk loc oty (Tast.If (c, some, mk loc oty Tast.None_)) + | None when not used -> stmt (branch_at ()) + | _ -> + let t = branch_at () in + if valueless t then stmt t + else if Types.equal t.Tast.ty Types.Dyn then + expect ctx loc ~want (mk loc Types.Dyn (Tast.If (c, t, nil ()))) + else + let oty = Types.Option t.Tast.ty in + expect ctx loc ~want + (mk loc oty (Tast.If (c, mk loc oty (Tast.Some_ t), mk loc oty Tast.None_))) + +(* Whether a two-armed [if] is kept and its else chain ends without one — + [(do)], or a one-armed [if] — so the whole chain answers an Option. *) +and kept_open ~used want (e : Ast.expr) = + let kept = + match want with + | Some (Types.Unit | Types.Never) -> false + | Some _ -> true + | None -> used + in + let rec open_ (e : Ast.expr) = + match e.Ast.e with + | Ast.Do [] | Ast.If (_, _, None) | Ast.IfLet (_, _, None) -> true + | Ast.If (_, _, Some e') | Ast.IfLet (_, _, Some e') -> open_ e' + | _ -> false + in + kept && open_ e + (* The type two literals meet at, each at its own type — a wide integer at u64, which is the only type that holds one. *) and literal_join ctx (a : Ast.expr) (b : Ast.expr) = @@ -9664,7 +9799,19 @@ and check_array_gen ctx ~want loc dims f = (array_build ctx loc ns elem ~pre:[ (fs, f) ] ~element:(fun idxs -> mk loc elem (Tast.CallPtr (fv, idxs)))) -and check_match ctx ?(tail = false) ?want loc scrutinee arms = +and check_match ctx ?(tail = false) ?(used = false) ?(stmt = false) ?(opt = false) + ?opt_rest ?want loc scrutinee arms = + (* [stmt] is an [if let] with no else: a statement, Unit whatever its arm + answers, as a one-armed [if] is when nothing keeps it. [opt] is one that + is kept: its arm answers [Some], and the arm with no body [None]. *) + let used = used && not stmt in + let arms_ast_for_opt = arms in + let want0 = want in + let want = + if stmt then None + else if opt then (match want with Some (Types.Option i) -> Some i | _ -> None) + else want + in let s = check ctx scrutinee in (* What the arms are alternatives over. An [Option] is a two-case data type wearing a special coat, so the two shapes below are the same shape: a set @@ -10068,8 +10215,11 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = (* Every arm is the tail, exactly as an [if]'s two arms are. Restored here because checking the scrutinee withdrew it. *) ctx.tail <- tail; + ctx.used <- used; let arm = (a, ctor, binds) in + let empty = opt && a.Ast.body = [] in let body = + if empty then unit_at a.Ast.aloc else if free && !want <> None && not (literal_arm arm) then (* As an [if]'s else arm: at the join so far first, on its own terms only when that is refused as a mismatch. *) @@ -10114,7 +10264,12 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = | Error _ -> at !want ()) else block ctx ?want:!want a.Ast.aloc a.Ast.body in - (if body.Tast.ty <> Types.Never then + let body = + if stmt && body.Tast.ty <> Types.Unit && body.Tast.ty <> Types.Never + then mk body.Tast.loc Types.Unit (Tast.Do [ body; unit_at body.Tast.loc ]) + else body + in + (if body.Tast.ty <> Types.Never && not stmt && not empty then match !want with | None -> want := Some body.Tast.ty | Some w when free -> @@ -10146,8 +10301,11 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = is said, as each would be checked at it. *) List.map (fun (i, (arm : Tast.arm)) -> + let empty = + opt && (let (a : Ast.arm), _, _ = List.nth resolved i in a.Ast.body = []) + in match arm.Tast.abody with - | [ b ] when not (Types.equal b.Tast.ty j || b.Tast.ty = Types.Never) -> + | [ b ] when not (empty || Types.equal b.Tast.ty j || b.Tast.ty = Types.Never) -> let at = value_loc i in let b = try expect ctx at ~want:(Some j) b @@ -10161,6 +10319,75 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = let arms = List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) checked) in + (* [opt]: what the pattern's arm answered decides the whole, as a + one-armed [if]'s branch does — no value is a statement, Never stays + Never, a dyn is the value or nil, and anything else is [Some] of it. The + arm with no body is the rest of the chain, [opt_rest], checked now that + its want is known, or [None] when the chain ends here. *) + let opt_result = ref None in + let arms = + if not opt then arms + else + let raw = + List.fold_left2 + (fun acc (a : Ast.arm) (arm : Tast.arm) -> + match a.Ast.body, arm.Tast.abody with + | _ :: _, [ b ] -> Some b.Tast.ty + | _ -> acc) + None arms_ast_for_opt arms + in + let rest ~used ?want () = + match opt_rest with + | Some f -> Some (f ~used ?want ()) + | None -> None + in + let fill body_of wild_of = + List.map2 + (fun (a : Ast.arm) (arm : Tast.arm) -> + match a.Ast.body, arm.Tast.abody with + | [], _ -> { arm with Tast.abody = [ wild_of a ] } + | _, [ b ] -> { arm with Tast.abody = [ body_of b ] } + | _ -> arm) + arms_ast_for_opt arms + in + match raw with + | None | Some Types.Unit -> + opt_result := Some Types.Unit; + let r = rest ~used:false () in + fill Fun.id (fun a -> + match r with + | Some e when e.Tast.ty = Types.Unit || e.Tast.ty = Types.Never -> e + | Some e -> mk e.Tast.loc Types.Unit (Tast.Do [ e; unit_at e.Tast.loc ]) + | None -> unit_at a.Ast.aloc) + | Some Types.Never -> + (match rest ~used:true ?want:want0 () with + | Some e -> + opt_result := Some e.Tast.ty; + fill Fun.id (fun _ -> e) + | None -> + (match want0 with + | Some (Types.Option _ as o) -> + opt_result := Some o; + fill Fun.id (fun a -> mk a.Ast.aloc o Tast.None_) + | _ -> + opt_result := Some Types.Unit; + fill Fun.id (fun a -> unit_at a.Ast.aloc))) + | Some Types.Dyn -> + opt_result := Some Types.Dyn; + let r = rest ~used:true ~want:Types.Dyn () in + fill Fun.id (fun a -> + match r with + | Some e -> e + | None -> rt a.Ast.aloc Types.Dyn "flan_dyn_nil" []) + | Some t -> + let oty = Types.Option t in + opt_result := Some oty; + let r = rest ~used:true ~want:oty () in + fill (fun b -> mk b.Tast.loc oty (Tast.Some_ b)) (fun a -> + match r with + | Some e -> e + | None -> mk a.Ast.aloc oty Tast.None_) + in (* Exhaustiveness is refused, not defaulted. A match that silently fell through would have to produce a value of the match's type out of nothing, and there is no such value for most types; and the case a data type grows @@ -10208,7 +10435,11 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = (String.concat ", " missing) (if List.length missing = 1 then "has" else "have") (if List.length missing = 1 then "it" else "them"); - let ty = match !want with Some t -> t | None -> Types.Never in + let ty = + if stmt then Types.Unit + else if opt then (match !opt_result with Some t -> t | None -> Types.Never) + else match !want with Some t -> t | None -> Types.Never + in match subject with | `Option _ | `Data _ -> mk loc ty (Tast.Match (s, arms)) | `Enum _ | `Bool | `Lit _ -> @@ -10244,6 +10475,80 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = in mk loc ty (Tast.Let ([ (slot, s) ], [ chain arms ])) +(* [if let P = v] — (if-let [P v] then else) — is the two-arm match + [(match v P then _ else)]. With no else it is a statement, Unit whatever + [then] answers, as a one-armed [if] is. + + A pattern that cannot fail — [_], or a plain name, which is a name to bind + and not a case — tests nothing, and is refused toward [let]. A bare name is + a case when some data type, Option or bool has a case of that name, or it + names an enum member through its enum. *) +and check_if_let ctx ~tail ~used ?want loc scrutinee (arm : Ast.arm) els = + let fln = fln_source loc in + let is_case n = + List.mem n [ "None"; "Some"; "true"; "false" ] + || String.contains n '.' + || Hashtbl.fold + (fun _ u acc -> acc || Tast.case_index u n <> None) + ctx.env.datas false + in + let irrefutable name = + match name with + | Some n -> + Loc.failk "check/if-let-irrefutable" arm.Ast.aloc + "the pattern %s is a plain name, which always matches, so this if let \ + has nothing to test. Bind the value with %s" + n + (if fln then Printf.sprintf "let %s = ..." n + else Printf.sprintf "(let [%s ...] ...)" n) + | None -> + Loc.failk "check/if-let-irrefutable" arm.Ast.aloc + "the pattern _ always matches, so this if let has nothing to test. \ + Use the value directly, or match on it" + in + (match arm.Ast.pat with + | Ast.Pwild -> irrefutable None + | Ast.Pctor (n, []) when not (is_case n) -> irrefutable (Some n) + | _ -> ()); + let wild body = { Ast.pat = Ast.Pwild; body; aloc = loc } in + (* Kept with no else at the end of its chain, it is a [when] over a + pattern: [Some] of the arm that ran and [None] when none did — or, where + a dyn is wanted, the value or nil. *) + let open_end = + match els with None -> true | Some e -> kept_open ~used:true None e + in + let kept = + match want with + | Some (Types.Unit | Types.Never) -> false + | Some _ -> true + | None -> used + in + let at (x : Ast.expr) e = { Ast.e; loc = x.Ast.loc } in + match els with + | _ when kept && open_end -> + let rest = match els with Some e -> e | None -> at scrutinee (Ast.Var "nil") in + (match want with + | Some Types.Dyn -> + check_match ctx ~tail ~used:true ?want loc scrutinee [ arm; wild [ rest ] ] + | _ -> + (* The rest of the chain is checked once the arm's own type is + known, as a one-armed [if]'s else is: see [opt] in [check_match]. *) + let opt_rest = + Option.map + (fun e ~used ?want () -> + branch ctx (fun () -> + ctx.tail <- tail; ctx.used <- used; check ctx ?want e)) + els + in + expect ctx loc ~want + (check_match ctx ~tail ~used:true ~opt:true ?opt_rest ?want loc scrutinee + [ arm; wild [] ])) + | Some e -> + check_match ctx ~tail ~used ?want loc scrutinee [ arm; wild [ e ] ] + | None -> + expect ctx loc ~want + (check_match ctx ~tail ~stmt:true loc scrutinee [ arm; wild [] ]) + (* ── Places ────────────────────────────────────────────────────────── *) (* The fields a name has, whether it is a struct or an untagged union. The two @@ -11037,6 +11342,7 @@ and cast_operand ctx loc name ~needs ?also ~what ~is v = "%s converts %s. %s — %s" name what known fix and fold_left_prim ctx ~want loc name p ~needs ok what args = + refuse_kept_when ctx name args; let x, y, rest = match args with x :: y :: rest -> x, y, rest | _ -> assert false in @@ -11124,6 +11430,58 @@ and char_operands ctx ?(charish = false) name (args : Ast.expr list) f = args; raise ex +(* An operand is kept, so a form with no else at its end — a [when], a + [cond] or an [if]/[if let] chain with no final else, or a [do] or [let] + ending in one — answers an Option there. Beside a number that is refused + at the form itself, before the operands are checked against each other, + where the number beside it would be blamed instead. One over a dyn answers + a dyn, and that is left to the operator. *) +and refuse_kept_when ctx name (args : Ast.expr list) = + (* The form with no else, found at the end of [a]. *) + let rec else_less (a : Ast.expr) = + match a.Ast.e with + | Ast.If (_, _, None) | Ast.IfLet (_, _, None) -> Some a + | Ast.If (_, _, Some e) | Ast.IfLet (_, _, Some e) -> + if open_tail e then Some a else None + | Ast.Do (_ :: _ as xs) | Ast.Let (_, (_ :: _ as xs)) -> + else_less (List.nth xs (List.length xs - 1)) + | _ -> None + and open_tail (e : Ast.expr) = + match e.Ast.e with + | Ast.Do [] -> true + | _ -> else_less e <> None + in + let ty (a : Ast.expr) = probe ctx a.Ast.loc (fun () -> (check ctx a).Tast.ty) in + let number (a : Ast.expr) = + match a.Ast.e with + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true + | _ when else_less a <> None -> false + | _ -> (match ty a with Some t -> Types.is_numeric t | None -> false) + in + List.iter + (fun (a : Ast.expr) -> + match else_less a with + | Some form -> + (match ty a with + | Some (Types.Option _ as t) + when List.exists (fun b -> b != a && number b) args -> + let fln = fln_source form.Ast.loc in + let what = + match form.Ast.e with + | Ast.If (_, _, None) -> if fln then "if without an else" else "when" + | Ast.IfLet _ -> "if let without an else" + | _ -> if fln then "if chain without an else" else "chain without an else" + in + Loc.failk "check/kept-when" form.Ast.loc + "this %s is an operand of %s, so its value is kept, and there it \ + gives %s: Some of its value when a test holds, None when none \ + does. The other side is a number. Give it an else, or unwrap \ + what it gives with match" + what name (tyname form.Ast.loc t) + | _ -> ()) + | None -> ()) + args + (* The dyn lowering of a fold: one call per operator application, left to right, each taking and answering a dyn word. The typed side of a mixed pair is boxed on the way in — [box] is the identity on something already dyn, so @@ -11741,6 +12099,148 @@ and vec_at ctx loc (target : Tast.expr) (idx : Ast.expr list) = fail loc "a Vec takes exactly one index, as (at v i)" +(* [(get xs i ...)] over an array, a slice, a string or a Vec: the element + as [(Some e)], or [None] when any index is out of range, negative + included, where [at] would trap. One index per dimension, as [at] takes. + + The indices are evaluated once, left to right, before any test. An array's + length is static, so the array itself is read once and is not copied; a + slice's, a string's or a Vec's is read off the value, so that value is + put in a slot first unless it is already a name. Each level is tested + before the next is reached, because a Vec of Vecs has no inner length to + test until the outer index is known to be in range. The element is then + read by [at] as usual, whose own check can no longer fail. *) +and checked_get ctx ~want loc (target : Tast.expr) (idx : Ast.expr list) = + let rec result ty = function + | [] -> ty + | (i : Ast.expr) :: rest -> + (match ty with + | Types.Array (_, t) | Types.Slice (_, t) | Types.Vec t -> result t rest + | Types.String -> result (Types.Int Types.U8) rest + | other -> + fail i.Ast.loc + "get takes an array, a slice, a string, a Vec, a Map or a dyn, and \ + %s cannot be indexed" (tyname i.Ast.loc other)) + in + let oty = Types.Option (result target.Tast.ty idx) in + let none () = mk loc oty Tast.None_ in + let is_name (e : Tast.expr) = + match e.Tast.e with Tast.Local _ | Tast.Global _ -> true | _ -> false + in + (* A value a call answered is bound before the indices run, so the target + is still evaluated first. *) + let pre = ref [] in + let target = + match target.Tast.e with + | Tast.Call _ | Tast.CallPtr _ -> + let s = fresh_slot ctx target.Tast.ty in + pre := [ (s, target) ]; + mk loc target.Tast.ty (Tast.Local s) + | _ -> target + in + let islots = + map_lr + (fun (i : Ast.expr) -> + let v = index_expr ctx i in + let s = fresh_slot ctx index_ty in + (s, v)) + idx + in + let ivar (s, _) = mk loc index_ty (Tast.Local s) in + let i32 k = mk loc index_ty (Tast.Int (k, Types.I32)) in + let within i len = + let ge = mk loc Types.Bool (Tast.Prim (Tast.Ge, [ i; i32 0L ])) in + let lt = mk loc Types.Bool (Tast.Prim (Tast.Lt, [ i; len ])) in + mk loc Types.Bool (Tast.If (ge, lt, mk loc Types.Bool (Tast.Bool false))) + in + (* The value reached so far is [base] indexed by [path], innermost last. *) + let reached base path ty = + if path = [] then base + else mk loc ty (Tast.Prim (Tast.At, base :: List.rev path)) + in + (* A value whose length is read as well as indexed, in a slot unless it is + a name already. *) + let named cur k = + if is_name cur then k cur + else + let s = fresh_slot ctx cur.Tast.ty in + mk loc oty + (Tast.Let ([ (s, cur) ], [ k (mk loc cur.Tast.ty (Tast.Local s)) ])) + in + let rec go base path ty = function + | [] -> mk loc oty (Tast.Some_ (reached base path ty)) + | i :: rest -> + let i = ivar i in + (match ty with + | Types.Array (n, t) -> + mk loc oty (Tast.If (within i (i32 n), go base (i :: path) t rest, none ())) + | Types.Slice _ | Types.String -> + let t = + match ty with Types.Slice (_, t) -> t | _ -> Types.Int Types.U8 + in + named (reached base path ty) (fun cur -> + let len = mk loc index_ty (Tast.Prim (Tast.Len, [ cur ])) in + mk loc oty (Tast.If (within i len, go cur [ i ] t rest, none ()))) + | Types.Vec t -> + named (reached base path ty) (fun cur -> + let n = rt loc (Types.Int Types.I64) "flan_vec_len" [ cur; here loc ] in + let len = mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ])) in + let p = + rt loc (Types.Ptr (Types.Mut, t)) "flan_vec_at" + [ cur; i; size_of loc t; here loc ] + in + mk loc oty + (Tast.If (within i len, go (mk loc t (Tast.Deref p)) [] t rest, + none ()))) + | _ -> assert false) + in + expect ctx loc ~want + (mk loc oty (Tast.Let (!pre @ islots, [ go target [] target.Tast.ty islots ]))) + +(* [(get d k ...)] over a dyn: a map's value at the key, a vec's or a text's + element at the index, or nil when there is none — dyn has no Option. More + than one key walks a level per key, and a nil level answers nil. *) +and dyn_get ctx ~want loc (target : Tast.expr) (keys : Ast.expr list) = + let nil () = rt loc Types.Dyn "flan_dyn_nil" [] in + let one v k = rt loc Types.Dyn "flan_dyn_get_at" [ v; k; here loc ] in + (* A slot per key only when there are several: one key goes straight to + [flan_dyn_get_at]. Over a text or a vec that runs [at]'s own body in the + runtime, so [get] and [at] count a text the same way whatever [at] + comes to count. *) + let slotted = List.length keys > 1 in + let keys = + map_lr + (fun k -> + let v = check ctx ~want:Types.Dyn k in + ((if slotted then fresh_slot ctx Types.Dyn else -1), v)) + keys + in + let kvar (s, _) = mk loc Types.Dyn (Tast.Local s) in + let rec go v = function + | [] -> v + | k :: rest when rest = [] -> one v (kvar k) + | k :: rest -> + let s = fresh_slot ctx Types.Dyn in + let sv = mk loc Types.Dyn (Tast.Local s) in + let is_nil = + mk loc Types.Bool + (Tast.Prim (Tast.Ne, + [ rt loc (Types.Int Types.I32) "flan_dyn_is_nil" [ sv ]; + mk loc (Types.Int Types.I32) (Tast.Int (0L, Types.I32)) ])) + in + mk loc Types.Dyn + (Tast.Let ([ (s, one v (kvar k)) ], + [ mk loc Types.Dyn (Tast.If (is_nil, nil (), go sv rest)) ])) + in + match keys with + | [ (_, k) ] -> expect ctx loc ~want (one target k) + | _ -> + let ts = fresh_slot ctx Types.Dyn in + expect ctx loc ~want + (mk loc Types.Dyn + (Tast.Let ((ts, target) :: keys, + [ go (mk loc Types.Dyn (Tast.Local ts)) keys ]))) + (* [(slice v)], [(slice v lo)] and [(slice v lo hi)] over a Vec — the arm for it is in [slice], and this is the half that differs from an array's. @@ -12378,6 +12878,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = nobody writes on purpose. *) | "%" -> arity ctx loc name 2 args; + refuse_kept_when ctx name args; let a, b = char_operands ctx name args (fun () -> binary ctx ~dyn_ok:true name loc ~want:(numeric_want want) args) @@ -12399,6 +12900,7 @@ 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 + refuse_kept_when ctx name args; if List.exists (fun a -> peeks_string ctx a) args then string_compare ctx ~want loc name p args else @@ -13542,20 +14044,33 @@ and named_call ?(qualified = false) ctx ~want loc name args = There is no allocation here and therefore no guard: a lookup that finds nothing is an answer, not a failure. *) | "get" -> - arity ctx loc name 2 args; (match args with + | target :: (_ :: _ :: _ as idx) -> + (* Two indices or more: an array, a slice or a Vec, one per + dimension, or a dyn walked a level per index. A map takes one key. *) + let target = check_target ctx target in + (match target.Tast.ty with + | Types.Map _ -> + fail loc "a map's get takes one key, as (get m k), and this has %d" + (List.length idx) + | Types.Named "String" -> + (ignore (refuse_string_index (List.hd idx).Ast.loc ~store:false); assert false) + | Types.Dyn -> dyn_get ctx ~want loc target idx + | _ -> checked_get ctx ~want loc target idx) | [ target; k ] -> let target = check_target ctx target in + (match target.Tast.ty with + | Types.Array _ | Types.Slice _ | Types.String | Types.Vec _ -> + checked_get ctx ~want loc target [ k ] + (* The same refusal [at] gives: a String is not indexed. *) + | Types.Named "String" -> (ignore (refuse_string_index k.Ast.loc ~store:false); assert false) + | Types.Dyn -> dyn_get ctx ~want loc target [ k ] + | _ -> (* A dyn map's absence is nil, not None: the typed map can promise an (Option V) because V was written down, and a dyn map has nothing to write. nil is an ordinary dyn value the caller compares against — and (contains? m k) is the question to ask when nil might also be stored under the key. *) - if target.Tast.ty = Types.Dyn then - expect ctx loc ~want - (rt loc Types.Dyn "flan_dyn_get" - [ target; check ctx ~want:Types.Dyn k; here loc ]) - else begin let kt, vt = map_kv loc "get" target.Tast.ty in let k = check ctx ~want:kt k in (* Deferred, and the placeholder is [None] rather than [Unit]: this @@ -13564,9 +14079,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = if deferred_key ctx.env loc "get" kt then expect ctx loc ~want (mk loc (Types.Option vt) Tast.None_) else - map_lookup ctx ~want loc "flan_map_get" target kt vt k - end - | _ -> assert false) + map_lookup ctx ~want loc "flan_map_get" target kt vt k) + | _ -> arity ctx loc name 2 args; assert false) (* (keyword s) -> 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 @@ -15926,7 +16440,7 @@ and trial ctx f = let[@warning "+9"] { env = _; ret = _; lits = _; slots; slot_tys; slot_names; scope; defers; defer_slot; defer_ok; defer_block; outer = _; outer_what; caught; place_ok; envslot; parent = _; - in_frames; loops; tail; in_defer; + in_frames; loops; tail; used; kept; in_defer; owner = _ } = ctx in let undo, keep = snapshot_env ctx.env in match speculate ctx.env f with @@ -15939,7 +16453,8 @@ and trial ctx f = ctx.defer_ok <- defer_ok; ctx.defer_block <- defer_block; ctx.outer_what <- outer_what; ctx.in_frames <- in_frames; ctx.caught <- caught; ctx.place_ok <- place_ok; ctx.envslot <- envslot; - ctx.loops <- loops; ctx.tail <- tail; ctx.in_defer <- in_defer; + ctx.loops <- loops; ctx.tail <- tail; ctx.used <- used; ctx.kept <- kept; + ctx.in_defer <- in_defer; Error d | exception e -> keep (); raise e @@ -16422,10 +16937,13 @@ let builtins : (string * string * string) list = ("put", "put [(Map K V) K V] ()", "Inserts or replaces. Unit rather than an error code, and \ (set (get m k) v) is not map syntax."); - ("get", "get [(Map K V) K] (Option V)", + ("get", "get [(Map K V) K]|[collection i32 ...] (Option V)|(Option T)", "The value at the key, or None. Nothing signals here — a lookup that \ finds nothing is an answer — and the value comes back as a copy of \ - its bytes."); + its bytes. Over an array, a slice, a string or a Vec it is at that \ + answers None for an index out of range, negative included, one index \ + per dimension. Over a dyn it answers nil for an absent key or index, \ + and more keys walk a level each."); ("map-remove", "map-remove [(Map K V) K] (Option V)", "Removes the entry and answers the value it held, or None if there was \ none."); @@ -17447,6 +17965,9 @@ let escaping_names ~returns (body : Ast.expr list) : string list = | Ast.Do es | Ast.Let (_, es) -> (match List.rev es with x :: _ -> tails x | [] -> ()) | Ast.If (_, a, b) -> tails a; Option.iter tails b + | Ast.IfLet (_, a, b) -> + (match List.rev a.Ast.body with x :: _ -> tails x | [] -> ()); + Option.iter tails b | Ast.Match (_, arms) -> List.iter (fun (a : Ast.arm) -> diff --git a/lib/dev.ml b/lib/dev.ml index 4f078e5f..6897d2a8 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -5106,6 +5106,27 @@ let push_request p req op reply = else p.watch_every <- None | _ -> () +(* A test harness that starts a daemon names itself in FLAN_DEV_HARNESS + (test/watchdog.ml), and the daemon dies with its parent and ends when the + harness has gone. The parent half is PR_SET_PDEATHSIG, armed in [start]. + The harness half is for a daemon whose parent is not the harness — one an + Emacs under test started — and is read by [accept_loop] and [serve]. + Opt-in only: a daemon an editor or a shell starts must outlive them, as it + always has. *) +let harness () = + match Sys.getenv_opt "FLAN_DEV_HARNESS" with + | Some s -> + (match int_of_string_opt (String.trim s) with + | Some p when p > 0 -> Some p + | _ -> None) + | None -> None + +let alive pid = + match Unix.kill pid 0 with + | () -> true + | exception Unix.Unix_error (Unix.ESRCH, _, _) -> false + | exception Unix.Unix_error _ -> true + (* ── The loop ──────────────────────────────────────────────────────── *) (* One connection at a time. An editor is one client, evaluations are @@ -5118,12 +5139,43 @@ let push_request p req op reply = let serve t fd = let p = { on = false; out_due = None; last_out = 0.; watch_every = None; watch_due = 0.; pend = Buffer.create 4096; sent = 0 } in + (* Under a test harness only: an attached client is no proof the harness is + alive — an Emacs under test holds its connection after the test binary + that ran it is gone, and it is this daemon's parent, so PDEATHSIG does not + fire either. So the wait is capped at a second and the harness looked at + each time round. Not the socket: an attached editor can still reach this + daemon whatever happened to the file. *) + let harness_pid = harness () in + let harness_due = ref 0. in + let harness_gone () = + match harness_pid with + | None -> false + | Some pid -> + let now = Unix.gettimeofday () in + if now < !harness_due then false + else begin + harness_due := now +. 1.; + if alive pid then false + else begin + Printf.eprintf + "flan dev: this session is ending; the test harness that started \ + it (pid %d) has exited\n%!" pid; + true + end + end + in + let cap wait = + match harness_pid with + | None -> wait + | Some _ -> if wait < 0. || wait > 1. then 1. else wait + in (* Between requests: push what is due, then wait for a request, for the program's output, or for the next push, whichever comes first. The pipe is drained here whether or not this client takes pushes, which is the liveness requirement [drain] describes, met while an editor is attached as well as between editors. *) let rec go () = + if harness_gone () then true else match push_due p t fd (Unix.gettimeofday ()) with | exception Unix.Unix_error _ -> false | blocked -> @@ -5134,7 +5186,7 @@ let serve t fd = let wfds, wait = if blocked then [ fd ], -1. else [], push_wait p (Unix.gettimeofday ()) in - (match Unix.select fds wfds [] wait with + (match Unix.select fds wfds [] (cap wait) with | ready, _, _ -> if List.mem t.stdout ready && not t.finished then begin drain t; @@ -5282,6 +5334,60 @@ let client_grace () = | None -> client_grace_default) | None -> client_grace_default +(* ── Whether anything can still reach this session ─────────────────── *) + +(* A daemon whose socket file has been deleted, or replaced by another daemon + binding the same path, can never be connected to again: an editor finds a + session only by that path. So the accept loop looks at the path about once a + second and ends the session, cleanly, when it no longer names the file this + daemon bound. + + The identity is taken with [stat] on the path right after the bind, never + from the listening fd (a socket fd's inode is sockfs's, not the file's), and + the watch starts only in [accept_loop], after the bind — so a session still + building cannot trip it. [stat] takes a path up to PATH_MAX, so a socket + bound through /proc/self/fd because its path is past 107 bytes is looked at + by that long path directly; the short symlink an editor connects through is + not what is checked. Both daemon shapes bind in this process, so + --two-process watches the same file the merged build does. *) +type bound = { path : string; dev : int; ino : int } + +let bound_at sock = + let path = + if Filename.is_relative sock then Filename.concat (Sys.getcwd ()) sock + else sock + in + match Unix.stat path with + | s -> Some { path; dev = s.Unix.st_dev; ino = s.Unix.st_ino } + | exception Unix.Unix_error _ -> None + +let still_bound b = + match Unix.stat b.path with + | s -> s.Unix.st_dev = b.dev && s.Unix.st_ino = b.ino + | exception Unix.Unix_error _ -> false + +(* Why the session can no longer be reached, if it cannot. *) +let unreachable bound = + match bound with + | Some b when not (still_bound b) -> + Some + (Printf.sprintf "its socket %s was removed or replaced, so no editor can \ + reach it" b.path) + | _ -> + match harness () with + | Some pid when not (alive pid) -> + Some (Printf.sprintf "the test harness that started it (pid %d) has exited" + pid) + | _ -> None + +(* The socket file and its short symlink, removed on the way out only while + the path still names this daemon's socket: one that was replaced belongs to + the daemon that replaced it, and so does the symlink to it. *) +let release_socket bound sock ~unlink_short = + let mine = match bound with Some b -> still_bound b | None -> true in + if mine then (try Unix.unlink sock with Unix.Unix_error _ -> ()); + if mine || not (Sys.file_exists sock) then unlink_short sock + (* [accept] would block past the program's own exit, so it is waited on with a timeout and the child checked each time round: a daemon whose program has finished has nothing left to do, and an editor waiting on it would wait @@ -5298,18 +5404,29 @@ let client_grace () = hole: it reads the client, not the program, and all of an Emacs's windows share the one [flan--connection], so closing one of them changes nothing this loop can see. *) -let accept_loop ?grace t ls = +let accept_loop ?grace ?bound t ls = let grace = match grace with Some g -> g | None -> client_grace () in (* [served] arms the clock and [since] is when the last client let go — set when [serve] returns rather than when [accept] fires, so a connection that is held for an hour is an hour of the clock not running. *) let served = ref false and since = ref (Unix.gettimeofday ()) in + let reach_due = ref 0. in + let cut_off () = + let now = Unix.gettimeofday () in + if now < !reach_due then None + else begin reach_due := now +. 1.; unreachable bound end + in let rec go () = (* The other place the agent clock is read: between connections, which is where a session with no editor attached spends its time. *) agent_check t; match liveness t with | Gone when t.relaunch = None -> () + | _ when (match cut_off () with + | Some why -> + Printf.eprintf "flan dev: this session is ending; %s\n%!" why; + true + | None -> false) -> () | live -> (* A --two-process child that has ended can be started again, so the session waits as a parked one does, on the parked grace. *) @@ -5614,6 +5731,7 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock ( let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in link_short_socket sock; Wire.bind_socket ls sock; + let bound = bound_at sock in Unix.listen ls 4; Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock ((Unix.gettimeofday () -. t0) *. 1000.); @@ -5625,9 +5743,8 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock ( | None -> ()); (try Unix.close ls with Unix.Unix_error _ -> ()); (try Unix.close t.stdout with Unix.Unix_error _ -> ()); - (try Unix.unlink sock with Unix.Unix_error _ -> ()); - unlink_short_socket sock) - (fun () -> accept_loop t ls); + release_socket bound sock ~unlink_short:unlink_short_socket) + (fun () -> accept_loop ?bound t ls); (* Here only when the loop returned: an exception out of it has already left through the [finally]. A child killed by a signal is the crash that keeps the directory. *) @@ -6478,8 +6595,9 @@ let merged_setup () = let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in link_short_socket sock; Wire.bind_socket ls sock; + let bound = bound_at sock in Unix.listen ls 4; - merged_state := Some (t, ls, sock); + merged_state := Some (t, ls, sock, bound); Printf.eprintf "flan dev: %s ready on %s (%.0fms, one process)\n%!" file sock ((Unix.gettimeofday () -. t0) *. 1000.) with @@ -6508,7 +6626,7 @@ let merged_setup () = let merged_serve () = match !merged_state with | None -> prerr_endline "flan dev: serve was called before setup"; exit 1 - | Some (t, ls, sock) -> + | Some (t, ls, sock, bound) -> (* The agent is bound by the program on the main thread, which only starts once [merged_setup] has returned. So this does not wait for it: it arms the clock that eventually says it never came, and serves. @@ -6529,15 +6647,14 @@ let merged_serve () = [eval] for what a delivery to such a program honestly reports. *) t.agent_watch <- Some (Unix.gettimeofday () +. 10.); let clean = - match accept_loop t ls with + match accept_loop ?bound t ls with | () -> true | exception e -> Printf.eprintf "flan dev: %s\n%!" (Printexc.to_string e); false in (try Unix.close ls with Unix.Unix_error _ -> ()); - (try Unix.unlink sock with Unix.Unix_error _ -> ()); - unlink_short_socket sock; + release_socket bound sock ~unlink_short:unlink_short_socket; (* The program is this process, so a program that crashed never gets here; the one end that does and is not clean is the loop raising. *) if clean then remove_session_dirs t; @@ -6615,6 +6732,15 @@ let start_merged ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock actually deleted. *) let start ?(debug = false) ?(sanitize = false) ?(merged = true) ?(x86 = true) ~file ~sock () = + (* Under a test harness only (see [harness]): SIGKILL when the parent dies, + which the kernel keeps across the exec into a merged build. A parent that + died before this was armed is caught by asking whether the harness is + still there; one that is not the harness is left to [accept_loop]. *) + (match harness () with + | Some pid -> + Spawn.die_with_parent (); + if not (alive pid) then exit 1 + | None -> ()); (* The sanitizers are LLVM passes, and the x86 backend's host is written by hand with no pass run over it. The modules a session sends are not instrumented on either backend; what is checked is the host and the diff --git a/lib/emit.ml b/lib/emit.ml index 9c271658..e156bf39 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -5084,6 +5084,7 @@ declare void @flan_dyn_class_hook(ptr) declare i64 @flan_dyn_kw(ptr, i64) declare i64 @flan_dyn_map_get(i64, i64) declare i64 @flan_dyn_get(i64, i64, ptr, i64) +declare i64 @flan_dyn_get_at(i64, i64, ptr, i64) declare void @flan_dyn_map_set(i64, i64, i64) declare i64 @flan_dyn_map_contains(i64, i64) declare i64 @flan_dyn_map_contains_at(i64, i64, ptr, i64) diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 0a87fcf3..b3d8ef5b 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -536,8 +536,19 @@ and list f h args = ("fn(" ^ commas ps ^ ") => " ^ unit_text body, 0) | Form.Sym "if", [ c; a; b ] -> ("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0) + (* A used when is a value, [when c then a]. *) + | Form.Sym "when", [ c; a ] -> ("when " ^ at 1 c ^ " then " ^ inline_text a, 0) + | Form.Sym "if-let", ({ v = Form.Vec [ _; _ ]; _ } as hd) :: a :: ([] | [ _ ] as b) -> + (if_let_head hd ^ " then " ^ inline_text ~lvl:1 a + ^ (match b with [ b ] -> " else " ^ inline_text b | _ -> ""), 0) | _ -> call () +(* [if let P = v], the head (if-let [P v] ...) is written with. *) +and if_let_head (hd : Form.t) = + match hd.v with + | Form.Vec [ pat; v ] -> "if let " ^ at 11 pat ^ " = " ^ at 1 v + | _ -> assert false + (* A one-line slot's text — an arm's value, a then or an else, what follows defer: the statements that fit on a line are written as statements, everything else as a value. [lvl] is what a value in the slot needs. *) @@ -700,7 +711,7 @@ let body_guess (h : Form.t) args = match a.v with | Form.List _ when is_chain a -> false | Form.List ({ v = Form.Sym h; _ } :: _) -> - List.mem h [ "let"; "set"; "when"; "unless"; "cond"; "while"; + List.mem h [ "let"; "set"; "when"; "if-let"; "unless"; "cond"; "while"; "until"; "dotimes"; "match"; "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; "break"; "continue" ] @@ -772,7 +783,7 @@ let body_split (h : Form.t) args = | Some k, _ -> Some (k, false) let sugar_heads = - [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match"; + [ "let"; "set"; "if"; "when"; "if-let"; "cond"; "while"; "until"; "dotimes"; "match"; "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; "quasiquote"; "update" ] @@ -1045,6 +1056,33 @@ and value_lines n prefix (v : Form.t) = and slot n (f : Form.t) = block n (stmts_of f) +(* Whether an else is a chain the reader makes of an [elif let]: an if-let, + or an [if] whose own else is one. *) +and has_let_else (x : Form.t) = + match x.v with + | Form.List ({ v = Form.Sym "if-let"; _ } :: { v = Form.Vec [ _; _ ]; _ } :: _ :: ([] | [ _ ])) -> true + | Form.List [ { v = Form.Sym "if"; _ }; _; _; r ] -> has_let_else r + | _ -> false + +(* Such a chain as the elif and else clauses at column [n]. A [when] at its + end is an [elif] with no else after it, which is how the reader reads one + back. *) +and let_chain n (x : Form.t) = + let i = ind n in + let tag (x : Form.t) l = Source_text.tag x.loc.Loc.line l in + match x.v with + | Form.List ({ v = Form.Sym "if-let"; _ } :: ({ v = Form.Vec [ _; _ ]; _ } as hd) :: a + :: ([] | [ _ ] as r)) -> + (tag x (i ^ "el" ^ if_let_head hd) :: slot (n + 2) a) + @ (match r with [ r ] -> let_chain n r | _ -> []) + (* Past an [elif let] every clause nests, so an [if] here is an [elif] + whether or not another let follows. *) + | Form.List [ { v = Form.Sym "if"; _ }; c; a; r ] -> + (tag c (i ^ "elif " ^ at 1 c) :: slot (n + 2) a) @ let_chain n r + | Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) -> + tag c (i ^ "elif " ^ at 1 c) :: block (n + 2) body + | _ -> tag x (i ^ "else") :: slot (n + 2) x + and label_of = function | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest) | rest -> ("", rest) @@ -1080,6 +1118,9 @@ and sugar n (f : Form.t) : string list option = | _ -> simple x in let line = i ^ fst (expr f) in + if has_let_else b then + Some (((i ^ "if " ^ at 1 c) :: slot (n + 2) a) @ let_chain n b) + else if simple a && chain b && String.length line <= width && not (!inside f) then Some [ line ] else @@ -1088,6 +1129,50 @@ and sugar n (f : Form.t) : string list option = @ [ Source_text.tag b.loc.Loc.line (i ^ "else") ] @ slot (n + 2) b) | Form.List ({ v = Form.Sym "when"; _ } :: c :: (_ :: _ as body)) -> Some ((i ^ "if " ^ at 1 c) :: block (n + 2) body) + (* [if let P = v] and its block; an else that is a cond is its elif + chain, which is what the reader makes of one. *) + | Form.List + ({ v = Form.Sym "if-let"; _ } :: ({ v = Form.Vec [ _; _ ]; _ } as hd) :: a + :: ([] | [ _ ] as b)) -> + let simple (x : Form.t) = + match x.v with + | Form.List ({ v = Form.Sym ("return" | "set" | "break" | "continue"); _ } :: _) -> true + | Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads) + | _ -> true + in + let line = i ^ fst (expr f) in + if simple a && List.for_all simple b && String.length line <= width + && not (!inside f) + then Some [ line ] + else + let head = (i ^ if_let_head hd) :: slot (n + 2) a in + (match b with + | [] -> Some head + | [ e ] when has_let_else e -> Some (head @ let_chain n e) + | [ ({ v = Form.List ({ v = Form.Sym "cond"; _ } :: args); _ } as e) ] -> + (match pairs args with + | Some (_ :: _ as prs) -> + let tests, else_ = + match List.rev prs with + | (k, e) :: rest when is_else k -> (List.rev rest, Some (k, e)) + | _ -> (prs, None) + in + Some + (head + @ List.concat_map + (fun ((c : Form.t), b) -> + Source_text.tag c.loc.Loc.line (i ^ "elif " ^ at 1 c) + :: slot (n + 2) b) + tests + @ (match else_ with + | Some ((k : Form.t), e) -> + Source_text.tag k.loc.Loc.line (i ^ "else") :: slot (n + 2) e + | None -> [])) + | _ -> + Some (head @ [ Source_text.tag e.loc.Loc.line (i ^ "else") ] @ slot (n + 2) e)) + | [ e ] -> + Some (head @ [ Source_text.tag e.loc.Loc.line (i ^ "else") ] @ slot (n + 2) e) + | _ -> None) | Form.List ({ v = Form.Sym "cond"; _ } :: args) -> (match pairs args with | None -> None diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 32375dc2..81391ad9 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -823,6 +823,13 @@ let no_loop loc word = break leaves the loop early, and continue goes on to the next round." word +(* A [when] has one branch; an else under one is an if's. *) +let when_else p = + failk "when-else" (peek p).loc + "a when has no else — it answers Some of its value when the test holds \ + and None when it does not. For two branches write if c then a else b, \ + or an if with an else block" + (* A refused chain written out as the [and] of all its tests. A middle operand that is more than a name or a literal is named by a [let] first, so the rewrite does not run it twice. *) @@ -991,7 +998,7 @@ and primary p : Form.t * int = | NAME s -> let nxt = peek_at p 1 in let glued_lp = nxt.tok = LP && not nxt.sp in - if s = "if" && nxt.sp && starts_value nxt.tok then if_expr p + if (s = "if" || s = "when") && nxt.sp && starts_value nxt.tok then if_expr p else if s = "fn" && glued_lp then fn_expr p (* Only the Lisp loop's spellings are refused here, for a message at the word: [loop x = a, ...], [loop([...]):], a bare [loop] over a block @@ -1090,30 +1097,76 @@ and primary p : Form.t * int = failk "expected-value" (where_ p) "expected a value here, and found %s" (show tk) -(* [if c then a else b]: the one-line form, for a value. *) +(* [if c then a else b]: the one-line form, for a value. [if let P = v then + a else b] and [when c then a] too. *) and if_expr p = let t = advance p in - let c, _ = binary p 1 in + let word = match t.tok with NAME w -> w | _ -> "if" in + let letp = if word = "if" then if_let_head p else None in + let c = match letp with Some m -> m | None -> fst (binary p 1) in (match (peek p).tok with | NAME "then" -> ignore (advance p) | _ -> failk "if-then" (where_ p) - "an if inside a line is if c then a else b, and there is no then \ - after %s. Write the then, or start the if on its own line with its \ + "an %s inside a line is %s, and there is no then \ + after %s. Write the then, or start the %s on its own line with its \ branches indented under it" - (text_of c)); + word + (if word = "when" then "when c then a" else "if c then a else b") + (text_of c) word); let a = inline_stmt p in match (peek p).tok with + | NAME ("else" | "elif") when word = "when" -> when_else p | NAME "else" -> ignore (advance p); let b = inline_stmt p in - (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ]), 0) + (if_let_wrap letp (mk p t.loc (Form.List [ sym t.loc "if"; c; a; b ])), 0) | NAME "elif" -> failk "one-line-elif" (peek p).loc "a one-line if has then and else and no elif. Chain another if after \ the else — if a then x else if b then y else z — or write the if over \ several lines, where elif goes" - | _ -> (mk p t.loc (Form.List [ sym t.loc "when"; c; a ]), 0) + | _ -> (if_let_wrap letp (mk p t.loc (Form.List [ sym t.loc "when"; c; a ])), 0) + +(* [if let P = v]: after the [if], the pattern and the value, as the one form + [[P v]] that stands where the test would. [None] when no [let] follows. *) +and if_let_head p = + match (peek p).tok, (peek_at p 1) with + | NAME "let", n when n.sp -> + let lt = advance p in + let pat, _ = unary p in + expect_name p "=" ~what:"= and the value the pattern is matched against"; + let v, _ = binary p 1 in + Some (mk p lt.loc (Form.Vec [ pat; v ])) + | _ -> None + +(* The if an [if let] head was read into, rewritten to (if-let [P v] then + else): [(if [P v] a b)], [(when [P v] body ...)] and an elif chain's + [(cond [P v] a c2 b2 ...)], whose rest is the else. *) +and if_let_wrap letp (f : Form.t) = + match letp with + | None -> f + | Some m -> + let il (h : Form.t) items = + { f with Form.v = Form.List (sym h.Form.loc "if-let" :: m :: items) } + in + let body (h : Form.t) = function + | [ x ] -> x + | (x : Form.t) :: _ as xs -> + Form.make (Form.List (sym x.Form.loc "do" :: xs)) x.Form.loc + | [] -> Form.make (Form.List [ sym h.Form.loc "do" ]) h.Form.loc + in + match f.Form.v with + | Form.List (({ v = Form.Sym "if"; _ } as h) :: c :: rest) when c == m -> il h rest + | Form.List (({ v = Form.Sym "when"; _ } as h) :: c :: b) when c == m -> + il h [ body h b ] + | Form.List (({ v = Form.Sym "cond"; _ } as h) :: c :: b1 :: rest) when c == m -> + (match rest with + | [] -> il h [ b1 ] + | [ { v = Form.Kw "else"; _ }; e ] -> il h [ b1; e ] + | (c2 : Form.t) :: _ -> + il h [ b1; Form.make (Form.List (sym c2.Form.loc "cond" :: rest)) c2.Form.loc ]) + | _ -> f (* What a one-line slot takes — a match arm's value, a then or an else, the thing after defer: a value, or one of the statements that fit on a line, @@ -1529,7 +1582,7 @@ let header_follow p s = | "fn" | "fn-" | "def" | "once" | "const" | "struct" | "union" | "data" | "enum" | "import" -> n.sp && plain_name n.tok - | "if" | "while" | "until" | "match" | "let" | "for" -> + | "if" | "when" | "while" | "until" | "match" | "let" | "for" -> n.sp && starts_value n.tok && (match n.tok with | NAME x when x = "=" || List.mem_assoc x assign_ops -> false @@ -1716,7 +1769,8 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t = | NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w) when header_follow p w -> header s w - | NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if" + | NAME (("if" | "when") as w) when header_follow p w && not (then_on_line p) -> + header s w | _ -> let e, _ = expr p in match (peek p).tok with @@ -2317,17 +2371,27 @@ and header (s : st) w : Form.t = in expect_eol p ~after:(text_of path); form [ alias; path ] - | "if" -> - let c, _ = binary p 1 in + | "if" | "when" -> + let letp = if w = "if" then if_let_head p else None in + let c = match letp with Some m -> m | None -> fst (binary p 1) in (* The elif and else clauses at the if's column, then the whole form. [oneline] when the if was [if c then a]: its clauses may then be one-line too, [elif c then x] and [else y], or take blocks. *) let clauses ~oneline body = + (match (peek p).tok with + | NAME ("else" | "elif") when w = "when" && not (assigns p) -> when_else p + | _ -> ()); + (* The [elif let P = v] heads, as the [[P v]] each stands as. *) + let elif_lets = ref [] in let rec elifs acc = match (peek p).tok with | NAME "elif" when not (assigns p) -> ignore (advance p); - let c, _ = binary p 1 in + let c = + match if_let_head p with + | Some m -> elif_lets := m :: !elif_lets; m + | None -> fst (binary p 1) + in (match (peek p).tok with | NAME "then" when oneline -> ignore (advance p); @@ -2363,8 +2427,27 @@ and header (s : st) w : Form.t = | _ -> None in match els_, else_ with + | _ when !elif_lets <> [] -> + (* An [elif let] makes the rest of the chain the else of an if-let: + each clause nests in the one before it, [if] or [if-let] as its + head is, and a chain with no else ends in a [when]. *) + let is_let c = List.memq c !elif_lets || Some c == letp in + let rec build = function + | [] -> Option.map (fun (el, e) -> blk s el e) else_ + | ((c : Form.t), b) :: rest -> + let at = c.Form.loc in + let f items = Form.make (Form.List items) at in + let r = build rest in + Some + (if is_let c then f (sym at "if-let" :: c :: blk s at b :: Option.to_list r) + else + match r with + | None -> f (sym at "when" :: c :: b) + | Some r -> f [ sym at "if"; c; blk s at b; r ]) + in + Option.get (build ((c, body) :: els_)) | [], None -> named "when" (c :: body) - | [], Some (el, e) -> form [ c; blk s l0 body; blk s el e ] + | [], Some (el, e) -> named "if" [ c; blk s l0 body; blk s el e ] | _ -> let pairs = List.concat_map (fun (c, b) -> [ c; blk s c.Form.loc b ]) ((c, body) :: els_) @@ -2376,15 +2459,17 @@ and header (s : st) w : Form.t = in named "cond" (pairs @ tail) in + if_let_wrap letp @@ (match (peek p).tok with | NAME "then" -> ignore (advance p); let a = inline_stmt p in (match (peek p).tok with + | NAME ("else" | "elif") when w = "when" -> when_else p | NAME "else" -> ignore (advance p); let b = inline_stmt p in - let f = form [ c; a; b ] in + let f = named "if" [ c; a; b ] in expect_eol p ~after:(text_of f); f | NAME "elif" -> diff --git a/lib/load.ml b/lib/load.ml index 3c8be027..6cd6398a 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -279,6 +279,14 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = in { a with Ast.body = List.map (rename_expr owned alias bound) a.Ast.body }) arms) + | Ast.IfLet (sc, a, e') -> + let inner = + match a.Ast.pat with Ast.Pctor (_, ns) -> ns @ bound | _ -> bound + in + Ast.IfLet (go sc, + { a with Ast.body = List.map (rename_expr owned alias inner) + a.Ast.body }, + Option.map go e') (* A quoted symbol naming something the package declares. [(Form.Sym {.s "Cursor"})] is what a quasiquote desugars to, and it is the one place a package's name survives into a *string* — which is @@ -840,6 +848,7 @@ let rec expr_uses acc (e : Ast.expr) = | Ast.Call (h, args) -> go h; gos args | Ast.Match (sc, arms) -> go sc; List.iter (fun (a : Ast.arm) -> gos a.Ast.body) arms + | Ast.IfLet (sc, a, e') -> go sc; gos a.Ast.body; Option.iter go e' | Ast.Struct (n, kvs) -> acc := (n, e.Ast.loc) :: !acc; List.iter (fun (_, v) -> go v) kvs diff --git a/lib/paren_printer.ml b/lib/paren_printer.ml index 7e73b39b..d977ad87 100644 --- a/lib/paren_printer.ml +++ b/lib/paren_printer.ml @@ -38,7 +38,7 @@ let rec flat spell (f : Form.t) = (* Heads whose arguments are statements or clauses rather than values: these break one argument to a line, never filled. *) let statement_heads = - [ "let"; "loop"; "set"; "if"; "when"; "unless"; "cond"; "while"; "until"; + [ "let"; "loop"; "set"; "if"; "if-let"; "when"; "unless"; "cond"; "while"; "until"; "dotimes"; "match"; "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; "fn"; "with-allocator"; "comment"; "quasiquote"; "break"; "continue" ] diff --git a/lib/parse.ml b/lib/parse.ml index 42431173..63c187ae 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -489,6 +489,18 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = | Sym "cond" -> cond f args + (* (if-let [pattern value] then) and (if-let [pattern value] then else): + [value] is matched against [pattern], whose names are bound in [then] + only. Any [match] pattern may stand there. *) + | Sym "if-let" -> + (match args with + | { v = Vec [ p; v ]; _ } :: t :: rest when List.length rest <= 1 -> + let arm = { Ast.pat = pattern p; body = [ expr t ]; aloc = p.loc } in + mk (Ast.IfLet (expr v, arm, Option.map expr (List.nth_opt rest 0))) + | _ -> + fail f "if-let is (if-let [pattern value] then) or \ + (if-let [pattern value] then else)") + (* Short-circuiting, so they cannot be ordinary calls. *) | Sym "and" -> shortcircuit f args ~is_and:true | Sym "or" -> shortcircuit f args ~is_and:false diff --git a/lib/spawn.ml b/lib/spawn.ml index 85baac85..9c3f757d 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -4,3 +4,6 @@ external dying : string -> string array -> int = "flan_spawn_dying" (** The host number of an OCaml signal number. *) external host_signal : int -> int = "flan_host_signal" + +(** Ask for SIGKILL when this process's parent dies; nothing off Linux. *) +external die_with_parent : unit -> unit = "flan_die_with_parent" diff --git a/lib/spawn_stubs.c b/lib/spawn_stubs.c index f8ab49a0..b4e67cfe 100644 --- a/lib/spawn_stubs.c +++ b/lib/spawn_stubs.c @@ -56,3 +56,15 @@ value flan_spawn_dying(value path, value argv) { value flan_host_signal(value s) { return Val_int(caml_convert_signal_number(Int_val(s))); } + +/* The same request made by this process for itself: SIGKILL when whatever is + * its parent now dies. Only `flan dev` under a test harness asks + * (FLAN_DEV_HARNESS, lib/dev.ml); the kernel keeps it across the exec into a + * merged build. */ +value flan_die_with_parent(value unit) { + (void)unit; +#ifdef __linux__ + prctl(PR_SET_PDEATHSIG, SIGKILL); +#endif + return Val_unit; +} diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 3d57bcf9..93264feb 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -4972,44 +4972,62 @@ static int64_t need_index(const uint8_t *loc, int64_t loclen, const char *op, } /* 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) { + * text, a walk from the front on any other. A typed str counts bytes. + * + * [at]'s, and [get]'s over a text or a vec: one body, so the two always + * count the same way. [soft] is [get]'s — an index out of range is nil + * rather than a trap. */ +static flan_dyn at_core(flan_dyn v, flan_dyn i, const uint8_t *loc, + int64_t loclen, int soft, const char *op) { int64_t k; flan_obj *o; /* m[:k] on a map is (get m :k), whatever the key: get's rule, nil when * absent. */ if (is_map(v)) return flan_dyn_get(v, i, loc, loclen); if (!is_text(v) && !is_vec(v)) - trap2(loc, loclen, TYPE_TRAP, "at", "only a text, a vec or a map is indexed", + trap2(loc, loclen, TYPE_TRAP, op, "only a text, a vec or a map is indexed", v, i); - k = need_index(loc, loclen, "at", v, i); + k = need_index(loc, loclen, op, v, i); o = dyn_obj(v); if (o->kind == OBJ_VIEW) { - int64_t len = view_len(loc, loclen, "at", o); - if (k < 0 || k >= len) trap_range(loc, loclen, "at", v, k, len); + int64_t len = view_len(loc, loclen, op, o); + if (k < 0 || k >= len) { + if (soft) return flan_dyn_nil(); + trap_range(loc, loclen, op, v, k, len); + } { uint8_t *p = view_elem_at(o, k); switch ((o->gen >> 9) & 3) { case VIEW_FAST_I64: { int64_t x; memcpy(&x, p, 8); return flan_dyn_from_i64(x); } case VIEW_FAST_F64: { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); } case VIEW_FAST_BOOL: return flan_dyn_from_bool(*p ? 1 : 0); - default: return view_read(loc, loclen, "at", o, o->u.view.desc, p); + default: return view_read(loc, loclen, op, o, o->u.view.desc, p); } } } 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); + if (k < 0 || k >= o->u.i) { + if (soft) return flan_dyn_nil(); + trap_range(loc, loclen, op, 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 (k < 0 || k >= o->len) { + if (soft) return flan_dyn_nil(); + trap_range(loc, loclen, op, v, k, o->len); + } return o->u.v.items[k]; } +flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc, + int64_t loclen) { + return at_core(v, i, loc, loclen, 0, "at"); +} + /* (slice s lo) and (slice s lo hi) over a text; nil for [hi] is the length. * The typed slice of a string is a view, and this is a copy: a text is * immutable, so no program can tell the two apart. A vec's slice would have @@ -5247,6 +5265,18 @@ flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc, return flan_dyn_map_get(m, k); } +/* The [get] builtin's, which [.field] does not share: over a map it is + * [flan_dyn_get], and over a vec or a text it is [at] that answers nil for an + * index out of range, negative included, where [at] traps. The index must + * still be an int — a wrong kind of key is a mistake, not an absence. */ +flan_dyn flan_dyn_get_at(flan_dyn v, flan_dyn i, const uint8_t *loc, + int64_t loclen) { + /* Through [at]'s own body, so however [at] counts a text — by code point — + * [get] counts the same. */ + if (!is_text(v) && !is_vec(v)) return flan_dyn_get(v, i, loc, loclen); + return at_core(v, i, loc, loclen, 1, "get"); +} + static flan_dyn contains_walk(flan_dyn m, flan_dyn k) { flan_obj *o = want_map(walk_loc, walk_len, walk_op, m, k); if (o->kind == OBJ_VIEW) { diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index f48cdcc1..f8591676 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -270,6 +270,10 @@ flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k); /* [get]'s, and a dyn's [.field]: [flan_dyn_map_get] with a site. */ flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc, int64_t loclen); +/* The [get] builtin's: [flan_dyn_get] over a map, and over a vec or a text + * the element, or nil for an index out of range. */ +flan_dyn flan_dyn_get_at(flan_dyn v, flan_dyn i, const uint8_t *loc, + int64_t loclen); void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); /* [put]'s: [flan_dyn_map_set], with the site a typed class slot's refusal * prints. */ diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 98a86cb3..680edde3 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -795,12 +795,17 @@ static void rt_flush_out(void) { * The two functions are kept saying the same thing on purpose. They are the * two ways a Flan program dies where it stands, and a difference between them * would be a difference nobody could predict from the outside. */ +/* Set by the dev agent once it has bound its own socket, to remove it: the + * [_exit] below skips the atexit handler that otherwise would. */ +void (*flan_die_hook)(void); + static _Noreturn void rt_die(void) { const char *sock; rt_flush_out(); fflush(stderr); sock = getenv("FLAN_DEV_SOCK"); if (sock != NULL && *sock != '\0') unlink(sock); + if (flan_die_hook != NULL) flan_die_hook(); _exit(134); } diff --git a/spec-syntax.md b/spec-syntax.md index 2f24a3b5..929ced4a 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -258,6 +258,19 @@ Each item: the proposal, then the reason in one line. line after a one-line `if c then a`, at its column, continues it (section 3, item 6); each such clause is one-line (`elif c then x`, `else y`) or takes a block. +- **`when c`** plus a block, or `when c then a`, reads as `when`, which is + what an `if` without `else` reads as too. No `else` or `elif` follows it. + A `when` whose value is kept (a `let`'s value, an argument, a return) gives + `Some(a)` when `c` holds and `None` when it does not; where a `dyn` is + wanted, `a` or `nil`. As a statement it gives nothing. An `if`/`elif` chain + with no `else` is the same when kept: `None` when no test holds. **Built.** +- **`if let P = v`** plus a block reads as `(if-let [P v] then)`; `elif` and + `else` follow as for `if`, the rest of the chain being the `if-let`'s else. + `elif let P = v` is a further `if-let` nested in that else. + Kept with no `else` at the end of its chain, it gives an Option as `when` does. + `P` is any `match` pattern, and its names are bound in the block only. One + line: `if let Some(g) = o then g else 0`. A pattern that cannot fail, a + plain name or `_`, is refused toward `let`. **Built.** - **`while c`, `until c`**, optional label first: `while :outer c`. **Built.** - **`for i in range(n)`**, `range(a, b)`, `range(a, b, step)` read as `dotimes`. `range` here is syntax, not a function. `..` is avoided because diff --git a/test/programs/agent-auto.flan b/test/programs/agent-auto.flan index ef624d4b..c1b159f8 100644 --- a/test/programs/agent-auto.flan +++ b/test/programs/agent-auto.flan @@ -2,7 +2,7 @@ ;;;; ;;;; Under [flan dev] it binds where the daemon said, exactly as the explicit ;;;; form did, and nothing here can tell the difference. Run on its own — which -;;;; is what test_agent.ml does with it — it picks a path under /tmp and prints +;;;; is what test_agent.ml does with it — it picks a path under TMPDIR and prints ;;;; it to stderr, and that printed line is the only way anything could connect. ;;;; ;;;; The second start is here to be a no-op. It answers 0 like the first, does diff --git a/test/programs/get-checked.flan b/test/programs/get-checked.flan new file mode 100644 index 00000000..ff34c121 --- /dev/null +++ b/test/programs/get-checked.flan @@ -0,0 +1,68 @@ +;;;; get over an array, a slice, a string and a Vec is at that answers None +;;;; for an index out of range, negative included, one index per dimension. +;;;; Over a dyn it answers nil, and more keys walk a level each. + +(defn show [o (Option i32)] () + (match o (Some v) (println v) None (println "none"))) + +(defn three [] (Vec i32) + (let [v (vec-new i32)] (push v 10) (push v 20) (push v 30) v)) + +(defn dvec [] dyn [10 [20 21] 30]) +(defn dmap [] dyn {:a 1 :b [5 6]}) +(defn dtext [] dyn "héy") + +(defn main [] () + (let [a [1 2 3] + grid [[1 2 3] [4 5 6]] + s (slice a) + v (three) + n (length a) + vv (vec-new (Vec i32) context/temp)] + (push vv v) + ;; -1, 0, len-1 and len on an array. + (show (get a -1)) + (show (get a 0)) + (show (get a (- n 1))) + (show (get a n)) + ;; Two dimensions, each tested. + (let [r 0 c 1] + (show (get grid (+ r 1) (- c 1))) + (show (get grid (- r 1) c)) + (show (get grid r (+ c 2)))) + (show (get grid 1 2)) + (show (get grid 2 0)) + ;; A slice. + (show (get s 2)) + (show (get s 3)) + ;; A Vec, and one a call answered. + (show (get v -1)) + (show (get v 0)) + (show (get v 2)) + (show (get v 3)) + (show (get (three) 1)) + ;; A Vec of Vecs: the inner length is tested only once the outer index is. + (show (get vv 0 2)) + (show (get vv 0 3)) + (show (get vv 1 0)) + ;; A string's byte. + (match (get "hey" 1) (Some b) (println b) None (println "none")) + (match (get "hey" 3) (Some b) (println b) None (println "none"))) + ;; Dyn. + (let [d (dvec) m (dmap)] + (println (get d -1)) + (println (get d 0)) + (println (get d 2)) + (println (get d 3)) + (println (get d 1 1)) + (println (get d 1 2)) + (println (get d 5 0)) + (println (get m :a)) + (println (get m :z)) + (println (get m :b 1)) + (println (get m :z 1)) + (println (.a m)) + ;; Dyn text: get counts it as at does, by character. + (println (get (dtext) 1)) + (println (get (dtext) 2)) + (println (get (dtext) 3)))) diff --git a/test/programs/get-trap.flan b/test/programs/get-trap.flan new file mode 100644 index 00000000..8f84ec2c --- /dev/null +++ b/test/programs/get-trap.flan @@ -0,0 +1,5 @@ +;;;; A dyn get with an index that is not an int traps, in get's own words: +;;;; the message names get and shows the get call, not at. + +(defn main [] () + (println (get (the dyn "héllo") 1.5))) diff --git a/test/programs/if-let-kept.fln b/test/programs/if-let-kept.fln new file mode 100644 index 00000000..0fb4714c --- /dev/null +++ b/test/programs/if-let-kept.fln @@ -0,0 +1,47 @@ +;; A kept if let with no else at the end of its chain gives an Option: Some of +;; the arm that ran, None when none did. + +fn pick(a: Option(i32), k: i32) -> Option(i32) + if let Some(x) = a then x + elif k > 0 then k + +fn only(a: Option(i32)) -> Option(i32) + if let Some(x) = a then x * 2 + +fn lead(k: i32, b: Option(i32)) -> Option(i32) + if k > 5 + k + elif let Some(y) = b + y + +;; An arm that returns stays Never, and the rest of the chain decides. +fn early(a: Option(i32)) -> Option(i32) + if let Some(x) = a + return None + elif true + 3 + +fn dyn_only(a: Option(i32)) -> dyn + if let Some(x) = a then x + +fn show(o: Option(i32)) + match o + Some(v) -> println(v) + None -> println("none") + +fn main() + show(pick(Some(1), 0)) + show(pick(None, 4)) + show(pick(None, 0)) + show(only(Some(3))) + show(only(None)) + show(lead(9, None)) + show(lead(1, Some(2))) + show(lead(1, None)) + show(early(None)) + show(early(Some(1))) + println(dyn_only(Some(5))) + println(dyn_only(None)) + ;; As a statement it is unchanged. + if let Some(x) = Some(7) + println(x) diff --git a/test/programs/if-let.fln b/test/programs/if-let.fln new file mode 100644 index 00000000..6bcfb887 --- /dev/null +++ b/test/programs/if-let.fln @@ -0,0 +1,71 @@ +;; if let: the block runs when the pattern matches, its names bound there only. + +data Shape + Rect(w: i32, h: i32) + Dot + +enum Dir + north = 0 + south = 1 + +fn describe(o: Option(i32), k: i32) -> i32 + if let Some(g) = o + g + 1 + elif k > 5 + 100 + else + 0 + +fn first(xs: [3 i32]) -> i32 + if let Some(x) = get(xs, 0) then x else -1 + +;; elif let: the rest of the chain is the else of an if let. +fn pick(a: Option(i32), b: Option(i32), k: i32) -> i32 + if let Some(x) = a + x + elif let Some(y) = b + y * 10 + elif k > 5 + 100 + else + 0 + +;; Nested: a pattern tested inside the block of another. +fn area(s: Option(Shape)) -> i32 + if let Some(x) = s + if let Rect(w, h) = x + w * h + else + -1 + else + -2 + +fn main() + let g = 7 + println(describe(Some(4), 0)) + println(describe(None, 9)) + println(describe(None, 1)) + println(first([9, 8, 7])) + println(pick(Some(1), None, 0)) + println(pick(None, Some(2), 0)) + println(pick(None, None, 9)) + println(pick(None, None, 1)) + ;; Shadowing: g is the payload inside the block and the outer g after it. + if let Some(g) = Some(1) + println(g) + println(g) + ;; Any match pattern. + if let None = get([1, 2], 5) + println("absent") + if let :north = Dir.north + println("north") + println(area(Some(Shape.Rect{.w 2 .h 3}))) + println(area(Some(Shape.Dot))) + println(area(None)) + ;; when on one line and with a block. + let w = when g > 3 then g * 2 + match w + Some(v) -> println(v) + None -> println("none") + when g > 1 + println("when block") diff --git a/test/programs/when-value.flan b/test/programs/when-value.flan new file mode 100644 index 00000000..c1c907b4 --- /dev/null +++ b/test/programs/when-value.flan @@ -0,0 +1,63 @@ +;;;; A when whose value is kept answers an Option: Some of its body when the +;;;; test holds, None when it does not. As a statement it answers nothing. +;;;; Where a dyn is wanted it answers the body or nil, since dyn has no +;;;; Option. A body that is already an Option is not flattened. + +(defn show [o (Option i32)] () + (match o (Some v) (println v) None (println "none"))) + +;; Returned: the return type is the want. +(defn half [n i32] (Option i32) (when (= 0 (% n 2)) (/ n 2))) + +;; Nested, as Rust's bool::then: None from the body stays apart from a +;; failed test. +(defn wrap [c bool o (Option i32)] (Option (Option i32)) (when c o)) + +(defn level [oo (Option (Option i32))] () + (match oo + (Some o) (match o (Some v) (println v) None (println "some none")) + None (println "none"))) + +;; Dyn: the body or nil. +(defn dyn-when [x] dyn (when x 5)) + +;; An if-let arm that returns stays Never; the when after it decides. +(defn early [a (Option i32)] (Option i32) + (if-let [(Some x) a] (return None) (when true 3))) + +;; A lambda's last form is kept at the return type its position wants. +(defn call-it [f (Fn [] (Option i32))] () (show (f))) + +;; A kept cond with no :else is a when over several tests. +(defn pick [n i32] (Option i32) (cond (= n 1) 10 (= n 2) 20)) +(defn dpick [n] dyn (cond (= n 1) "a" (= n 2) "b")) + +(defn main [] () + (show (half 10)) + (show (half 7)) + ;; A let's value. + (let [a (when (> 3 2) 42) + b (when (> 2 3) 42)] + (show a) + (show b)) + ;; An argument. + (show (when true 9)) + (level (wrap true (Some 1))) + (level (wrap true None)) + (level (wrap false (Some 1))) + (println (dyn-when true)) + (println (dyn-when nil)) + (show (early None)) + (show (early (Some 1))) + (call-it (fn [] (when true 6))) + (call-it (fn [] (when false 6))) + (show (pick 2)) + (show (pick 3)) + (let [k (cond (> 3 5) 1 (> 3 2) 2)] (show k)) + (println (dpick 1)) + (println (dpick 9)) + (cond (> 3 5) (println "no") (> 3 2) (println "cond stmt")) + ;; Statements, unchanged. + (when true (println "ran")) + (when false (println "not run")) + (println "end")) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 69111762..0c364e20 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2224,6 +2224,46 @@ let () = dyn_if_truthy_out; outputs ~x86:true "dyn if truthiness, --x86" "programs/dyn-if-truthy.flan" dyn_if_truthy_out; + (* A kept when is an Option; get is a checked lookup; if let. *) + let when_value_out = + "5\nnone\n42\nnone\n9\n1\nsome none\nnone\n5\nnil\n3\nnone\n6\nnone\n20\nnone\n2\n\ + a\nnil\ncond stmt\nran\nend\n" + in + outputs "when as a value" "programs/when-value.flan" when_value_out; + outputs ~opt:"-O0" "when as a value, -O0" "programs/when-value.flan" when_value_out; + outputs ~x86:true "when as a value, --x86" "programs/when-value.flan" when_value_out; + let get_checked_out = + "none\n1\n3\nnone\n4\nnone\nnone\n6\nnone\n3\nnone\n\ + none\n10\n30\nnone\n20\n30\nnone\nnone\n101\nnone\n\ + nil\n10\n30\nnil\n21\nnil\nnil\n1\nnil\n6\nnil\n1\n\u{e9}\ny\nnil\n" + in + outputs "get as a checked lookup" "programs/get-checked.flan" get_checked_out; + outputs ~opt:"-O0" "get as a checked lookup, -O0" "programs/get-checked.flan" + get_checked_out; + outputs ~x86:true "get as a checked lookup, --x86" "programs/get-checked.flan" + get_checked_out; + let if_let_out = + "5\n100\n0\n9\n1\n20\n100\n0\n1\n7\nabsent\nnorth\n6\n-1\n-2\n14\nwhen block\n" + in + let if_let_kept_out = + "1\n4\nnone\n6\nnone\n9\n2\nnone\n3\nnone\n5\nnil\n7\n" + in + outputs "a kept if let chain" "programs/if-let-kept.fln" if_let_kept_out; + outputs ~opt:"-O0" "a kept if let chain, -O0" "programs/if-let-kept.fln" if_let_kept_out; + outputs ~x86:true "a kept if let chain, --x86" "programs/if-let-kept.fln" if_let_kept_out; + outputs "if let" "programs/if-let.fln" if_let_out; + (let exe = compile "programs/get-trap.flan" in + let code, text = run exe None in + if code <> 134 || not (contains text "dyn get:") + || not (contains text "(get \"h\195\169llo\" 1.5)") + then begin + incr failures; + Printf.printf "FAIL a dyn get's trap names get\n got: %S (exit %d)\n" + text code + end; + (try Sys.remove exe with Sys_error _ -> ())); + outputs ~opt:"-O0" "if let, -O0" "programs/if-let.fln" if_let_out; + outputs ~x86:true "if let, --x86" "programs/if-let.fln" if_let_out; (* format-f64, the first number formatter a caller can steer. The three lines that would ship wrong are pinned deliberately: 0.999995 at five places, where the rounded fraction equals the scale and is the next diff --git a/test/test_agent.ml b/test/test_agent.ml index ecd63d4f..01ad672d 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -242,7 +242,11 @@ let () = (* The shape is part of the claim: two programs started at once must not choose the same file, and the pid alone would not separate two runs of the same program in sequence. *) - let pid_part = Printf.sprintf "/tmp/flan-agent-%d-" apid in + (* Under TMPDIR, which the program inherited from this suite. *) + let pid_part = + Filename.concat (Filename.get_temp_dir_name ()) + (Printf.sprintf "flan-agent-%d-" apid) + in if not (String.length apath > String.length pid_part && String.sub apath 0 (String.length pid_part) = pid_part) then fail "the chosen path is not this process's: %S" apath; @@ -286,6 +290,41 @@ let () = end end end; + (* ── The socket goes with a program ended by a signal ────────────── + + SIGTERM runs no atexit, so the agent removes its socket from a handler + of its own and then dies of the signal as before. *) + let terr = tmp "term.err" in + let t1 = ofd (tmp "term.out") and t2 = ofd terr in + let tpid = Unix.create_process_env aexe [| aexe |] aenv Unix.stdin t1 t2 in + Unix.close t1; + Unix.close t2; + let tpath () = + let text = In_channel.with_open_bin terr In_channel.input_all in + List.find_map + (fun l -> + if String.starts_with ~prefix l then + Some (String.sub l (String.length prefix) + (String.length l - String.length prefix)) + else None) + (String.split_on_char '\n' text) + in + (match + if await (fun () -> tpath () <> None) then tpath () else None + with + | None -> + fail "a program to be sent SIGTERM never announced its socket"; + (try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ()) + | Some p -> + ignore (await (fun () -> Sys.file_exists p)); + Unix.kill tpid Sys.sigterm; + let _, st = Unix.waitpid [] tpid in + if st <> Unix.WSIGNALED Sys.sigterm then + fail "a program sent SIGTERM did not die of it"; + if Sys.file_exists p then + fail "the socket outlived a program ended by SIGTERM: %S" p); + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) + [ terr; tmp "term.out" ]; (* ── A path that cannot be bound ────────────────────────────────── *) (* The same program again, told to listen somewhere that does not exist. diff --git a/test/test_dev.ml b/test/test_dev.ml index ed8b54fe..268a9149 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -5923,6 +5923,14 @@ let () = (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ()) end else begin + (* Past two of the daemon's socket checks with no editor attached: + a socket reached through its directory is still its own. *) + Unix.sleepf 2.5; + (match Unix.waitpid [ Unix.WNOHANG ] pid with + | 0, _ -> () + | _ -> fail "a deep TMPDIR (%s): the daemon ended with its socket \ + in place" shape + | exception Unix.Unix_error _ -> ()); let c = connect dsock in let said r = Option.value ~default:(status r) (Wire.string_field r "message") @@ -5958,6 +5966,180 @@ let () = [ [||]; [| "--two-process" |] ]; Own_tmp.remove deep; + (* ── A daemon nothing can reach any more ends ────────────────────── + + Three ways a session becomes unreachable, each in both shapes: the + process that started it is SIGKILLed (the daemon, and under + --two-process its program, die with it); the test harness named in + FLAN_DEV_HARNESS goes, though the daemon's own parent lives on (the + Emacs-started case); and its socket file is deleted. And one way it + does not: a socket left alone keeps the daemon running. *) + let gone pid = + match In_channel.with_open_bin (Printf.sprintf "/proc/%d/stat" pid) + In_channel.input_all with + | st -> + (match String.rindex_opt st ')' with + | Some i when i + 2 < String.length st -> st.[i + 2] = 'Z' + | _ -> false) + | exception Sys_error _ -> true + in + let children pid = + match In_channel.with_open_bin + (Printf.sprintf "/proc/%d/task/%d/children" pid pid) + In_channel.input_all with + | s -> List.filter_map int_of_string_opt (String.split_on_char ' ' (String.trim s)) + | exception Sys_error _ -> [] + in + let with_harness env = + Array.of_list + (env + @ List.filter + (fun v -> not (String.starts_with ~prefix:"FLAN_DEV_HARNESS=" v)) + (Array.to_list (Unix.environment ()))) + in + List.iter + (fun mode -> + let shape = if mode = [||] then "one process" else "--two-process" in + let argv s = + Array.append [| flan; "dev"; "programs/dev-pause.flan"; "-s"; s |] mode + in + (* The parent SIGKILLed. A harness process of its own, so that the + parent can be killed without killing this test. *) + let ksock = tmp "orphan-parent.sock" in + (try Sys.remove ksock with Sys_error _ -> ()); + let rd, wr = Unix.pipe () in + (match Unix.fork () with + | 0 -> + Unix.close rd; + let d = + Unix.create_process flan (argv ksock) Unix.stdin Unix.stdout + Unix.stderr + in + let msg = string_of_int d ^ "\n" in + ignore (Unix.write_substring wr msg 0 (String.length msg)); + Unix.close wr; + Unix.sleep 600; + Unix._exit 0 + | h -> + Unix.close wr; + let ic = Unix.in_channel_of_descr rd in + let d = int_of_string (String.trim (input_line ic)) in + close_in ic; + if not (listening ~pid:d ksock) then + fail "a daemon under a harness (%s): %s" shape !listen_why; + let kids = children d in + if mode <> [||] && kids = [] then + fail "a daemon under a harness (%s): no program child found" shape; + Unix.kill h Sys.sigkill; + ignore (Unix.waitpid [] h); + if not (await ~ms:5000 (fun () -> gone d)) then begin + fail "a daemon (%s) outlived the process that started it" shape; + (try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ()) + end; + List.iter + (fun k -> + if not (await ~ms:5000 (fun () -> gone k)) then begin + fail "a daemon's program (%s) outlived the daemon" shape; + (try Unix.kill k Sys.sigkill with Unix.Unix_error _ -> ()) + end) + kids); + (try Sys.remove ksock with Sys_error _ -> ()); + + (* The harness gone, the parent alive. [sleep] stands in for it. + Twice: with no client, and with one connected and holding on, as + an Emacs under test does after the binary that ran it is gone. *) + List.iter + (fun held -> + let how = if held then "connected" else "idle" in + let hsock = tmp "orphan-harness.sock" in + (try Sys.remove hsock with Sys_error _ -> ()); + let stand_in = + Unix.create_process "sleep" [| "sleep"; "600" |] Unix.stdin + Unix.stdout Unix.stderr + in + let d = + Unix.create_process_env flan (argv hsock) + (with_harness [ "FLAN_DEV_HARNESS=" ^ string_of_int stand_in ]) + Unix.stdin Unix.stdout Unix.stderr + in + let client = ref None in + if not (listening ~pid:d hsock) then + fail "a daemon with a harness (%s, %s): %s" shape how !listen_why + else begin + if held then begin + let c = connect hsock in + client := Some c; + if status (request c "(:op \"describe\")") <> "ok" then + fail "a daemon with a harness (%s): describe failed" shape + end; + Unix.kill stand_in Sys.sigkill; + ignore (Unix.waitpid [] stand_in); + let ended = + await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] d with + | 0, _ -> false + | _ -> true) + in + if not ended then + fail "a daemon (%s, %s) outlived the test harness that \ + started it" shape how + end; + (match !client with + | Some c -> (try Unix.close c with Unix.Unix_error _ -> ()) + | None -> ()); + (try Unix.kill stand_in Sys.sigkill with Unix.Unix_error _ -> ()); + (try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] d) with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] stand_in) with Unix.Unix_error _ -> ()); + (try Sys.remove hsock with Sys_error _ -> ())) + [ false; true ]; + + (* The socket: kept, the daemon stays; deleted, it ends, cleanly. *) + let ssock = tmp "orphan-socket.sock" in + (try Sys.remove ssock with Sys_error _ -> ()); + let d = + Unix.create_process flan (argv ssock) Unix.stdin Unix.stdout + Unix.stderr + in + if not (listening ~pid:d ssock) then + fail "a daemon whose socket goes (%s): %s" shape !listen_why + else begin + let kids = children d in + Unix.sleepf 2.5; + (match Unix.waitpid [ Unix.WNOHANG ] d with + | 0, _ -> () + | _ -> fail "a daemon (%s) ended with its socket in place" shape); + Sys.remove ssock; + let st = ref None in + let ended = + await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] d with + | 0, _ -> false + | _, s -> st := Some s; true) + in + if not ended then + fail "a daemon (%s) outlived its deleted socket" shape + else begin + if !st <> Some (Unix.WEXITED 0) then + fail "a daemon (%s) whose socket was deleted did not end cleanly" + shape; + let dir = + Filename.concat (Filename.get_temp_dir_name ()) + (Printf.sprintf "flan-dev-%d" d) + in + if Sys.file_exists dir then + fail "a daemon (%s) whose socket was deleted left %s" shape dir; + List.iter + (fun k -> + if not (await ~ms:5000 (fun () -> gone k)) then + fail "the program (%s) outlived its daemon's socket" shape) + kids + end + end; + (try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] d) with Unix.Unix_error _ -> ())) + [ [||]; [| "--two-process" |] ]; + (* ── Prelude functions shadowed live keep the prelude's own calls ── [rand] and then [rand-int] redefined in a running program: the diff --git a/test/test_flan.ml b/test/test_flan.ml index c30bd8e1..74ac68fb 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -4050,7 +4050,7 @@ let () = rejects_check "an inline generator's body has to answer the element type" "(defonce grid [2 [3 u8]] (array-gen [2 3] (fn [i j] 1.5)))\n\ (defn f [] i32 0)" - ~needle:"expected u8, found f64"; + ~needle:"expected u8, found the float literal 1.5"; rejects_check "an inline generator takes one argument per dimension too" "(defn f [] i32 (let [a (array-gen [2] (fn [i j] i))] 0))" ~needle:"this array-gen has 1 dimension, so its generator is called with \ @@ -8397,5 +8397,52 @@ let () = parse_rejects "_ in a defgeneric's return slot" ~needle:"defgeneric's methods each have their own" "(defgeneric area [s] _)"; + (* if-let refuses a pattern that cannot fail, toward let; the program half + is programs/if-let.flan. *) + rejects_check "if-let over a plain name" + ~needle:"the pattern g is a plain name, which always matches" + "(defn main [] () (if-let [g (Some 1)] (println g)))"; + rejects_check "and says let" ~needle:"(let [g ...] ...)" + "(defn main [] () (if-let [g (Some 1)] (println g)))"; + rejects_check "if-let over _" ~needle:"the pattern _ always matches" + "(defn main [] () (if-let [_ (Some 1)] (println 1)))"; + accepts "if-let over a case with no fields" + "(defdata S [(A []) (B [])])\n(defn main [] () (if-let [A S.B] (println 1)))"; + (* A used when is an Option, and a statement's is nothing. *) + accepts "a let's when is an Option" + "(defn main [] () (let [x (the (Option i32) (when true 1))] (println x)))"; + rejects_check "a when is not its branch's type" ~needle:"(Option i32)" + "(defn f [] i32 (when true 1))\n(defn main [] ())"; + rejects_check "a when as an operand is blamed, not the literal beside it" + ~needle:"this when is an operand of +, so its value is kept" + "(defn main [] () (println (+ 1 (when true 5))))"; + rejects_check "on either side" + ~needle:"this when is an operand of +, so its value is kept" + "(defn main [] () (println (+ (when true 5) 1)))"; + (* Any form with no else at its end, beside a number, is blamed itself. *) + List.iter + (fun (what, e, needle) -> + rejects_check ("a kept " ^ what ^ " beside a number is blamed itself") + ~needle + ("(defn main [] () (let [c true] (println " ^ e ^ ")))")) + [ ("when in <", "(< 1 (when c 5))", "this when is an operand of <, so its value is kept"); + ("when in =", "(= 1 (when c 5))", "this when is an operand of =, so its value is kept"); + ("cond", "(+ 1 (cond c 5))", "this chain without an else is an operand of +"); + ("if ending in a when", "(+ 1 (if c 5 (when c 6)))", + "this chain without an else is an operand of +"); + ("do ending in a when", "(+ 1 (do (when c 5)))", "this when is an operand of +"); + ("if-let", "(+ 1 (if-let [(Some x) (Some c)] 5))", + "this if let without an else is an operand of +") ]; + (* get on a String is refused as at is. *) + rejects_check "get on a String is refused as at is" + ~needle:"a String is not indexed" + "(defn main [] () (let [s (string-new \"abc\")] (println (get s 1))))"; + accepts "a lambda's when takes the Option its position wants" + "(defn call-it [f (Fn [] (Option i32))] () (println (f)))\n\ + (defn main [] () (call-it (fn [] (when true 6))))"; + accepts "a kept cond with no :else is an Option" + "(defn f [n i32] (Option i32) (cond (= n 1) 10 (= n 2) 20))\n(defn main [] ())"; + rejects_check "a map's get takes one key" ~needle:"a map's get takes one key" + "(defn main [] () (let [m (map-new i32 i32)] (println (get m 1 2))))"; Test_support.report () diff --git a/test/test_syntax.ml b/test/test_syntax.ml index f2c48bf9..fb228996 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -1138,6 +1138,40 @@ let () = " sort-by(xs, fn(a, b) =>\n g(a)\n a < b)"; round "one closer for a call in a call" "(defn f [] () (println (run (fn [] (g) 1))))" " println(run(fn() =>\n g()\n 1))"; + (* if let and when, read both ways and printed back. *) + round "if let with a block and an else" + "(defn f [o (Option i32)] i32 (if-let [(Some g) o] (do (println g) g) 0))" + " if let Some(g) = o\n println(g)\n g\n else\n 0"; + round "if let on one line" + "(defn f [o (Option i32)] i32 (if-let [(Some g) o] g 0))" + " if let Some(g) = o then g else 0"; + round "if let with elif" + "(defn f [o (Option i32) k i32] i32 (if-let [(Some g) o] (+ g 1) (cond (> k 5) 100 :else 0)))" + " elif k > 5\n 100\n else\n 0"; + round "if let with no else" "(defn f [o (Option i32)] () (if-let [(Some g) o] (do (println g) (println g))))" + " if let Some(g) = o\n println(g)"; + round "elif let" + "(defn f [a (Option i32) b (Option i32) k i32] i32 \ + (if-let [(Some x) a] x (if-let [(Some y) b] (* y 10) (if (> k 5) 100 0))))" + " elif let Some(y) = b\n y * 10\n elif k > 5\n 100\n else\n 0"; + round "elif let after a plain if" + "(defn f [a bool b (Option i32)] () \ + (if a (println 1) (if-let [(Some y) b] (println y) (when (> 1 0) (println 2)))))" + " elif let Some(y) = b\n println(y)\n elif 1 > 0\n println(2)"; + reads "elif let reads as a nested if-let" + "if let Some(x) = a\n f(x)\nelif let None = b\n g()\nelse\n h()" + "(if-let [(Some x) a] (f x) (if-let [None b] (g) (h)))"; + round "a kept if let chain with no else" + "(defn f [a (Option i32) k i32] (Option i32) (if-let [(Some x) a] (do (g) x) (cond (> k 0) k)))" + " if let Some(x) = a\n g()\n x\n elif k > 0\n k"; + round "a kept when" "(defn f [] () (let [w (when (> a 1) 2)] (g w)))" + " let w = when a > 1 then 2"; + reads "when with a block" "when a\n b()\n c()" "(when a (b) (c))"; + reads "when on one line" "when a then b()" "(when a (b))"; + reads "if let with elif and no else" "if let None = o\n a()\nelif c\n b()" + "(if-let [None o] (a) (cond c (b)))"; + refuses "when has no else" "when a then b() else c()" "indent/when-else" "a when has no else"; + refuses "nor an else block" "when a\n b()\nelse\n c()" "indent/when-else" "a when has no else"; round "a typed block lambda in a call" "(defn f [] () (h (the (Fn [C] bool) (fn [c] (g c) (> (.n c) 3)))))" " h(fn(c: C) -> bool =>\n g(c)\n c.n > 3)"; @@ -1349,6 +1383,24 @@ let checks name text = | _ -> () | exception e -> fail "%s does not check: %s" name (diag_text e) +(* A kept if-let chain whose arm gives no value is a statement, refused as a + plain if's is; one whose arm returns stays Never, in both syntaxes. *) +let () = + refused "if-let-unit.flan" + "(defn main [] () (let [a (Some 1) r (if-let [(Some x) a] (println x) \ + (when true (println 2)))] (println r)))\n" + [ "r would be bound to (), which is not a value" ]; + refused "if-let-unit.fln" + "fn main()\n let a = Some(1)\n let r = if let Some(x) = a then println(x) \ + else when true then println(2)\n println(r)\n" + [ "r would be bound to (), which is not a value" ]; + checks "if-let-never.flan" + "(defn f [a (Option i32)] (Option i32) (if-let [(Some x) a] (return None) \ + (when true 3)))\n(defn main [] () (println (f None)))\n"; + checks "if-let-never.fln" + "fn f(a: Option(i32)) -> Option(i32)\n if let Some(x) = a\n return None\n \ + elif true\n 3\n\nfn main()\n println(f(None))\n" + let () = let poke_fln = "fn poke(coll) -> dyn\n coll[0] = 99\n coll\n\n" in let poke_flan = "(defn poke [coll] dyn (set (at coll 0) 99) coll)\n" in diff --git a/test/watchdog.ml b/test/watchdog.ml index 75beecbf..e4779d88 100644 --- a/test/watchdog.ml +++ b/test/watchdog.ml @@ -76,6 +76,10 @@ let arm ?(seconds = 600) name = label := name; budget := seconds; deadline := Unix.gettimeofday () +. float_of_int seconds; + (* Every [flan dev] this binary starts, directly or from an Emacs it runs, + dies with its parent and ends once this process is gone (lib/dev.ml, + [harness]), so a run killed partway leaves no daemon behind. *) + Unix.putenv "FLAN_DEV_HARNESS" (string_of_int (Unix.getpid ())); backstop () (* [f] under a tighter alarm, with the backstop restored afterwards however diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index e5c687f7..38d60e2b 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -1023,28 +1023,55 @@ static int sock_dir_fd = -1; /* A socket file outlives the process that bound it, and a stale one answers * the next client with ECONNREFUSED — which reads like a program that is there * and refusing rather than one that has gone. So the bind registers its own - * removal, and the three ways out of a program each unlink it: + * removal, and every way out of a program that runs any code unlinks it: * * ordinary exit this handler, via atexit * break-loop abort die_now, by hand, because it takes _exit + * trap rt_die in flan_rt.c, through [flan_die_hook] * orphaned child orphan_die, by hand, for the same reason + * fatal signal fatal_unlink: SIGTERM, SIGINT, SIGHUP, SIGQUIT and + * SIGABRT, while their disposition is still the default * - * Outside a daemon that is the whole story, and the path is under /tmp where - * nothing else would ever reclaim it. + * Outside a daemon that is the whole story, and the path is under TMPDIR where + * nothing else would ever reclaim it. SIGKILL is the one end nothing survives. * - * Under [flan dev] none of the three is how a session usually ends, and this - * is worth being exact about rather than claiming cover it does not give: the - * two-process daemon kills its child with SIGTERM, whose default disposition - * runs no atexit, and the merged session leaves by [Unix._exit 0]. So the - * socket there is left in the daemon's temp directory — which is itself never - * removed today. TODO.org, "The daemon leaves its temp directory behind": the - * session-end cleanup that item asks for takes the socket with it, and until - * it lands the socket outlives the session. Nothing below can fix that from - * here; a program that is killed does not get to tidy up. */ + * Under [flan dev] the session's own end also covers it: the two-process + * daemon stops its child with SIGTERM, which [fatal_unlink] sees, and the + * merged session leaves by [Unix._exit 0] after removing its temp directory, + * the socket with it (lib/dev.ml, [remove_session_dirs]). */ static void unlink_bound_sock(void) { if (bound_sock[0] != '\0') unlink(bound_sock); } +extern void (*flan_die_hook)(void); + +/* unlink and re-raise under the default disposition, so the process still + * ends by the signal it was sent: a parent waiting on it sees the same status + * as before. Both calls are async-signal-safe. */ +static void fatal_unlink(int sig) { + if (bound_sock[0] != '\0') unlink(bound_sock); + signal(sig, SIG_DFL); + raise(sig); +} + +/* Only a signal nobody has claimed: a program, or the runtime a merged build + * carries, that installed its own handler keeps it. Called after the bind. */ +static void unlink_on_fatal_signals(void) { + static const int sigs[] = { SIGTERM, SIGINT, SIGHUP, SIGQUIT, SIGABRT }; + size_t i; + for (i = 0; i < sizeof sigs / sizeof sigs[0]; i++) { + struct sigaction old, sa; + if (sigaction(sigs[i], NULL, &old) != 0) continue; + if ((old.sa_flags & SA_SIGINFO) != 0 || old.sa_handler != SIG_DFL) continue; + memset(&sa, 0, sizeof sa); + sa.sa_handler = fatal_unlink; + sigemptyset(&sa.sa_mask); + sa.sa_flags = SA_RESETHAND; + sigaction(sigs[i], &sa, NULL); + } + flan_die_hook = unlink_bound_sock; +} + /* Every way out of the break loop that is not a resume. [_exit] and not * [exit], because this runs on the game thread while the listener thread may * be inside [dlopen] holding the loader lock — and [exit] runs the atexit @@ -2786,6 +2813,7 @@ static int32_t start_on(const char *path) { /* After the bind, because a program that is going to fail to listen should fail on its own terms rather than arrange its death first. */ watch_the_daemon(); + unlink_on_fatal_signals(); /* From here an unhandled error stops rather than dying. Installed with the * socket and not before it: without a listener there is nobody to ask what * to do, and stopping forever is worse than the abort it replaces. */ @@ -2864,14 +2892,25 @@ int32_t flan_agent_start(const uint8_t *path, int64_t len) { * silently reuses a file it may not own. stderr rather than stdout, so a * program whose output is data stays data. */ int32_t flan_agent_start_auto(void) { - char path[sizeof(((struct sockaddr_un *)0)->sun_path)]; + /* Room for a TMPDIR too deep for sun_path; [start_on] binds such a path + * through its directory. */ + char path[4096]; struct timespec ts; int32_t r; const char *env = daemon_socket(); + const char *dir = getenv("TMPDIR"); + size_t dlen; + int n; if (env != NULL) return start_on(env) < 0 ? -1 : 0; + /* TMPDIR, as everything else Flan makes on the fly: a test run's own + * directory, or a user's, is removed with it. /tmp when unset. */ + if (dir == NULL || dir[0] != '/') dir = "/tmp"; + dlen = strlen(dir); + while (dlen > 1 && dir[dlen - 1] == '/') dlen--; if (clock_gettime(CLOCK_REALTIME, &ts) != 0) ts.tv_nsec = 0; - snprintf(path, sizeof path, "/tmp/flan-agent-%ld-%08lx.sock", - (long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL)); + n = snprintf(path, sizeof path, "%.*s/flan-agent-%ld-%08lx.sock", (int)dlen, + dir, (long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL)); + if (n < 0 || (size_t)n >= sizeof path) return -1; r = start_on(path); /* Only when this call is the one that bound: a second [(agent/start)] would * otherwise print a path it did not bind and nothing is listening on. */