Merge master

This commit is contained in:
Joseph Ferano 2026-09-26 09:29:40 +07:00
commit 697c016231
39 changed files with 2437 additions and 494 deletions

View File

@ -590,10 +590,11 @@ method to a running program is an ordinary redefinition.
** CANCELLED Class features deferred, each with its reason ** CANCELLED Class features deferred, each with its reason
CLOSED: [2026-09-20] CLOSED: [2026-09-20]
Inheritance, multi-argument dispatch, =:before=/=:after=/=:around= and Inheritance, multi-argument dispatch, =:before=/=:after=/=:around= and
=call-next-method=, named-slot construction, unknown-slot checking, computed =call-next-method=, named-slot construction, compile-time unknown-slot checking,
dispatch values. With single dispatch on literal values there is no specificity computed dispatch values. With single dispatch on literal values there is no
question, and inheritance or multiple dispatch would create one. Unknown-slot specificity question, and inheritance or multiple dispatch would create one.
checking needs class-typed tracking the dyn side deliberately does not have. Compile-time unknown-slot checking needs class-typed tracking the dyn side
deliberately does not have; the runtime refuses an unknown slot instead.
** DONE update-instance-for-redefined-class, the user hook ** DONE update-instance-for-redefined-class, the user hook
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
@ -646,50 +647,34 @@ awaiting confirmation, and the build order. Rules out Parinfer, wisp and
sweet-expressions, and a simplified in-paren syntax — all thin the parens sweet-expressions, and a simplified in-paren syntax — all thin the parens
without removing them. without removing them.
** NEXT Lambdas are written with => ** DONE Lambdas are written with =>
Decided 2026-09-26: a lambda's body follows ~=>~, and ~=>~ is its only spelling CLOSED: [2026-09-26]
(~fn(a) = x~ is refused for a lambda; named functions keep ~=~). A header ending in ~=>~ A block lambda inside brackets is the last thing in them, its block ending where they close: a comma
takes an indented block even inside brackets, closing where the brackets close: after it (so a second block lambda, or one not last) is refused, and the fix names it with ~let~.
~sort-by(xs, fn(a, b) =>~ plus a block.
** NEXT A condition struct with a parent has no sugar ** NEXT Indices separate like vector elements
On the author's decision. =defstruct(DiskFull, :parent, IoError, [free i64])= is the fallback, with a Decided 2026-09-26: ~grid[r c]~ and ~grid[(r + 1) (c - 1)]~ read like a vector's
paren field vector. Proposal: =struct DiskFull :parent IoError= plus field lines. space-separated single values; commas always work; an index with a bare operator
needs them, ~grid[r + 1, c]~.
** NEXT A type alias is written type Row = Vec(i32) ** WAIT Calls without parentheses
Decided 2026-09-26: .fln reads ~type Name = T~ as ~(defalias Name T)~, and the printer Held 2026-09-26 by the author: F#-style ~f x y~ or Nim-style one-argument calls
writes it back. without parentheses. Collides with space-separated vector and index elements.
** TODO flan check prints every definition of a file that checks ** TODO RET inside an open call puts the closer at the statement's column
A clean =flan check= lists the whole prelude (about 170 lines). Clean should print In a .fln buffer, ~if and(state.paused|)~ then RET leaves ~)~ at the ~if~'s column, so
nothing, or only the file's own definitions behind a flag. the next argument cannot be typed where it belongs. A line inside open brackets,
closer-led or not, goes to the continuation column (aligned after the opening bracket).
** NEXT Classes and methods have .fln syntax ** NEXT not is a prefix word
Decided 2026-09-26: ~class Lambda(param, body, env)~, ~generic describe(v) -> dyn~, Decided 2026-09-26: .fln writes ~not x~ (binding like F#'s ~not~, tighter than
~method describe(f: Lambda)~ plus a block (the class as the parameter's type), ~and~/~or~, looser than comparisons); ~not(x)~ keeps working as a call.
~multi kind(v) -> dyn = type-of(v)~, ~method kind(v) when :int~ plus a block.
** NEXT A top-level let is a global
Decided 2026-09-26: in .fln ~let x = v~ at column 0 reads ~(def x v)~ and replaces
~def~, which is refused with that fix; ~once~ and ~const~ stay.
** NEXT A let takes several bindings on indented lines ** NEXT A let takes several bindings on indented lines
Decided 2026-09-26: lines indented under a ~let~ that are ~name = v~ or ~name: T = v~ are Decided 2026-09-26: lines indented under a ~let~ that are ~name = v~ or ~name: T = v~ are
more bindings of the same let; anything else there stays refused. flan convert writes more bindings of the same let; anything else there stays refused. flan convert writes
consecutive lets this way. consecutive lets this way.
** NEXT A struct fits on one line
Decided 2026-09-26: ~struct Pt(x: i32, y: i32)~ beside the block form, like a data
case; union and a struct with a parent too.
** NEXT defmacro has no sugar
On the author's decision. =defmacro(repeat, [i n & body]):= with a space-separated parameter vector.
Proposal: =macro repeat(i, n, & body)= plus a block.
** NEXT loop/recur has no sugar
On the author's decision. =loop([x a y b]):=. Proposal: =loop x = a, y = b= plus a block; =recur(...)=
stays a call.
** TODO Hard-coded code in messages is still paren syntax in a .fln file ** TODO Hard-coded code in messages is still paren syntax in a .fln file
Types follow the code's syntax now (=Types.spell=). Hints written into a message's Types follow the code's syntax now (=Types.spell=). Hints written into a message's
text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the
@ -733,10 +718,10 @@ of !=.
* Checker * Checker
** NEXT A dyn value takes .field and [:key] ** DONE A dyn value takes .field and [:key]
Decided 2026-09-26: on a dyn value, ~x.name~ / ~(.name x)~ reads ~(get x :name)~ and CLOSED: [2026-09-26]
assigning it is ~(put x :name v)~ — a class slot or a map key; ~m[:k]~ indexes a dyn Assigning ~x.name~ or ~m[:k]~ is ~put~: a plain map gains the key, and a class
map as ~(get m :k)~, and assigning it puts. instance refuses one its class does not declare, on read too, as ~get~ and ~put~ now do.
** DONE A slice from a C pointer, and a pointer cast ** DONE A slice from a C pointer, and a pointer cast
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
@ -1405,9 +1390,8 @@ CLOSED: [2026-09-20]
CLHS 4.3.6. Nothing is enumerated and no heap is walked — the CLHS 4.3.6. Nothing is enumerated and no heap is walked — the
redefinition is constant time and each instance pays once, at its next touch. redefinition is constant time and each instance pays once, at its next touch.
Neither printer migrates, so a stale instance shows its old slots to the editor Neither printer migrates, so a stale instance shows its old slots to the editor
until something touches it. The registry is advisory: a key the class never until something touches it. An instance holds only declared slots — get, put and
declared is dropped by the next migration, which is data loss with no enforcement set refuse any other key — so the migration's drop loses nothing a program wrote.
behind it.
** WAIT A class registry keeps one slot list per class, not one per layout version ** WAIT A class registry keeps one slot list per class, not one per layout version
Decided 2026-09-25: waits for a case name-matching migration to the current list gets wrong. Decided 2026-09-25: waits for a case name-matching migration to the current list gets wrong.

View File

@ -226,9 +226,14 @@ let no_gc_flag = "--no-gc"
downstream that it ran. *) downstream that it ran. *)
let warn_memory_flag = "--warn-memory" let warn_memory_flag = "--warn-memory"
(* [flan check --defs]: every definition the checked program holds, prelude
included. Off by default, so a file that checks prints nothing. *)
let defs_flag = "--defs"
let flags = let flags =
[ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag; [ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag;
x86_flag; llvm_flag; no_annotate_flag; no_gc_flag; warn_memory_flag ] x86_flag; llvm_flag; no_annotate_flag; no_gc_flag; warn_memory_flag;
defs_flag ]
(* The warnings, where errors go. Printed one to a location in the repo's (* The warnings, where errors go. Printed one to a location in the repo's
standard [file:line:col:] shape, with the squiggle [Loc.entry] draws, so standard [file:line:col:] shape, with the squiggle [Loc.entry] draws, so
@ -355,6 +360,7 @@ let () =
files files
| _ :: "check" :: args when List.exists (fun a -> not (is_flag a)) args -> | _ :: "check" :: args when List.exists (fun a -> not (is_flag a)) args ->
let warn_memory = List.mem warn_memory_flag args in let warn_memory = List.mem warn_memory_flag args in
let defs = List.mem defs_flag args in
let files = List.filter (fun a -> not (is_flag a)) args in let files = List.filter (fun a -> not (is_flag a)) args in
List.iter List.iter
(fun path -> (fun path ->
@ -366,6 +372,7 @@ let () =
program that checked, which is what leaves the exit status program that checked, which is what leaves the exit status
alone. *) alone. *)
if warn_memory then print_memory_warnings ~file:path p; if warn_memory then print_memory_warnings ~file:path p;
if defs then begin
List.iter List.iter
(fun (g : Flan.Tast.global) -> (fun (g : Flan.Tast.global) ->
Printf.printf "%s %s %s\n" Printf.printf "%s %s %s\n"
@ -385,7 +392,8 @@ let () =
(String.concat " " (String.concat " "
(List.map Flan.Types.to_string f.params)) (List.map Flan.Types.to_string f.params))
(Flan.Types.to_string f.ret) (Array.length f.slots)) (Flan.Types.to_string f.ret) (Array.length f.slots))
p.fns)) p.fns
end))
files files
(* The generated C, for looking at. A wrong FFI binding is wrong in the (* The generated C, for looking at. A wrong FFI binding is wrong in the
wrapper, and the wrapper is not on disk anywhere — [Build] hands the text wrapper, and the wrapper is not on disk anywhere — [Build] hands the text
@ -982,7 +990,7 @@ let () =
| None -> code)) | None -> code))
| _ -> | _ ->
prerr_endline prerr_endline
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan check <file.flan>... [--warn-memory]\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\ "usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan check <file.flan>... [--warn-memory] [--defs]\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\
\ flan import-c <header.h> [package.flan...] [clang flags...]\n\ \ flan import-c <header.h> [package.flan...] [clang flags...]\n\
\ flan generate-c <package-dir>\n\ \ flan generate-c <package-dir>\n\
\ flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \ \ flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \

View File

@ -326,10 +326,9 @@ The CLOS answer would need, concretely:
Flan spelling of that hook is a generic function, e.g. Flan spelling of that hook is a generic function, e.g.
`(defmethod update-for-redefined point [p added discarded] ...)`, which fits `(defmethod update-for-redefined point [p added discarded] ...)`, which fits
the dispatch mechanism that already exists. the dispatch mechanism that already exists.
- A decision on whether `put` of an unknown slot stays legal. Today it is — a - A decision on whether `put` of an unknown slot stays legal. Decided
class instance is an open map, and TODO.org, "Class features deferred, each with 2026-09-26: it does not; `get`, `put` and `set` refuse an unknown slot on an
its reason", already defers refusing an unknown slot at `(get p :z)`. If unknown slots stay legal, the registry's slot list is instance at run time, so the registry's slot list is enforced.
advisory and the whole update protocol is advisory with it.
This is a real, SBCL/CLOS-precedented design that Flan's runtime can actually This is a real, SBCL/CLOS-precedented design that Flan's runtime can actually
support. It is also a feature with no user yet, since redefinition on the dyn support. It is also a feature with no user yet, since redefinition on the dyn

View File

@ -1205,7 +1205,7 @@ Use `C-c C-g` if you need frames.
| `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) | | `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) |
| `C-M-u` | same | up to the enclosing bracket, or the line that owns the block | | `C-M-u` | same | up to the enclosing bracket, or the line that owns the block |
| `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere | | `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere |
| `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, a lambda header) | | `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, `= loop i = 0`, a lambda header). After a line ending in `=>`, one level in from that line, inside brackets too; a line of that block keeps to the block's columns |
| `DEL` in indentation | same | drop one level | | `DEL` in indentation | same | drop one level |
| `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level | | `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level |
| `M-<up>` / `M-<down>` | same | move the statement past its neighbour | | `M-<up>` / `M-<down>` | same | move the statement past its neighbour |
@ -1225,7 +1225,7 @@ enclosing statement, top-level form.
- **term**: a run with no space outside brackets — `f(a, b)`, `grid[r, c]`, `p.x`. - **term**: a run with no space outside brackets — `f(a, b)`, `grid[r, c]`, `p.x`.
- **group**: a bracket pair and what is inside it. - **group**: a bracket pair and what is inside it.
- **statement**: a line, the deeper lines under it, lines inside brackets it leaves open, lines an operator continues, and `else`/`elif`/`on`/`restart` at its column. Blank and comment lines inside never end it. - **statement**: a line, the deeper lines under it, lines inside brackets it leaves open, lines an operator continues, and `else`/`elif`/`on`/`restart` at its column. Blank and comment lines inside never end it. A lambda's block inside brackets, `sort-by(xs, fn(a, b) =>` and the lines under it, is part of the call's statement, and each of its lines is a statement too: `C-c C-e` or `C-u C-c C-c` there takes that line, not the call, and never the call's closing `)` at the end of it.
- **body**: a statement's own block, up to its first clause. - **body**: a statement's own block, up to its first clause.
- **clause**: one `else`/`elif`/`on`/`restart` line and its block, or the value on its line (`else x`). - **clause**: one `else`/`elif`/`on`/`restart` line and its block, or the value on its line (`else x`).
- **top-level form**: a column-0 line that is code, not a clause and not a continuation, through the last code line before the next one. - **top-level form**: a column-0 line that is code, not a clause and not a continuation, through the last code line before the next one.

View File

@ -25,7 +25,8 @@
;; leaves open, the lines an operator continues, and the ;; leaves open, the lines an operator continues, and the
;; `else'/`elif'/`on'/`restart' clauses at its own column. Blank ;; `else'/`elif'/`on'/`restart' clauses at its own column. Blank
;; and comment lines inside never end it; trailing ones are not ;; and comment lines inside never end it; trailing ones are not
;; part of it. ;; part of it. A `=>' ending a line inside brackets opens a
;; lambda's block there, whose lines are statements again.
;; body a statement's own block: the deeper lines under its first line, ;; body a statement's own block: the deeper lines under its first line,
;; up to its first clause. ;; up to its first clause.
;; clause one `else'/`elif'/`on'/`restart' line and its block. ;; clause one `else'/`elif'/`on'/`restart' line and its block.
@ -83,8 +84,14 @@ fine here. Brackets and strings are still paired."
(defconst flan-fln--clause-words '("else" "elif" "on" "restart") (defconst flan-fln--clause-words '("else" "elif" "on" "restart")
"Words that start a clause of the statement above, at its column.") "Words that start a clause of the statement above, at its column.")
;; What follows a word that starts a clause or a header: a space and not an
;; assignment, or the end of the line. `on = 2' assigns a variable named on,
;; as `assigns' in lib/indent_reader.ml reads it.
(defconst flan-fln--word-end-re
"\\(?:[ \t]+\\(?:[^-+*/= \t\n]\\|[-+*/]\\(?:[^=]\\|$\\)\\)\\|[ \t]*$\\)")
(defconst flan-fln--clause-re (defconst flan-fln--clause-re
"\\(else\\|elif\\|on\\|restart\\)\\(?:[ \t]\\|$\\)") (concat "\\(else\\|elif\\|on\\|restart\\)" flan-fln--word-end-re))
(defconst flan-fln--clause-headers (defconst flan-fln--clause-headers
'(("else" "if" "elif") ("elif" "if" "elif") '(("else" "if" "elif") ("elif" "if" "elif")
@ -97,7 +104,8 @@ fine here. Brackets and strings are still paired."
'("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import" '("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import"
"if" "elif" "else" "while" "until" "for" "match" "let" "return" "break" "if" "elif" "else" "while" "until" "for" "match" "let" "return" "break"
"continue" "defer" "handler-case" "handler-bind" "restart-case" "on" "continue" "defer" "handler-case" "handler-bind" "restart-case" "on"
"restart" "quote")) "restart" "quote" "macro" "loop" "type" "class" "generic" "multi"
"method"))
;; The headers whose block follows on the lines under them. `defer' and ;; The headers whose block follows on the lines under them. `defer' and
;; `quote' open one only when nothing follows them on the line; `fn' does not ;; `quote' open one only when nothing follows them on the line; `fn' does not
@ -106,12 +114,15 @@ fine here. Brackets and strings are still paired."
(defconst flan-fln--opener-words (defconst flan-fln--opener-words
'("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while" '("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while"
"until" "for" "match" "defer" "handler-case" "handler-bind" "until" "for" "match" "defer" "handler-case" "handler-bind"
"restart-case" "on" "restart" "quote")) "restart-case" "on" "restart" "quote" "macro" "loop" "class" "multi"
"method"))
(defconst flan-fln--declaration-words (defconst flan-fln--declaration-words
'(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce") '(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce")
("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata") ("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata")
("enum" . "defenum") ("union" . "defunion") ("import" . "import")) ("enum" . "defenum") ("union" . "defunion") ("import" . "import")
("let" . "def") ("macro" . "defmacro") ("type" . "defalias") ("class" . "defclass")
("generic" . "defgeneric") ("multi" . "defmulti") ("method" . "defmethod"))
"Each declaration header word, and the paren head it reads as.") "Each declaration header word, and the paren head it reads as.")
;;; Syntax ;;; Syntax
@ -224,15 +235,63 @@ fine here. Brackets and strings are still paired."
(setq hit (line-beginning-position))) (setq hit (line-beginning-position)))
hit))) hit)))
(defun flan-fln--closer-line-p (pos)
"Non-nil if POS's line starts inside a bracket with the bracket's closer."
(save-excursion
(let ((s (syntax-ppss (flan-fln--bol pos))))
(and (nth 1 s) (not (nth 3 s))
(progn (goto-char (flan-fln--bol pos))
(skip-chars-forward " \t")
(looking-at "\\s)"))))))
(defun flan-fln--lambda-arrow (pos)
"The `=>' whose block POS's line is in, when that block is inside brackets.
A `=>' ending a line inside a bracket opens a block there, which lasts until
the bracket closes (lib/indent_reader.ml's `layout'): a line inside the same
bracket after it is a statement of that block, not a continuation. A line
that starts with the bracket's closer is not in the block.
Each call scans the lines from the open bracket to POS, so walking a long
bracketed literal line by line costs the square of its length."
(save-excursion
(let* ((bol (flan-fln--bol pos))
(s (syntax-ppss bol))
(open (nth 1 s)))
(when (and open (not (nth 3 s)) (not (flan-fln--closer-line-p bol)))
(goto-char open)
(let (hit)
(while (and (not hit) (< (line-end-position) bol))
(let ((end (flan-fln--code-end (point))))
(goto-char end)
(when (and (looking-back "[ \t]=>" (line-beginning-position))
(= (nth 1 (save-excursion (syntax-ppss (- end 2)))) open))
(setq hit (- end 2))))
(forward-line 1))
hit)))))
(defun flan-fln--bracketed-p (pos)
"Non-nil if POS's line is inside a bracket or a string, where a line break
is only a space: not in a lambda's block."
(and (flan-fln--in-open-p pos) (not (flan-fln--lambda-arrow pos))))
(defun flan-fln--continuation-p (pos) (defun flan-fln--continuation-p (pos)
"Non-nil if POS's line continues the line above it. "Non-nil if POS's line continues the line above it.
Inside a bracket or a string, after a line that ends in a spaced operator, or Inside a bracket or a string, after a line that ends in a spaced operator, or
starting with one: the reader's three ways a line break is not a new line." starting with one: the reader's three ways a line break is not a new line.
(or (flan-fln--in-open-p pos) Not a line of a lambda's block inside brackets, which is a statement."
(or (flan-fln--bracketed-p pos)
(flan-fln--starts-with-op-p pos) (flan-fln--starts-with-op-p pos)
(let ((p (flan-fln--prev-code pos))) (let ((p (flan-fln--prev-code pos)))
(and p (flan-fln--ends-in-op-p p))))) (and p (flan-fln--ends-in-op-p p)))))
(defun flan-fln--continues-p (pos start)
"Non-nil if POS's line continues the statement that starts at START.
A line that starts with the closer of a bracket opened before START closes
something START is inside, a lambda's block's call, and is not START's."
(and (flan-fln--continuation-p pos)
(not (and (flan-fln--closer-line-p pos)
(< (nth 1 (save-excursion (syntax-ppss (flan-fln--bol pos))))
(flan-fln--bol start))))))
(defun flan-fln--clause-line-p (pos) (defun flan-fln--clause-line-p (pos)
"Non-nil if POS's line starts a clause: else, elif, on or restart. "Non-nil if POS's line starts a clause: else, elif, on or restart.
A word, and only when a space or the end of the line follows it." A word, and only when a space or the end of the line follows it."
@ -245,16 +304,21 @@ A word, and only when a space or the end of the line follows it."
(defun flan-fln--logical-start (pos) (defun flan-fln--logical-start (pos)
"The first line of the line POS is on, after continuation lines are joined." "The first line of the line POS is on, after continuation lines are joined."
(let ((bol (flan-fln--bol pos)) p) (let ((bol (flan-fln--bol pos)) p)
(while (and (flan-fln--continuation-p bol) (while (cond
;; A closer's line belongs with the line its bracket opens on,
;; not with a lambda's block just above it.
((flan-fln--closer-line-p bol)
(setq bol (flan-fln--bol (nth 1 (save-excursion (syntax-ppss bol))))))
((and (flan-fln--continuation-p bol)
(setq p (flan-fln--prev-code bol))) (setq p (flan-fln--prev-code bol)))
(setq bol p)) (setq bol p))))
bol)) bol))
(defun flan-fln--logical-end (pos) (defun flan-fln--logical-end (pos)
"The last line of the joined line whose first line is POS's." "The last line of the joined line whose first line is POS's."
(let ((bol (flan-fln--bol pos)) n) (let* ((bol (flan-fln--bol pos)) (start bol) n)
(while (and (setq n (flan-fln--next-code bol)) (while (and (setq n (flan-fln--next-code bol))
(flan-fln--continuation-p n)) (flan-fln--continues-p n start))
(setq bol n)) (setq bol n))
bol)) bol))
@ -285,10 +349,18 @@ depth, outside strings and comments, or nil."
(flan-fln--joined-end l)))) (flan-fln--joined-end l))))
(and m (car m)))) (and m (car m))))
(defun flan-fln--value-end (l)
"Where a value written on the joined line L ends: at the line's code end,
or, when the line ends in `=>', at the end of the lambda's block under it."
(let ((last (flan-fln--logical-end l)))
(if (flan-fln--ends-in-arrow-p last)
(cdr (flan-fln--span l (flan-fln--statement-last l t)))
(flan-fln--code-end last))))
(defun flan-fln--clause-value (l) (defun flan-fln--clause-value (l)
"Bounds of the value on the clause line L itself: `x' of `else x' or of "Bounds of the value on the clause line L itself: `x' of `else x' or of
`elif c then x'; nil when the clause's value is its block." `elif c then x'; nil when the clause's value is its block."
(let ((end (flan-fln--joined-end l)) (let ((end (flan-fln--value-end l))
(then (flan-fln--then l))) (then (flan-fln--then l)))
(save-excursion (save-excursion
(goto-char (flan-fln--first-char l)) (goto-char (flan-fln--first-char l))
@ -309,30 +381,36 @@ depth, outside strings and comments, or nil."
(flan-fln--joined-end l)))) (flan-fln--joined-end l))))
(and m (cdr m)))) (and m (cdr m))))
(defun flan-fln--ends-in-arrow-p (pos)
"Non-nil if POS's line ends in `=>': a lambda's header, its block under it."
(save-excursion
(let ((end (flan-fln--code-end pos)))
(goto-char end)
(and (not (nth 8 (syntax-ppss end)))
(looking-back "[ \t]=>" (line-beginning-position))))))
(defun flan-fln--lambda-header-p (pos end) (defun flan-fln--lambda-header-p (pos end)
"Non-nil if a lambda with its body under it starts at POS and runs to END: "Non-nil if a lambda with its body under it starts at POS and runs to END:
`fn(a, b)', or `fn(a: C, b) -> R', with no `= body' after it." `fn(a, b) =>', or `fn(a: C, b) -> R =>', with nothing after the `=>'."
(save-excursion (save-excursion
(goto-char pos) (goto-char pos)
(and (looking-at "fn(") (and (looking-at "fn(")
(let ((close (ignore-errors (scan-lists (+ pos 2) 1 0)))) (let ((close (ignore-errors (scan-lists (+ pos 2) 1 0))))
(and close (<= close end) (and close (<= close end)
(progn (goto-char close) (skip-chars-forward " \t") (progn (goto-char end) (looking-back "[ \t]=>" close)))))))
(or (>= (point) end)
(and (looking-at "->[ \t]")
(not (flan-fln--find-top "[ \t]=[ \t]" (point) end))))))))))
(defun flan-fln--value-opens-p (l) (defun flan-fln--value-opens-p (l)
"Non-nil if the value the joined line L binds or assigns goes on under it: "Non-nil if the value the joined line L binds or assigns goes on under it:
`= match x', `= if c' with no `then', `= handler-case', `= restart-case', or `= match x', `= if c' with no `then', `= handler-case', `= restart-case',
a lambda header. These are the values lib/indent_reader.ml's `value_line' `= loop i = 0', or a lambda header. These are the values
reads a block for, besides a bare `=' and a call ending in `:'." lib/indent_reader.ml's `value_line' reads a block for, besides a bare `='
and a call ending in `:'."
(let ((v (flan-fln--value-start l)) (let ((v (flan-fln--value-start l))
(end (flan-fln--joined-end l))) (end (flan-fln--joined-end l)))
(and v (< v end) (and v (< v end)
(save-excursion (save-excursion
(goto-char v) (goto-char v)
(or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\)\\(?:[ \t]\\|$\\)") (or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\|loop\\)\\(?:[ \t]\\|$\\)")
(and (looking-at "if[ \t]") (not (flan-fln--then l))) (and (looking-at "if[ \t]") (not (flan-fln--then l)))
(flan-fln--lambda-header-p v end)))))) (flan-fln--lambda-header-p v end))))))
@ -346,6 +424,8 @@ line's own block only."
(last (flan-fln--logical-end start)) (last (flan-fln--logical-end start))
(next (flan-fln--next-code last))) (next (flan-fln--next-code last)))
(while (and next (while (and next
(not (and (flan-fln--closer-line-p next)
(not (flan-fln--continues-p next start))))
(or (> (flan-fln--indent-at next) indent) (or (> (flan-fln--indent-at next) indent)
(flan-fln--continuation-p next) (flan-fln--continuation-p next)
(and (not no-clauses) (and (not no-clauses)
@ -355,9 +435,26 @@ line's own block only."
next (flan-fln--next-code last))) next (flan-fln--next-code last)))
last)) last))
(defun flan-fln--trim-closers (beg end)
"END, less the closers before it whose brackets open before BEG.
The last statement of a lambda's block inside a call ends with the call's `)'
on its line, which is not the statement's."
(save-excursion
(goto-char end)
(let (done)
(while (not done)
(skip-chars-backward " \t" beg)
(let ((open (and (> (point) beg) (memq (char-before) '(?\) ?\] ?\}))
(nth 1 (save-excursion (syntax-ppss (1- (point))))))))
(if (and open (< open beg))
(backward-char 1)
(setq done t))))
(point))))
(defun flan-fln--span (start last) (defun flan-fln--span (start last)
"(BEG . END) from the text of START's line to the code end of LAST's." "(BEG . END) from the text of START's line to the code end of LAST's."
(cons (flan-fln--first-char start) (flan-fln--code-end last))) (let ((beg (flan-fln--first-char start)))
(cons beg (flan-fln--trim-closers beg (flan-fln--code-end last)))))
(defun flan-fln--statement-bounds (start) (defun flan-fln--statement-bounds (start)
"Bounds of the statement whose first line is START." "Bounds of the statement whose first line is START."
@ -602,7 +699,7 @@ the form."
(defun flan-fln--declaration-head-at (pos &optional heads) (defun flan-fln--declaration-head-at (pos &optional heads)
"The paren head of the declaration written at POS, or nil. "The paren head of the declaration written at POS, or nil.
The .fln twin of `flan--declaration-head-at': POS must be at column 0 and not The .fln twin of `flan--declaration-head-at': POS must be at column 0 and not
in a string or comment, and the header word -- `fn', `def', `struct', ... -- in a string or comment, and the header word -- `fn', `let', `struct', ... --
or the fallback call's name, `defmethod(', must read as one of HEADS, or the fallback call's name, `defmethod(', must read as one of HEADS,
`flan--declaration-heads' by default." `flan--declaration-heads' by default."
(save-excursion (save-excursion
@ -687,7 +784,11 @@ forms, where the clause line itself is not."
(g (flan-fln--group-bounds pos))) (g (flan-fln--group-bounds pos)))
(cond (cond
((and arm (< pos (plist-get arm :arrow))) (plist-get arm :value)) ((and arm (< pos (plist-get arm :arrow))) (plist-get arm :value))
((and g (cdr g) (> (car g) (car b))) ;; Not the brackets a lambda's block is in: a line of the block is a
;; statement of its own.
((and g (cdr g) (> (car g) (car b))
(not (let ((a (flan-fln--lambda-arrow pos)))
(and a (< (car g) a) (< a pos)))))
(cons (flan-fln--group-form-start (car g)) (cdr g))) (cons (flan-fln--group-form-start (car g)) (cdr g)))
(arm (plist-get arm :value)) (arm (plist-get arm :value))
((and l (flan-fln--clause-line-p l)) (flan-fln--clause-target l)) ((and l (flan-fln--clause-line-p l)) (flan-fln--clause-target l))
@ -759,7 +860,7 @@ pattern names something, so the value cannot be evaluated alone."
(let* ((pat (string-trim (buffer-substring-no-properties start arrow))) (let* ((pat (string-trim (buffer-substring-no-properties start arrow)))
(vbeg (save-excursion (goto-char (+ arrow 2)) (vbeg (save-excursion (goto-char (+ arrow 2))
(skip-chars-forward " \t") (point))) (skip-chars-forward " \t") (point)))
(value (if (< vbeg last) (cons vbeg last) (value (if (< vbeg last) (cons vbeg (flan-fln--value-end l))
(flan-fln--body-bounds l)))) (flan-fln--body-bounds l))))
(and value (and value
(list :arrow arrow :value value (list :arrow arrow :value value
@ -924,8 +1025,9 @@ before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does."
"Non-nil if START's statement is a `let'. "Non-nil if START's statement is a `let'.
A let takes no block: lines under it are its value's (`= match x', a lambda A let takes no block: lines under it are its value's (`= match x', a lambda
header), and its name lasts to the end of the block it is in." header), and its name lasts to the end of the block it is in."
(and (> (flan-fln--indent-at start) 0)
(save-excursion (goto-char (flan-fln--first-char start)) (save-excursion (goto-char (flan-fln--first-char start))
(looking-at "let[ \t]"))) (looking-at "let[ \t]"))))
(defun flan-fln--block-rest (start) (defun flan-fln--block-rest (start)
"START's statement and every statement after it in the same block." "START's statement and every statement after it in the same block."
@ -1135,7 +1237,7 @@ Before it at the same level, else out to the line that owns this block."
(goto-char start) (goto-char start)
(back-to-indentation) (back-to-indentation)
(and (looking-at (concat (regexp-opt flan-fln--opener-words t) (and (looking-at (concat (regexp-opt flan-fln--opener-words t)
"\\(?:[ \t]\\|$\\)")) flan-fln--word-end-re))
(let* ((w (match-string-no-properties 1)) (let* ((w (match-string-no-properties 1))
(w-end (match-end 1)) (w-end (match-end 1))
(end (flan-fln--code-end last)) (end (flan-fln--code-end last))
@ -1143,8 +1245,13 @@ Before it at the same level, else out to the line that owns this block."
(cond (cond
;; `else x' after an if's block is the whole else. ;; `else x' after an if's block is the whole else.
((member w '("defer" "quote" "else")) alone) ((member w '("defer" "quote" "else")) alone)
((member w '("fn" "fn-")) ((member w '("fn" "fn-" "multi" "method"))
(not (re-search-forward "[ \t]=[ \t]" end t))) (not (re-search-forward "[ \t]=[ \t]" end t)))
;; `struct Pt(x: i32)' has its fields on the line.
((member w '("struct" "union" "class"))
(not (save-excursion
(goto-char w-end)
(looking-at "[ \t]+[^][ \t\n(){},;\":]+("))))
((member w '("if" "elif")) (not (flan-fln--then start))) ((member w '("if" "elif")) (not (flan-fln--then start)))
(t t))))) (t t)))))
;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda ;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda
@ -1158,15 +1265,27 @@ Before it at the same level, else out to the line that owns this block."
(let ((bol (line-beginning-position))) (let ((bol (line-beginning-position)))
(or (looking-back ":" bol) (or (looking-back ":" bol)
(looking-back "[ \t]->" bol) (looking-back "[ \t]->" bol)
;; `let x =' and `def colors =' with the value as a block, ;; A lambda's header, at the top of a line or inside brackets.
(looking-back "[ \t]=>" bol)
;; `let x =' and `let colors =' at the top level with the value as a block,
;; which the author's list leaves out and the reader reads. ;; which the author's list leaves out and the reader reads.
(looking-back "[ \t]=" bol)))))) (looking-back "[ \t]=" bol))))))
(defun flan-fln--outside-block (p pos)
"P, or when P's line is in a lambda's block inside brackets that POS is not
inside, the first line of the statement that block's `=>' is in: a block
whose brackets have closed is no block POS can join."
(let ((a (flan-fln--lambda-arrow p)))
(if (and a (not (memq (nth 1 (save-excursion (syntax-ppss (flan-fln--bol p))))
(nth 9 (save-excursion (syntax-ppss (flan-fln--bol pos)))))))
(flan-fln--outside-block (flan-fln--logical-start a) pos)
p)))
(defun flan-fln--stack (pos) (defun flan-fln--stack (pos)
"The open block columns above POS's line, deepest first, as (COL . LINE)." "The open block columns above POS's line, deepest first, as (COL . LINE)."
(let ((p (flan-fln--prev-code pos)) out (min most-positive-fixnum)) (let ((p (flan-fln--prev-code pos)) out (min most-positive-fixnum))
(while p (while p
(setq p (flan-fln--logical-start p)) (setq p (flan-fln--outside-block (flan-fln--logical-start p) pos))
(let ((i (flan-fln--indent-at p))) (let ((i (flan-fln--indent-at p)))
(when (< i min) (push (cons i p) out) (setq min i))) (when (< i min) (push (cons i p) out) (setq min i)))
(setq p (and (> min 0) (flan-fln--prev-code p)))) (setq p (and (> min 0) (flan-fln--prev-code p))))
@ -1177,11 +1296,28 @@ Before it at the same level, else out to the line that owns this block."
"Columns TAB offers POS's line outside brackets, deepest first." "Columns TAB offers POS's line outside brackets, deepest first."
(let* ((prev (flan-fln--prev-code pos)) (let* ((prev (flan-fln--prev-code pos))
(stack (mapcar #'car (flan-fln--stack pos)))) (stack (mapcar #'car (flan-fln--stack pos))))
(if (and prev (flan-fln--opener-p (flan-fln--logical-start prev) prev)) (cond
;; A lambda's block goes under the line its `=>' ends, which may be a
;; line of a call wrapped inside its brackets.
((and prev (flan-fln--ends-in-arrow-p prev))
(cons (+ (flan-fln--indent-at prev) flan-fln-indent-offset) stack))
((and prev (flan-fln--opener-p (flan-fln--logical-start prev) prev))
(cons (+ (flan-fln--indent-at (flan-fln--logical-start prev)) (cons (+ (flan-fln--indent-at (flan-fln--logical-start prev))
flan-fln-indent-offset) flan-fln-indent-offset)
stack) stack))
stack))) (t stack))))
(defun flan-fln--block-levels (pos)
"Columns TAB offers POS's line at a block's level, deepest first.
In a lambda's block inside brackets, only those right of the line its `=>'
ends: a line at or left of it would be outside the block, still inside the
brackets, which the reader refuses."
(let ((arrow (flan-fln--lambda-arrow pos)))
(if (not arrow)
(flan-fln--levels pos)
(let ((base (flan-fln--indent-at arrow)))
(or (seq-filter (lambda (c) (> c base)) (flan-fln--levels pos))
(list (+ base flan-fln-indent-offset)))))))
(defun flan-fln--clause-columns (word pos) (defun flan-fln--clause-columns (word pos)
"Columns of the lines above POS a clause WORD may sit under, deepest first." "Columns of the lines above POS a clause WORD may sit under, deepest first."
@ -1226,19 +1362,20 @@ opening line's column."
(let ((s (syntax-ppss (point)))) (let ((s (syntax-ppss (point))))
(cond (cond
((nth 3 s) nil) ((nth 3 s) nil)
((> (car s) 0) (list (flan-fln--bracket-column (nth 1 s)))) ((and (> (car s) 0) (not (flan-fln--lambda-arrow (point))))
(list (flan-fln--bracket-column (nth 1 s))))
(t (t
(let ((prev (flan-fln--prev-code (point)))) (let ((prev (flan-fln--prev-code (point))))
(cond (cond
((null prev) (list 0)) ((null prev) (list 0))
((save-excursion (back-to-indentation) (looking-at flan-fln--clause-re)) ((save-excursion (back-to-indentation) (looking-at flan-fln--clause-re))
(or (flan-fln--clause-columns (match-string-no-properties 1) (point)) (or (flan-fln--clause-columns (match-string-no-properties 1) (point))
(flan-fln--levels (point)))) (flan-fln--block-levels (point))))
((or (flan-fln--starts-with-op-p (point)) ((or (flan-fln--starts-with-op-p (point))
(flan-fln--ends-in-op-p prev)) (flan-fln--ends-in-op-p prev))
(list (+ (flan-fln--indent-at (flan-fln--logical-start prev)) (list (+ (flan-fln--indent-at (flan-fln--logical-start prev))
flan-fln-indent-offset))) flan-fln-indent-offset)))
(t (flan-fln--levels (point)))))))))) (t (flan-fln--block-levels (point))))))))))
(defun flan-fln-indent-line () (defun flan-fln-indent-line ()
"Indent the line to a block column. "Indent the line to a block column.
@ -1284,11 +1421,13 @@ Never re-indents a line against the others: the columns are the program."
(if (and (= arg 1) (not (use-region-p)) (if (and (= arg 1) (not (use-region-p))
(> (current-column) 0) (> (current-column) 0)
(= (current-column) (current-indentation)) (= (current-column) (current-indentation))
(not (flan-fln--in-open-p (point)))) (not (flan-fln--bracketed-p (point))))
(let ((cur (current-indentation))) (let ((cur (current-indentation)))
(indent-line-to (or (seq-find (lambda (c) (< c cur)) (indent-line-to (or (seq-find (lambda (c) (< c cur))
(flan-fln--levels (point))) (flan-fln--block-levels (point)))
0))) ;; A lambda's block inside brackets has no
;; level left of its own.
(if (flan-fln--lambda-arrow (point)) cur 0))))
(let ((cmd (or (command-remapping 'delete-backward-char) (let ((cmd (or (command-remapping 'delete-backward-char)
#'delete-backward-char))) #'delete-backward-char)))
(setq this-command cmd) (setq this-command cmd)
@ -1306,7 +1445,7 @@ Run when the word is finished by a space or a newline."
(if nl (line-end-position) (point))))) (if nl (line-end-position) (point)))))
(when (and (string-match "\\`[ \t]*\\(else\\|elif\\|on\\|restart\\)[ \t]*\\'" (when (and (string-match "\\`[ \t]*\\(else\\|elif\\|on\\|restart\\)[ \t]*\\'"
text) text)
(not (flan-fln--in-open-p (point)))) (not (flan-fln--bracketed-p (point))))
(let ((cols (flan-fln--clause-columns (match-string 1 text) (point)))) (let ((cols (flan-fln--clause-columns (match-string 1 text) (point))))
(when (and cols (not (memq (current-indentation) cols))) (when (and cols (not (memq (current-indentation) cols)))
(indent-line-to (car cols)))))))) (indent-line-to (car cols))))))))
@ -1524,6 +1663,29 @@ it, so a block pasted at another depth stays one block."
(defconst flan-fln--name-re "\\([^][ \t\n(){},;\":]+\\)" (defconst flan-fln--name-re "\\([^][ \t\n(){},;\":]+\\)"
"A declared name: a run up to a bracket, a space, or the colon of `x: T'.") "A declared name: a run up to a bracket, a space, or the colon of `x: T'.")
;; A defining form written as the fallback call, `defmacro(m, [x]):' or
;; `defmethod(area, point, [p]):'. The heads are `flan-mode''s own, so a
;; head it learns is drawn here too; its name is drawn as the sugar draws the
;; same kind of name.
(defconst flan-fln--fallback-type-heads
(seq-filter (lambda (h) (member h '("defstruct" "defdata" "defunion" "defenum"
"defalias" "defclass")))
flan--definers))
(defconst flan-fln--fallback-variable-heads
(seq-filter (lambda (h) (member h '("def" "defonce" "defconst"))) flan--definers))
(defconst flan-fln--fallback-function-heads
(seq-remove (lambda (h) (or (member h flan-fln--fallback-type-heads)
(member h flan-fln--fallback-variable-heads)
(member h '("defmacro" "import" "package"
"declare" "declare-c"))))
flan--definers)
"The fallback heads that define something called, for imenu.")
(defun flan-fln--fallback-re (heads)
(concat "^" (regexp-opt heads t) "(" flan-fln--name-re))
(defun flan-fln--return-type-matcher (limit) (defun flan-fln--return-type-matcher (limit)
"Find the next return type up to LIMIT: after the `->' of a fn header, a "Find the next return type up to LIMIT: after the `->' of a fn header, a
lambda or a `Fn(...)' type, and not after a match arm's." lambda or a `Fn(...)' type, and not after a match arm's."
@ -1554,19 +1716,44 @@ lambda or a `Fn(...)' type, and not after a match arm's."
(defvar flan-fln-font-lock-keywords (defvar flan-fln-font-lock-keywords
`(;; The header words, at the start of a line and followed by a space or the `(;; The header words, at the start of a line and followed by a space or the
;; end of it: `if(c, a)' is the fallback call and is not a header. ;; end of it: `if(c, a)' is the fallback call and is not a header.
(,(concat "^[ \t]*" (regexp-opt flan-fln--header-words t) "\\(?:[ \t]\\|$\\)") (,(concat "^[ \t]*" (regexp-opt flan-fln--header-words t) flan-fln--word-end-re)
1 font-lock-keyword-face) 1 font-lock-keyword-face)
(,(concat "^\\(fn-?\\)[ \t]+" flan-fln--name-re) (,(concat "^\\(fn-?\\|macro\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re)
2 font-lock-function-name-face) 2 font-lock-function-name-face)
(,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) (,(concat "^\\(?:struct\\|data\\|union\\|enum\\|type\\|class\\)[ \t]+" flan-fln--name-re)
1 font-lock-type-face) 1 font-lock-type-face)
(,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) ;; A method's class, `method area(p: point)', and a value after `when'.
(,(concat "^method[ \t]+[^][ \t\n(){},;\":]+([^][ \t\n(){},;\":]+:[ \t]*" flan-fln--name-re)
1 font-lock-type-face)
("^method[ \t].*)[ \t]+\\(when\\)[ \t]" 1 font-lock-keyword-face)
;; An alias's type, `type Row = Vec(i32)'.
(,(concat "^type[ \t]+[^][ \t\n(){},;\":]+[ \t]+=[ \t]+" flan-fln--name-re)
1 font-lock-type-face)
;; A defining form as the fallback call: the head a keyword, its first
;; argument the name it defines.
(,(flan-fln--fallback-re flan-fln--fallback-type-heads)
(1 font-lock-keyword-face) (2 font-lock-type-face))
(,(flan-fln--fallback-re flan-fln--fallback-variable-heads)
(1 font-lock-keyword-face) (2 font-lock-variable-name-face))
(,(flan-fln--fallback-re
(seq-remove (lambda (h) (or (member h flan-fln--fallback-type-heads)
(member h flan-fln--fallback-variable-heads)))
flan--definers))
(1 font-lock-keyword-face) (2 font-lock-function-name-face))
;; A condition's parent, `struct DiskFull :parent IoError'.
(,(concat "^struct[ \t]+[^][ \t\n(){},;\":]+\\(?:([^)\n]*)\\)?[ \t]+:parent[ \t]+"
flan-fln--name-re)
1 font-lock-type-face)
;; A global: a let at column 0 is one.
(,(concat "^\\(?:let\\|once\\|const\\)[ \t]+" flan-fln--name-re)
1 font-lock-variable-name-face) 1 font-lock-variable-name-face)
;; A restart clause's name, `restart retry() "Try again"'. ;; A restart clause's name, `restart retry() "Try again"'.
(,(concat "^[ \t]*restart[ \t]+" flan-fln--name-re) (,(concat "^[ \t]*restart[ \t]+" flan-fln--name-re)
1 font-lock-function-name-face) 1 font-lock-function-name-face)
;; A lambda's `fn', glued to its parameters. ;; A lambda's `fn', glued to its parameters.
("\\(?:^\\|[ \t=(,]\\)\\(fn\\)(" 1 font-lock-keyword-face) ("\\(?:^\\|[ \t=(,]\\)\\(fn\\)(" 1 font-lock-keyword-face)
;; And the `=>' its body follows.
("[ \t]\\(=>\\)\\(?:[ \t]\\|$\\)" 1 font-lock-keyword-face)
;; An enum member written `Dir.north', a constant as `:north' is. ;; An enum member written `Dir.north', a constant as `:north' is.
("\\_<[A-Z][^][ \t\n(){},;\":.]*\\.[^][ \t\n(){},;\":.]+\\_>" ("\\_<[A-Z][^][ \t\n(){},;\":.]*\\.[^][ \t\n(){},;\":.]+\\_>"
. font-lock-constant-face) . font-lock-constant-face)
@ -1593,10 +1780,13 @@ lambda or a `Fn(...)' type, and not after a match arm's."
"Font lock for `flan-fln-mode'.") "Font lock for `flan-fln-mode'.")
(defvar flan-fln-imenu-generic-expression (defvar flan-fln-imenu-generic-expression
`(("Functions" ,(concat "^fn-?[ \t]+" flan-fln--name-re) 1) `(("Functions" ,(concat "^\\(?:fn-?\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re) 1)
("Macros" ,(concat "^defmacro(" flan-fln--name-re) 1) ("Functions" ,(flan-fln--fallback-re flan-fln--fallback-function-heads) 2)
("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) 1) ("Macros" ,(concat "^\\(?:macro[ \t]+\\|defmacro(\\)" flan-fln--name-re) 1)
("Variables" ,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)) ("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\|type\\|class\\)[ \t]+" flan-fln--name-re) 1)
("Types" ,(flan-fln--fallback-re flan-fln--fallback-type-heads) 2)
("Variables" ,(concat "^\\(?:let\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)
("Variables" ,(flan-fln--fallback-re flan-fln--fallback-variable-heads) 2))
"Imenu index for `flan-fln-mode'.") "Imenu index for `flan-fln-mode'.")
(defun flan-fln-current-defun-name () (defun flan-fln-current-defun-name ()
@ -1605,7 +1795,7 @@ lambda or a `Fn(...)' type, and not after a match arm's."
(when s (when s
(save-excursion (save-excursion
(goto-char s) (goto-char s)
(and (looking-at (concat "\\(?:fn-?\\|def\\|once\\|const\\|struct\\|data\\|union\\|enum\\)[ \t]+" (and (looking-at (concat "\\(?:fn-?\\|macro\\|generic\\|multi\\|method\\|class\\|let\\|once\\|const\\|struct\\|data\\|union\\|enum\\|type\\)[ \t]+"
flan-fln--name-re)) flan-fln--name-re))
(match-string-no-properties 1)))))) (match-string-no-properties 1))))))

View File

@ -63,11 +63,22 @@ fn size(k: i64) -> i64
else 2 else 2
fn lam(k: i64) -> i64 fn lam(k: i64) -> i64
let add = fn(a: i64, b: i64) -> i64 = a + b let add = fn(a: i64, b: i64) -> i64 => a + b
let dbl = fn(a: i64) -> i64 let dbl = fn(a: i64) -> i64 =>
a * 2 a * 2
add(dbl(k), 1) add(dbl(k), 1)
fn app(x: i64, f: Fn(i64) -> i64) -> i64 = f(x)
fn lam2(k: i64) -> i64
let a = 1
let b = app(k, fn(x) =>
let y = x + a
y)
let c = fn(z: i64) -> i64 =>
z * 2
c(b)
fn rs() -> i64 fn rs() -> i64
restart-case restart-case
3 3
@ -85,6 +96,55 @@ fn dir(d: Dir) -> i64
Dir.north -> 7 Dir.north -> 7
_ -> 8 _ -> 8
struct Oops :parent Error
code: i64
type Count = i64
let speed: i64 = 3
fn speed-of() -> i64 = speed
struct Pair(a: i64, b: i64)
fn pair-sum(p: Pair) -> i64 = p.a + p.b
class shape(w, h)
generic area(s) -> dyn
method area(s: shape) = get(s, :w) * get(s, :h)
multi kind(v) -> dyn = type-of(v)
method kind(v) when :int = 1
method kind(v) when :else
0
fn counted(n: Count) -> Count = n + 1
fn oops-code() -> i64
handler-case
error(Oops{.code 7})
on Oops(c)
c.code
macro dbl-of(x, & more)
quote
~x + ~x
fn use-mac(k: i64) -> i64 = dbl-of(k)
fn gcd(a: i64, b: i64) -> i64
loop x = a, y = b
if y == 0 then x else recur(y, x % y)
fn sum-to(n: i64) -> i64
let r = loop i = 0, acc = 0
if i > n then acc else recur(i + 1, acc + i)
r
comment(): comment():
if 1 < 2 and if 1 < 2 and
3 < 4 3 < 4
@ -92,6 +152,9 @@ comment():
elif 1 > 2 or elif 1 > 2 or
3 > 4 3 > 4
0 0
app(5, fn(a) =>
a * 3
)
if 2 < 1 then 5 if 2 < 1 then 5
elif 2 == 1 then 6 elif 2 == 1 then 6
else 7 else 7
@ -208,13 +271,50 @@ comment():
'(("fn sign2" "(sign2 0)" "0") '(("fn sign2" "(sign2 0)" "0")
("fn size" "(size 20)" "2") ("fn size" "(size 20)" "2")
("fn lam" "(lam 3)" "7") ("fn lam" "(lam 3)" "7")
("fn lam2" "(lam2 3)" "8")
("fn rs" "(rs)" "3") ("fn rs" "(rs)" "3")
("fn dir" "(dir :north)" "7"))) ("fn dir" "(dir :north)" "7")
("struct Oops" "(oops-code)" "7")
("type Count" "(counted 1)" "2")
("struct Pair" "(pair-sum (Pair {.a 1 .b 2}))" "3")
("fn pair-sum" "(pair-sum (Pair {.a 1 .b 2}))" "3")
("class shape" "(i64 (area (shape 2 3)))" "6")
("generic area" "(i64 (area (shape 2 3)))" "6")
("method area" "(i64 (area (shape 2 3)))" "6")
("multi kind" "(i64 (kind 3))" "1")
("method kind(v) when :else" "(i64 (kind :x))" "0")
("fn counted" "(counted 1)" "2")
("fn oops-code" "(oops-code)" "7")
("macro dbl-of" "(use-mac 5)" "10")
("fn use-mac" "(use-mac 5)" "10")
("fn gcd" "(gcd 1071 462)" "21")
("fn sum-to" "(sum-to 4)" "10")))
(funcall goto needle) (funcall goto needle)
(flan-fln-eval-defun) (flan-fln-eval-defun)
(test-flan--check (funcall name (format "C-c C-c installs %s" needle)) (test-flan--check (funcall name (format "C-c C-c installs %s" needle))
(equal (funcall value call) want))) (equal (funcall value call) want)))
;; A top-level let is a global, installed and re-run by C-c C-c.
(funcall goto "let speed: i64 = 3")
(end-of-line)
(delete-char -1)
(insert "9")
(flan-fln-eval-defun)
(test-flan--check (funcall name "C-c C-c on a top-level let installs the global")
(equal (funcall value "(speed-of)") "9"))
;; A macro changed in the buffer and installed again reaches the
;; function installed after it.
(funcall goto "~x + ~x")
(delete-char 7)
(insert "~x * 3")
(funcall goto "macro dbl-of")
(flan-fln-eval-defun)
(funcall goto "fn use-mac")
(flan-fln-eval-defun)
(test-flan--check (funcall name "C-c C-c on a changed macro takes effect")
(equal (funcall value "(use-mac 5)") "15"))
;; The pause mark. What is sent is a line and column, and the daemon ;; The pause mark. What is sent is a line and column, and the daemon
;; answers `:pause' only when a form the reader made starts exactly ;; answers `:pause' only when a form the reader made starts exactly
;; there (`Ast.mark_pause'). Each kind of target once, and one position ;; there (`Ast.mark_pause'). Each kind of target once, and one position
@ -262,6 +362,16 @@ comment():
(unless (and (car r) (string-suffix-p (cadr r) (car r))) (unless (and (car r) (string-suffix-p (cadr r) (car r)))
(message " want ...%s\n got %S" (cadr r) (car r)))))) (message " want ...%s\n got %S" (cadr r) (car r))))))
(flan-clear-errors) (flan-clear-errors)
;; A lambda's block inside a call's brackets: the call goes whole
;; from its header line, and reads.
(funcall goto "app(5")
(flan-fln-eval-statement)
(test-flan--check (funcall name "C-c C-e on a call with a block lambda sends it whole, and it reads")
(funcall shows "15"))
(funcall goto "app(5, fn(a) =>" t)
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e at the end of its header line too")
(funcall shows "15"))
(funcall goto "if 2 > 1" t) (funcall goto "if 2 > 1" t)
(flan-fln-eval-last) (flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e at the end of an if line evaluates the condition") (test-flan--check (funcall name "C-x C-e at the end of an if line evaluates the condition")
@ -281,10 +391,19 @@ comment():
("else 2" "a one-line else after a block, at its value") ("else 2" "a one-line else after a block, at its value")
("a: i64, b" "a typed lambda, from its fn") ("a: i64, b" "a typed lambda, from its fn")
("a * 2" "a typed lambda's block") ("a * 2" "a typed lambda's block")
("x) =>" "a block lambda in a call, from its fn")
("let y = x" "a statement in a block lambda's block")
("y)" "the block's last statement, less the call's closer")
("let b = app" "a merged let's call with a block lambda, at its value")
("let c = fn" "a merged let's block lambda, at its value")
("restart retry" "a restart with a report, at its block") ("restart retry" "a restart with a report, at its block")
("Dir.north" "an enum member's arm, at its value") ("Dir.north" "an enum member's arm, at its value")
("let b = 2" "a let the let above takes in, at its value") ("let b = 2" "a let the let above takes in, at its value")
("let c: i64" "a typed one, at its value"))) ("let c: i64" "a typed one, at its value")
("loop x = a" "a loop, at its word")
("if y == 0" "a loop's block")
("let r = loop" "a let-bound loop, at its let")
("if i > n" "a let-bound loop's block")))
(funcall goto (car c)) (funcall goto (car c))
(let ((reply (flan-fln-eval-defun '(4)))) (let ((reply (flan-fln-eval-defun '(4))))
(test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it" (test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it"

View File

@ -203,7 +203,7 @@ fn step() -> ()
(test-flan-fln--is "before any form, the next one" (test-flan-fln--is "before any form, the next one"
(test-flan-fln--thing 'flan-fln-toplevel) "fn f() -> i32 = 1")) (test-flan-fln--thing 'flan-fln-toplevel) "fn f() -> i32 = 1"))
(test-flan-fln--in "def xs = [1 2\n3 4]\n + 1\nfn|x() -> i32 = 1\n" (test-flan-fln--in "let xs = [1 2\n3 4]\n + 1\nfn|x() -> i32 = 1\n"
(test-flan-fln--is "column 0 inside a bracket or after a leading operator is no form start" (test-flan-fln--is "column 0 inside a bracket or after a leading operator is no form start"
(save-excursion (beginning-of-defun) (save-excursion (beginning-of-defun)
(buffer-substring-no-properties (point) (line-end-position))) (buffer-substring-no-properties (point) (line-end-position)))
@ -598,8 +598,8 @@ fn size(n: i64) -> i64
else 2 else 2
fn k(n: i64) -> i64 fn k(n: i64) -> i64
let add = fn(a: i64, b) -> i64 = a + b let add = fn(a: i64, b) -> i64 => a + b
let dbl = fn(a: Fn(i64) -> i64, b: i64) -> i64 let dbl = fn(a: Fn(i64) -> i64, b: i64) -> i64 =>
a(b) * 2 a(b) * 2
let r = match n let r = match n
0 -> 1 0 -> 1
@ -689,7 +689,7 @@ of its line with AT-END."
(null (funcall face "x:"))))) (null (funcall face "x:")))))
(test-flan-fln--in "fn f(d: Dir) -> i64 (test-flan-fln--in "fn f(d: Dir) -> i64
let g = fn(a: Fn(i64) -> i64, b) -> Vec(i64) let g = fn(a: Fn(i64) -> i64, b) -> Vec(i64) =>
a(b) a(b)
restart-case restart-case
3 3
@ -711,6 +711,103 @@ of its line with AT-END."
(test-flan-fln--is "an enum member as a constant" (funcall face "Dir.north") 'font-lock-constant-face) (test-flan-fln--is "an enum member as a constant" (funcall face "Dir.north") 'font-lock-constant-face)
(test-flan-fln--is "an arm's value is not a type" (funcall face "twice(1)") nil) (test-flan-fln--is "an arm's value is not a type" (funcall face "twice(1)") nil)
(test-flan-fln--is "nor after a pattern with parentheses" (funcall face "r\n") nil))) (test-flan-fln--is "nor after a pattern with parentheses" (funcall face "r\n") nil)))
(test-flan-fln--in "struct DiskFull :parent IoError
free: i64
type Row = Vec(i64)
macro repeat(i, n, & body)
quote
for ~i in range(~n)
~@body
fn gcd(a: i32, b: i32) -> i32
loop x = a, y = b
if y == 0 then x else recur(y, x % y)
"
(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 "a struct's parent is a type" (funcall face "IoError") 'font-lock-type-face)
(test-flan-fln--is "and :parent a keyword" (funcall face ":parent") 'font-lock-constant-face)
(test-flan-fln--is "macro is a keyword" (funcall face "macro") 'font-lock-keyword-face)
(test-flan-fln--is "and its name a function's" (funcall face "repeat") 'font-lock-function-name-face)
(test-flan-fln--is "loop is a keyword" (funcall face "loop") 'font-lock-keyword-face)
(test-flan-fln--is "type is a keyword" (funcall face "type") 'font-lock-keyword-face)
(test-flan-fln--is "an alias's name is a type" (funcall face "Row") 'font-lock-type-face)
(test-flan-fln--is "and so is what it names" (funcall face "Vec(i64)") 'font-lock-type-face))
(goto-char (point-min))
(search-forward "Row")
(test-flan-fln--is "an alias installs as a defalias"
(flan-fln--declaration-head-at (line-beginning-position)) "defalias")
(goto-char (point-min))
(search-forward "~@body")
(test-flan-fln--is "a macro is one top-level form"
(test-flan-fln--thing 'flan-fln-toplevel)
"macro repeat(i, n, & body)
quote
for ~i in range(~n)
~@body")
(test-flan-fln--is "installed as a defmacro"
(flan-fln--declaration-head-at (car (flan-fln--toplevel-bounds (point))))
"defmacro")
(search-forward "recur")
(test-flan-fln--is "a loop's statement is its header and block"
(progn (forward-line -1)
(test-flan-fln--thing 'flan-fln-statement))
"loop x = a, y = b
if y == 0 then x else recur(y, x % y)")
(test-flan-fln--is "and its body the block"
(test-flan-fln--thing 'flan-fln-body)
"if y == 0 then x else recur(y, x % y)")
(goto-char (point-min))
(test-flan-fln--is "the struct's head is defstruct"
(flan-fln--declaration-head-at (point)) "defstruct")
(let ((imenu-generic-expression flan-fln-imenu-generic-expression))
(test-flan--check "imenu lists the macro"
(assoc "repeat" (cdr (assoc "Macros" (imenu--generic-function
imenu-generic-expression)))))))
(test-flan-fln--in "defmacro(m, [x]):
quote
~x
defmethod(area, point, [p]):
0
defclass(Shape, [w dyn]):
defstruct(Io, :parent, Error, [])
defconst(k, 3)
"
(font-lock-ensure)
(let ((face (lambda (needle)
(save-excursion (goto-char (point-min)) (search-forward needle)
(get-text-property (match-beginning 0) 'face)))))
(dolist (c '(("defmacro" m font-lock-function-name-face)
("defmethod" area font-lock-function-name-face)
("defclass" Shape font-lock-type-face)
("defstruct" Io font-lock-type-face)
("defconst" k font-lock-variable-name-face)))
(test-flan-fln--is (format "a fallback %s's head is a keyword" (car c))
(funcall face (concat (car c) "(")) 'font-lock-keyword-face)
(test-flan-fln--is (format "and the name it defines, %s" (cadr c))
(save-excursion
(goto-char (point-min))
(search-forward (concat (car c) "("))
(get-text-property (point) 'face))
(nth 2 c))))
(let ((index (imenu--generic-function flan-fln-imenu-generic-expression)))
(test-flan--check "imenu lists a fallback defmacro"
(assoc "m" (cdr (assoc "Macros" index))))
(test-flan--check "a fallback defmethod"
(assoc "area" (cdr (assoc "Functions" index))))
(test-flan--check "a fallback defclass and defstruct"
(and (assoc "Shape" (cdr (assoc "Types" index)))
(assoc "Io" (cdr (assoc "Types" index)))))
(test-flan--check "and a fallback defconst"
(assoc "k" (cdr (assoc "Variables" index))))))
(test-flan-fln--in "fn far(a: i64,\n b: i64) -> Point\n match a\n Some(x) -> Other\n" (test-flan-fln--in "fn far(a: i64,\n b: i64) -> Point\n match a\n Some(x) -> Other\n"
(font-lock-ensure) (font-lock-ensure)
(let ((face (lambda (needle) (let ((face (lambda (needle)
@ -756,7 +853,7 @@ of its line with AT-END."
(test-flan-fln--is "after a trailing colon too" (test-flan-fln--is "after a trailing colon too"
(test-flan-fln--tabs "rl/with-drawing():\n|" 1) 2) (test-flan-fln--tabs "rl/with-drawing():\n|" 1) 2)
(test-flan-fln--is "and after let x =" (test-flan-fln--is "and after let x ="
(test-flan-fln--tabs "def colors =\n|" 1) 2) (test-flan-fln--tabs "let colors =\n|" 1) 2)
(test-flan-fln--is "but not after a one-line fn" (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--tabs "fn f() -> i32 = 1\n|" 1) 0)
(test-flan-fln--is "else goes to its if's column, whatever the depth" (test-flan-fln--is "else goes to its if's column, whatever the depth"
@ -779,14 +876,97 @@ of its line with AT-END."
("let r = if c" "a let's if") ("let r = if c" "a let's if")
("x = if c" "an assignment's if") ("x = if c" "an assignment's if")
("let r = handler-case" "a let's handler-case") ("let r = handler-case" "a let's handler-case")
("let f = fn(a, b)" "a lambda header") ("let f = fn(a, b) =>" "a lambda header")
("let f = fn(a: i64, b) -> i64" "a typed lambda header") ("let f = fn(a: i64, b) -> i64 =>" "a typed lambda header")
("let f = fn(g: Fn(i64) -> i64) -> Option(i64)" "one with a function type in it") ("let f = fn(g: Fn(i64) -> i64) -> Option(i64) =>" "one with a function type in it")
("fn(a: i64) -> i64" "a typed lambda as a statement"))) ("let r = loop i = 0, acc = 1" "a let's loop")
("loop i = 0, acc = 1" "a loop")
("fn(a: i64) -> i64 =>" "a typed lambda as a statement")))
(test-flan-fln--is (format "unless its value goes on under it: %s" (cadr c)) (test-flan-fln--is (format "unless its value goes on under it: %s" (cadr c))
(test-flan-fln--tabs (concat "fn f()\n " (car c) "\n|") 1) 4)) (test-flan-fln--tabs (concat "fn f()\n " (car c) "\n|") 1) 4))
(test-flan-fln--is "but not a typed lambda with its body on the line" (test-flan-fln--is "but not a typed lambda with its body on the line"
(test-flan-fln--tabs "fn f()\n let f = fn(a: i64) -> i64 = a\n|" 1) 2) (test-flan-fln--tabs "fn f()\n let f = fn(a: i64) -> i64 => a\n|" 1) 2)
(test-flan-fln--is "a header word being assigned opens nothing"
(test-flan-fln--tabs "fn f()\n for = 1\n|" 1) 2)
(test-flan-fln--in "fn f()\n handler-case\n g()\n on E(c)\n h(c)\n on = 2\n data += 1\n"
(font-lock-ensure)
(goto-char (point-min))
(search-forward "on = 2")
(test-flan--check "nor is a clause word being assigned a clause"
(not (flan-fln--clause-line-p (line-beginning-position))))
(test-flan-fln--is "or drawn as a keyword"
(get-text-property (match-beginning 0) 'face) nil)
(search-forward "data")
(test-flan-fln--is "and a header word assigned is not either"
(get-text-property (match-beginning 0) 'face) nil))
(test-flan-fln--is "a macro opens a block"
(test-flan-fln--tabs "macro repeat(i, n, & body)\n|" 1) 2)
(test-flan-fln--is "and a struct with a parent"
(test-flan-fln--tabs "struct DiskFull :parent IoError\n|" 1) 2)
(test-flan-fln--in "let speed: i64 = 3\n\nfn f()\n let x = 1\n x\n"
(font-lock-ensure)
(test-flan-fln--is "a top-level let's name is a variable's"
(save-excursion (goto-char (point-min)) (search-forward "speed")
(get-text-property (match-beginning 0) 'face))
'font-lock-variable-name-face)
(test-flan-fln--is "and installs as a def" (flan-fln--declaration-head-at (point-min)) "def")
(test-flan--check "imenu lists it"
(assoc "speed" (cdr (assoc "Variables" (imenu--generic-function
flan-fln-imenu-generic-expression)))))
(test-flan--check "it is no local let" (not (flan-fln--let-p (point-min))))
(goto-char (point-min))
(search-forward "let x")
(test-flan--check "one in a fn is" (flan-fln--let-p (line-beginning-position)))
(test-flan-fln--is "and its name is not a global's"
(get-text-property (match-end 0) 'face) nil))
(test-flan-fln--is "a class with a slot per line opens a block"
(test-flan-fln--tabs "class point\n|" 1) 2)
(test-flan-fln--is "not one on one line"
(test-flan-fln--tabs "class point(x, y)\n|" 1) 0)
(test-flan-fln--is "a method opens its block"
(test-flan-fln--tabs "method area(p: point)\n|" 1) 2)
(test-flan-fln--is "but not one with its value on the line"
(test-flan-fln--tabs "method kind(v) when :int = 1\n|" 1) 0)
(test-flan-fln--is "a multi with a block opens it"
(test-flan-fln--tabs "multi kind(v) -> dyn\n|" 1) 2)
(test-flan-fln--is "a generic never does"
(test-flan-fln--tabs "generic area(p) -> dyn\n|" 1) 0)
(test-flan-fln--in "class point(x, y)\n\ngeneric area(p) -> dyn\n\nmethod area(p: point)\n 1\n\nmulti kind(v) -> dyn = type-of(v)\n\nmethod kind(v) when :int = 2\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 "class is a keyword" (funcall face "class") 'font-lock-keyword-face)
(test-flan-fln--is "and its name a type" (funcall face "point(") 'font-lock-type-face)
(test-flan-fln--is "a generic's name is a function's" (funcall face "area(p)") 'font-lock-function-name-face)
(test-flan-fln--is "a method's class is a type" (funcall face "point)") 'font-lock-type-face)
(test-flan-fln--is "a method's when is a keyword" (funcall face "when") 'font-lock-keyword-face))
(let ((index (imenu--generic-function flan-fln-imenu-generic-expression)))
(test-flan--check "imenu lists the class, the generic and the multi"
(and (assoc "point" (cdr (assoc "Types" index)))
(assoc "area" (cdr (assoc "Functions" index)))
(assoc "kind" (cdr (assoc "Functions" index))))))
(goto-char (point-min))
(search-forward "method area")
(test-flan-fln--is "a method installs as a defmethod"
(flan-fln--declaration-head-at (line-beginning-position)) "defmethod"))
(test-flan-fln--is "but not a struct on one line"
(test-flan-fln--tabs "struct Pt(x: i32, y: i32)\n|" 1) 0)
(test-flan-fln--is "nor one with a parent"
(test-flan-fln--tabs "struct D(free: i64) :parent IoError\n|" 1) 0)
(test-flan-fln--in "struct D(free: i64) :parent IoError\n\nunion U(a: i32)\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 "a one-line struct's name is a type" (funcall face "D(") 'font-lock-type-face)
(test-flan-fln--is "its field's type too" (funcall face "i64") 'font-lock-type-face)
(test-flan-fln--is "and its parent" (funcall face "IoError") 'font-lock-type-face)
(test-flan-fln--is "a one-line union's name" (funcall face "U(") 'font-lock-type-face))
(goto-char (point-min))
(test-flan-fln--is "a one-line struct is a top-level form of one line"
(test-flan-fln--thing 'flan-fln-toplevel)
"struct D(free: i64) :parent IoError"))
(test-flan-fln--is "a one-line fn whose value is a match opens it" (test-flan-fln--is "a one-line fn whose value is a match opens it"
(test-flan-fln--tabs "fn f(x) = match x\n|" 1) 2) (test-flan-fln--tabs "fn f(x) = match x\n|" 1) 2)
(test-flan-fln--is "no deeper after a one-line else" (test-flan-fln--is "no deeper after a one-line else"
@ -849,6 +1029,108 @@ of its line with AT-END."
(buffer-string) (buffer-string)
"fn f() -> ()\n if a\n while x\n y\n\n")) "fn f() -> ()\n if a\n while x\n y\n\n"))
;;; A lambda's block inside brackets
(defconst test-flan-fln--lam
"fn f(xs) -> i64
let n = 1
sort-by(xs, fn(a, b) =>
let d = a - b
d < n)
map(xs, fn(x) =>
g(x)
x
)
h(n)
")
(defun test-flan-fln--lam-at (needle fn &optional at-end)
"What FN sends with point at NEEDLE in the lambda program, or at the end of
its line with AT-END."
(test-flan-fln--in (test-flan-fln--at test-flan-fln--lam needle)
(when at-end (end-of-line))
(let ((r (test-flan-fln--sending (funcall fn))))
(and r (list (test-flan-fln--sent-code r) (plist-get r :pause))))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--lam "sort-by")
(test-flan-fln--is "a call with a block lambda is one statement, block and closer too"
(test-flan-fln--thing 'flan-fln-statement)
"sort-by(xs, fn(a, b) =>\n let d = a - b\n d < n)")
(test-flan-fln--is "its body is the lambda's block, less the call's closer"
(test-flan-fln--thing 'flan-fln-body)
"let d = a - b\n d < n"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--lam "d < n")
(test-flan-fln--is "a line of the block is a statement of its own, less the closer"
(test-flan-fln--thing 'flan-fln-statement) "d < n"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--lam " )")
(test-flan-fln--is "a closer on a line of its own belongs to the call"
(test-flan-fln--thing 'flan-fln-statement)
"map(xs, fn(x) =>\n g(x)\n x\n )"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--lam " x\n")
(test-flan-fln--is "and not to the statement above it"
(test-flan-fln--thing 'flan-fln-statement) "x"))
(test-flan-fln--is "C-c C-e on the header sends the call, block and all"
(car (test-flan-fln--lam-at "sort-by" #'flan-fln-eval-statement))
"sort-by(xs, fn(a, b) =>\n let d = a - b\n d < n)")
(test-flan-fln--is "and C-x C-e at the header's end"
(car (test-flan-fln--lam-at "sort-by" #'flan-fln-eval-last t))
"sort-by(xs, fn(a, b) =>\n let d = a - b\n d < n)")
(test-flan-fln--is "C-x C-e at the end of the block's last line sends its statement"
(car (test-flan-fln--lam-at "d < n" #'flan-fln-eval-last t))
"d < n")
(test-flan-fln--is "C-c C-e on a line of the block sends that statement"
(car (test-flan-fln--lam-at "g(x)" #'flan-fln-eval-statement))
"g(x)")
(dolist (c '(("let d" (4 5) "a statement in the block, where the reader starts it")
("g(x)" (7 5) "one in a block with its closer on a line of its own")
("a, b)" (3 15) "the lambda, from its fn")
("xs, fn(a" (3 3) "the call, from its name")))
(test-flan-fln--is (format "C-u C-c C-c marks %s" (nth 2 c))
(cadr (test-flan-fln--lam-at (car c) (lambda () (flan-fln-eval-defun '(4)))))
(cadr c)))
(test-flan-fln--is "TAB after a => inside brackets goes one level in"
(test-flan-fln--tabs "fn f()\n sort-by(xs, fn(a, b) =>\n|" 1) 4)
(test-flan-fln--is "and a line of the block stays in it"
(test-flan-fln--tabs "fn f()\n sort-by(xs, fn(a, b) =>\n g(a)\n| a < b)" 1) 4)
(test-flan-fln--is "under a header on a wrapped argument line, in from that line"
(test-flan-fln--tabs "f(a,\n fn(b) =>\n|" 1) 4)
(test-flan-fln--is "a closer on its own line goes to the call's column"
(test-flan-fln--tabs "fn f()\n m(xs, fn(x) =>\n x\n|)" 1) 2)
(test-flan-fln--is "after the block's brackets close, its column is no longer offered"
(list (test-flan-fln--tabs "fn f()\n app(k, fn(x) =>\n x)\n|g()" 1)
(test-flan-fln--tabs "fn f()\n app(k, fn(x) =>\n x)\n|g()" 2)
(test-flan-fln--tabs "fn f()\n app(k, fn(x) =>\n x)\n|g()" 3))
'(0 2 0))
(test-flan-fln--is "inside a bracket in the block, under its first argument"
(test-flan-fln--tabs "fn f()\n m(xs, fn(x) =>\n g(x,\n|y))" 1) 6)
(test-flan-fln--in "fn f()\n m(xs, fn(x) => x)\n"
(font-lock-ensure)
(test-flan-fln--is "=> is a keyword"
(save-excursion (goto-char (point-min)) (search-forward "=>")
(get-text-property (match-beginning 0) 'face))
'font-lock-keyword-face))
(defconst test-flan-fln--lam-arm
"fn f(n: i64) -> i64
match n
1 -> app(1, fn(a) =>
a * 2)
_ -> 0
")
(test-flan-fln--is "C-x C-e at the end of an arm whose value ends in => sends the value, block and all"
(test-flan-fln--in (test-flan-fln--at test-flan-fln--lam-arm "1 ->")
(end-of-line)
(test-flan-fln--sent-code (test-flan-fln--sending (flan-fln-eval-last))))
"app(1, fn(a) =>\n a * 2)")
(test-flan-fln--is "and C-u C-c C-c on its pattern stops at the value"
(test-flan-fln--in (test-flan-fln--at test-flan-fln--lam-arm "1 ->")
(plist-get (test-flan-fln--sending (flan-fln-eval-defun '(4))) :pause))
'(3 10))
(test-flan-fln--is "an else whose value ends in => takes the block too"
(test-flan-fln--in "fn f(c)\n if c\n g()\n |else app(1, fn(a) =>\n a)\n"
(test-flan-fln--text (flan-fln--clause-value (line-beginning-position))))
"app(1, fn(a) =>\n a)")
;;; Block editing ;;; Block editing
(test-flan-fln--in "fn f() -> ()\n if a\n |b()\n c()\n d()\n" (test-flan-fln--in "fn f() -> ()\n if a\n |b()\n c()\n d()\n"

View File

@ -6125,12 +6125,36 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
let p, pty = check_place ctx loc p in let p, pty = check_place ctx loc p in
let v = lit_down ctx key pty v in let v = lit_down ctx key pty v in
expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v)))
(* (set (.name x) v) on a dyn is (put x :name v): a class slot's declared
type is checked by put, and a map takes a key it did not hold. Not
[flan_dyn_slot_set], which refuses a plain map — .name reads either, so
assigning it writes either. The target is checked once, here. *)
| Ast.Set (Ast.Pfield (target, name), v) ->
let t = check_target ctx target in
if t.Tast.ty = Types.Dyn then begin
refuse_const_change ctx loc t;
let k = dyn_kw ctx loc name in
let v = check ctx ~want:Types.Dyn v in
expect ctx loc ~want
(rt loc Types.Unit "flan_dyn_map_put" [ t; k; v; here loc ])
end else begin
let p, pty = field_place ~store:true ctx loc target t name in
let v = check ctx ~want:pty v in
expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v)))
end
| Ast.Set (p, v) -> | Ast.Set (p, v) ->
let p, pty = check_place ctx loc p in let p, pty = check_place ctx loc p in
let v = check ctx ~want:pty v in let v = check ctx ~want:pty v in
expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v)))
(* On a dyn, (.name x) is (get x :name) — the same call, so a missing key is
nil and a value that is not a map traps with get's own sentence. *)
| Ast.Field (target, name) -> | Ast.Field (target, name) ->
let target, sname = struct_target ctx target in let t = check_target ctx target in
if t.Tast.ty = Types.Dyn then
expect ctx loc ~want
(rt loc Types.Dyn "flan_dyn_get" [ t; dyn_kw ctx loc name; here loc ])
else
let target, sname = struct_of ctx target t in
let s = Option.get (fields_named ctx.env sname) in let s = Option.get (fields_named ctx.env sname) in
(match Tast.field_index s name with (match Tast.field_index s name with
| None -> | None ->
@ -6675,7 +6699,7 @@ and check_fn ctx ~want ?gen loc (params : string list) body =
"nothing here says what this fn's parameters are — an fn takes \ "nothing here says what this fn's parameters are — an fn takes \
its types from the position it is written in. Pass it where a \ its types from the position it is written in. Pass it where a \
Fn(T, ...) -> R is expected, or name the type where it is \ Fn(T, ...) -> R is expected, or name the type where it is \
bound: let f: Fn(T, ...) -> R = fn(...)" bound: let f: Fn(T, ...) -> R = fn(...) => ..."
else else
fail loc fail loc
"nothing here says what this fn's parameters are — an fn takes \ "nothing here says what this fn's parameters are — an fn takes \
@ -8976,7 +9000,7 @@ and array_build ctx loc ns elem ~pre ~element =
[n T] the literal is, since an array literal is never a slice. *) [n T] the literal is, since an array literal is never a slice. *)
and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) =
let ty = resolve ctx.env t in let ty = resolve ctx.env t in
(* A typed .fln lambda, [fn(c: C) -> bool = ...], reads as [(the (Fn [C] (* A typed .fln lambda, [fn(c: C) -> bool => ...], reads as [(the (Fn [C]
bool) (fn ...))]; where a CFn of the same signature is wanted, the bool) (fn ...))]; where a CFn of the same signature is wanted, the
literal is that CFn, as an untyped one would be. *) literal is that CFn, as an untyped one would be. *)
let ty = let ty =
@ -9828,6 +9852,15 @@ and unknown_name : 'a. ?setting:bool -> ctx -> Loc.t -> string -> 'a =
else else
Loc.failk "check/dot-access" loc ~notes Loc.failk "check/dot-access" loc ~notes
"unknown name %s — %s, and %s has no field %s" name how sn field "unknown name %s — %s, and %s has no field %s" name how sn field
| None, Some Types.Dyn ->
let how =
if setting then Printf.sprintf "(set (.%s %s) ...)" field head
else Printf.sprintf "(.%s %s)" field head
in
Loc.failk "check/dot-access" loc
"unknown name %s — a dot is part of the name here, not field access. \
%s is dyn, and its :%s is reached with %s"
name head field how
| None, Some t -> | None, Some t ->
Loc.failk "check/dot-access" loc Loc.failk "check/dot-access" loc
"unknown name %s — a dot is part of the name here, not field access. \ "unknown name %s — a dot is part of the name here, not field access. \
@ -9907,9 +9940,9 @@ and fields_named env n : Tast.structure option =
(* The target of [.field] is a struct or an untagged union, or one level of (* The target of [.field] is a struct or an untagged union, or one level of
pointer to one. The auto-deref is inserted here as a real node, so no pointer to one. The auto-deref is inserted here as a real node, so no
backend re-derives it. *) backend re-derives it. The target comes checked, because every caller
and struct_target ctx (target : Ast.expr) : Tast.expr * string = looks first for a dyn, whose [.name] is a map entry and not a field. *)
let t = check_target ctx target in and struct_of ctx (target : Ast.expr) (t : Tast.expr) : Tast.expr * string =
let has n = fields_named ctx.env n <> None in let has n = fields_named ctx.env n <> None in
match t.Tast.ty with match t.Tast.ty with
| Types.Named n when has n -> t, n | Types.Named n when has n -> t, n
@ -10044,15 +10077,19 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t =
| Some (ty, false) -> Tast.Pglobal name, ty | Some (ty, false) -> Tast.Pglobal name, ty
| None -> unknown_name ~setting:true ctx loc name) | None -> unknown_name ~setting:true ctx loc name)
| Ast.Pfield (target, name) -> | Ast.Pfield (target, name) ->
let target, sname = struct_target ctx target in let t = check_target ctx target in
let s = Option.get (fields_named ctx.env sname) in if t.Tast.ty = Types.Dyn then begin
(match Tast.field_index s name with let x = match target.Ast.e with Ast.Var x -> x | _ -> "x" in
| None -> if Source.indented_at loc then
Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) fail loc
"%s has no field %s" (tyname loc (Types.Named sname)) name "%s.%s is an entry of a dyn map, and has no address. Read it into \
| Some i -> a local: let v = %s.%s" x name x name
if store then Option.iter (refuse_const_place ctx.env loc) (const_reached target); else
Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty) fail loc
"(.%s %s) is an entry of a dyn map, and has no address. Read it \
into a local: (let [v (.%s %s)] ...)" name x name x
end;
field_place ~store ctx loc target t name
| Ast.Pindex (target, idx) -> | Ast.Pindex (target, idx) ->
let target = check_target ctx target in let target = check_target ctx target in
(match target.Tast.ty with (match target.Tast.ty with
@ -10082,6 +10119,21 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t =
"a class slot (get inst :slot) is written with set and has no address. \ "a class slot (get inst :slot) is written with set and has no address. \
Read it into a local with let" Read it into a local with let"
(* The dyn keyword [:name], for a dyn's [.name]. *)
and dyn_kw ctx loc name = check ctx ~want:Types.Dyn { Ast.e = Ast.Kw name; loc }
(* A struct field as a place, over a target already checked. *)
and field_place ~store ctx loc target t name =
let target, sname = struct_of ctx target t in
let s = Option.get (fields_named ctx.env sname) in
match Tast.field_index s name with
| None ->
Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname)
"%s has no field %s" (tyname loc (Types.Named sname)) name
| Some i ->
if store then Option.iter (refuse_const_place ctx.env loc) (const_reached target);
Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty
(* An index or a slice bound that is a literal is known now, so it is an error (* An index or a slice bound that is a literal is known now, so it is an error
now rather than a trap later. Only literals: a [defconst] is a global in the now rather than a trap later. Only literals: a [defconst] is a global in the
typed IR, not a folded constant, so [(at arr size)] still traps at runtime — typed IR, not a folded constant, so [(at arr size)] still traps at runtime —
@ -12197,8 +12249,8 @@ and named_call ?(qualified = false) ctx ~want loc name args =
stored under the key. *) stored under the key. *)
if target.Tast.ty = Types.Dyn then if target.Tast.ty = Types.Dyn then
expect ctx loc ~want expect ctx loc ~want
(rt loc Types.Dyn "flan_dyn_map_get" (rt loc Types.Dyn "flan_dyn_get"
[ target; check ctx ~want:Types.Dyn k ]) [ target; check ctx ~want:Types.Dyn k; here loc ])
else begin else begin
let kt, vt = map_kv loc "get" target.Tast.ty in let kt, vt = map_kv loc "get" target.Tast.ty in
let k = check ctx ~want:kt k in let k = check ctx ~want:kt k in

View File

@ -185,9 +185,9 @@ let collect (decls : Ast.decl list) =
is what [class-of] answers and what a generic dispatches on. is what [class-of] answers and what a generic dispatches on.
Named-slot construction — the dyn twin of [(Cursor {.src s})], with an Named-slot construction — the dyn twin of [(Cursor {.src s})], with an
omitted slot meaning nil — is deferred, and so is refusing an unknown slot omitted slot meaning nil — is deferred (TODO.org, "Class features deferred,
at [(get p :z)]. Both are recorded in TODO.org, "Class features deferred, each with its reason"). An unknown slot, [(get p :z)], is refused at run
each with its reason". *) time by the runtime's [trap_no_slot]. *)
let constructor n (slots : Ast.field list) loc : Ast.decl = let constructor n (slots : Ast.field list) loc : Ast.decl =
(* Two slots of one name would write one entry and read one value, and the (* Two slots of one name would write one entry and read one value, and the
constructor would take two arguments for it. The duplicate parameter constructor would take two arguments for it. The duplicate parameter

View File

@ -4590,10 +4590,19 @@ let rec handle t req =
match Wire.string_field req "syntax", Wire.string_field req "op", match Wire.string_field req "syntax", Wire.string_field req "op",
Wire.string_field req "file" with Wire.string_field req "file" with
| (Some _ as s), _, _ -> Source.syntax_of_field s | (Some _ as s), _, _ -> Source.syntax_of_field s
(* A whole file named with no [:syntax] is in the syntax its name says: (* With no [:syntax], a file named is in the syntax its name says — what
that is not a guess, it is what [Source.read_file] would do. *) [Source.read_file] would do — for every op, so code sent from a .fln
| None, Some "load-file", Some f when Source.is_indented f -> Source.Indented buffer by a client that left the field out is not read as parens. A
| None, _, _ -> Source.Paren paren expansion sent back under a .fln name says [:syntax "paren"]. *)
| None, _, Some f when Source.is_source f ->
if Source.is_indented f then Source.Indented else Source.Paren
(* A pseudo-name — "<repl>", "<inspect>", whose text is built in parens —
is paren. No file at all is the program's own syntax: evaluating in a
stopped frame names none, and its code is written as the program is. *)
| None, _, Some _ -> Source.Paren
| None, _, None ->
if Source.is_indented t.session.Session.file then Source.Indented
else Source.Paren
in in
let at = let at =
match Wire.int_field req "line", Wire.int_field req "col" with match Wire.int_field req "line", Wire.int_field req "col" with

View File

@ -5007,6 +5007,7 @@ declare void @flan_dyn_class_def(i64, ptr, i64)
declare void @flan_dyn_class_hook(ptr) declare void @flan_dyn_class_hook(ptr)
declare i64 @flan_dyn_kw(ptr, i64) declare i64 @flan_dyn_kw(ptr, i64)
declare i64 @flan_dyn_map_get(i64, i64) declare i64 @flan_dyn_map_get(i64, i64)
declare i64 @flan_dyn_get(i64, i64, ptr, i64)
declare void @flan_dyn_map_set(i64, i64, i64) declare void @flan_dyn_map_set(i64, i64, i64)
declare i64 @flan_dyn_map_contains(i64, i64) declare i64 @flan_dyn_map_contains(i64, i64)
; The ones that trap carry the site as ptr+len, the way the bounds and ; The ones that trap carry the site as ptr+len, the way the bounds and

View File

@ -74,6 +74,11 @@ let is_sym s (f : Form.t) = match f.v with Form.Sym x -> x = s | _ -> false
[let] there takes in what follows it and no one-argument [and] is dropped. *) [let] there takes in what follows it and no one-argument [and] is dropped. *)
let quasi = ref 0 let quasi = ref 0
(* While [hole_lines] looks for where a lambda sits in a line, the lambda is
printed as [hole_sym], at a lambda's level. *)
let hole = ref false
let hole_sym = "\003lambda\003"
let in_quasi (f : Form.t) k = let in_quasi (f : Form.t) k =
match f.v with match f.v with
| Form.List ({ v = Form.Sym "quasiquote"; _ } :: _) -> | Form.List ({ v = Form.Sym "quasiquote"; _ } :: _) ->
@ -296,6 +301,7 @@ let flatten (f : Form.t) (rest : Form.t list) =
one-line [if] or a lambda. *) one-line [if] or a lambda. *)
let rec expr (f : Form.t) : string * int = let rec expr (f : Form.t) : string * int =
match f.v with match f.v with
| Form.Sym s when !hole && s = hole_sym -> (s, 0)
| Form.Sym s -> sym f s | Form.Sym s -> sym f s
| Form.Kw k -> | Form.Kw k ->
if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling" if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling"
@ -420,10 +426,10 @@ and list f h args =
(s ^ fst (expr m), 9) (s ^ fst (expr m), 9)
| Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) -> | Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) ->
(match typed_lambda f with (match typed_lambda f with
| Some (head, [ body ]) -> (head ^ " = " ^ unit_text body, 0) | Some (head, [ body ]) -> (head ^ " => " ^ unit_text body, 0)
| _ -> assert false) | _ -> assert false)
| Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps -> | Form.Sym "fn", [ { v = Form.Vec ps; _ }; body ] when List.for_all sym_param ps ->
("fn(" ^ commas ps ^ ") = " ^ unit_text body, 0) ("fn(" ^ commas ps ^ ") => " ^ unit_text body, 0)
| Form.Sym "if", [ c; a; b ] -> | Form.Sym "if", [ c; a; b ] ->
("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0) ("if " ^ at 1 c ^ " then " ^ inline_text ~lvl:1 a ^ " else " ^ inline_text b, 0)
| _ -> call () | _ -> call ()
@ -499,10 +505,15 @@ let rec ty (f : Form.t) =
primitive, a capitalised or [$] name, or a bracket. [[x y]] with a primitive, a capitalised or [$] name, or a bracket. [[x y]] with a
lowercase [y] keeps the fallback, because what it means depends on lowercase [y] keeps the fallback, because what it means depends on
whether [y] names a type. *) whether [y] names a type. *)
(* The file's own class names, which are types and lowercase. Set by
[program]. *)
let classes : string list ref = ref []
let type_shaped (f : Form.t) = let type_shaped (f : Form.t) =
match f.v with match f.v with
| Form.Sym t -> | Form.Sym t ->
List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t
|| List.mem t !classes
| Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true | Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true
| _ -> false | _ -> false
@ -544,7 +555,17 @@ let lead_word text =
(* A statement whose text leads with a reserved word, parenthesised. *) (* A statement whose text leads with a reserved word, parenthesised. *)
let guard text = let guard text =
let w, spaced = lead_word text in let w, spaced = lead_word text in
if spaced && List.mem w reserved then paren text else text (* [data = 3]: a name being assigned is read as one, header word or not. *)
let assigned =
let k = String.length w + 1 in
List.exists
(fun op ->
let o = op ^ " " in
String.length text >= k + String.length o
&& String.sub text k (String.length o) = o)
[ "="; "+="; "-="; "*="; "/=" ]
in
if spaced && List.mem w reserved && not assigned then paren text else text
let stmts_of (f : Form.t) = let stmts_of (f : Form.t) =
match f.v with match f.v with
@ -703,9 +724,12 @@ and plain n (f : Form.t) : string list =
| _ -> head_text h ^ "(" ^ commas fixed ^ "):" | _ -> head_text h ^ "(" ^ commas fixed ^ "):"
in in
[ ind n ^ guard opener ] @ block ~seq (n + 2) rest [ ind n ^ guard opener ] @ block ~seq (n + 2) rest
| _ when n + String.length text > width && fst (expr f) = text -> | _ ->
wrapped n "" f match hole_lines ~guarded:true n "" f with
| _ -> one) | Some ls -> ls
| None ->
if n + String.length text > width && fst (expr f) = text then wrapped n "" f
else one)
| _ -> one | _ -> one
(* A call too long for its line, broken after commas inside its (* A call too long for its line, broken after commas inside its
@ -761,6 +785,131 @@ and wrapped n prefix (f : Form.t) =
go (ind n ^ open_) [] ts go (ind n ^ open_) [] ts
| _ -> [ ind n ^ prefix ^ at 0 f ] | _ -> [ ind n ^ prefix ^ at 0 f ]
(* A lambda as its header, [fn(a, b)] or [fn(a: C) -> R], and its body. *)
and lambda_parts (f : Form.t) =
match typed_lambda f with
| Some _ as l -> l
| None ->
match f.v with
| Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when List.for_all sym_param ps ->
Some ("fn(" ^ commas ps ^ ")", body)
| _ -> None
(* A lambda body that reads better as a block under [=>] than on the line:
several statements, or one that is a statement. *)
and block_body (body : Form.t list) =
match body with
| [ { v = Form.List ({ v = Form.Sym h; _ } :: _); _ } ] ->
List.mem h sugar_heads && h <> "if" && h <> "update"
| [ _ ] -> false
| _ -> true
(* A lambda that takes a block: one whose body does, or has a comment in
it, or holds a lambda that takes one. *)
and wants_block (l : Form.t) body =
let rec holds (x : Form.t) =
match lambda_parts x with
| Some (_, b) -> wants_block x b
| None ->
match x.v with
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> false
| Form.List xs | Form.Vec xs | Form.Map xs -> List.exists holds xs
| _ -> false
in
block_body body || !inside l || List.exists holds body
(* A block under [=>]: a body that is one [do] is its statements, written
straight under the header rather than in a [do:] of their own. *)
and lambda_block n body =
match body with
| [ { Form.v = Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)); _ } ] -> block (n + 2) ss
| _ -> block (n + 2) body
(* A line holding a lambda that takes its block there: [prefix] and the
line's text up to the lambda, [fn(x) =>], the block under it, and what
followed the lambda on the line at the end of the block's last line. The
reader ends a block inside brackets where they close, so the lambda must
be the last thing in its brackets: what follows it starts with a closer.
Each lambda in [f], outside the others, is tried in turn, a lambda that
wants a block (several statements, a statement, a comment inside) or any
when the line is too long; its place is found by printing the line with
a placeholder where it stands. [guarded]: the text is a statement's. *)
and hole_lines ?(guarded = false) n prefix (f : Form.t) =
let rec cands (x : Form.t) =
if lambda_parts x <> None then [ x ]
else
match x.v with
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> []
| Form.List xs | Form.Vec xs | Form.Map xs -> List.concat_map cands xs
| _ -> []
in
let inner =
match f.v with
| Form.List xs | Form.Vec xs | Form.Map xs -> List.concat_map cands xs
| _ -> []
in
if inner = [] then None
else
let long = lazy (n + String.length prefix + String.length (fst (expr f)) > width) in
let rec subst (l : Form.t) (x : Form.t) =
if x == l then Form.make (Form.Sym hole_sym) l.loc
else
match x.v with
| Form.List xs -> { x with v = Form.List (List.map (subst l) xs) }
| Form.Vec xs -> { x with v = Form.Vec (List.map (subst l) xs) }
| Form.Map xs -> { x with v = Form.Map (List.map (subst l) xs) }
| _ -> x
in
let find t =
let k = String.length hole_sym in
let rec go i =
if i + k > String.length t then None
else if String.sub t i k = hole_sym then Some i
else go (i + 1)
in
go 0
in
let rec try_ = function
| [] -> None
| (l : Form.t) :: rest ->
let head, body = Option.get (lambda_parts l) in
if not (wants_block l body || Lazy.force long) then try_ rest
else begin
hole := true;
let t =
Fun.protect ~finally:(fun () -> hole := false)
(fun () -> fst (expr (subst l f)))
in
let t = if guarded then guard t else t in
match find t with
| Some i
when (let j = i + String.length hole_sym in
j < String.length t && (t.[j] = ')' || t.[j] = ']' || t.[j] = '}')) ->
let j = i + String.length hole_sym in
let post = String.sub t j (String.length t - j) in
let ls = lambda_block n body in
let ls =
match List.rev ls with
| last :: before -> List.rev ((last ^ post) :: before)
| [] -> ls
in
Some ((ind n ^ prefix ^ String.sub t 0 i ^ head ^ " =>") :: ls)
| _ -> try_ rest
end
in
try_ inner
(* [prefix = fn(a) =>] or [prefix = f(x, fn(a) =>] and a lambda's block,
when the value is a lambda that takes one or ends a bracket with one. *)
and lambda_value n prefix (v : Form.t) =
match lambda_parts v with
| Some (head, body)
when wants_block v body
|| n + String.length prefix + 3 + String.length (fst (expr v)) > width ->
Some ((ind n ^ prefix ^ " = " ^ head ^ " =>") :: lambda_block n body)
| _ -> hole_lines n (prefix ^ " = ") v
(* [prefix = v], or [prefix =] and the value as an indented block when it is (* [prefix = v], or [prefix =] and the value as an indented block when it is
too long for the line. *) too long for the line. *)
and value_lines n prefix (v : Form.t) = and value_lines n prefix (v : Form.t) =
@ -771,15 +920,16 @@ and value_lines n prefix (v : Form.t) =
| _ -> false | _ -> false
in in
if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
else if n + String.length inline <= width then [ ind n ^ inline ] else if loop_head v <> None then
let head, body = Option.get (loop_head v) in
[ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body
else
match lambda_value n prefix v with
| Some ls -> ls
| None ->
if n + String.length inline <= width then [ ind n ^ inline ]
else else
match v.v with match v.v with
| _ when typed_lambda v <> None ->
let head, body = Option.get (typed_lambda v) in
[ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body
| Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when List.for_all sym_param ps ->
[ ind n ^ prefix ^ " = fn(" ^ commas ps ^ ")" ] @ block (n + 2) body
| Form.List ({ v = Form.Sym h; _ } :: _) | Form.List ({ v = Form.Sym h; _ } :: _)
when not (List.mem h sugar_heads || h = "fn" || h = "if") -> when not (List.mem h sugar_heads || h = "fn" || h = "if") ->
wrapped n (prefix ^ " = ") v wrapped n (prefix ^ " = ") v
@ -789,6 +939,23 @@ and value_lines n prefix (v : Form.t) =
and slot n (f : Form.t) = block n (stmts_of f) and slot n (f : Form.t) = block n (stmts_of f)
(* [(loop [x a y b] body ...)] as the header [loop x = a, y = b] and its
body, when every binding is a plain name. A lambda or one-line if as a
value is parenthesised, so its else cannot run on into the next binding. *)
and loop_head (f : Form.t) =
match f.v with
| Form.List ({ v = Form.Sym "loop"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
(match pairs bs with
| Some (_ :: _ as prs)
when List.for_all (fun ((x : Form.t), _) ->
match x.v with Form.Sym x -> def_name x | _ -> false) prs ->
Some
("loop "
^ String.concat ", " (List.map (fun (x, v) -> fst (expr x) ^ " = " ^ at 1 v) prs),
body)
| _ -> None)
| _ -> None
and label_of = function and label_of = function
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest) | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
| rest -> ("", rest) | rest -> ("", rest)
@ -805,7 +972,8 @@ and sugar n (f : Form.t) : string list option =
Some [ i ^ guard (inline_text f) ] Some [ i ^ guard (inline_text f) ]
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> | Form.List [ { v = Form.Sym "set"; _ }; t; v ] ->
let line = i ^ guard (assign_text t v) in let line = i ^ guard (assign_text t v) in
if String.length line <= width then Some [ line ] if String.length line <= width && lambda_value n (guard (at 9 t)) v = None
then Some [ line ]
else Some (value_lines n (guard (at 9 t)) v) else Some (value_lines n (guard (at 9 t)) v)
| Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] -> | Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] ->
let simple (x : Form.t) = let simple (x : Form.t) =
@ -877,7 +1045,10 @@ and sugar n (f : Form.t) : string list option =
((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body) ((i ^ "for " ^ lbl ^ v ^ " in range(" ^ commas bs ^ ")") :: block (n + 2) body)
| _ -> None) | _ -> None)
| Form.List [ { v = Form.Sym "return"; _ } ] -> Some [ i ^ "return" ] | Form.List [ { v = Form.Sym "return"; _ } ] -> Some [ i ^ "return" ]
| Form.List [ { v = Form.Sym "return"; _ }; v ] -> Some [ i ^ "return " ^ at 0 v ] | Form.List [ { v = Form.Sym "return"; _ }; v ] ->
(match hole_lines n "return " v with
| Some ls -> Some ls
| None -> Some [ i ^ "return " ^ at 0 v ])
| Form.List [ { v = Form.Sym (("break" | "continue") as w); _ } ] -> Some [ i ^ w ] | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ } ] -> Some [ i ^ w ]
| Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ] | Form.List [ { v = Form.Sym (("break" | "continue") as w); _ }; { v = Form.Kw k; _ } ]
when kw_ok k -> when kw_ok k ->
@ -939,9 +1110,9 @@ and sugar n (f : Form.t) : string list option =
@ List.concat_map Option.get cs) @ List.concat_map Option.get cs)
| Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> | Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] ->
Some ((i ^ "quote") :: slot (n + 2) x) Some ((i ^ "quote") :: slot (n + 2) x)
| Form.List ({ v = Form.Sym "fn"; _ } :: { v = Form.Vec ps; _ } :: (_ :: _ :: _ as body)) | _ when (match lambda_parts f with Some (_, body) -> wants_block f body | None -> false) ->
when List.for_all sym_param ps -> let head, body = Option.get (lambda_parts f) in
Some ((guard (i ^ "fn(" ^ commas ps ^ ")")) :: block (n + 2) body) Some ((i ^ head ^ " =>") :: lambda_block n body)
| Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ } | Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: ret :: body) :: { v = Form.Vec ps; _ } :: ret :: body)
when def_name name -> when def_name name ->
@ -971,7 +1142,8 @@ and sugar n (f : Form.t) : string list option =
| Form.List (({ v = Form.Sym h; _ } as hf) :: args) -> | Form.List (({ v = Form.Sym h; _ } as hf) :: args) ->
(* A call that takes a block is a statement, not a value. *) (* A call that takes a block is a statement, not a value. *)
not (List.mem h sugar_heads) && body_split hf args = None not (List.mem h sugar_heads) && body_split hf args = None
| _ -> true) && lambda_value (n + 2) "" x = None
| _ -> lambda_value (n + 2) "" x = None)
&& String.length head + 3 + String.length (at 0 x) <= width && String.length head + 3 + String.length (at 0 x) <= width
&& not (!inside f) -> && not (!inside f) ->
Some [ head ^ " = " ^ unit_text x ] Some [ head ^ " = " ^ unit_text x ]
@ -979,9 +1151,12 @@ and sugar n (f : Form.t) : string list option =
| Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ } | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
:: { v = Form.Sym name; _ } :: rest) :: { v = Form.Sym name; _ } :: rest)
when def_name name -> when def_name name ->
let w = match d with "def" -> "def" | "defonce" -> "once" | _ -> "const" in (* A global [def] is a top-level [let]; nested, where a let is local, it
keeps the fallback. *)
let w = match d with "def" -> "let" | "defonce" -> "once" | _ -> "const" in
let pre = i ^ w ^ " " ^ name in let pre = i ^ w ^ " " ^ name in
(match d, rest with (match d, rest with
| "def", _ when n > 0 -> None
| "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v) | "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v)
| "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) | "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
| "defconst", _ -> None | "defconst", _ -> None
@ -989,14 +1164,64 @@ and sugar n (f : Form.t) : string list option =
| _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ] | _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ]
| _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) | _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
| _ -> None) | _ -> None)
| Form.List [ { v = Form.Sym (("defstruct" | "defunion") as d); _ }; | Form.List ({ v = Form.Sym "loop"; _ } :: _) when loop_head f <> None ->
{ v = Form.Sym name; _ }; { v = Form.Vec fs; _ } ] let head, body = Option.get (loop_head f) in
Some ((i ^ head) :: block (n + 2) body)
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when def_name name -> when def_name name ->
(* A parameter is a name, a destructuring vector, or & and the rest's
name, last. *)
let rec go = function
| [] -> Some []
| [ { Form.v = Form.Sym "&"; _ }; { Form.v = Form.Sym r; _ } ] when def_name r ->
Some [ "& " ^ r ]
| { Form.v = Form.Sym x; _ } :: rest when def_name x && x <> "&" ->
Option.map (fun r -> x :: r) (go rest)
| ({ Form.v = Form.Vec _; _ } as v) :: rest ->
Option.map (fun r -> fst (expr v) :: r) (go rest)
| _ -> None
in
Option.map
(fun pt ->
(i ^ "macro " ^ name ^ "(" ^ String.concat ", " pt ^ ")") :: block (n + 2) body)
(go ps)
| Form.List ({ v = Form.Sym (("defstruct" | "defunion") as d); _ }
:: { v = Form.Sym name; _ } :: rest)
when def_name name
&& (match d, rest with
| _, [ { v = Form.Vec _; _ } ] -> true
(* [(defstruct N :parent P [])] keeps the fallback: no field lines
reads as the form with no vector. *)
| "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ } ]
| "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ };
{ v = Form.Vec (_ :: _); _ } ] ->
def_name pn
| _ -> false) ->
let parent, fs =
match rest with
| [ { v = Form.Vec fs; _ } ] -> ("", fs)
| [ _; pf ] -> (" :parent " ^ ty pf, [])
| [ _; pf; { v = Form.Vec fs; _ } ] -> (" :parent " ^ ty pf, fs)
| _ -> assert false
in
(* One line when it fits, [struct Pt(x: i32, y: i32)], and a line per
field otherwise. *)
let one =
match fs, params_text fs with
| _ :: _, Some pt ->
let line =
i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ "(" ^ pt ^ ")" ^ parent
in
if String.length line <= width && not (!inside f) then Some [ line ] else None
| _ -> None
in
(match pairs fs with (match pairs fs with
| _ when one <> None -> one
| Some prs when List.for_all (fun ((f : Form.t), _) -> | Some prs when List.for_all (fun ((f : Form.t), _) ->
match f.v with Form.Sym x -> def_name x | _ -> false) prs -> match f.v with Form.Sym x -> def_name x | _ -> false) prs ->
Some Some
((i ^ (if d = "defstruct" then "struct " else "union ") ^ name) ((i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ parent)
:: List.map :: List.map
(fun ((f : Form.t), t) -> (fun ((f : Form.t), t) ->
let fname = fst (expr f) in let fname = fst (expr f) in
@ -1004,6 +1229,58 @@ and sugar n (f : Form.t) : string list option =
(ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t)) (ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t))
prs) prs)
| _ -> None) | _ -> None)
| Form.List [ { v = Form.Sym "defclass"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ss; _ } ]
when def_name name ->
(* A name, and the type after it when the next item is shaped like one:
read back, the slots are the same items in the same order. *)
let rec walk = function
| [] -> Some []
| ({ Form.v = Form.Sym x; _ } as xf) :: t :: rest when def_name x && type_shaped t ->
Option.map (fun r -> (xf, Some t) :: r) (walk rest)
| ({ Form.v = Form.Sym x; _ } as xf) :: rest when def_name x ->
Option.map (fun r -> (xf, None) :: r) (walk rest)
| _ -> None
in
let slots = walk ss in
Option.map
(fun sl ->
let one (x, t) =
fst (expr x) ^ match t with Some t -> ": " ^ ty t | None -> ""
in
let line = i ^ "class " ^ name ^ "(" ^ String.concat ", " (List.map one sl) ^ ")" in
if sl = [] then [ i ^ "class " ^ name ]
else if String.length line <= width && not (!inside f) then [ line ]
else
(i ^ "class " ^ name)
:: List.map (fun ((x : Form.t), t) ->
Source_text.tag x.loc.Loc.line (ind (n + 2) ^ one (x, t))) sl)
slots
| Form.List [ { v = Form.Sym "defgeneric"; _ }; { v = Form.Sym name; _ };
{ v = Form.Vec ps; _ }; r ]
when def_name name && List.for_all sym_param ps && not (is_sym "_" r) ->
Some [ i ^ "generic " ^ name ^ "(" ^ commas ps ^ ") -> " ^ ty r ]
| Form.List ({ v = Form.Sym "defmulti"; _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: r :: (_ :: _ as body))
when def_name name && List.for_all sym_param ps && not (is_sym "_" r) ->
Some (fn_like n f (i ^ "multi " ^ name ^ "(" ^ commas ps ^ ") -> " ^ ty r) body)
| Form.List ({ v = Form.Sym "defmethod"; _ } :: { v = Form.Sym name; _ } :: key
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when def_name name && List.for_all sym_param ps ->
(* A class written as the first parameter's type; any other value, and a
class with no parameter to hang it on, after when. *)
let head =
match key.v, ps with
| Form.Sym k, p0 :: rest when k <> "true" && k <> "false" && name_ok k ->
Some ("(" ^ fst (expr p0) ^ ": " ^ ty key
^ String.concat "" (List.map (fun p -> ", " ^ fst (expr p)) rest) ^ ")")
| (Form.Kw _ | Form.Str _ | Form.Int _ | Form.Sym _), _ ->
Some ("(" ^ commas ps ^ ") when " ^ at 9 key)
| _ -> None
in
Option.map (fun h -> fn_like n f (i ^ "method " ^ name ^ h) body) head
| Form.List [ { v = Form.Sym "defalias"; _ }; { v = Form.Sym name; _ }; t ]
when def_name name && type_shaped t ->
Some [ i ^ "type " ^ name ^ " = " ^ ty t ]
| Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ] | Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ]
when def_name name -> when def_name name ->
let case (c : Form.t) = let case (c : Form.t) =
@ -1044,6 +1321,19 @@ and sugar n (f : Form.t) : string list option =
and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false
(* A header and its body: [head = value] when the body is one value that
fits the line, else the block under it, as a [fn]'s. *)
and fn_like n (f : Form.t) head body =
match body with
| [ x ] when (match x.v with
| Form.List (({ v = Form.Sym h; _ } as hf) :: args) ->
not (List.mem h sugar_heads) && body_split hf args = None
| _ -> true)
&& String.length head + 3 + String.length (at 0 x) <= width
&& not (!inside f) ->
[ head ^ " = " ^ unit_text x ]
| _ -> head :: block (n + 2) body
and handler_clauses n cls = and handler_clauses n cls =
let clause (c : Form.t) = let clause (c : Form.t) =
match c.v with match c.v with
@ -1080,6 +1370,13 @@ and let_lines n prs body =
file's own macros are known and no imported package's. *) file's own macros are known and no imported package's. *)
let program ?source ?macros:m (fs : Form.t list) : string = let program ?source ?macros:m (fs : Form.t list) : string =
macros := (match m with Some m -> m | None -> Body_macros.table fs); macros := (match m with Some m -> m | None -> Body_macros.table fs);
classes :=
List.filter_map
(fun (f : Form.t) ->
match f.v with
| Form.List [ { v = Form.Sym "defclass"; _ }; { v = Form.Sym c; _ }; _ ] -> Some c
| _ -> None)
fs;
spelling := spelling :=
(match source with Some src -> Source_text.spelling src | None -> fun _ -> None); (match source with Some src -> Source_text.spelling src | None -> fun _ -> None);
let cs = match source with Some src -> Source_text.comments src | None -> [] in let cs = match source with Some src -> Source_text.comments src | None -> [] in
@ -1089,8 +1386,8 @@ let program ?source ?macros:m (fs : Form.t list) : string =
(fun (c : Source_text.comment) -> (fun (c : Source_text.comment) ->
f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline) f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline)
cs); cs);
(* A flat [let] at the top level would take in the forms after it, so one (* A [let] at the top level is a global, so a local one goes in a [do:]
that is not last goes in a [do:] block. *) block. *)
let top x = let top x =
Hashtbl.reset used; Hashtbl.reset used;
Hashtbl.reset made; Hashtbl.reset made;
@ -1099,7 +1396,6 @@ let program ?source ?macros:m (fs : Form.t list) : string =
in in
let rec go = function let rec go = function
| [] -> [] | [] -> []
| [ x ] -> [ (x, top x) ]
| x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest | x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest
in in
let text = let text =
@ -1108,6 +1404,7 @@ let program ?source ?macros:m (fs : Form.t list) : string =
in in
spelling := (fun _ -> None); spelling := (fun _ -> None);
inside := (fun _ -> false); inside := (fun _ -> false);
classes := [];
(* With the source, its comments go back where they were; without it the (* With the source, its comments go back where they were; without it the
tags come out and nothing goes in. *) tags come out and nothing goes in. *)
Source_text.weave ~starts:(Source_text.form_starts fs) Source_text.weave ~starts:(Source_text.form_starts fs)

View File

@ -261,35 +261,82 @@ let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol }
(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a (* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a
line break is whitespace. A line continues the one before it when either line break is whitespace. A line continues the one before it when either
side of the break is a spaced binary operator (spec §2 "Continuation"). *) side of the break is a spaced binary operator (spec §2 "Continuation").
The one exception is a lambda's block. A [=>] that ends its line inside
brackets opens a block there: the lines under it are laid out as they
would be at depth zero, against a base of their own (the column the [=>]
line starts at), until the bracket around the lambda closes. That closer
ends the block, whether it ends the block's last line or has a line of
its own. The block is the last thing in its brackets: a comma after it,
or a line back at the header's column, is refused. *)
type frame = {
f_base : int;
f_stack : int list;
f_opens : token list; (* the brackets open around the lambda *)
f_arrow : token; (* the [=>] that opened the block *)
}
let lambda_not_last (fr : frame) (t : token) =
failk "lambda-block-last" t.loc
"%s follows the block of the lambda on line %d, inside the same \
brackets. A lambda with a block is the last thing in its brackets, and \
its block ends where they close. Name the lambda with a let first and \
pass the name:\n\n\
\ let f = fn(a) =>\n ...\n g(f, x)"
(if t.tok = COMMA then "a comma" else show t.tok) fr.f_arrow.loc.Loc.line
let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token array = let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token array =
let arr = Array.of_list toks in let arr = Array.of_list toks in
let n = Array.length arr in let n = Array.length arr in
(* A snippet from the editor starts wherever it was written, and its first (* A snippet from the editor starts wherever it was written, and its first
line is its base: a later line may not go left of it. *) line is its base: a later line may not go left of it. One cut from the
let base = if snippet && n > 0 then arr.(0).loc.Loc.col else base in middle of a line (see [indent]) has that line's start as its base, so a
block under the line, a [let]'s [match] arms or a lambda's, reads as it
does in the file. *)
let base =
ref (if snippet && n > 0 then
match indent with
| Some c -> min c arr.(0).loc.Loc.col
| None -> arr.(0).loc.Loc.col
else base)
in
let out = ref [] in let out = ref [] in
let add tok loc = out := { tok; loc; sp = true } :: !out in let add tok loc = out := { tok; loc; sp = true } :: !out in
let stack = ref [ base ] in let stack = ref [ !base ] in
(* [indent] is the column of the statement a snippet was cut out of, when (* [indent] is the column of the statement a snippet was cut out of, when
the snippet starts after that statement's first word (an elif's the snippet starts after that statement's first word (an elif's
condition, an arm's value). Its first joined line continues as it does condition, an arm's value). Its first joined line continues as it does
in the file: deeper than the statement, not than the cut. *) in the file: deeper than the statement, not than the cut. *)
let first_line = ref true in let first_line = ref true in
let depth = ref 0 in (* The brackets open in the current layout, innermost first. A lambda's
block starts with none, and [frames] holds what it interrupted. *)
let opens = ref [] in
let frames = ref [] in
let binop t = match t.tok with NAME s -> is_binop s | _ -> false in let binop t = match t.tok with NAME s -> is_binop s | _ -> false in
let closer t = match t.tok with RP | RB | RC -> true | _ -> false in
(* The column [i]'s line starts at. *)
let line_col i =
let rec go j =
if j > 0 && arr.(j - 1).loc.Loc.eline = arr.(i).loc.Loc.line then go (j - 1) else j
in
arr.(go i).loc.Loc.col
in
for i = 0 to n - 1 do for i = 0 to n - 1 do
let t = arr.(i) in let t = arr.(i) in
(if i = 0 then begin (if i = 0 then begin
if t.loc.Loc.col <> base then if t.loc.Loc.col <> !base && indent = None then
failk "unexpected-indent" t.loc failk "unexpected-indent" t.loc
"the first line starts at column %d, and a file's top-level lines \ "the first line starts at column %d, and a file's top-level lines \
start at column %d. Remove the indentation" start at column %d. Remove the indentation"
t.loc.Loc.col base t.loc.Loc.col !base
end end
else else
let p = arr.(i - 1) in let p = arr.(i - 1) in
if !depth = 0 && t.loc.Loc.line > p.loc.Loc.eline then begin (* The closer that ends a lambda's block takes the block's end with
it, below: the line break before it is nothing. *)
let ends_block = !frames <> [] && !opens = [] && closer t in
if !opens = [] && t.loc.Loc.line > p.loc.Loc.eline && not ends_block then begin
let spaced_after = let spaced_after =
i + 1 < n && arr.(i + 1).loc.Loc.line = t.loc.Loc.line i + 1 < n && arr.(i + 1).loc.Loc.line = t.loc.Loc.line
&& arr.(i + 1).sp && arr.(i + 1).sp
@ -324,15 +371,33 @@ let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token ar
if not continues then begin if not continues then begin
first_line := false; first_line := false;
let at = point p.loc in let at = point p.loc in
add NEWLINE at;
let col = t.loc.Loc.col in let col = t.loc.Loc.col in
(* Inside a lambda's brackets, a line at or left of the line its
header is on would be a statement beside the lambda. *)
(match !frames with
(* Left of the block's own column, after the block: the next
element of the brackets, which the block must end. *)
| fr :: _ when List.length !stack > 1
&& col < List.nth !stack (List.length !stack - 2) ->
lambda_not_last fr t
| fr :: _ when col <= !base ->
if t.tok = COMMA then lambda_not_last fr t
else
failk "lambda-block-left" t.loc
"this line starts at column %d and is still inside the \
brackets of the lambda on line %d, whose block is indented \
past column %d. Indent it into the block, or close the \
brackets at the end of the block's last line"
col fr.f_arrow.loc.Loc.line !base
| _ -> ());
add NEWLINE at;
let top = List.hd !stack in let top = List.hd !stack in
if col > top then begin if col > top then begin
stack := col :: !stack; stack := col :: !stack;
add INDENT at add INDENT at
end end
else if col < top then begin else if col < top then begin
if col < base then if col < !base then
failk "dedent" t.loc failk "dedent" t.loc
"%s" "%s"
(if snippet then (if snippet then
@ -342,11 +407,11 @@ let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token ar
edge, and no later line can go left of it: send the \ edge, and no later line can go left of it: send the \
enclosing form, or line this up at column %d or right \ enclosing form, or line this up at column %d or right \
of it" of it"
col base base col !base !base
else else
Printf.sprintf Printf.sprintf
"this line starts at column %d, left of the top level at \ "this line starts at column %d, left of the top level at \
column %d" col base); column %d" col !base);
let closed = ref top in let closed = ref top in
let rec pop () = let rec pop () =
match !stack with match !stack with
@ -368,12 +433,46 @@ let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token ar
end end
end end
end); end);
(match !frames with
(* A comma at the top of a lambda's block, on one of the block's lines. *)
| fr :: _ when !opens = [] && t.tok = COMMA -> lambda_not_last fr t
(* The closer of the brackets a lambda's block is in: the block ends. *)
| fr :: rest when !opens = [] && closer t ->
let at = point arr.(i - 1).loc in
add NEWLINE at;
List.iter (fun _ -> add DEDENT at) (List.tl !stack);
base := fr.f_base;
stack := fr.f_stack;
opens := fr.f_opens;
frames := rest
| _ -> ());
out := t :: !out; out := t :: !out;
(match t.tok with (match t.tok with
| LP | LB | LC -> incr depth | LP | LB | LC -> opens := t :: !opens
| RP | RB | RC -> if !depth > 0 then decr depth | RP | RB | RC -> (match !opens with _ :: r -> opens := r | [] -> ())
| NAME "=>" when !opens <> [] && i + 1 < n
&& arr.(i + 1).loc.Loc.line > t.loc.Loc.eline ->
frames := { f_base = !base; f_stack = !stack; f_opens = !opens; f_arrow = t }
:: !frames;
(* A snippet cut from the middle of a line starts where its line
does in the file, [indent], not where the cut does. *)
base :=
(match indent with
| Some c when t.loc.Loc.line = arr.(0).loc.Loc.line -> min c (line_col i)
| _ -> line_col i);
stack := [ !base ];
opens := []
| _ -> ()) | _ -> ())
done; done;
(match !frames with
| fr :: _ ->
let o = match fr.f_opens with o :: _ -> o | [] -> fr.f_arrow in
failk "unclosed" o.loc
~notes:[ Loc.note (point arr.(n - 1).loc) "the input ends here, still inside it" ]
"unclosed %s: the block of the lambda on line %d ends where this \
bracket closes"
(show o.tok) fr.f_arrow.loc.Loc.line
| [] -> ());
(if n > 0 then (if n > 0 then
let at = point arr.(n - 1).loc in let at = point arr.(n - 1).loc in
add NEWLINE at; add NEWLINE at;
@ -384,11 +483,17 @@ let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token ar
(* ── Parsing ───────────────────────────────────────────────────────── *) (* ── Parsing ───────────────────────────────────────────────────────── *)
type p = { toks : token array; mutable i : int } (* [closed] is where a lambda's block that ended its statement stopped:
the block took the line's end with it, so a check for that end passes
there. *)
type p = { toks : token array; mutable i : int; mutable closed : int }
(* Set below [params] and [ty], which the expression parser comes before. *) (* Set below [params] and [ty], which the expression parser comes before. *)
let typed_fn_expr : (p -> Form.t * int) ref = ref (fun _ -> assert false) let typed_fn_expr : (p -> Form.t * int) ref = ref (fun _ -> assert false)
(* A block's statements, for a lambda's; set once the statement parser is. *)
let block_of : (p -> Form.t list) ref = ref (fun _ -> assert false)
let peek p = p.toks.(p.i) let peek p = p.toks.(p.i)
let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1)) let peek_at p k = p.toks.(min (p.i + k) (Array.length p.toks - 1))
let advance p = let advance p =
@ -487,6 +592,7 @@ let expect_name p s ~what =
(* The end of a line that is not followed by a block. *) (* The end of a line that is not followed by a block. *)
let expect_eol p ~after = let expect_eol p ~after =
if p.i = p.closed then () else
match (peek p).tok with match (peek p).tok with
| NEWLINE -> | NEWLINE ->
ignore (advance p); ignore (advance p);
@ -637,7 +743,7 @@ and postfix p =
loop (mk p l0 (Form.List (f :: args)), 9) loop (mk p l0 (Form.List (f :: args)), 9)
| LB -> | LB ->
ignore (advance p); ignore (advance p);
let idx = items p RB t.loc ~what:"indices" in let idx = items p RB t.loc ~what:"indices" ~head:(text_of f) in
loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9) loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9)
| NAME s when String.length s > 1 && s.[0] = '.' -> | NAME s when String.length s > 1 && s.[0] = '.' ->
ignore (advance p); ignore (advance p);
@ -785,36 +891,83 @@ and inline_stmt p : Form.t =
mk p t.loc (compound eq.loc (List.assoc op assign_ops) e v (span p e.loc)) mk p t.loc (compound eq.loc (List.assoc op assign_ops) e v (span p e.loc))
| _ -> unit_slot p i0 t e | _ -> unit_slot p i0 t e
(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the (* [fn(a, b) => body] is a lambda; [fn(...)] followed by anything else is the
fallback call spelling of [(fn ...)]. *) fallback call spelling of [(fn ...)]. *)
and fn_expr p = and fn_expr p =
if typed_lambda p then !typed_fn_expr p else if typed_lambda p then !typed_fn_expr p else
let t = advance p in let t = advance p in
let lp = advance p in let lp = advance p in
let args = items p RP lp.loc ~what:"parameters" in let args = items p RP lp.loc ~what:"parameters" in
match (peek p).tok with let rp = last p in
| NAME "=" -> let names = List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args in
let header () = "fn(" ^ String.concat ", " (List.map text_of args) ^ ")" in
let n = peek p in
match n.tok with
| NAME "=>" ->
ignore (advance p); ignore (advance p);
let ps = lambda_params args in let ps = lambda_params args in
let i0 = p.i and t0 = peek p in let body = lambda_body p ~header:(header ()) in
let body, _ = expr p in
let body = unit_slot p i0 t0 body in
(mk p t.loc (mk p t.loc
(Form.List (Form.List
[ sym t.loc "fn"; Form.make (Form.Vec ps) (span_of_list lp.loc args); body ]), (sym t.loc "fn" :: Form.make (Form.Vec ps) (span_of_list lp.loc args) :: body)),
0) 0)
| NAME "=" when names -> lambda_equals p (header ())
| NAME w when names && glued_arrow w -> lambda_glued n (header ()) w
| NEWLINE when names && (peek_at p 1).tok = INDENT ->
lambda_arrow (peek_at p 2).loc (header ())
(* Inside brackets a line break is no token: the next line's first token
is what follows. *)
| tk when names && n.loc.Loc.line > rp.loc.Loc.eline && starts_value tk ->
lambda_arrow n.loc (header ())
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9) | _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9)
(* A lambda with a block written inside a call's brackets, where no block can (* What follows a lambda's [=>]: a value on the line, or the indented block
open. The fix shown is the typed form, since a lambda bound by [let] has under it. [header] is the lambda's header as written, for a message. *)
no call to take its types from; [header] is [fn(a: T) -> R] or the and lambda_body p ~header =
header as written. *) match (peek p).tok, (peek_at p 1).tok with
and lambda_in_brackets : 'a. Loc.t -> string -> 'a = fun at header -> | NEWLINE, INDENT ->
failk "lambda-block-in-brackets" at ignore (advance p);
"a lambda's block cannot go inside brackets, where a line break is only \ let body = !block_of p in
a space. Name it first, with its types and the block under it:\n\n\ p.closed <- p.i;
\ let f = %s\n ...\n\n\ body
and pass f, or write it on one line: %s = value" | (NEWLINE | EOF | DEDENT), _ ->
failk "lambda-body" (where_ p)
"the line ends after %s =>, and the lambda's body is not under it. Put \
the body after the =>, or on the lines under it, indented:\n\n\
\ %s =>\n ..."
header header
| _ ->
let i0 = p.i and t0 = peek p in
let body, _ = expr p in
[ unit_slot p i0 t0 body ]
(* [fn(a) = x]: a lambda written with a named function's [=]. *)
and lambda_equals : 'a. p -> string -> 'a = fun p header ->
let eq = advance p in
let body =
match expr p with
| b, _ -> text_of b
| exception _ -> "..."
in
failk "lambda-equals" eq.loc
"a lambda's body follows =>, and this one has =, which is how a named \
function is written. Write:\n\n %s => %s"
header body
(* [fn(a) =>x]: the body glued to the arrow reads as one name. *)
and glued_arrow w = String.length w > 2 && String.sub w 0 2 = "=>"
and lambda_glued : 'a. token -> string -> string -> 'a = fun t header w ->
failk "lambda-arrow-space" t.loc
"%s is one name, with nothing between => and the body. Put a space \
after the arrow: %s => %s"
w header (String.sub w 2 (String.length w - 2))
(* A lambda header with lines under it and no [=>]. *)
and lambda_arrow : 'a. Loc.t -> string -> 'a = fun at header ->
failk "lambda-arrow" at
"the lines under %s are a lambda's body only after =>. End the header \
with it:\n\n %s =>\n ..."
header header header header
(* Whether the [fn(] at point has a [:] among its parameters or a [->] (* Whether the [fn(] at point has a [:] among its parameters or a [->]
@ -852,7 +1005,8 @@ and lambda_params args =
(* Comma-separated values up to [closer]. [const T] is two elements without a (* Comma-separated values up to [closer]. [const T] is two elements without a
comma, for [Ptr(const u8)]: const is a reserved word in a type and never a comma, for [Ptr(const u8)]: const is a reserved word in a type and never a
value. *) value. *)
and items p closer open_loc ~what = (* [head] is the text of what is indexed, for [[ ]]'s message. *)
and items ?head p closer open_loc ~what =
let opener = if closer = RB then '[' else '(' in let opener = if closer = RB then '[' else '(' in
let rec go acc = let rec go acc =
let t = peek p in let t = peek p in
@ -871,22 +1025,7 @@ and items p closer open_loc ~what =
| EOF -> unclosed p opener open_loc | EOF -> unclosed p opener open_loc
| _ -> | _ ->
let n = peek p in let n = peek p in
let block_lambda = if starts_value n.tok && n.sp && not (negative_literal n.tok)
match e.v with
| Form.List ({ v = Form.Sym "fn"; _ } :: ps) ->
List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) ps
&& n.loc.Loc.line > e.loc.Loc.eline
| _ -> false
in
if block_lambda then
let names =
match e.v with
| Form.List (_ :: ps) -> List.map text_of ps
| _ -> []
in
lambda_in_brackets n.loc
("fn(" ^ String.concat ", " (List.map (fun x -> x ^ ": T") names) ^ ") -> R")
else if starts_value n.tok && n.sp && not (negative_literal n.tok)
&& n.loc.Loc.line > e.loc.Loc.eline then && n.loc.Loc.line > e.loc.Loc.eline then
(* Most often the bracket was never closed: the next statement (* Most often the bracket was never closed: the next statement
has been read as one more argument. *) has been read as one more argument. *)
@ -898,8 +1037,11 @@ and items p closer open_loc ~what =
else if starts_value n.tok && n.sp && not (negative_literal n.tok) then else if starts_value n.tok && n.sp && not (negative_literal n.tok) then
failk "missing-comma" n.loc failk "missing-comma" n.loc
"%s follows %s with no comma between them. Separate %s with \ "%s follows %s with no comma between them. Separate %s with \
commas: f(a, b)" commas: %s"
(show n.tok) (text_of e) what (show n.tok) (text_of e) what
(match head with
| Some h -> Printf.sprintf "%s[%s, %s]" h (text_of e) (show n.tok)
| None -> "f(a, b)")
else stray p ~after:(text_of e)) else stray p ~after:(text_of e))
in in
go [] go []
@ -1042,14 +1184,15 @@ let blk (s : st) l (ss : Form.t list) =
| (first : Form.t) :: _ -> mk s.p first.loc (Form.List (sym first.loc "do" :: ss)) | (first : Form.t) :: _ -> mk s.p first.loc (Form.List (sym first.loc "do" :: ss))
| [] -> mk s.p l (Form.List [ sym l "do" ]) | [] -> mk s.p l (Form.List [ sym l "do" ])
let is_lambda_candidate (e : Form.t) = (* The word at the head of the line is a variable being assigned, [data = 3]
match e.v with or [on += 1], whatever else it could start. *)
| Form.List ({ v = Form.Sym "fn"; _ } :: args) -> let assigns p =
List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args let n = peek_at p 1 in
| _ -> false n.sp && (match n.tok with NAME x -> x = "=" || List.mem_assoc x assign_ops | _ -> false)
let header_follow p s = let header_follow p s =
let n = peek_at p 1 in let n = peek_at p 1 in
(not (assigns p)) &&
let plain_name = function let plain_name = function
| NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops) | NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops)
| _ -> false | _ -> false
@ -1066,6 +1209,26 @@ let header_follow p s =
let a = peek_at p 2 in let a = peek_at p 2 in
a.tok = LP && not a.sp a.tok = LP && not a.sp
| _ -> true) | _ -> true)
(* [macro name(...)]: the name and its glued parenthesis. *)
| "macro" ->
n.sp && plain_name n.tok
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
(* [class Lambda(...)] or [class Lambda] over its slot lines. *)
| "class" -> n.sp && plain_name n.tok
(* [generic describe(v)], [multi kind(v)], [method describe(f: C)]: the
name and its glued parenthesis. *)
| "generic" | "multi" | "method" ->
n.sp && plain_name n.tok
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
(* [type Row = Vec(i32)]: a name and its [=]. *)
| "type" -> n.sp && plain_name n.tok && (peek_at p 2).tok = NAME "="
(* [loop x = a, ...]: a name and its [=]. A name and a comma or the end
of the line, or [loop] alone over a block, is a loop missing its first
values, which [header] answers. *)
| "loop" ->
(n.sp && plain_name n.tok
&& (match (peek_at p 2).tok with NAME "=" | COMMA | NEWLINE -> true | _ -> false))
|| (n.tok = NEWLINE && (peek_at p 2).tok = INDENT)
| "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok) | "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok)
| "break" | "continue" -> | "break" | "continue" ->
n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
@ -1122,11 +1285,32 @@ let params p (lp : token) =
in in
go [] go []
(* [fn(a: C, b) -> R = body] is [(the (Fn [C dyn] R) (fn [a b] body))]: the (* [(a, b: T)] as each name and its type when one is written. *)
let named_params p (lp : token) =
let rec go acc =
let t = peek p in
match t.tok with
| RP -> ignore (advance p); List.rev acc
| EOF -> unclosed p '(' lp.loc
| _ ->
let n = name_tok p ~what:"a parameter's name" in
let tyf =
match (peek p).tok with
| COLON -> ignore (advance p); Some (ty p)
| _ -> None
in
(match (peek p).tok with
| COMMA -> ignore (advance p)
| RP -> ()
| _ -> stray p ~after:(text_of (match tyf with Some t -> t | None -> n)));
go ((n, tyf) :: acc)
in
go []
(* [fn(a: C, b) -> R => body] is [(the (Fn [C dyn] R) (fn [a b] body))]: the
paren [fn] takes its parameters' types from where it is written, and [the] paren [fn] takes its parameters' types from where it is written, and [the]
is the form that says what a value is, as in [let x: T = v]. An untyped is the form that says what a value is, as in [let x: T = v]. An untyped
parameter is dyn, as in a definition, and the return type is required. A parameter is dyn, as in a definition, and the return type is required. *)
block body is added by [lambda_block]. *)
let () = typed_fn_expr := fun p -> let () = typed_fn_expr := fun p ->
let t = advance p in let t = advance p in
let lp = advance p in let lp = advance p in
@ -1136,18 +1320,22 @@ let () = typed_fn_expr := fun p ->
| _ -> ([], []) | _ -> ([], [])
in in
let names, tys = split ps in let names, tys = split ps in
let params_text () =
String.concat ", "
(List.map2 (fun n (ty : Form.t) ->
if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty)
names tys)
in
let r = let r =
match (peek p).tok with match (peek p).tok with
| NAME "->" -> ignore (advance p); ty p | NAME "->" -> ignore (advance p); ty p
| _ -> | _ ->
failk "lambda-return" (where_ p) failk "lambda-return" (where_ p)
"a lambda that states its parameters' types states its return type \ "a lambda that states its parameters' types states its return type \
too: fn(%s) -> R = value" too: fn(%s) -> R => value"
(String.concat ", " (params_text ())
(List.map2 (fun n (ty : Form.t) ->
if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty)
names tys))
in in
let header () = "fn(" ^ params_text () ^ ") -> " ^ text_of r in
let fty = mk p lp.loc (Form.List [ sym t.loc "Fn"; Form.make (Form.Vec tys) lp.loc; r ]) in let fty = mk p lp.loc (Form.List [ sym t.loc "Fn"; Form.make (Form.Vec tys) lp.loc; r ]) in
let vec = Form.make (Form.Vec names) lp.loc in let vec = Form.make (Form.Vec names) lp.loc in
let wrap body = let wrap body =
@ -1155,26 +1343,21 @@ let () = typed_fn_expr := fun p ->
mk p t.loc (Form.List (sym t.loc "fn" :: vec :: body)) ]) mk p t.loc (Form.List (sym t.loc "fn" :: vec :: body)) ])
in in
match (peek p).tok with match (peek p).tok with
| NAME "=" -> | NAME "=>" ->
ignore (advance p); ignore (advance p);
let i0 = p.i and t0 = peek p in let body = lambda_body p ~header:(header ()) in
let body, _ = expr p in (wrap body, 0)
(wrap [ unit_slot p i0 t0 body ], 0) | NAME "=" -> lambda_equals p (header ())
| NEWLINE when (peek_at p 1).tok = INDENT -> (wrap [], 0) | NAME w when glued_arrow w -> lambda_glued (peek p) (header ()) w
| NEWLINE when (peek_at p 1).tok = INDENT -> lambda_arrow (peek_at p 2).loc (header ())
(* Inside brackets a line break is no token: the next line's first token (* Inside brackets a line break is no token: the next line's first token
is what follows. *) is what follows. *)
| tk when (peek p).loc.Loc.line > (last p).loc.Loc.eline && tk <> EOF -> | tk when (peek p).loc.Loc.line > (last p).loc.Loc.eline && tk <> EOF ->
let header = lambda_arrow (peek p).loc (header ())
"fn(" ^ String.concat ", "
(List.map2 (fun n (ty : Form.t) ->
if ty.v = Form.Sym "dyn" then text_of n else text_of n ^ ": " ^ text_of ty)
names tys)
^ ") -> " ^ text_of r
in
lambda_in_brackets (peek p).loc header
| _ -> | _ ->
failk "lambda-body" (where_ p) failk "lambda-body" (where_ p)
"a lambda's body follows = on its line, or is the block under it" "a lambda's body follows => on its line, or is the block under it: \
%s => value" (header ())
let rec stmts (s : st) : Form.t list = let rec stmts (s : st) : Form.t list =
let p = s.p in let p = s.p in
@ -1209,7 +1392,7 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t =
match (peek p).tok with match (peek p).tok with
(* [let r = match a] with its arms under it, and [let r = if c] with its (* [let r = match a] with its arms under it, and [let r = if c] with its
branches: a header read as the value, block and all. *) branches: a header read as the value, block and all. *)
| NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w) | NAME (("match" | "handler-case" | "handler-bind" | "restart-case" | "loop") as w)
when header_follow p w -> when header_follow p w ->
header s w header s w
| NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if" | NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if"
@ -1249,33 +1432,13 @@ and then_on_line p =
in in
go 1 0 go 1 0
(* The end of a statement's line, which a lambda's block may already have
taken. *)
and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after = and lambda_block ?(block_ok = false) (s : st) (e : Form.t) ~after =
let p = s.p in let p = s.p in
match e.v with if block_ok && p.i <> p.closed && (peek p).tok = NEWLINE then ignore (advance p)
(* A typed lambda waiting for its block, from [typed_fn_expr]. *)
| Form.List [ ({ v = Form.Sym "the"; _ } as th); fty;
({ v = Form.List [ ({ v = Form.Sym "fn"; _ } as fh); ({ v = Form.Vec _; _ } as vec) ]; _ } as fn_) ]
when (peek p).tok = NEWLINE && (peek_at p 1).tok = INDENT ->
ignore (advance p);
let body = block s ~after in
mk p e.loc (Form.List [ th; fty; { fn_ with v = Form.List (fh :: vec :: body) } ])
| _ ->
if is_lambda_candidate e && (last p).tok = RP && (peek p).tok = NEWLINE
&& (peek_at p 1).tok = INDENT
then begin
ignore (advance p);
let body = block s ~after in
match e.v with
| Form.List (h :: args) ->
mk p e.loc
(Form.List (h :: Form.make (Form.Vec args) (span_of_list e.loc args) :: body))
| _ -> assert false
end
else begin
if block_ok && (peek p).tok = NEWLINE then ignore (advance p)
else expect_eol p ~after; else expect_eol p ~after;
e e
end
and let_stmt (s : st) : Form.t list = and let_stmt (s : st) : Form.t list =
let p = s.p in let p = s.p in
@ -1331,6 +1494,7 @@ and stmt (s : st) : Form.t =
let t = peek p in let t = peek p in
match t.tok with match t.tok with
| NAME w when header_follow p w -> header s w | NAME w when header_follow p w -> header s w
| NAME _ when assigns p -> expr_stmt s
| NAME (("else" | "elif") as w) when else_if_above p t -> | NAME (("else" | "elif") as w) when else_if_above p t ->
failk "orphan-else" t.loc failk "orphan-else" t.loc
"the else above took the one-line if after it as its value, so this %s \ "the else above took the one-line if after it as its value, so this %s \
@ -1473,6 +1637,9 @@ and header (s : st) w : Form.t =
named (if w = "fn" then "defn" else "defn-") named (if w = "fn" then "defn" else "defn-")
(name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)) (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body))
| "def" | "once" | "const" -> | "def" | "once" | "const" ->
(* A top-level [let] is read here too, as [def]: [w] is then "def" and
[t] the let. *)
let shown = match t.tok with NAME "let" -> "let" | _ -> w in
let name = name_tok p ~what:"the name being defined" in let name = name_tok p ~what:"the name being defined" in
let tyf = let tyf =
match (peek p).tok with match (peek p).tok with
@ -1483,7 +1650,7 @@ and header (s : st) w : Form.t =
match (peek p).tok with match (peek p).tok with
| NAME "=" -> | NAME "=" ->
ignore (advance p); ignore (advance p);
Some (value_line s ~after:(w ^ " " ^ text_of name ^ " =")) Some (value_line s ~after:(shown ^ " " ^ text_of name ^ " ="))
| _ -> | _ ->
expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name); expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name);
None None
@ -1491,6 +1658,18 @@ and header (s : st) w : Form.t =
let head = let head =
match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst" match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst"
in in
if shown = "def" then
failk "def-is-let" l0
"a global is written with let, at the file's top level:\n\n let %s%s%s"
(text_of name)
(match tyf, v with
| Some t, _ -> ": " ^ text_of t
| None, None -> ": i32"
| None, Some _ -> "")
(match v, tyf with
| Some v, _ -> " = " ^ text_of v
| None, None -> " = 0"
| None, Some _ -> "");
let items = let items =
match w, tyf, v with match w, tyf, v with
| "const", None, Some v -> [ name; v ] | "const", None, Some v -> [ name; v ]
@ -1505,13 +1684,39 @@ and header (s : st) w : Form.t =
failk "def-empty" l0 failk "def-empty" l0
"%s %s names neither a type nor a value. Give it one or both: %s %s: \ "%s %s names neither a type nor a value. Give it one or both: %s %s: \
i32 = 0" i32 = 0"
w (text_of name) w (text_of name) shown (text_of name) shown (text_of name)
in in
named head items named head items
| "struct" | "union" -> | "struct" | "union" ->
let name = name_tok p ~what:"the type's name" in let name = name_tok p ~what:"the type's name" in
expect_eol_block p ~after:(w ^ " " ^ text_of name); (* [struct Pt(x: i32, y: i32)]: the fields on the header's line, as a
data case writes them, with no block under it. *)
let inline =
match (peek p).tok with
| LP when not (peek p).sp -> let lp = advance p in Some (params p lp)
| _ -> None
in
(* [struct DiskFull :parent IoError]: a condition's parent, before the
fields as in the paren form. *)
let parent =
match (peek p).tok with
| KW "parent" when w = "struct" ->
let kt = advance p in
let pt = ty p in
Some (Form.make (Form.Kw "parent") kt.loc, pt)
| _ -> None
in
let after =
match parent, inline with
| Some (_, pt), _ -> text_of pt
| None, Some _ -> ")"
| None, None -> w ^ " " ^ text_of name
in
let fields = let fields =
match inline with
| Some fs -> expect_eol p ~after; fs
| None ->
expect_eol_block p ~after;
lines s (fun () -> lines s (fun () ->
let f = name_tok p ~what:"a field's name" in let f = name_tok p ~what:"a field's name" in
let tf = let tf =
@ -1522,8 +1727,196 @@ and header (s : st) w : Form.t =
expect_eol p ~after:(text_of tf); expect_eol p ~after:(text_of tf);
[ f; tf ]) [ f; tf ])
in in
let fv = Form.make (Form.Vec fields) (span p name.loc) in
(* No field lines under a parent is the category form, which has no
field vector. *)
named (if w = "struct" then "defstruct" else "defunion") named (if w = "struct" then "defstruct" else "defunion")
[ name; Form.make (Form.Vec fields) (span p name.loc) ] (match parent with
| None -> [ name; fv ]
| Some (k, pt) -> name :: k :: pt :: (if fields = [] then [] else [ fv ]))
| "class" ->
let name = name_tok p ~what:"the class's name" in
let ps =
match (peek p).tok with
| LP when not (peek p).sp ->
let lp = advance p in
let ps = named_params p lp in
expect_eol p ~after:")";
ps
| _ ->
expect_eol_block p ~after:("class " ^ text_of name);
let acc = ref [] in
ignore
(lines s (fun () ->
let f = name_tok p ~what:"a slot's name" in
let t =
match (peek p).tok with
| COLON -> ignore (advance p); Some (ty p)
| _ -> None
in
expect_eol p ~after:(match t with Some t -> text_of t | None -> text_of f);
acc := (f, t) :: !acc;
[]));
List.rev !acc
in
(* Each slot's name, and its type after it when one is written: the
paren form's [(defclass c [a b n i32])], whose untyped slots are dyn. *)
let slots =
List.concat_map (fun (n, t) -> match t with Some t -> [ n; t ] | None -> [ n ]) ps
in
named "defclass" [ name; Form.make (Form.Vec slots) (span p name.loc) ]
| "generic" | "multi" | "method" ->
let name = name_tok p ~what:(Printf.sprintf "the %s's name" w) in
let lp = advance p in
let ps = named_params p lp in
(* A method's first parameter may name the class it answers for; every
other parameter of these is dyn, so it takes no type. *)
let names = String.concat ", " (List.map (fun ((n : Form.t), _) -> text_of n) ps) in
let first = match ps with (n, _) :: _ -> text_of n | [] -> "v" in
let first_class = ref None in
List.iteri
(fun k ((n : Form.t), t) ->
match t with
| Some (tf : Form.t) when k = 0 && w = "method" -> first_class := Some tf
| Some tf ->
failk "dyn-parameter" tf.loc
"every parameter of a %s is dyn, so %s takes no type: write %s %s(%s)%s"
w (text_of n) w (text_of name)
(String.concat ", "
(List.mapi
(fun k ((n : Form.t), t) ->
match t with
| Some t when k = 0 && w = "method" -> text_of n ^ ": " ^ text_of t
| _ -> text_of n)
ps))
(if w = "method" then "" else " -> dyn")
| None -> ())
ps;
let pv = Form.make (Form.Vec (List.map fst ps)) (span p lp.loc) in
let ret () =
match (peek p).tok with
| NAME "->" -> ignore (advance p); ty p
| _ ->
(* At the end of the header's line, where the arrow goes. *)
let e = (last p).loc in
failk "generic-return"
{ e with Loc.line = e.Loc.eline; col = e.Loc.ecol }
"a %s states the type every method returns: %s %s(%s) -> dyn"
w w (text_of name) names
in
let body ~after ~prev =
match (peek p).tok with
| NAME "=" ->
ignore (advance p);
[ value_line s ~after:"=" ]
| NEWLINE ->
ignore (advance p);
block s ~after
| _ -> stray p ~after:prev
in
(match w with
| "generic" ->
let r = ret () in
expect_eol p ~after:(text_of r);
named "defgeneric" [ name; pv; r ]
| "multi" ->
let r = ret () in
named "defmulti"
(name :: pv :: r :: body ~after:("multi " ^ text_of name ^ "(...)") ~prev:(text_of r))
| _ ->
let key =
match (peek p).tok, !first_class with
| NAME "when", Some tf ->
failk "method-key" (peek p).loc
"this method already answers for %s, its first parameter's type. \
Write the type or the when, not both"
(text_of tf)
| NAME "when", None ->
ignore (advance p);
fst (unary p)
| _, Some tf -> tf
| _, None ->
failk "method-key" (where_ p)
"a method says what it answers for: a class as its first \
parameter's type, method %s(%s: point), or a value after when, \
method %s(%s) when :int"
(text_of name) first (text_of name) names
in
named "defmethod"
(name :: key :: pv
:: body ~after:("method " ^ text_of name ^ "(...)")
~prev:(if !first_class = None then text_of key else ")")))
| "type" ->
let name = name_tok p ~what:"the alias's name" in
expect_name p "=" ~what:"= and the type it names";
let t = ty p in
expect_eol p ~after:(text_of t);
named "defalias" [ name; t ]
| "macro" ->
let name = name_tok p ~what:"the macro's name" in
let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in
let rec go acc =
let t = peek p in
match t.tok with
| RP -> ignore (advance p); List.rev acc
| EOF -> unclosed p '(' lp.loc
| _ ->
let one =
match t.tok with
| NAME "&" ->
ignore (advance p);
[ name_tok p ~what:"the rest parameter's name after &"; sym t.loc "&" ]
| LB -> [ fst (primary p) ]
| _ -> [ name_tok p ~what:"a parameter's name" ]
in
(match (peek p).tok with
| COMMA -> ignore (advance p)
| RP -> ()
| _ -> stray p ~after:(text_of (List.hd one)));
go (one @ acc)
in
let ps = go [] in
let n = List.length ps in
List.iteri
(fun k (a : Form.t) ->
if a.v = Form.Sym "&" && k < n - 2 then begin
let r = List.nth ps (k + 1) in
let others = List.filteri (fun j _ -> j <> k && j <> k + 1) ps in
failk "macro-rest-last" a.loc
"& %s takes the arguments left over, so it comes last: macro %s(%s)"
(text_of r) (text_of name)
(String.concat ", " (List.map text_of others @ [ "& " ^ text_of r ]))
end)
ps;
let pv = Form.make (Form.Vec ps) (span p lp.loc) in
expect_line_end p ~after:")";
let body = block s ~after:("macro " ^ text_of name ^ "(...)") in
named "defmacro" (name :: pv :: body)
| "loop" ->
let missing () =
failk "loop-bindings" l0
"loop names each variable with its first value: loop i = 0, acc = 1. \
A loop with no variables is written loop([]):"
in
if (peek p).tok = NEWLINE then missing ();
let rec binds acc =
let n = name_tok p ~what:"a loop variable's name" in
(match (peek p).tok with
| NAME "=" -> ignore (advance p)
| _ ->
failk "loop-bindings" n.loc
"%s needs its first value: loop %s = 0. Each variable of a loop \
takes one, separated by commas: loop i = 0, acc = 1"
(text_of n) (text_of n));
let v, _ = expr p in
match (peek p).tok with
| COMMA -> ignore (advance p); binds (v :: n :: acc)
| _ -> List.rev (v :: n :: acc)
in
let bs = binds [] in
expect_line_end p ~after:(text_of (List.nth bs (List.length bs - 1)));
let body = block s ~after:"loop" in
form (Form.make (Form.Vec bs) (span_of_list (List.hd bs).loc bs) :: body)
| "data" -> | "data" ->
let name = name_tok p ~what:"the type's name" in let name = name_tok p ~what:"the type's name" in
expect_eol_block p ~after:("data " ^ text_of name); expect_eol_block p ~after:("data " ^ text_of name);
@ -1578,7 +1971,7 @@ and header (s : st) w : Form.t =
let clauses ~oneline body = let clauses ~oneline body =
let rec elifs acc = let rec elifs acc =
match (peek p).tok with match (peek p).tok with
| NAME "elif" -> | NAME "elif" when not (assigns p) ->
ignore (advance p); ignore (advance p);
let c, _ = binary p 1 in let c, _ = binary p 1 in
(match (peek p).tok with (match (peek p).tok with
@ -1600,7 +1993,7 @@ and header (s : st) w : Form.t =
let els_ = elifs [] in let els_ = elifs [] in
let else_ = let else_ =
match (peek p).tok with match (peek p).tok with
| NAME "else" -> | NAME "else" when not (assigns p) ->
let et = advance p in let et = advance p in
(match (peek p).tok with (match (peek p).tok with
| NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else") | NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else")
@ -1748,7 +2141,7 @@ and header (s : st) w : Form.t =
let body = block s ~after:w in let body = block s ~after:w in
let rec clauses acc = let rec clauses acc =
match (peek p).tok, (peek_at p 1) with match (peek p).tok, (peek_at p 1) with
| NAME "on", n when n.sp -> | NAME "on", n when n.sp && not (assigns p) ->
let ot = advance p in let ot = advance p in
let head, _ = postfix p in let head, _ = postfix p in
let ty, var = let ty, var =
@ -1777,7 +2170,7 @@ and header (s : st) w : Form.t =
let body = block s ~after:w in let body = block s ~after:w in
let rec clauses acc = let rec clauses acc =
match (peek p).tok, (peek_at p 1) with match (peek p).tok, (peek_at p 1) with
| NAME "restart", n when n.sp -> | NAME "restart", n when n.sp && not (assigns p) ->
ignore (advance p); ignore (advance p);
let name = name_tok p ~what:"the restart's name" in let name = name_tok p ~what:"the restart's name" in
let lp = glued_lp p ~what:"the restart's parameters in parentheses" in let lp = glued_lp p ~what:"the restart's parameters in parentheses" in
@ -1837,6 +2230,7 @@ and clause_end p head =
(* The end of a header line whose block must follow. *) (* The end of a header line whose block must follow. *)
and expect_line_end p ~after = and expect_line_end p ~after =
if p.i = p.closed then () else
match (peek p).tok with match (peek p).tok with
| NEWLINE -> ignore (advance p) | NEWLINE -> ignore (advance p)
| _ -> stray p ~after | _ -> stray p ~after
@ -1861,9 +2255,11 @@ and lines (s : st) (one : unit -> Form.t list) : Form.t list =
go [] go []
end end
let () = block_of := fun p -> block { p; lets = [] } ~after:"=>"
(** All top-level forms in a [.fln] source string. [col] is the column the (** All top-level forms in a [.fln] source string. [col] is the column the
text's top level starts at, 1 for a file. *) text's top level starts at, 1 for a file. *)
let read_all ?(line = 1) ?col ?indent ~file src = let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
let snippet = col <> None in let snippet = col <> None in
let col = Option.value col ~default:1 in let col = Option.value col ~default:1 in
let saved = !source in let saved = !source in
@ -1874,8 +2270,20 @@ let read_all ?(line = 1) ?col ?indent ~file src =
(String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src))); (String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src)));
Fun.protect ~finally:(fun () -> source := saved) (fun () -> Fun.protect ~finally:(fun () -> source := saved) (fun () ->
let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in
let s = { p = { toks; i = 0 }; lets = [] } in let s = { p = { toks; i = 0; closed = -1 }; lets = [] } in
let fs = stmts s in (* At the top level, a [let] is a global, [(def x dyn v)]: a let there has
no block to be local to. Not in an expression the editor sends, where
a let is the statement it is in a body. *)
let rec top () =
match (peek s.p).tok with
| EOF -> []
| DEDENT -> ignore (advance s.p); []
| NAME "let" when header_follow s.p "let" ->
let f = header s "def" in
f :: top ()
| _ -> let f = stmt s in f :: top ()
in
let fs = if global_let then top () else stmts s in
(match (peek s.p).tok with (match (peek s.p).tok with
| EOF -> () | EOF -> ()
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk)); | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));

View File

@ -72,9 +72,11 @@ let read_paren ?(line = 1) ?(col = 1) ~file src =
in in
go [] go []
(** Editor code, in the request's syntax and at its position. With [expr], an (** Editor code, in the request's syntax and at its position. With [expr],
indented snippet of several statements is one expression, [(do ...)]: a an indented snippet of several statements is one expression,
block of lines means its lines in order. *) [(do ...)]: a block of lines means its lines in order. A [let] is a
global only in code from column 1 that is not an expression: a form cut
from inside a body, for a macroexpansion say, keeps its lets local. *)
let read_code ?(expr = false) ~file code = let read_code ?(expr = false) ~file code =
let line, col = let line, col =
match !code_at with Some (l, c) -> (l, c) | None -> (1, 1) match !code_at with Some (l, c) -> (l, c) | None -> (1, 1)
@ -82,7 +84,8 @@ let read_code ?(expr = false) ~file code =
match !code_syntax with match !code_syntax with
| Paren -> read_paren ~line ~col ~file code | Paren -> read_paren ~line ~col ~file code
| Indented -> | Indented ->
(match Indent_reader.read_all ~line ~col ?indent:!code_indent ~file code with (match Indent_reader.read_all ~line ~col ?indent:!code_indent ~global_let:(not expr && col = 1)
~file code with
| (first :: _ :: _ as forms) when expr -> | (first :: _ :: _ as forms) when expr ->
let last = List.nth forms (List.length forms - 1) in let last = List.nth forms (List.length forms - 1) in
let loc = let loc =

View File

@ -1610,15 +1610,10 @@ flan_dyn flan_dyn_map_new(void) {
* *
* **What the registry constrains.** A store into a slot the class declares * **What the registry constrains.** A store into a slot the class declares
* — the constructor's, [put]'s, [set]'s — is checked against the slot's * — the constructor's, [put]'s, [set]'s — is checked against the slot's
* type. A key the class does not declare is not refused by [put]: a class * type. A key the class does not declare is refused by [get], [put] and
* instance is an open map — TODO.org, "Class features deferred, each with its * [set] alike ([trap_no_slot]), so an instance's keys are its class's slots
* reason", defers unknown-slot checking — so a key nobody declared can be * and the migration below, which keeps only those, drops nothing a program
* written to one, and the migration below will *drop* it at the next * wrote.
* redefinition, because its rule is that an instance's keys are the class's
* slots. That is real data loss and it is written down as such in TODO.org,
* "A redefined defclass migrates its instances lazily", rather than dressed
* up as enforcement. [set] does refuse an undeclared key, because a slot it
* writes has to exist.
* *
* **Where a migration happens.** [want_map], so every [get], [put] and * **Where a migration happens.** [want_map], so every [get], [put] and
* [has-key?]; [flan_dyn_len]'s map arm; and [dyn_equal]'s, so two instances * [has-key?]; [flan_dyn_len]'s map arm; and [dyn_equal]'s, so two instances
@ -1963,6 +1958,10 @@ flan_dyn flan_dyn_vec_new(void);
flan_dyn flan_dyn_map_new(void); flan_dyn flan_dyn_map_new(void);
void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen); void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen);
void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v);
flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc,
int64_t loclen);
void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc,
int64_t loclen);
/* The user hook, run on an instance the name-matching has just brought up to /* The user hook, run on an instance the name-matching has just brought up to
* date. [inst], [added] and [gone] are rooted by the caller. * date. [inst], [added] and [gone] are rooted by the caller.
@ -3037,8 +3036,12 @@ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc,
int64_t loclen) { int64_t loclen) {
int64_t k; int64_t k;
flan_obj *o; 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)) if (!is_text(v) && !is_vec(v))
trap2(loc, loclen, TYPE_TRAP, "at", "only a text or a vec is indexed", v, i); trap2(loc, loclen, TYPE_TRAP, "at", "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, "at", v, i);
o = dyn_obj(v); o = dyn_obj(v);
if (o->kind == OBJ_VIEW) { if (o->kind == OBJ_VIEW) {
@ -3086,8 +3089,14 @@ void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc,
if (is_text(v)) if (is_text(v))
trap2(loc, loclen, TYPE_TRAP, "set-at", trap2(loc, loclen, TYPE_TRAP, "set-at",
"a text is immutable — build another one", v, i); "a text is immutable — build another one", v, i);
/* Assigning m[:k] is (put m :k x), a class slot's type check with it. */
if (is_map(v)) {
flan_dyn_map_put(v, i, x, loc, loclen);
return;
}
if (!is_vec(v)) if (!is_vec(v))
trap2(loc, loclen, TYPE_TRAP, "set-at", "only a vec is assigned into", v, i); trap2(loc, loclen, TYPE_TRAP, "set-at",
"only a vec or a map is assigned into", v, i);
k = need_index(loc, loclen, "set-at", v, i); k = need_index(loc, loclen, "set-at", v, i);
o = dyn_obj(v); o = dyn_obj(v);
if (o->kind == OBJ_VIEW) { if (o->kind == OBJ_VIEW) {
@ -3191,6 +3200,24 @@ flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k) {
return i < 0 ? flan_dyn_nil() : o->u.v.items[i * 2 + 1]; return i < 0 ? flan_dyn_nil() : o->u.v.items[i * 2 + 1];
} }
/* A program's (get m k) and (.k m): the same, with the site a value that is
* not a map is refused at, and a key an instance's class does not declare
* refused rather than answered nil — [trap_no_slot]. */
static class_entry *class_sync(flan_obj *o);
static int64_t class_slot(class_entry *e, flan_dyn k);
static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
const char *op, flan_obj *o,
class_entry *e, flan_dyn k);
flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc,
int64_t loclen) {
class_entry *e;
if (!is_map(m)) trap2(loc, loclen, TYPE_TRAP, "get", "only a map answers it", m, k);
e = class_sync(dyn_obj(m));
if (e != NULL && class_slot(e, k) < 0)
trap_no_slot(loc, loclen, "get", dyn_obj(m), e, k);
return flan_dyn_map_get(m, k);
}
flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) { flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) {
flan_obj *o = want_map("has-key?", m, k); flan_obj *o = want_map("has-key?", m, k);
return flan_dyn_from_bool(map_find(o, k) >= 0); return flan_dyn_from_bool(map_find(o, k) >= 0);
@ -3272,6 +3299,29 @@ static flan_dyn check_slot(const uint8_t *loc, int64_t loclen, int by,
static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v); static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v);
/* A key an instance's class does not declare, read or written. An instance
* has exactly its class's slots — a typo in a slot name is an error at the
* access and not a new key — so get, put and set all refuse one; a plain map
* takes any key. */
static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
const char *op, flan_obj *o,
class_entry *e, flan_dyn k) {
char sk[SAY_MAX];
kw_entry *c = o->u.v.klass;
int64_t i;
say(sk, SAY_MAX, k);
said_len = 0;
said_add("dyn %s: %.*s has no slot %s. Its slots are", op, (int)c->len,
(const char *)(c + 1), sk);
if (e == NULL || e->nslots == 0) said_add(" none");
else
for (i = 0; i < e->nslots; i++)
said_add(" :%.*s", (int)e->slots[i]->len,
(const char *)(e->slots[i] + 1));
flan_say(loc, loclen, "%s", said_buf);
flan_trap((const uint8_t *)"DynType", 7);
}
/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for /* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for
* the constructor call it happened inside rather than for a [put] nobody * the constructor call it happened inside rather than for a [put] nobody
* wrote, and placed at the slot's declaration. */ * wrote, and placed at the slot's declaration. */
@ -3286,8 +3336,7 @@ void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v,
* they are three different mistakes: the value is not a class instance at * they are three different mistakes: the value is not a class instance at
* all (a map's entries are written with [put], which is where inserting a * all (a map's entries are written with [put], which is where inserting a
* key is real); the key is not a slot the class declares; the value does not * key is real); the key is not a slot the class declares; the value does not
* fit the slot's type. The first two are why this is not [put]: a declared * fit the slot's type. The first is why this is not [put]. */
* slot always exists, so writing one is a store and never an insertion. */
void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v, void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v,
const uint8_t *loc, int64_t loclen) { const uint8_t *loc, int64_t loclen) {
flan_obj *o; flan_obj *o;
@ -3307,43 +3356,37 @@ void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v,
o = dyn_obj(m); o = dyn_obj(m);
e = class_sync(o); e = class_sync(o);
j = class_slot(e, k); j = class_slot(e, k);
if (j < 0) { if (j < 0) trap_no_slot(loc, loclen, "set", o, e, k);
char sk[SAY_MAX];
kw_entry *c = o->u.v.klass;
int64_t i;
say(sk, SAY_MAX, k);
said_len = 0;
said_add("dyn set: %.*s has no slot %s. Its slots are",
(int)c->len, (const char *)(c + 1), sk);
if (e == NULL || e->nslots == 0) said_add(" none");
else
for (i = 0; i < e->nslots; i++)
said_add(" :%.*s", (int)e->slots[i]->len,
(const char *)(e->slots[i] + 1));
said_add("; a key the class does not declare is added with put, not set");
flan_say(loc, loclen, "%s", said_buf);
flan_trap((const uint8_t *)"DynType", 7);
}
if (!slot_admit(&e->types[j], v, &out)) if (!slot_admit(&e->types[j], v, &out))
trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v); trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v);
map_store(o, k, out); map_store(o, k, out);
} }
void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc, static void map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc,
int64_t loclen) { int64_t loclen, int any_key) {
flan_obj *o; flan_obj *o;
class_entry *e; class_entry *e;
if (!is_map(m)) trap2(NULL, 0, TYPE_TRAP, "put", "only a map answers it", m, k); if (!is_map(m)) trap2(loc, loclen, TYPE_TRAP, "put", "only a map answers it", m, k);
o = dyn_obj(m); o = dyn_obj(m);
e = class_sync(o); e = class_sync(o);
if (!any_key && e != NULL && class_slot(e, k) < 0)
trap_no_slot(loc, loclen, "put", o, e, k);
/* A map with no class, and a class with no typed slot, stop at the test. */ /* A map with no class, and a class with no typed slot, stop at the test. */
if (e != NULL && e->typed) v = check_slot(loc, loclen, BY_PUT, o, e, m, k, v); if (e != NULL && e->typed) v = check_slot(loc, loclen, BY_PUT, o, e, m, k, v);
map_store(o, k, v); map_store(o, k, v);
} }
/* The same with no site: a map literal's stores, and test/dyn_ops.c. */ /* A program's put, and the store under a dyn's [.k] and [:k]. */
void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc,
int64_t loclen) {
map_put(m, k, v, loc, loclen, 0);
}
/* With no site and any key: an untagged map literal's stores, and
* test/dyn_ops.c, which builds instances' odd states by hand. No program
* reaches an instance through it. */
void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) { void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) {
flan_dyn_map_put(m, k, v, NULL, 0); map_put(m, k, v, NULL, 0, 1);
} }
/* The store under all three, with the instance already brought up to date. */ /* The store under all three, with the instance already brought up to date. */

View File

@ -156,10 +156,8 @@ flan_dyn flan_dyn_type_of(flan_dyn v);
* declares are dropped. The instance's identity is preserved throughout; * declares are dropped. The instance's identity is preserved throughout;
* this is CLHS 4.3.6, and [flan_dyn_class_hook] is its user hook. * this is CLHS 4.3.6, and [flan_dyn_class_hook] is its user hook.
* *
* The drop is unconditional, which is the honest cost of a class instance * No key the class never declared can be there to drop: [get], [put] and
* being an open map: a key written by a raw [put] that the class never * [set] refuse one on an instance. */
* declared is dropped by the next migration too. The registry describes the
* class's intention and does not enforce it. */
void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n); void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n);
/* The body update-instance-for-redefined-class dispatches through, as a /* The body update-instance-for-redefined-class dispatches through, as a
@ -244,6 +242,9 @@ void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen);
* to ask when nil might also be stored. [set] replaces the value of an equal * to ask when nil might also be stored. [set] replaces the value of an equal
* key in place, so a key occurs once and insertion order is print order. */ * key in place, so a key occurs once and insertion order is print order. */
flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k); 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);
void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v); 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 /* [put]'s: [flan_dyn_map_set], with the site a typed class slot's refusal
* prints. */ * prints. */

View File

@ -117,10 +117,10 @@ Each item: the proposal, then the reason in one line.
trailing block is allowed. Make it parser-driven, the way GDScript's trailing block is allowed. Make it parser-driven, the way GDScript's
`push_multiline` is (`gdscript_parser.cpp` 658-672, 3695-3770), not a paren `push_multiline` is (`gdscript_parser.cpp` 658-672, 3695-3770), not a paren
counter in the lexer, or a block inside a call can't work. counter in the lexer, or a block inside a call can't work.
*Built as a depth counter instead: inside brackets a line break is always *Built as a depth counter instead: inside brackets a line break is
whitespace, so no block opens inside a call's parentheses (§3.1's blocks all whitespace, with one exception. A `=>` that ends a line inside brackets opens
open after the `)`; a lambda with a block body is a statement or a value, a lambda's block there, laid out as at the top level against the column its
`let f = fn(x)` plus a block).* line starts at, and the block ends where the enclosing bracket closes.*
- **Continuation outside brackets:** a line that starts with a spaced infix - **Continuation outside brackets:** a line that starts with a spaced infix
operator (`+`, `and`, `==`, …) continues the previous line; so does a line operator (`+`, `and`, `==`, …) continues the previous line; so does a line
after one that ends in a spaced infix operator. (F# `LexFilter.fs` 360-380, after one that ends in a spaced infix operator. (F# `LexFilter.fs` 360-380,
@ -172,6 +172,10 @@ Each item: the proposal, then the reason in one line.
one symbol. `test/programs/dev-rerun.flan:65` names a global one symbol. `test/programs/dev-rerun.flan:65` names a global
`.init-once.counter`; rename it. **Built**, without the rename: it prints and `.init-once.counter`; rename it. **Built**, without the rename: it prints and
reads back through the fallback, `defonce(.init-once.counter, i64, 7)`. reads back through the fallback, `defonce(.init-once.counter, i64, 7)`.
- **On a dyn value, `x.name` is `(get x :name)` and `x.name = v` is
`(put x :name v)`**, for a class slot and a plain map's key alike; `m[:k]`
is `(get m :k)` and `m[:k] = v` puts. The paren spellings `(.name x)` and
`(at m :k)` mean the same. **Built.**
- **`and`, `or`, `not` are words**, since they are Flan's own names. **Built.** - **`and`, `or`, `not` are words**, since they are Flan's own names. **Built.**
- **Casts and type-taking builtins are calls:** `i32(x)`, `vec-new(u8)`, - **Casts and type-taking builtins are calls:** `i32(x)`, `vec-new(u8)`,
`max-value(u8)`, `the([3 f32], [1 2 3.5])`. A pointer cast is the type `max-value(u8)`, `the([3 f32], [1 2 3.5])`. A pointer cast is the type
@ -267,11 +271,28 @@ Each item: the proposal, then the reason in one line.
- **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. **Built**; - **Unit:** `()` as a statement reads `(do)`; in a type it is `()`. **Built**;
inside an expression `()` stays `()`, and the printer writes a lone `()` inside an expression `()` stays `()`, and the printer writes a lone `()`
statement as `(())`. A bare `()` in a one-line body slot (`fn f() -> () = ()`, statement as `(())`. A bare `()` in a one-line body slot (`fn f() -> () = ()`,
`_ -> ()`, `fn() = ()`, `then ()`) is a statement too, and reads `(do)`. `_ -> ()`, `fn() => ()`, `then ()`) is a statement too, and reads `(do)`.
- **Lambda:** `fn(i, j) = i * 10 + j`, or `fn(i, j)` plus a block. **Built**; - **Lambda:** `fn(i, j) => i * 10 + j`, or `fn(i, j) =>` plus a block. **Built**;
its parameters are bare names, as `(fn [i j] …)` wants, with no `dyn`. its parameters are bare names, as `(fn [i j] …)` wants, with no `dyn`.
`fn(…)` followed by anything else is the fallback call. A lambda may state `fn(…)` followed by anything else is the fallback call. A lambda may state
its types, `fn(a: C, b) -> bool = …` or plus a block (section 3, item 7). its types, `fn(a: C, b) -> bool => …` or plus a block (section 3, item 7).
`=>` is a lambda's only spelling: `fn(a) = x` and a lambda header with a
block under it and no `=>` are refused, with the `=>` form as the fix.
Named functions keep `=`. A block lambda may sit inside brackets:
```
sort-by(slice(xs), fn(a, b) =>
let d = a.n - b.n
d < 0)
```
The block ends where the brackets close, with the `)` at the end of its
last line or on a line of its own at the call's column. It is the last
thing in them: a comma after the block is refused (so a call takes one
block lambda, as its last argument; name any other with `let`), as is a
line inside the brackets at or left of the column the `=>` line starts at.
Block lambdas nest, each block ending at its own brackets. `flan convert`
writes a call whose last argument is a lambda with a block this way.
### Definitions ### Definitions
@ -280,20 +301,45 @@ Each item: the proposal, then the reason in one line.
becomes `where ordered?($t)` after the return type. **Built**; with no becomes `where ordered?($t)` after the return type. **Built**; with no
`-> R` the return is `_`, read off the body. Several predicates are `-> R` the return is `_`, read off the body. Several predicates are
`where p, q`. `where p, q`.
- `def x = v`, `def x: T = v`, `once x: T`, `once x = v`, `const n = 3`, - A `let` at the top level is a global: `let x = v`, `let x: T = v`,
`def scratch: [4 u8] = uninit`. **Built.** `def x = v` and `once x = v` read `let scratch: [4 u8] = uninit` read `(def x dyn v)`, `(def x T v)`;
with `dyn`; `const n = 3` reads `(defconst n 3)`, its type inferred as today. `once x: T`, `once x = v`, `const n = 3`. **Built.** `let x = v` and
`once x = v` read with `dyn`; `const n = 3` reads `(defconst n 3)`, its type
inferred as today. `def` is refused with the `let` to write. A `let` in a
block, `comment:`'s included, is local, and so is one in code the editor
evaluates as an expression.
- `struct Cell` with a `name: Type` line per field. `data Shape` with a line per - `struct Cell` with a `name: Type` line per field. `data Shape` with a line per
case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like
`struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`). `struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`).
A member is `:mid` or `K.mid`, in a value and in a match arm, in both A member is `:mid` or `K.mid`, in a value and in a match arm, in both
syntaxes (section 3, item 8). syntaxes (section 3, item 8). A condition names its parent after the name,
`struct DiskFull :parent IoError` with its field lines, reading
`(defstruct DiskFull :parent IoError [free i64])`; with no field lines it
reads `(defstruct IoError :parent Error)`. A struct or union fits on one
line with its fields in parentheses, `struct Pt(x: i32, y: i32)` or
`struct DiskFull(free: i64) :parent IoError`; `flan convert` writes that
when it fits the line and no comment sits among the fields. **Built.**
- `type Row = Vec(i32)` reads `(defalias Row (Vec i32))`. **Built.**
- `macro repeat(i, n, & body)` plus a block reads
`(defmacro repeat [i n & body] …)`. A parameter is a bare name, a
destructuring vector `[a b]`, or `& rest`, last. **Built.**
- `loop x = a, y = b` plus a block reads `(loop [x a y b] …)`, as a statement
or as a value, `let r = loop i = 0`. `recur(y, x % y)` is a call. A loop with
no variables is the fallback, `loop([]):`. **Built.**
- `class lambda(param, body, env)`, or `class lambda` with a slot per line,
reads `(defclass lambda [param body env])`; a typed slot is `pause: bool`
and its type follows its name in the vector. **Built.**
- `generic describe(v) -> dyn` reads `(defgeneric describe [v] dyn)`;
`multi kind(v) -> dyn = type-of(v)`, or plus a block, reads
`(defmulti kind [v] dyn (type-of v))`. Their parameters are bare names.
**Built.**
- `method describe(f: lambda)` plus a block reads
`(defmethod describe lambda [f] …)`: a class is the first parameter's type.
Any other dispatch value follows `when`: `method kind(v) when :int`,
`when :else` for the default. `= value` for a one-line body. **Built.**
- `import rl "vendor:raylib"`. **Built.** - `import rl "vendor:raylib"`. **Built.**
- **Every other form uses the fallback** (next item) until someone asks for - **Every other form uses the fallback** (next item) until someone asks for
sugar: `defclass`, `defgeneric`, `defmulti`, `defmethod`, `declare`, sugar: `declare`, `declare-c`, `array-fill`. **Built.**
`declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. **Built.**
The class forms keep the fallback for good (2026-09-26):
`defmethod(area, point, [p]):` reads well enough.
### The fallback ### The fallback
@ -317,7 +363,7 @@ value, `vec-new(Fn([i32], i32))` is the call spelling).
### Macro templates ### Macro templates
``` ```
defmacro(with-mode-2d, [camera & body]): macro with-mode-2d(camera, & body)
quote quote
begin-mode-2d(~camera) begin-mode-2d(~camera)
~@body ~@body
@ -376,16 +422,15 @@ Settled 2026-09-26, after writing programs by hand (`test/syntax/handwritten/`):
is refused at its last line: the first `else` took `if b then y` as its is refused at its last line: the first `else` took `if b then y` as its
value, and the chain is `if a then x else if b then y else z` on one line, value, and the chain is `if a then x else if b then y else z` on one line,
or `elif b then y` on the second. or `elif b then y` on the second.
7. **Typed lambdas.** `fn(a: C, b) -> R = body`, or plus a block, reads 7. **Typed lambdas.** `fn(a: C, b) -> R => body`, or plus a block, reads
`(the (Fn [C dyn] R) (fn [a b] body))`: the paren `fn` has no typed `(the (Fn [C dyn] R) (fn [a b] body))`: the paren `fn` has no typed
parameters, and `the` is how a value states its type, as in parameters, and `the` is how a value states its type, as in
`let x: T = v`. An untyped parameter is `dyn`; the return type is `let x: T = v`. An untyped parameter is `dyn`; the return type is
required. Where a `CFn` of the same signature is wanted, the literal is required. Where a `CFn` of the same signature is wanted, the literal is
that `CFn`; at a generic's `CFn($t) -> $t` parameter the literal is a that `CFn`; at a generic's `CFn($t) -> $t` parameter the literal is a
`CFn` at its own types, which bind `$t` as any argument's would. The `CFn` at its own types, which bind `$t` as any argument's would. The
printer writes that form back as the typed lambda. A block lambda cannot printer writes that form back as the typed lambda. A typed block lambda
sit inside a call's brackets; the refusal shows the typed `let` form to sits inside brackets as an untyped one does.
bind it with.
8. **`Dir.north` is the enum member `:north`**, in a value and in a match 8. **`Dir.north` is the enum member `:north`**, in a value and in a match
pattern, in both syntaxes. `:north` stays. A local named `Dir` shadows the pattern, in both syntaxes. `:north` stays. A local named `Dir` shadows the
enum as a local shadows any global: `Dir.north` is then its field. enum as a local shadows any global: `Dir.north` is then its field.
@ -433,9 +478,11 @@ Each step lands on its own, with `dune test --root .` green.
space-padding in `flan--text-at` (`emacs/flan.el:2602-2622`), which breaks space-padding in `flan--text-at` (`emacs/flan.el:2602-2622`), which breaks
significant indentation, with `:line`/`:col` fields; the reader seeds its significant indentation, with `:line`/`:col` fields; the reader seeds its
indent stack with that column. **Built** (also `load-file` and restart indent stack with that column. **Built** (also `load-file` and restart
arguments; no `:syntax` means paren, except a `load-file` of a `.fln` arguments; with no `:syntax` a request is read in the syntax of the
file; several indented statements sent as one expression read as source `:file` it names, as paren under a pseudo-name such as `<repl>`,
`(do …)`). and with no `:file` at all in the program's — so
evaluating in a stopped frame of a `.fln` program reads indented;
several indented statements sent as one expression read as `(do …)`).
5. **Emacs mode** for `.fln`: 5. **Emacs mode** for `.fln`:
- A top-level form runs from a column-0 line that isn't `else`, `elif`, - A top-level form runs from a column-0 line that isn't `else`, `elif`,
`on` or `restart` to just before the next one, minus trailing blank and `on` or `restart` to just before the next one, minus trailing blank and
@ -453,7 +500,7 @@ Each step lands on its own, with `dune test --root .` green.
(`ast.ml:491-492`). (`ast.ml:491-492`).
**Built** (`emacs/flan-fln-mode.el`; keys and objects in `emacs/MANUAL.md`, **Built** (`emacs/flan-fln-mode.el`; keys and objects in `emacs/MANUAL.md`,
"Indented files"). A line ending in `=` or `fn(…)` also opens a block for "Indented files"). A line ending in `=` or `=>` also opens a block for
TAB, and a body is its statement's own block, up to its first clause. TAB, and a body is its statement's own block, up to its first clause.
6. **Return-type inference** in `Check`, with the recursion refusal and the 6. **Return-type inference** in `Check`, with the recursion refusal and the
stale-caller cause. This is independent of steps 1-5 once the marker exists. stale-caller cause. This is independent of steps 1-5 once the marker exists.

View File

@ -0,0 +1,26 @@
;; A dyn class instance in a .fln program, for code evaluated from its buffer:
;; eval-expr reads the request's syntax, at a stop as well as at a park.
import agent "vendor:agent"
defclass(State, [paused bool step bool])
once state = State(false, false)
once go = false
struct Missing(id: i32)
fn boom() -> i64
restart-case
error(Missing{.id 1})
0
restart carry-on()
-1
fn main() -> i32
agent/start("/tmp/flan-dev-fln-dyn-fallback.sock")
for i in range(4000)
agent/wait(5)
if go
go = false
boom()
0

View File

@ -28,12 +28,9 @@
(println (get s :step)) (println (get s :step))
(set (get s :tag) [1 2]) (set (get s :tag) [1 2])
(println (get s :tag)) (println (get s :tag))
;; put reaches the same check for a declared slot, and still inserts a ;; put reaches the same check for a declared slot.
;; key the class does not declare -- an instance is an open map to put.
(put s :speed 2.5) (put s :speed 2.5)
(put s :scratch 9)
(println (get s :speed)) (println (get s :speed))
(println (get s :scratch))
(println (length s)) (println (length s))
;; A typed caller boxes into the dyn parameter as any call does. ;; A typed caller boxes into the dyn parameter as any call does.
(set (get s :step) (twelve)) (set (get s :step) (twelve))

View File

@ -64,7 +64,9 @@
(println (get p :x)) (println (get p :x))
(println (has-key? p :x)) (println (has-key? p :x))
(println (has-key? p :nothing)) (println (has-key? p :nothing))
(println (get p :nothing)) ;; A key its class does not declare is refused on an instance; a plain
;; map answers nil for one it lacks.
(println (get {:x 1} :nothing))
;; The shape tag, as a value. Every value can be asked; only an instance ;; The shape tag, as a value. Every value can be asked; only an instance
;; answers with a name. ;; answers with a name.

View File

@ -0,0 +1,20 @@
;;;; A dyn's .field and [:key] trap with get's and put's own sentences, one
;;;; per run. The argument chooses which; the test asserts the line numbers.
(defclass State [paused bool step bool])
(defn as-dyn [d dyn] dyn d)
(defn main [args [str]] i32
(let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0)
s (State false false)
n (as-dyn 3)]
(println "before")
(cond
(= which 0) (println (.paused n))
(= which 1) (set (.paused s) 1)
(= which 2) (set (.paused n) true)
(= which 3) (set (at s :step) 2)
(= which 5) (set (.pasued s) true)
(= which 6) (println (.pasued s))
:else (println (at n :paused))))
0)

View File

@ -0,0 +1,27 @@
;;;; A dyn's .field and [:key] trap with get's and put's own sentences, one
;;;; per run. The argument chooses which; the test asserts the line numbers.
defclass(State, [paused bool step bool])
fn as-dyn(d) -> dyn = d
fn main(args: [str]) -> i32
let which =
if length(args) > 1 then i32(bytes->i64(bytes-view(args[1]))) else 0
let s = State(false, false)
let n = as-dyn(3)
println("before")
if which == 0
println(n.paused)
elif which == 1
s.paused = 1
elif which == 2
n.paused = true
elif which == 3
s[:step] = 2
elif which == 5
s.pasued = true
elif which == 6
println(s.pasued)
else
println(n[:paused])
0

View File

@ -0,0 +1,36 @@
;;;; A dyn value's (.field x) and (at m :key): a read is get, a set is put.
(defclass State [paused bool step bool])
(defclass Pos [x y])
(defclass Body [pos count items])
(defonce state (State false false))
(defn game-input [] ()
(when true
(set (.paused state) (not (.paused state)))))
(defn pick [b dyn] dyn b)
(defn main [] i32
(game-input)
(println (.paused state))
(game-input)
(println (.paused state))
(let [b (Body (Pos 1 2) 0 [10 20 30])]
(set (.count b) (+ (.count b) 1))
(++ (.count b))
(update (.count (pick b)) + 10)
(set (.x (.pos b)) 7)
(update (.y (.pos b)) * 10)
(set (at (.items b) 0) 11)
(update (at (.items b) 1) + 5)
(println (.count b) (.x (.pos b)) (.y (.pos b)) (at (.items b) 0) (at (.items b) 1))
(println (.missing {:a 1}) (= (.missing {:a 1}) (get {:a 1} :missing))))
(let [m {:hp 3}]
(set (.hp m) (- (.hp m) 1))
(set (at m :mp) 9)
(update (at m :mp) + 1)
(set (.name m) "slime")
(set (at m 1) :one)
(println (at m :hp) (.mp m) (at m :gone) (at m 1) m))
0)

View File

@ -8,11 +8,11 @@ enum State
quote-in-quoted quote-in-quoted
once rows-seen: i32 once rows-seen: i32
def fields-seen: i32 = 0 let fields-seen: i32 = 0
const separator = \, const separator = \,
; Frame the body's output with a title line and a closing rule. ; Frame the body's output with a title line and a closing rule.
defmacro(with-section, [title & body]): macro with-section(title, & body)
quote quote
println("--", ~title, "--") println("--", ~title, "--")
~@body ~@body

View File

@ -0,0 +1,34 @@
;; A dyn value's .field and [:key]: a read is get, an assignment is put.
defclass(State, [paused bool step bool])
defclass(Pos, [x y])
defclass(Body, [pos count items])
once state = State(false, false)
fn game-input() -> ()
if true
state.paused = not(state.paused)
fn main() -> i32
game-input()
println(state.paused)
game-input()
println(state.paused)
let b = Body(Pos(1, 2), 0, [10 20 30])
b.count += 1
b.count += 1
b.pos.x = 7
b.pos.y *= 10
b.items[0] = 11
b.items[1] += 5
println(b.count, b.pos.x, b.pos.y, b.items[0], b.items[1])
let plain = {:a 1}
println(plain.missing)
let m = {:hp 3}
m.hp -= 1
m[:mp] = 9
m[:mp] += 1
m.name = "slime"
println(m[:hp], m.mp, m[:gone], m)
0

View File

@ -0,0 +1,5 @@
true
false
2 7 20 11 25
nil
2 10 nil {:hp 2 :mp 10 :name "slime"}

View File

@ -8,24 +8,24 @@ struct Rule
label: str label: str
applies: CFn(stock/Item) -> bool applies: CFn(stock/Item) -> bool
def report-width: i32 = 28 let report-width: i32 = 28
once runs: i32 once runs: i32
const reorder-below = 5 const reorder-below = 5
; Run the body n times, counting passes in the name given. ; Run the body n times, counting passes in the name given.
defmacro(repeat, [i n & body]): macro repeat(i, n, & body)
quote quote
for ~i in range(~n) for ~i in range(~n)
~@body ~@body
; Say what went wrong when a check does not hold. ; Say what went wrong when a check does not hold.
defmacro(expect, [test message]): macro expect(test, message)
quote quote
if not ~test if not ~test
println("expected:", ~message) println("expected:", ~message)
fn gcd(a: i32, b: i32) -> i32 fn gcd(a: i32, b: i32) -> i32
loop([x a y b]): loop x = a, y = b
if y == 0 then x else recur(y, x % y) if y == 0 then x else recur(y, x % y)
fn line(it: stock/Item) -> () fn line(it: stock/Item) -> ()
@ -51,7 +51,7 @@ fn main() -> i32
let items = [stock/item("bolts", 12, 400), stock/item("nuts", 5, 3), let items = [stock/item("bolts", 12, 400), stock/item("nuts", 5, 3),
stock/item("gears", 1250, 7), stock/item("belts", 899, 0)] stock/item("gears", 1250, 7), stock/item("belts", 899, 0)]
let rules = [Rule{.label "reorder", .applies low?}, let rules = [Rule{.label "reorder", .applies low?},
Rule{.label "valuable", .applies fn(it) = stock/value(it) > 5000}] Rule{.label "valuable", .applies fn(it) => stock/value(it) > 5000}]
let frame = arena-new(4096) let frame = arena-new(4096)
repeat(pass, 2): repeat(pass, 2):
runs += 1 runs += 1
@ -75,7 +75,7 @@ fn main() -> i32
println("sign bits", stock/sign-bit(-2.5), stock/sign-bit(2.5), println("sign bits", stock/sign-bit(-2.5), stock/sign-bit(2.5),
"masked", bit-and(-total, 0xFF)) "masked", bit-and(-total, 0xFF))
let big = 1000 let big = 1000
println("worth over", big, count-if(slice(items), fn(it) = stock/value(it) > big)) println("worth over", big, count-if(slice(items), fn(it) => stock/value(it) > big))
expect(total == 407, "407 on even rows") expect(total == 407, "407 on even rows")
expect(runs == 2, "two runs") expect(runs == 2, "two runs")
0 0

View File

@ -2,11 +2,11 @@
; overdraw signals, and the caller picks a restart: skip it, cap it at what ; overdraw signals, and the caller picks a restart: skip it, cap it at what
; the account holds, or allow an overdraft up to a limit it supplies. ; the account holds, or allow an overdraft up to a limit it supplies.
defstruct(Overdraft, :parent, Error, [account i32 short i64]) struct Overdraft :parent Error
struct Audit
account: i32 account: i32
amount: i64 short: i64
struct Audit(account: i32, amount: i64)
once balances: [4 i64] once balances: [4 i64]
once audits: i32 once audits: i32

View File

@ -2,22 +2,21 @@
; first element is a keyword naming the operation, variables are keywords, ; first element is a keyword naming the operation, variables are keywords,
; and environments are dyn maps chained through a :parent key. ; and environments are dyn maps chained through a :parent key.
defclass(lambda, [param body env]) class lambda(param, body, env)
defgeneric(describe, [v], dyn) generic describe(v) -> dyn
defmethod(describe, lambda, [f]): method describe(f: lambda)
"a function of one argument" "a function of one argument"
defmulti(kind, [v], dyn, type-of(v)) multi kind(v) -> dyn = type-of(v)
defmethod(kind, :int, [v]): method kind(v) when :int
"number" "number"
defmethod(kind, :vec, [v]): method kind(v) when :vec = "form"
"form"
defmethod(kind, :else, [v]): method kind(v) when :else
"value" "value"
once steps = 0 once steps = 0

View File

@ -60,7 +60,7 @@ fn repeat-apply(f: CFn($t) -> $t, x: $t, n: i32) -> $t
v = f(v) v = f(v)
v v
fn halve-all(x: $t) -> $t where numeric?($t) = repeat-apply(fn(a: $t) -> $t = a / 2, x, 3) fn halve-all(x: $t) -> $t where numeric?($t) = repeat-apply(fn(a: $t) -> $t => a / 2, x, 3)
fn main() -> i32 fn main() -> i32
let r: Ring(5, i32) = zeroed() let r: Ring(5, i32) = zeroed()
@ -80,16 +80,16 @@ fn main() -> i32
let d = distinct(slice(samples)) let d = distinct(slice(samples))
println("distinct", slice(d)) println("distinct", slice(d))
free(d) free(d)
let big = filter(slice(samples), fn(x) = x >= 7) let big = filter(slice(samples), fn(x) => x >= 7)
println("seven and up", slice(big), "sum", reduce(slice(big), 0, fn(a, b) = a + b)) println("seven and up", slice(big), "sum", reduce(slice(big), 0, fn(a, b) => a + b))
free(big) free(big)
let rs = [Reading{.sensor 2, .value 40} Reading{.sensor 1, .value 15} let rs = [Reading{.sensor 2, .value 40} Reading{.sensor 1, .value 15}
Reading{.sensor 3, .value 22}] Reading{.sensor 3, .value 22}]
sort-by(slice(rs), fn(a, b) = a.value < b.value) sort-by(slice(rs), fn(a, b) => a.value < b.value)
for i in range(length(rs)) for i in range(length(rs))
println("sensor", rs[i].sensor, rs[i].value) println("sensor", rs[i].sensor, rs[i].value)
let raw: [4 u32] = [1 2 3 4] let raw: [4 u32] = [1 2 3 4]
let p = Ptr(u8)(addr(raw[0])) let p = Ptr(u8)(addr(raw[0]))
println("checksum", checksum(p, 16)) println("checksum", checksum(p, 16))
println("doubled", repeat-apply(fn(a: i32) -> i32 = a * 2, 1, 10), "halved", halve-all(800.0)) println("doubled", repeat-apply(fn(a: i32) -> i32 => a * 2, 1, 10), "halved", halve-all(800.0))
0 0

View File

@ -58,7 +58,7 @@ fn main() -> i32
let text = "The cat saw the dog. The dog didn't see the cat, but the bird saw both!" let text = "The cat saw the dog. The dog didn't see the cat, but the bird saw both!"
let ws = words(bytes-view(text)) let ws = words(bytes-view(text))
let counts = tally(slice(ws)) let counts = tally(slice(ws))
let by-count = fn(a: Count, b: Count) -> bool let by-count = fn(a: Count, b: Count) -> bool =>
if a.n != b.n if a.n != b.n
return a.n > b.n return a.n > b.n
bytes<?(a.word, b.word) bytes<?(a.word, b.word)
@ -73,7 +73,7 @@ fn main() -> i32
let distinct = i32(length(counts)) let distinct = i32(length(counts))
let g = grade(distinct, total) let g = grade(distinct, total)
println(distinct, "of", total, "distinct:", describe(g)) println(distinct, "of", total, "distinct:", describe(g))
let longest = reduce(slice(ws), slice(ws[0], 0, 0), fn(a, b) = let longest = reduce(slice(ws), slice(ws[0], 0, 0), fn(a, b) =>
if length(b) > length(a) then b else a) if length(b) > length(a) then b else a)
println("longest", str(longest)) println("longest", str(longest))
let short = 0 < length(longest) < 5 let short = 0 < length(longest) < 5

View File

@ -15,8 +15,8 @@ const brush-size = 10
fn dyn->f64(v: f64) -> f64 = v fn dyn->f64(v: f64) -> f64 = v
fn dyn->u32(v: i64) -> u32 = u32(v) fn dyn->u32(v: i64) -> u32 = u32(v)
def gravity = 0.05 let gravity = 0.05
def colors = let colors =
let v = vec-new(dyn) let v = vec-new(dyn)
push(v, 0xFFF00FFF) push(v, 0xFFF00FFF)
push(v, 0x3B6E8CFF) push(v, 0x3B6E8CFF)
@ -121,7 +121,7 @@ fn game-draw() -> ()
rl/draw-fps(20, 20) rl/draw-fps(20, 20)
once frame: Allocator = arena-new(262144) once frame: Allocator = arena-new(262144)
def game-data = let game-data =
handler-case handler-case
edn/read-file("game-data.edn") edn/read-file("game-data.edn")
on FileError(c) on FileError(c)

View File

@ -5660,13 +5660,12 @@ level "1"
(* Typed class slots and set on a slot: the stores that fit, then one (* Typed class slots and set on a slot: the stores that fit, then one
run per refusal. The constructor, put and set each check a declared run per refusal. The constructor, put and set each check a declared
slot's type, set refuses a slot the class does not declare and a slot's type, and set refuses a slot the class does not declare and a
value that is not an instance, and put still inserts an undeclared value that is not an instance. On both backends, because every one of these is a runtime call
key. On both backends, because every one of these is a runtime call
whose arguments the two emit separately. *) whose arguments the two emit separately. *)
let slots_out = let slots_out =
"#state{:pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\ "#state{:pause false :step 3 :speed 1.5 :name \"sand\" :tag :x}\n\
true\n-7\n[1 2]\n2.5\n9\n6\n12\n3.5\ntrue\n2\n:state\n" true\n-7\n[1 2]\n2.5\n5\n12\n3.5\ntrue\n2\n:state\n"
in in
outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out; outputs "dyn: typed class slots" "programs/dyn-class-slots.flan" slots_out;
outputs ~x86:true "dyn: typed class slots, --x86" outputs ~x86:true "dyn: typed class slots, --x86"
@ -5696,8 +5695,7 @@ level "1"
is declared i32, and 5000000000 is not a value it holds \ is declared i32, and 5000000000 is not a value it holds \
exactly"); exactly");
("3", "dyn-slot-trap.flan:17:19: dyn set: state has no slot :paws. \ ("3", "dyn-slot-trap.flan:17:19: dyn set: state has no slot :paws. \
Its slots are :pause :step :tag; a key the class does not \ Its slots are :pause :step :tag");
declare is added with put, not set");
("4", "dyn-slot-trap.flan:18:19: dyn set: (get m k) is a place only \ ("4", "dyn-slot-trap.flan:18:19: dyn set: (get m k) is a place only \
on a class instance, and this is a map with no class"); on a class instance, and this is a map with no class");
("5", "dyn-slot-trap.flan:19:28: dyn construct: the slot :owner of \ ("5", "dyn-slot-trap.flan:19:28: dyn construct: the slot :owner of \
@ -5709,6 +5707,73 @@ level "1"
slot_trap (); slot_trap ();
slot_trap ~x86:true (); slot_trap ~x86:true ();
(* A dyn's (.field x) and (at m :key) are get and put: a class slot, a
plain map's key, nil for one it lacks, and chained and compound forms
over both. The .fln spelling is test/syntax/handwritten/dynfields.fln. *)
let fields_out =
"true\nfalse\n12 7 20 11 25\nnil true\n\
2 10 nil :one {:hp 2 :mp 10 :name \"slime\" 1 :one}\n"
in
outputs "dyn: .field and [:key]" "programs/dyn-fields.flan" fields_out;
outputs ~opt:"-O0" "dyn: .field and [:key], -O0" "programs/dyn-fields.flan"
fields_out;
outputs ~x86:true "dyn: .field and [:key], --x86" "programs/dyn-fields.flan"
fields_out;
outputs ~dev:true "dyn: .field and [:key], --dev" "programs/dyn-fields.flan"
fields_out;
(* Their refusals are get's, put's and at's own sentences, placed at the
access, in both syntaxes. *)
let field_trap ?x86 path rows =
let exe = compile ?x86 path in
List.iter
(fun (arg, want) ->
let code, text = run exe (Some arg) in
if code <> 134 || not (contains text want) then begin
incr failures;
Printf.printf
"FAIL dyn: a .field's refusal%s\n got: %S (exit %d)\n \
wanted: %S (exit 134)\n"
(match x86 with Some true -> ", --x86" | _ -> "")
text code want
end)
rows;
(try Sys.remove exe with Sys_error _ -> ())
in
(* 5 and 6 are a misspelt slot on a class instance, written and read:
refused naming the class and its slots, never a new key or a nil. *)
let field_rows (l0, l1, l2, l3, l4, l5, l6) =
[ ("0", l0 ^ ": dyn get: int and keyword, and only a map answers it — \
(get 3 :paused)");
("1", l1 ^ ": dyn put: the slot :paused of State is declared bool, \
and this is int — (put #State{:paused false :step false} \
:paused 1)");
("2", l2 ^ ": dyn put: int and keyword, and only a map answers it — \
(put 3 :paused)");
("3", l3 ^ ": dyn put: the slot :step of State is declared bool, and \
this is int");
("4", l4 ^ ": dyn at: int and keyword, and only a text, a vec or a \
map is indexed — (at 3 :paused)");
("5", l5 ^ ": dyn put: State has no slot :pasued. Its slots are \
:paused :step");
("6", l6 ^ ": dyn get: State has no slot :pasued. Its slots are \
:paused :step") ]
in
let flan_rows =
field_rows ("dyn-field-trap.flan:13:28", "dyn-field-trap.flan:14:19",
"dyn-field-trap.flan:15:19", "dyn-field-trap.flan:16:19",
"dyn-field-trap.flan:19:22", "dyn-field-trap.flan:17:19",
"dyn-field-trap.flan:18:28")
and fln_rows =
field_rows ("dyn-field-trap.fln:14:13", "dyn-field-trap.fln:16:5",
"dyn-field-trap.fln:18:5", "dyn-field-trap.fln:20:5",
"dyn-field-trap.fln:26:13", "dyn-field-trap.fln:22:5",
"dyn-field-trap.fln:24:13")
in
field_trap "programs/dyn-field-trap.flan" flan_rows;
field_trap ~x86:true "programs/dyn-field-trap.flan" flan_rows;
field_trap "programs/dyn-field-trap.fln" fln_rows;
field_trap ~x86:true "programs/dyn-field-trap.fln" fln_rows;
(* A numeric cast opening a dyn box — TODO.org, "A numeric cast opens a (* A numeric cast opening a dyn box — TODO.org, "A numeric cast opens a
dyn box". programs/dyn-cast.flan is one program because the three dyn box". programs/dyn-cast.flan is one program because the three
behaviours are one story told in order: the same-kind casts print, the behaviours are one story told in order: the same-kind casts print, the
@ -7322,6 +7387,14 @@ level "1"
cli_case "check on a file that is not there" cli_case "check on a file that is not there"
"check no-such-file.flan" ~code:1 "check no-such-file.flan" ~code:1
~says:[ "no-such-file.flan"; "No such file or directory" ]; ~says:[ "no-such-file.flan"; "No such file or directory" ];
(* A file that checks prints nothing; --defs lists what it defined. *)
(match cli "check programs/recur.flan" with
| 0, "" -> ()
| code, text ->
incr failures;
Printf.printf "FAIL a clean check prints nothing\n got: %S (exit %d)\n" text code);
cli_case "check --defs lists the definitions" "check programs/recur.flan --defs" ~code:0
~says:[ "defn gcd : (Fn [i32 i32] i32)" ];
(* And every other front end takes the same route, since the arm is on the (* And every other front end takes the same route, since the arm is on the
one wrapper they all go through. *) one wrapper they all go through. *)
cli_case "build on a file that is not there" cli_case "build on a file that is not there"

View File

@ -7283,6 +7283,78 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ xsock2; xout2; msock; mout ]; [ xsock2; xout2; msock; mout ];
(* ── Code from a .fln program, with no :syntax ──────────────────────
A request that leaves :syntax out is read in the syntax of the file it
names, and with no file — evaluating in a stopped frame names none —
in the program's. So a dyn instance's dot assignment evaluates from a
.fln buffer at a park and in the program's own stopped frame. *)
List.iter
(fun backend ->
let fsock = tmp ("flndyn" ^ backend ^ ".sock")
and fout = tmp ("flndyn" ^ backend ^ ".out") in
(try Sys.remove fsock with Sys_error _ -> ());
let ffd =
Unix.openfile fout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let fpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-fln-dyn.fln"; "-s"; fsock;
"--" ^ backend |]
Unix.stdin ffd Unix.stderr
in
Unix.close ffd;
if not (listening ~pid:fpid fsock) then begin
fail "the .fln dyn daemon (--%s) %s" backend !listen_why;
(try Unix.kill fpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect fsock in
let ask ?frame code =
request c
(match frame with
| Some n ->
Printf.sprintf "(:op \"eval-expr\" :frame %d :code %s)" n
(Wire.quote code)
| None ->
Printf.sprintf
"(:op \"eval-expr\" :code %s :file \"programs/dev-fln-dyn.fln\")"
(Wire.quote code))
in
let answer r =
match Wire.string_field r "value" with
| Some v -> v
| None -> Option.value ~default:(status r) (Wire.string_field r "message")
in
let is ?frame what code want =
let a = answer (ask ?frame code) in
if a <> want then fail "--%s: %s answered %S, not %S" backend what a want
in
if not (await ~ms:20000 (fun () -> status (ask "1") = "ok")) then
fail "--%s: the .fln dyn program never took an expression" backend
else begin
is "a dot assignment from a .fln file" "state.paused = not(state.paused)" "()";
is "and a dot read" "state.paused" "true";
ignore (ask "go = true");
let stopped () =
match Wire.field (request c "(:op \"describe\")") "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
if not (await ~ms:20000 stopped) then
fail "--%s: the .fln dyn program did not stop in boom" backend
else begin
is ~frame:0 "a dot assignment in a stopped frame"
"state.paused = not(state.paused)" "()";
is ~frame:0 "and a dot read there" "state.paused" "false"
end
end;
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill fpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] fpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ fsock; fout ])
[ "x86"; "llvm" ];
(* ── The dyn globals a park holds ─────────────────────────────────── *) (* ── The dyn globals a park holds ─────────────────────────────────── *)
(* The banner a finished run prints says the globals are as it left them, (* The banner a finished run prints says the globals are as it left them,
@ -7418,6 +7490,22 @@ let () =
if read () <> "\"kept\"" then if read () <> "\"kept\"" then
fail "--%s: the global was not readable before any thunk ran: %S" fail "--%s: the global was not readable before any thunk ran: %S"
backend (read ()); backend (read ());
(* A dyn's .field and [:key] are get and put in a thunk too. *)
List.iter
(fun (code, want) ->
let r =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %s \
:file \"programs/dev-dyn-global.flan\")"
(Wire.quote code))
in
if answer r <> want then
fail "--%s: %s answered %S (%s: %s), not %S" backend code
(answer r) (status r) (said r) want)
[ ("(.s config)", "\"kept\"");
("(do (set (.n config) 5) (++ (.n config)) (.n config))", "6");
("(do (set (at config :n) 1) (at config :n))", "1") ];
for cycle = 1 to 3 do for cycle = 1 to 3 do
let r = churn () in let r = churn () in
if status r <> "ok" then if status r <> "ok" then
@ -9330,13 +9418,13 @@ let () =
(* ── A slot lost, and a second generation ── (* ── A slot lost, and a second generation ──
[:y] goes. Nothing calls [area] after this: its method reads :y, [:y] goes. Nothing calls [area] after this: its method reads :y,
which is now nil, and a generic that traps on a slot its class no which is now refused, and a generic that traps on a slot its class no
longer has is the program being wrong rather than the migration. *) longer has is the program being wrong rather than the migration. *)
let r = redefine "(defclass point [x z])" in let r = redefine "(defclass point [x z])" in
if status r <> "ok" then fail "removing a slot from a class: %s" (said r) if status r <> "ok" then fail "removing a slot from a class: %s" (said r)
else begin else begin
holds "a lost slot reads as absent" holds "a lost slot is absent"
"(if (= (get (at instances 0) :y) nil) 1 0)"; "(if (has-key? (at instances 0) :y) 0 1)";
holds "a lost slot is gone from the count" holds "a lost slot is gone from the count"
"(if (= (length (at instances 0)) 2) 1 0)"; "(if (= (length (at instances 0)) 2) 1 0)";
holds "the slots either side of it are untouched" holds "the slots either side of it are untouched"
@ -9366,34 +9454,9 @@ let () =
"(if (= (type-of (at instances 1)) :point) 1 0)"; "(if (= (type-of (at instances 1)) :point) 1 0)";
holds "and a kind for anything that is not an instance" holds "and a kind for anything that is not an instance"
"(if (= (type-of (get (at instances 1) :w)) :nil) 1 0)" "(if (= (type-of (get (at instances 1) :w)) :nil) 1 0)"
end; end
(* A definition that did not change migrates nothing: the hook block
(* ── A definition that did not change ── below asks that with a method that would mark the instance. *)
Every C-c C-k re-runs a file's class definitions, and a generation
bumped per registration rather than per *change* would migrate
every instance in the program on every save. Here that would be
visible: the value written below is put into a slot the class
declares, and a spurious migration would keep it — so the
discriminating half is the raw key on the line after, which a real
migration drops and an ignored re-registration leaves alone. *)
holds "a key written straight into an instance"
"(do (put (at instances 0) :scratch 7) 1)";
let r = redefine "(defclass point [x z w])" in
if status r <> "ok" then fail "re-evaluating an unchanged class: %s" (said r)
else
holds "an unchanged definition migrates nothing"
"(if (= (get (at instances 0) :scratch) 7) 1 0)";
(* And the same key after a definition that *did* change, which is
the advisory registry stated as a test rather than as a hope: a
class instance is an open map, [put] accepts any key, and the next
migration drops the ones the class does not declare. TODO.org, "A
redefined defclass migrates its instances lazily", says so in as
many words. *)
let r = redefine "(defclass point [x z w q])" in
if status r <> "ok" then fail "a fourth redefinition: %s" (said r)
else
holds "a migration drops a key the class never declared"
"(if (= (get (at instances 0) :scratch) nil) 1 0)"
end; end;
(try Unix.close c with Unix.Unix_error _ -> ()); (try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill mpid Sys.sigkill with Unix.Unix_error _ -> ()); (try Unix.kill mpid Sys.sigkill with Unix.Unix_error _ -> ());
@ -9625,6 +9688,26 @@ let () =
if not (await warned) then if not (await warned) then
fail "%sno warning for a kept value that does not fit: %S" what fail "%sno warning for a kept value that does not fit: %S" what
(output ()) (output ())
end;
(* ── A definition that did not change ──
Every C-c C-k re-runs a file's class definitions, and one that
bumped the generation per registration rather than per change
would migrate every instance on every save. A method that marks
the instance says whether a migration ran: not for the same
definition again, and once for a changed one. *)
if defined "a method that marks the instance"
"(defmethod update-instance-for-redefined-class point \
[p added discarded] (set (get p :radius) 777) nil)"
&& defined "the same definition again"
"(defclass point [x str radius z n i32 note str])"
then begin
holds "an unchanged definition migrates nothing"
"(if (= (get (at instances 0) :radius) 4) 1 0)";
if defined "a changed definition after it"
"(defclass point [x str radius z n i32 note str w])"
then
holds "a changed one runs the method"
"(if (= (get (at instances 0) :radius) 777) 1 0)"
end end
end; end;
(try Unix.close c with Unix.Unix_error _ -> ()); (try Unix.close c with Unix.Unix_error _ -> ());

View File

@ -230,7 +230,7 @@ let () =
("atrange", "index 9 is out of bounds for text of length 2"); ("atrange", "index 9 is out of bounds for text of length 2");
("atnegative", "index -1 is out of bounds"); ("atnegative", "index -1 is out of bounds");
("setattext", "a text is immutable"); ("setattext", "a text is immutable");
("setatnotvec", "only a vec is assigned into"); ("setatnotvec", "only a vec or a map is assigned into");
("setatrange", "index 0 is out of bounds for vec of length 0"); ("setatrange", "index 0 is out of bounds for vec of length 0");
("push", "only a vec is pushed to"); ("push", "only a vec is pushed to");
("needi64", "dyn i64: text"); ("needi64", "dyn i64: text");

View File

@ -2903,6 +2903,12 @@ let () =
"(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (set (.x p) 2) (.x p)))"; "(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (set (.x p) 2) (.x p)))";
rejects_check "a dotted head that is not a struct says what it is" rejects_check "a dotted head that is not a struct says what it is"
"(defn f [] i32 (let [n 1] n.x))" ~needle:"n is i32, which has no fields"; "(defn f [] i32 (let [n 1] n.x))" ~needle:"n is i32, which has no fields";
rejects_check "a dotted dyn head points to the accessor"
"(defn f [] i32 (let [s {:p 1}] (println s.p) 0))"
~needle:"s is dyn, and its :p is reached with (.p s)";
rejects_check "and to the place in a set"
"(defn f [] i32 (let [s {:p 1}] (set s.p 2) 0))"
~needle:"s is dyn, and its :p is reached with (set (.p s) ...)";
(* The fourth shape: nothing is bound under the head either, so the message (* The fourth shape: nothing is bound under the head either, so the message
claims nothing about what q is — only that the dot is not the operator claims nothing about what q is — only that the dot is not the operator
the writer took it for. *) the writer took it for. *)

View File

@ -58,7 +58,8 @@ let describe_diff a b =
[let] takes in the statements after it (the printer's flat [let]; with [let] takes in the statements after it (the printer's flat [let]; with
every [let] name unique by now, nothing after it can mean one of them). A every [let] name unique by now, nothing after it can mean one of them). A
[(do x)] whose [x] is a [let] is [x], a [let] whose whole body is another [(do x)] whose [x] is a [let] is [x], a [let] whose whole body is another
[let] is the merged [let], and [(and x)] and [(or x)] are [x]. The flat [let] is the merged [let], [(fn [a] (do x y))] is [(fn [a] x y)], and
[(and x)] and [(or x)] are [x]. The flat
[let] and the one-argument [and] stop at a quote or quasiquote: data, or [let] and the one-argument [and] stop at a quote or quasiquote: data, or
a template whose unquotes could name anything. *) a template whose unquotes could name anything. *)
@ -203,6 +204,12 @@ let rec shape ?(q = false) (f : Form.t) : Form.t =
| [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] -> | [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
Form.List (h :: Form.make (Form.Vec (List.map sh bs @ bs2)) loc :: body2) Form.List (h :: Form.make (Form.Vec (List.map sh bs @ bs2)) loc :: body2)
| body -> Form.List (h :: Form.make (Form.Vec (List.map sh bs)) loc :: body)) | body -> Form.List (h :: Form.make (Form.Vec (List.map sh bs)) loc :: body))
(* A lambda whose body is one [do] is the lambda of its statements:
the printer writes them straight under [=>]. *)
| Form.List [ ({ v = Form.Sym "fn"; _ } as h); ({ v = Form.Vec _; _ } as ps);
{ v = Form.List ({ v = Form.Sym "do"; _ } :: (_ :: _ :: _ as ss)); _ } ]
when not q ->
(sh { f with v = Form.List (h :: ps :: ss) }).v
| Form.List (({ v = Form.Sym "handler-case"; _ } as h) :: body :: ({ v = Form.Vec cls; _ } as cv) :: more) -> | Form.List (({ v = Form.Sym "handler-case"; _ } as h) :: body :: ({ v = Form.Vec cls; _ } as cv) :: more) ->
Form.List (h :: sh body :: { cv with v = Form.Vec (List.map clause cls) } Form.List (h :: sh body :: { cv with v = Form.Vec (List.map clause cls) }
:: List.map sh more) :: List.map sh more)
@ -411,17 +418,19 @@ let () =
(* ── Lexical edge cases ────────────────────────────────────────────── *) (* ── Lexical edge cases ────────────────────────────────────────────── *)
let read src = Indent_reader.read_all ~file:"<syntax>" src (* [~global:false] reads as an expression the editor sends, where a [let] is
local; a file's top-level [let] is a global. *)
let read ?(global = true) src = Indent_reader.read_all ~global_let:global ~file:"<syntax>" src
let reads name src want = let reads ?global name src want =
match read src with match read ?global src with
| forms -> | forms ->
let got = String.concat "\n" (List.map Form.to_string forms) in let got = String.concat "\n" (List.map Form.to_string forms) in
if got <> want then fail "%s: read %s, wanted %s" name got want if got <> want then fail "%s: read %s, wanted %s" name got want
| exception e -> fail "%s: refused: %s" name (diag_text e) | exception e -> fail "%s: refused: %s" name (diag_text e)
let refuses name src kind needle = let refuses ?global name src kind needle =
match read src with match read ?global src with
| forms -> | forms ->
fail "%s: read %s, wanted the refusal %s" name fail "%s: read %s, wanted the refusal %s" name
(String.concat " " (List.map Form.to_string forms)) kind (String.concat " " (List.map Form.to_string forms)) kind
@ -462,7 +471,7 @@ let () =
reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])"; reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])";
reads "character arguments" "f(\\,, \\))" "(f \\, \\))"; reads "character arguments" "f(\\,, \\))" "(f \\, \\))";
(* Keywords and annotations. *) (* Keywords and annotations. *)
reads "keyword" "def k = :else" "(def k dyn :else)"; reads "keyword" "let k = :else" "(def k dyn :else)";
reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])"; reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])";
reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)"; reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)";
refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32"; refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32";
@ -521,8 +530,8 @@ let () =
(* Statements. *) (* Statements. *)
reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b" reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b"
"(defn f [] i32 (let [a 1 b 2] (+ a b)))"; "(defn f [] i32 (let [a 1 b 2] (+ a b)))";
refuses "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column"; refuses ~global:false "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column";
reads "flat let" "let a = 1\na\nb" "(let [a 1] a b)"; reads ~global:false "flat let" "let a = 1\na\nb" "(let [a 1] a b)";
reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)"; reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)";
reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))"; reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))";
reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))"; reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
@ -545,15 +554,71 @@ let () =
reads "quote block" reads "quote block"
"defmacro(m, [x & ys]):\n quote\n f(~x)\n ~@ys" "defmacro(m, [x & ys]):\n quote\n f(~x)\n ~@ys"
"(defmacro m [x & ys] (quasiquote (do (f (unquote x)) (unquote-splicing ys))))"; "(defmacro m [x & ys] (quasiquote (do (f (unquote x)) (unquote-splicing ys))))";
reads "lambda" "g = fn(i, j) = i * 10 + j" "(set g (fn [i j] (+ (* i 10) j)))"; reads "lambda" "g = fn(i, j) => i * 10 + j" "(set g (fn [i j] (+ (* i 10) j)))";
reads "lambda with a block" "g = fn(i)\n a(i)\n b(i)" "(set g (fn [i] (a i) (b i)))"; reads "lambda with a block" "g = fn(i) =>\n a(i)\n b(i)" "(set g (fn [i] (a i) (b i)))";
reads "where" "fn s(xs: [$t]) -> () where ordered?($t) = f(xs)" reads "where" "fn s(xs: [$t]) -> () where ordered?($t) = f(xs)"
"(defn s [xs [$t]] () {:where (ordered? $t)} (f xs))"; "(defn s [xs [$t]] () {:where (ordered? $t)} (f xs))";
reads "data" "data Shape\n Circle(r: f32)\n Empty" reads "data" "data Shape\n Circle(r: f32)\n Empty"
"(defdata Shape [(Circle [r f32]) Empty])"; "(defdata Shape [(Circle [r f32]) Empty])";
reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])"; reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])";
reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])"; reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])";
reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)"; reads "struct with a parent" "struct DiskFull :parent IoError\n free: i64"
"(defstruct DiskFull :parent IoError [free i64])";
reads "type alias" "type Row = Vec(i32)" "(defalias Row (Vec i32))";
reads "type alias of an array" "type V2 = [2 f32]" "(defalias V2 [2 f32])";
reads "a local named type" "type = 3" "(set type 3)";
reads "a header word assigned" "data += 3" "(set data (+ data 3))";
reads "a clause word assigned after its header"
"handler-case\n g()\non E(c)\n h(c)\non = 2"
"(handler-case (g) [(E [c] (h c))])\n(set on 2)";
reads "an else assigned after an if" "if a\n b\nelse = 2" "(when a b)\n(set else 2)";
reads "class" "class lambda(param, body, env)" "(defclass lambda [param body env])";
reads "class with typed slots" "class state\n pause: bool\n tag"
"(defclass state [pause bool tag])";
reads "generic" "generic describe(v) -> dyn" "(defgeneric describe [v] dyn)";
reads "multi" "multi kind(v) -> dyn = type-of(v)" "(defmulti kind [v] dyn (type-of v))";
reads "method on a class" "method describe(f: lambda, x)\n g(f)"
"(defmethod describe lambda [f x] (g f))";
reads "method on a value" "method kind(v) when :else = 1" "(defmethod kind :else [v] 1)";
refuses "a generic's typed parameter" "generic g(p: point) -> dyn" "indent/dyn-parameter"
"write generic g(p) -> dyn";
refuses "a method with no dispatch" "method g(p)\n 1" "indent/method-key"
"method g(p: point)";
refuses "a method with both" "method g(p: point) when :x\n 1" "indent/method-key"
"not both";
reads "a top-level let is a global" "let g = 1\nlet h: i32 = 2\nlet s: [4 u8]\nf(g)"
"(def g dyn 1)\n(def h i32 2)\n(def s [4 u8])\n(f g)";
refuses "def" "def g: i32 = 1" "indent/def-is-let" "let g: i32 = 1";
refuses "a bare def" "def g" "indent/def-is-let" "let g: i32 = 0";
(match read "generic f(a)\n\nfn g() = 1" with
| exception Loc.Error d when d.Loc.dloc.Loc.line = 1 && d.Loc.dloc.Loc.col = 13 -> ()
| exception Loc.Error d ->
fail "a generic with no arrow is refused at %d:%d, not at its line's end"
d.Loc.dloc.Loc.line d.Loc.dloc.Loc.col
| _ -> fail "a generic with no arrow was read");
reads "a let in a comment block stays local" "comment:\n let x = 1\n f(x)"
"(comment (let [x 1] (f x)))";
reads "and in a fn" "fn f() -> i32\n let x = 1\n x" "(defn f [] i32 (let [x 1] x))";
reads "a one-line struct" "struct Pt(x: i32, y)" "(defstruct Pt [x i32 y dyn])";
reads "a one-line union" "union U(a: i32)" "(defunion U [a i32])";
reads "a one-line struct with a parent" "struct D(free: i64) :parent Io"
"(defstruct D :parent Io [free i64])";
refuses "a one-line struct takes no block" "struct Pt(x: i32)\n y: i32" "indent/stray-indent"
"takes no block";
reads "a parent and no fields" "struct Io :parent Error" "(defstruct Io :parent Error)";
reads "macro" "macro repeat(i, n, & body)\n quote\n f(~i)\n ~@body"
"(defmacro repeat [i n & body] (quasiquote (do (f (unquote i)) (unquote-splicing body))))";
reads "macro with a pattern" "macro m([a b], c)\n a" "(defmacro m [[a b] c] a)";
reads "macro with no parameters" "macro m()\n a" "(defmacro m [] a)";
refuses "a rest parameter not last" "macro m(& a, b)\n a" "indent/macro-rest-last"
"comes last: macro m(b, & a)";
reads "loop" "loop x = a, y = b + 1\n recur(y, x)" "(loop [x a y (+ b 1)] (recur y x))";
reads ~global:false "a let-bound loop" "let r = loop i = 0\n recur(i)\nr" "(let [r (loop [i 0] (recur i))] r)";
reads "the loop call stays a call" "loop([x 1]):\n x" "(loop [x 1] x)";
refuses "a loop with no values" "loop\n g()" "indent/loop-bindings" "loop([]):";
refuses "a loop variable with no value" "loop x, y = 1\n g()" "indent/loop-bindings"
"loop x = 0";
reads "read-only pointer" "let p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)";
(* Statements that fit on a line, in one-line slots. *) (* Statements that fit on a line, in one-line slots. *)
reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1" reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1"
"(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))"; "(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))";
@ -569,9 +634,9 @@ let () =
refuses "two assignments" "if a then b = c = d" "indent/assign-in-test" "if a then b = c,"; refuses "two assignments" "if a then b = c = d" "indent/assign-in-test" "if a then b = c,";
refuses "a let-bound if with no block" "let r = if a > 1\nr" "indent/expected-block" "if a > 1 takes"; refuses "a let-bound if with no block" "let r = if a > 1\nr" "indent/expected-block" "if a > 1 takes";
refuses "two bindings on a line" "let v: i32 = a, w = b" "indent/one-binding" "a is followed by a comma"; refuses "two bindings on a line" "let v: i32 = a, w = b" "indent/one-binding" "a is followed by a comma";
reads "a let-bound match" "let r = match a\n 1 -> 2\n _ -> 3\nr" "(let [r (match a 1 2 _ 3)] r)"; reads ~global:false "a let-bound match" "let r = match a\n 1 -> 2\n _ -> 3\nr" "(let [r (match a 1 2 _ 3)] r)";
reads "a let-bound if" "let q = if a\n 1\nelse\n 2\nq" "(let [q (if a 1 2)] q)"; reads ~global:false "a let-bound if" "let q = if a\n 1\nelse\n 2\nq" "(let [q (if a 1 2)] q)";
reads "a let-bound call with a block" "let v = foo(a):\n x\nv" "(let [v (foo a x)] v)"; reads ~global:false "a let-bound call with a block" "let v = foo(a):\n x\nv" "(let [v (foo a x)] v)";
refuses "colon after if" "if c:\n y" "indent/header-colon" "no colon"; refuses "colon after if" "if c:\n y" "indent/header-colon" "no colon";
refuses "colon after a return type" "fn f() -> i32:\n 0" "indent/header-colon" "no colon"; refuses "colon after a return type" "fn f() -> i32:\n 0" "indent/header-colon" "no colon";
refuses "colon after a number" "while x < 3:\n y" "indent/header-colon" "no colon"; refuses "colon after a number" "while x < 3:\n y" "indent/header-colon" "no colon";
@ -583,7 +648,7 @@ let () =
refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]"; refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]";
reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1" reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1"
"(defmacro m [x] (quasiquote (+ (unquote x) 1)))"; "(defmacro m [x] (quasiquote (+ (unquote x) 1)))";
reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)"; reads ~global:false "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)";
refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)" refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)"
"indent/let-block" "go at the let's column"; "indent/let-block" "go at the let's column";
(* Mistakes carried over from other languages, answered in this one. *) (* Mistakes carried over from other languages, answered in this one. *)
@ -592,10 +657,51 @@ let () =
refuses "field with =" "p = P{x = 1}" "indent/brace-field" "{.x value}"; refuses "field with =" "p = P{x = 1}" "indent/brace-field" "{.x value}";
refuses "field with a colon" "p = P{x: 1}" "indent/brace-field" "no colon"; refuses "field with a colon" "p = P{x: 1}" "indent/brace-field" "no colon";
refuses "a dotted range" "for i in 0..10\n g(i)" "indent/dot-range" "range(0, 10)"; refuses "a dotted range" "for i in 0..10\n g(i)" "indent/dot-range" "range(0, 10)";
refuses "a block lambda inside a call" "sort-by(xs, fn(a, b)\n a < b)" (* A lambda's block inside brackets ends where they close. *)
"indent/lambda-block-in-brackets" "let f = fn(a: T, b: T) -> R"; reads "a block lambda inside a call" "sort-by(xs, fn(a, b) =>\n let c = a + 1\n c < b)"
refuses "a typed block lambda inside a call" "sort-by(xs, fn(a: C, b: C) -> bool\n a < b)" "(sort-by xs (fn [a b] (let [c (+ a 1)] (< c b))))";
"indent/lambda-block-in-brackets" "let f = fn(a: C, b: C) -> bool"; reads "its closer on a line of its own" "sort-by(xs, fn(a, b) =>\n a < b\n)\ng()"
"(sort-by xs (fn [a b] (< a b)))\n(g)";
reads "a typed block lambda inside a call" "sort-by(xs, fn(a: C, b: C) -> bool =>\n a < b)"
"(sort-by xs (the (Fn [C C] bool) (fn [a b] (< a b))))";
reads "nested block lambdas"
"map(xs, fn(x) =>\n let ys = map(x, fn(y) =>\n if y > 0\n y\n else\n 0)\n sum(ys))"
"(map xs (fn [x] (let [ys (map x (fn [y] (if (> y 0) y 0)))] (sum ys))))";
reads "a block lambda on a wrapped argument line" "f(a,\n fn(b) =>\n g(b)\n h(b))"
"(f a (fn [b] (g b) (h b)))";
reads "a block lambda in a vector" "x = [1, fn(b) =>\n b]" "(set x [1 (fn [b] b)])";
reads ~global:false "a call after a block lambda's call" "let v = f(fn(a) =>\n a)\ng(v)"
"(let [v (f (fn [a] a))] (g v))";
refuses "a block lambda is the last argument" "sort-by(fn(a, b) =>\n a < b, xs)"
"indent/lambda-block-last" "let f = fn(a) =>";
refuses "one block lambda to a call" "f(fn(a) =>\n a\n, fn(b) =>\n b)"
"indent/lambda-block-last" "on line 1";
refuses "a line back at the header's column" "f(fn(a) =>\n a\nb)"
"indent/lambda-block-last" "b follows the block of the lambda on line 1";
refuses "an element after a block lambda, left of its block" "m = {:a fn(x) =>\n x\n :b 2}"
"indent/lambda-block-last" ":b follows the block";
refuses "a block's first line not indented" "f(fn(a) =>\na)"
"indent/lambda-block-left" "Indent it into the block";
refuses "a block lambda's brackets left open" "f(fn(a) =>\n a\n"
"indent/unclosed" "ends where this bracket closes";
refuses "indices with no comma" "x = grid[row col].color-idx"
"indent/missing-comma" "Separate indices with commas: grid[row, col]";
refuses "arguments with no comma" "x = f(a b)"
"indent/missing-comma" "Separate arguments with commas: f(a, b)";
refuses "a body glued to =>" "x = fn(a) =>a"
"indent/lambda-arrow-space" "fn(a) => a";
refuses "a lambda written with =" "x = fn(a, b) = a + b"
"indent/lambda-equals" "fn(a, b) => a + b";
refuses "a typed lambda written with =" "x = fn(a: C) -> bool = a.n > 1"
"indent/lambda-equals" "fn(a: C) -> bool => a.n > 1";
refuses "a block lambda with no =>" "let f = fn(a)\n a\nf"
"indent/lambda-arrow" "fn(a) =>";
refuses "a block lambda with no => inside a call" "sort-by(xs, fn(a, b)\n a < b)"
"indent/lambda-arrow" "fn(a, b) =>";
refuses "a typed block lambda with no => inside a call" "sort-by(xs, fn(a: C, b: C) -> bool\n a < b)"
"indent/lambda-arrow" "fn(a: C, b: C) -> bool =>";
refuses "a => with nothing under it" "let f = fn(a) =>\nf"
"indent/lambda-body" "fn(a) =>";
refuses "an else after else-if on one line" "if a then x\nelse if b then y\nelse z" refuses "an else after else-if on one line" "if a then x\nelse if b then y\nelse z"
"indent/orphan-else" "Write that line as elif"; "indent/orphan-else" "Write that line as elif";
refuses "else deeper than a one-line if" "if a then b\n else c" refuses "else deeper than a one-line if" "if a then b\n else c"
@ -610,17 +716,17 @@ let () =
"(cond a b c d e (do (f) (g)) :else (h))"; "(cond a b c d e (do (f) (g)) :else (h))";
refuses "else left of a one-line if" "while x\n if a then b\nelse c" refuses "else left of a one-line if" "while x\n if a then b\nelse c"
"indent/orphan-else" "goes at the if's column"; "indent/orphan-else" "goes at the if's column";
reads "a typed lambda" "f = fn(a: C, b) -> bool = a.n < b" reads "a typed lambda" "f = fn(a: C, b) -> bool => a.n < b"
"(set f (the (Fn [C dyn] bool) (fn [a b] (< (.n a) b))))"; "(set f (the (Fn [C dyn] bool) (fn [a b] (< (.n a) b))))";
reads "a typed lambda with a block" "let f = fn(x: i32) -> i32\n let y = x + 1\n y\ng(f)" reads ~global:false "a typed lambda with a block" "let f = fn(x: i32) -> i32 =>\n let y = x + 1\n y\ng(f)"
"(let [f (the (Fn [i32] i32) (fn [x] (let [y (+ x 1)] y)))] (g f))"; "(let [f (the (Fn [i32] i32) (fn [x] (let [y (+ x 1)] y)))] (g f))";
refuses "a typed lambda states its return type" "f = fn(a: C) = a" refuses "a typed lambda states its return type" "f = fn(a: C) = a"
"indent/lambda-return" "fn(a: C) -> R = value"; "indent/lambda-return" "fn(a: C) -> R => value";
reads "a restart's report on its header" reads "a restart's report on its header"
"restart-case\n go()\nrestart retry(n: i32) \"Try again\"\n n" "restart-case\n go()\nrestart retry(n: i32) \"Try again\"\n n"
"(restart-case (go) (retry [n i32] :report \"Try again\" n))"; "(restart-case (go) (retry [n i32] :report \"Try again\" n))";
reads "a bare () in a body slot does nothing" reads "a bare () in a body slot does nothing"
"fn f() -> () = ()\nfn g(x) -> ()\n match x\n 1 -> h()\n _ -> ()\n k = fn() = ()" "fn f() -> () = ()\nfn g(x) -> ()\n match x\n 1 -> h()\n _ -> ()\n k = fn() => ()"
"(defn f [] () (do))\n(defn g [x dyn] () (match x 1 (h) _ (do)) (set k (fn [] (do))))"; "(defn f [] () (do))\n(defn g [x dyn] () (match x 1 (h) _ (do)) (set k (fn [] (do))))";
reads "a parenthesised () stays a value" "x = (())" "(set x ())"; reads "a parenthesised () stays a value" "x = (())" "(set x ())";
reads "a template's for takes an unquoted variable" reads "a template's for takes an unquoted variable"
@ -700,7 +806,7 @@ let () =
prints "comment is a body in order" "(comment (let [a 1] (g a)) (h))" "comment:\n let a = 1\n g(a)\n h()"; prints "comment is a body in order" "(comment (let [a 1] (g a)) (h))" "comment:\n let a = 1\n g(a)\n h()";
prints "a later lambda keeps the outer name" prints "a later lambda keeps the outer name"
"(defn f [] i32 (let [x 1] (let [x 5] (g x)) (app (fn [y] (+ x y)) 2)))" "(defn f [] i32 (let [x 1] (let [x 5] (g x)) (app (fn [y] (+ x y)) 2)))"
" let x = 1\n let x-2 = 5\n g(x-2)\n app(fn(y) = x + y, 2)"; " let x = 1\n let x-2 = 5\n g(x-2)\n app(fn(y) => x + y, 2)";
prints "a renamed name renamed again counts on" prints "a renamed name renamed again counts on"
"(defn f [] () (let [x 1] (let [x 2] (let [x 3] (g x)) (g x)) (g x)))" "(defn f [] () (let [x 1] (let [x 2] (let [x 3] (g x)) (g x)) (g x)))"
" let x = 1\n let x-2 = 2\n let x-3 = 3\n g(x-3)\n g(x-2)\n g(x)"; " let x = 1\n let x-2 = 2\n let x-3 = 3\n g(x-3)\n g(x-2)\n g(x)";
@ -790,15 +896,61 @@ let () =
"(defn f [a bool b bool c bool] bool (or (and a b) c))" "= (a and b) or c"; "(defn f [a bool b bool c bool] bool (or (and a b) c))" "= (a and b) or c";
prints "a typed lambda prints as one" prints "a typed lambda prints as one"
"(defn f [] () (let [g (the (Fn [C] bool) (fn [c] (> (.n c) 3)))] (h g)))" "(defn f [] () (let [g (the (Fn [C] bool) (fn [c] (> (.n c) 3)))] (h g)))"
"let g = fn(c: C) -> bool = c.n > 3"; "let g = fn(c: C) -> bool => c.n > 3";
(* A lambda with a block as a call's last argument prints inside the call,
and reads back as it was. *)
let round name src want =
prints name src want;
let forms = Reader.read_all ~file:"<p>" src in
let text = Indent_printer.program ~source:src forms in
match Indent_reader.read_all ~file:"<p>" text with
| back ->
if not (same_forms forms back) then
fail "%s: read back %s from %S" name (describe_diff forms back) text
| exception e -> fail "%s: its text is refused: %s\n%s" name (diag_text e) text
in
round "a one-line lambda" "(defn f [] () (h (fn [a] (+ a 1)) 2))" "= h(fn(a) => a + 1, 2)";
round "a block lambda as a call's last argument"
"(defn f [] () (sort-by xs (fn [a b] (g a) (< a b))))"
" 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))";
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)";
round "a let's call with a block lambda"
"(defn f [] () (let [v (m xs (fn [x] (g x) x))] (h v)))"
" let v = m(xs, fn(x) =>\n g(x)\n x)\n h(v)";
round "nested block lambdas"
"(defn f [] () (m xs (fn [x] (let [y (m x (fn [z] (g z) z))] (h y)))))"
" m(xs, fn(x) =>\n let y = m(x, fn(z) =>\n g(z)\n z)\n h(y))";
round "a block lambda inside an expression, the line going on after it"
"(defn f [] i64 (+ (ap 1 (fn [x] (g x) x)) 1))" " ap(1, fn(x) =>\n g(x)\n x) + 1";
round "one in a lambda that fits on its line"
"(defn f [] i64 (ap 1 (fn [x] (ap x (fn [y] (g y) y)))))"
" ap(1, fn(x) =>\n ap(x, fn(y) =>\n g(y)\n y))";
round "a struct literal's last field"
"(defn f [] i64 (let [o (Ops {.k 1 .run (fn [x] (g x) x)})] (.k o)))"
" let o = Ops{.k 1, .run fn(x) =>\n g(x)\n x}";
round "a returned call"
"(defn f [] i64 (return (ap 2 (fn [x] (g x) x))))" " return ap(2, fn(x) =>\n g(x)\n x)";
round "a let in a lambda inside a call's argument"
"(defn f [] i64 (println (call0 (fn [] (let [n 0] (set n 1) n)))) 0)"
" println(call0(fn() =>\n let n = 0\n n = 1\n n))";
prints "a body that is one do goes straight under =>"
"(defn f [] i64 (call0 (fn [] (do (g 1) 2))))" " call0(fn() =>\n g(1)\n 2)";
round "a block lambda not last keeps the fallback"
"(defn f [] () (r (fn [a b] (g a) b) 0))" "= r(fn([a b], g(a), b), 0)";
round "a lambda bound by let"
"(defn f [] () (let [k (fn [a] (g a) a)] (k 1)))" " let k = fn(a) =>\n g(a)\n a\n k(1)";
prints "a restart's report goes on its header" prints "a restart's report goes on its header"
"(defn f [] i32 (restart-case (go) (retry [] :report \"Try again\" 7)))" "(defn f [] i32 (restart-case (go) (retry [] :report \"Try again\" 7)))"
"restart retry() \"Try again\"\n 7"; "restart retry() \"Try again\"\n 7";
prints "adjacent one-line globals stay adjacent" prints "adjacent one-line globals stay adjacent"
"(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)\n" "(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)\n"
"once a: i32\ndef b: i32 = 2\n\nconst c = 3"; "once a: i32\nlet b: i32 = 2\n\nconst c = 3";
back "adjacent one-line globals stay adjacent in parens" back "adjacent one-line globals stay adjacent in parens"
"once a: i32\ndef b: i32 = 2\n\nconst c = 3\n" "once a: i32\nlet b: i32 = 2\n\nconst c = 3\n"
"(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)"; "(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)";
prints "a field of a field chains" "(defn f [] () (g (.count (.x w))))" "g(w.x.count)"; prints "a field of a field chains" "(defn f [] () (g (.count (.x w))))" "g(w.x.count)";
prints "an else-if chain on one line" prints "an else-if chain on one line"
@ -807,7 +959,42 @@ let () =
prints "a long vector wraps" ("(defn f [] () (let [v [" ^ String.concat " " (List.init 30 string_of_int) ^ "]] (g v)))") prints "a long vector wraps" ("(defn f [] () (let [v [" ^ String.concat " " (List.init 30 string_of_int) ^ "]] (g v)))")
" let v = [0 1 2 3"; " let v = [0 1 2 3";
prints "a template's for keeps its unquotes" prints "a template's for keeps its unquotes"
"(defmacro m [i n & body] `(dotimes [~i ~n] ~@body))" "for ~i in range(~n)" "(defmacro m [i n & body] `(dotimes [~i ~n] ~@body))" "for ~i in range(~n)";
prints "a macro" "(defmacro m [[a b] n & body] `(do ~@body))" "macro m([a b], n, & body)\n quote";
prints "a header word assigned keeps no parentheses"
"(defn f [] () (set data 3) (set loop 4) (set on 5))" " data = 3\n loop = 4\n on = 5";
prints "a class" "(defclass point [x y])" "class point(x, y)";
prints "a class's typed slots, and one typed as a class of the file"
"(defclass state [pause bool tag])\n(defclass node [owner state n])"
"class state(pause: bool, tag)\n\nclass node(owner: state, n)";
prints "a generic" "(defgeneric area [self] dyn)" "generic area(self) -> dyn";
prints "a multi" "(defmulti kind [v] dyn (type-of v))" "multi kind(v) -> dyn = type-of(v)";
prints "a method on a class" "(defmethod area point [p] (g p) (h p))"
"method area(p: point)\n g(p)\n h(p)";
prints "a method on a value" "(defmethod kind :int [v] \"n\")" "method kind(v) when :int = \"n\"";
prints "a global is a top-level let" "(def g dyn 1)\n(def h i32 2)" "let g = 1\nlet h: i32 = 2";
prints "a def inside a form keeps the fallback" "(comment (def g i32 1))" "comment:\n def(g, i32, 1)";
prints "a local let at the top level goes in a do block" "(let [x 1] (f x))"
"do:\n let x = 1\n f(x)";
prints "a type alias" "(defalias Row (Vec i32))" "type Row = Vec(i32)";
prints "a struct with a parent" "(defstruct D :parent Io [free i64])"
"struct D(free: i64) :parent Io";
prints "a struct on one line" "(defstruct Pt [x i32 y dyn])" "struct Pt(x: i32, y)\n";
prints "a union too" "(defunion U [a i32 b f32])" "union U(a: i32, b: f32)";
prints "a struct too long for a line takes a line per field"
("(defstruct W [" ^ String.concat " " (List.init 8 (Printf.sprintf "field-number-%d i32")) ^ "])")
"struct W\n field-number-0: i32\n";
prints "and so does one with a comment among its fields"
"(defstruct C [a i32 ; first\n b i32])" "struct C\n a: i32 ; first\n b: i32";
prints "a parent with no fields" "(defstruct D :parent Io)" "struct D :parent Io";
prints "an empty field vector under a parent keeps the fallback"
"(defstruct D :parent Io [])" "defstruct(D, :parent, Io, [])";
prints "a loop" "(defn f [a i32] i32 (loop [x a y 0] (if (= x 0) y (recur (- x 1) (+ y 1)))))"
" loop x = a, y = 0\n if x == 0 then y";
prints "a let-bound loop" "(defn f [] i32 (let [r (loop [i 0] (recur i))] r))"
" let r = loop i = 0\n recur(i)";
prints "a lambda as a loop's value is parenthesised"
"(defn f [] () (loop [g (fn [x] x) n 0] (recur g n)))" "loop g = (fn(x) => x), n = 0"
(* ── Spans, for pause marks and error overlays ──────────────────────── *) (* ── Spans, for pause marks and error overlays ──────────────────────── *)
@ -1014,8 +1201,8 @@ let () =
[ "it has to be written: i32(x)" ]; [ "it has to be written: i32(x)" ];
refused "unknown-type.fln" "fn f(p: Keyword) -> i32 = 0\n\nfn main() -> i32 = 0\n" refused "unknown-type.fln" "fn f(p: Keyword) -> i32 = 0\n\nfn main() -> i32 = 0\n"
[ "unknown type Keyword" ]; [ "unknown type Keyword" ];
refused "untyped-lambda.fln" "fn main() -> i32\n let f = fn(a)\n a\n 0\n" refused "untyped-lambda.fln" "fn main() -> i32\n let f = fn(a) =>\n a\n 0\n"
[ "let f: Fn(T, ...) -> R = fn(...)" ]; [ "let f: Fn(T, ...) -> R = fn(...) =>" ];
refused "plusplus.fln" "fn main() -> i32\n let x = 1\n x++\n x\n" refused "plusplus.fln" "fn main() -> i32\n let x = 1\n x++\n x\n"
[ "write ++(x) or x += 1" ]; [ "write ++(x) or x += 1" ];
refused "plusplus-global.fln" "once g = 0\n\nfn main() -> i32\n g--\n 0\n" refused "plusplus-global.fln" "once g = 0\n\nfn main() -> i32\n g--\n 0\n"
@ -1045,25 +1232,28 @@ let () =
fail "map-key.fln: %d errors, wanted one" (List.length ds) fail "map-key.fln: %d errors, wanted one" (List.length ds)
| exception _ -> () | exception _ -> ()
| _ -> ()); | _ -> ());
(* The fix the lambda-in-brackets refusal shows compiles, with its (* The fix a block lambda with no => is shown compiles, inside the call. *)
placeholders filled in. *)
(match read "sort-by(xs, fn(a, b)\n a.n < b.n)" with (match read "sort-by(xs, fn(a, b)\n a.n < b.n)" with
| _ -> fail "lambda in brackets: read" | _ -> fail "lambda in brackets: read"
| exception Loc.Error d -> | exception Loc.Error d ->
let header = let header =
let m = d.Loc.dmsg in let m = d.Loc.dmsg in
let i = String.index m '=' + 2 in let i = String.index m '\n' + 6 in
String.sub m i (String.index_from m i '\n' - i) String.sub m i (String.index_from m i '\n' - i)
in in
let header =
String.concat "C" (String.split_on_char 'T' header)
|> String.split_on_char 'R' |> String.concat "bool"
in
checks "lambda-fix.fln" checks "lambda-fix.fln"
("struct C\n n: i32\n\nfn main() -> i32\n let xs = [C{.n 2} C{.n 1}]\n" ("struct C\n n: i32\n\nfn main() -> i32\n let xs = [C{.n 2} C{.n 1}]\n"
^ " let f = " ^ header ^ "\n a.n < b.n\n sort-by(slice(xs), f)\n xs[0].n\n")); ^ " sort-by(slice(xs), " ^ header ^ "\n a.n < b.n)\n xs[0].n\n"));
(* A typed block lambda inside a call, a closer on its own line, and one
nested in another's block. *)
checks "block-lambdas.fln"
("struct C\n n: i32\n\nfn app(x: i64, f: Fn(i64) -> i64) -> i64 = f(x)\n\n"
^ "fn main() -> i32\n let xs = [C{.n 2} C{.n 1}]\n"
^ " sort-by(slice(xs), fn(a: C, b: C) -> bool =>\n let d = a.n - b.n\n d < 0)\n"
^ " let k = app(2, fn(a) =>\n let b = app(a, fn(c) =>\n c * 10\n )\n b + 1)\n"
^ " i32(k) + xs[0].n\n");
refused "cfn-captures.fln" refused "cfn-captures.fln"
"fn app(f: CFn(Option(i32)) -> i32) -> i32 = f(None)\n\nfn main() -> i32\n let k = 1\n app(fn(o) = k)\n" "fn app(f: CFn(Option(i32)) -> i32) -> i32 = f(None)\n\nfn main() -> i32\n let k = 1\n app(fn(o) => k)\n"
[ "so it is a Fn(Option(i32)) -> i32 and not a CFn(Option(i32)) -> i32" ]; [ "so it is a Fn(Option(i32)) -> i32 and not a CFn(Option(i32)) -> i32" ];
refused "defvar.fln" "defvar(x, 1)\n\nfn main() -> i32 = 0\n" refused "defvar.fln" "defvar(x, 1)\n\nfn main() -> i32 = 0\n"
[ "once x = 1 initialises once"; "def x = 1 re-initialises" ] [ "once x = 1 initialises once"; "def x = 1 re-initialises" ]

View File

@ -81,10 +81,9 @@ do
name=${pair%%:*}; src=${pair#*:} name=${pair%%:*}; src=${pair#*:}
printf '%s\n' "$src" > "$here/.q.flan" printf '%s\n' "$src" > "$here/.q.flan"
out=$("$FLAN" check "$here/.q.flan" 2>&1) out=$("$FLAN" check "$here/.q.flan" 2>&1)
# A probe that compiles is the failure this loop is most likely to meet, and # A probe that compiles is the failure this loop is most likely to meet:
# it is the one that used to be unreadable: `flan check` answers a clean # `flan check` prints nothing for it, so the needle would be empty and the
# program with its whole symbol table, so the needle became eighty lines of # diff would say nothing. Say what actually happened.
# prelude signatures and the diff said nothing. Say what actually happened.
if "$FLAN" check "$here/.q.flan" >/dev/null 2>&1; then if "$FLAN" check "$here/.q.flan" >/dev/null 2>&1; then
echo "FAIL message: $name" echo "FAIL message: $name"
echo " this program compiles now — the page still says it is refused" echo " this program compiles now — the page still says it is refused"

View File

@ -700,7 +700,9 @@ program was edited elsewhere would not be worth having.</p>
<code>{:a 1 :b "two"}</code> is a dyn map and <code>[1 2 3]</code> is a dyn vector. <code>{:a 1 :b "two"}</code> is a dyn map and <code>[1 2 3]</code> is a dyn vector.
<code>get</code>, <code>put</code>, <code>has-key?</code>, <code>at</code> and <code>get</code>, <code>put</code>, <code>has-key?</code>, <code>at</code> and
<code>length</code> read and write them, the same names the typed <code>length</code> read and write them, the same names the typed
<code>Map</code> and <code>Vec</code> answer to. A keyword is a value here rather <code>Map</code> and <code>Vec</code> answer to. <code>(.hp m)</code> is
<code>(get m :hp)</code> and <code>(at m :hp)</code> is too; <code>set</code> on
either is <code>put</code>. A keyword is a value here rather
than only a way to name an enum member: keywords are interned, so comparing two is than only a way to name an enum member: keywords are interned, so comparing two is
comparing two pointers.</p> comparing two pointers.</p>
@ -724,10 +726,11 @@ for anything that is not an instance. <code>type-of</code> answers any value's
kind as a keyword — <code>:nil</code>, <code>:bool</code>, <code>:int</code>, kind as a keyword — <code>:nil</code>, <code>:bool</code>, <code>:int</code>,
<code>:float</code>, <code>:text</code>, <code>:vec</code>, <code>:map</code> or <code>:float</code>, <code>:text</code>, <code>:vec</code>, <code>:map</code> or
<code>:keyword</code> — and an instance's class name, so a class cannot be named <code>:keyword</code> — and an instance's class name, so a class cannot be named
after one of those kinds. The slots are map keys: <code>get</code> after one of those kinds. The slots are map keys: <code>(.pause s)</code>
reads one, and <code>set</code> writes one, as in reads one, and <code>(set (.pause s) true)</code> writes one, checking its
<code>(set (get s :pause) true)</code>. <code>put</code> writes one too, and is type. <code>get</code> and <code>put</code> do the same. A key the class does
also how a key the class does not declare is added.</p> not declare is refused, so a misspelled slot stops the program at the line that
misspelled it.</p>
<p>Dispatch comes in the two styles and they are one mechanism. <p>Dispatch comes in the two styles and they are one mechanism.
<code>defgeneric</code> dispatches on the class of the first argument, which is <code>defgeneric</code> dispatches on the class of the first argument, which is