JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge master into the .fln mode lane; a .fln arm sends its match whenever its value uses any name the pattern has, C-c C-s steps a .fln top-level form, and a comment block directly above a form is part of its text objects

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 20:53:48 +07:00
commit 4d3688a519
63 changed files with 6018 additions and 832 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
README.md
View File

@ -262,9 +262,9 @@ driver at all — it goes `llc` + `ld -shared` + `dlopen`, which is what makes
is a confusing shape of failure to meet without warning.
Variables beginning `FLAN_DEV_` other than `FLAN_DEV_LEAKS`, plus
`FLAN_AGENT_SOCKET` and `FLAN_COMPILER_STAMP`, are internal: `flan dev` sets
them across its own `exec` to hand the merged binary what it needs. Setting
them by hand is not supported.
`FLAN_AGENT_SOCKET`, `FLAN_AGENT_OWNER` and `FLAN_COMPILER_STAMP`, are
internal: `flan dev` sets them across its own `exec` to hand the merged binary
what it needs. Setting them by hand is not supported.
## Checking it

201
TODO.org
View File

@ -296,6 +296,14 @@ keyword resolves against the expected type and against nothing else, so two enum
could always share a member spelling. What the prefix buys is the call site read
on its own.
** WAIT ML-style patterns
Held 2026-09-25 as a future direction, like the JS backend: nested destructuring,
guards, or-patterns, literals at any depth, exhaustiveness over the nesting.
** NEXT match over numbers and strings
Decided 2026-09-25: a match arm's pattern can be an integer, a float, a char or a
string literal, compared as =(= t lit)=; a match over such a type needs a =_= arm.
** DONE match over enums
CLOSED: [2026-09-25]
=Ast.Pkw= is the keyword pattern; =Check.check_match= resolves it against the
@ -630,12 +638,6 @@ generic binding — saying =$= marks a
type variable and naming the bare spelling. A =defn= parameter was already
refused, as a type in a name slot.
** NEXT A container parameter the function grows is warned at
Decided 2026-09-25: Odin's behaviour stays — a Vec or Map passed by value is a
copy of its header, so growth inside the callee does not reach the caller. A
parameter the function grows (push, put, reserve, anything that can reallocate)
gets a warning at the parameter suggesting (Ptr ...).
** CANCELLED not= as a spelling of !=
CLOSED: [2026-09-25]
One spelling for one operation; != stays, and not= is refused with a suggestion
@ -643,6 +645,10 @@ of !=.
* Checker
** WAIT A _ body that returns an fn literal
Refused today; allowing it when the literal writes its parameter types is the
proposal. Postponed 2026-09-25 while .fln takes priority.
** DONE The ownership flow analysis is repealed
CLOSED: [2026-09-18]
Static use-after-move and double-free checking is gone; types, allocators and the
@ -680,14 +686,6 @@ A machine-type target needs =numeric?=; an enum target needs =integer?=;
by what it claims, not by the set it happens to denote this week — which is why
=ordered?= is refused even though every type it admits today converts.
** NEXT There is now no generic enum to integer conversion
Decided 2026-09-25: build =enum?= as described.
Recorded as a loss. The one spelling that worked did so by not asking about the
operand at all, so removing it was still right. =enum?= is the eventual answer —
it would entail =ordered?= and =equal?= and not =numeric?=, so the cast rule
becomes a disjunction and the refusal has to name whichever the reader meant. Each
part of that is a decision and the author has not been asked.
** DONE The Ptr and union arms of the fill boundary are relaxable
CLOSED: [2026-09-25]
A =Ptr= may be byte-filled, and an untagged union is filled over its whole
@ -750,15 +748,10 @@ depth it gave up at. The bare depth number is a backstop that also prints the
chain. Before any of it, the compiler hung rather than failed, which wedges =C-c
C-c= with nothing to show.
** NEXT Generic types
Decided 2026-09-25: the freeze is lifted for this; build both type and length parameters.
=(defstruct Pair [a $t b $t])= cannot be spelled, and neither can a length
parameter. =Types.Named= is a bare string with no room for parameters; giving it
some changes the type, the layout calculator, both backends, the renderer and the
DWARF path. Same price for one as for both. Decided and unblocked, deliberately
not started — it is a language feature under a freeze, and it was stopped once
already for that reason. The motivating case is Odin's =Small_Array=: a
fixed-capacity array with a count and no allocation.
** DONE Generic types
CLOSED: [2026-09-25]
A struct's parameters are its fields' $-names in first-written order, a length by position; there is no
explicit parameter vector. Each application is an ordinary struct under a key, so no backend sees a parameter.
** WAIT A value predicate over a length parameter
Decided 2026-09-25: waits until a program wants one.
@ -767,12 +760,6 @@ clause here admits nothing but type predicates. Whether it should take value
predicates over a length parameter deserves answering deliberately rather than
falling out of the implementation.
** TODO "In instantiation of" notes
A refusal inside a copy points at the generic's source with no note naming the
call site that asked for that type. The data is there — =instantiation_origin=
exists and the session already uses it — and wiring it into every failure under an
instantiation is a lane of its own.
** DONE A program is one compilation, so a generic's body is always visible
CLOSED: [2026-09-25]
Odin's and Zig's model: packages are never compiled separately. The cost is build
@ -856,34 +843,12 @@ CLOSED: [2026-09-20]
typed conditions stay strict =bool=. =and= and =or= hand back the operand that
decided them, Clojure's rule, through a desugaring that evaluates each test once.
** NEXT A bool arm and a dyn arm joining as dyn
Decided 2026-09-25: they join as =dyn=, the =bool= boxed — Clojure's rule, so =(or false (box "s"))= answers ="s"=.
With both arms of a desugared =and=/=or= holding real values, a non-bool =dyn= on
the losing side meets the strict =bool= boundary and traps —
=(or false (box "s"))= is the case. Whether a =bool= arm and a =dyn= arm should
join as =dyn= is the author's call and is not settled.
** NEXT A truthiness failure re-runs the whole failing subtree
Decided 2026-09-25: fix it without changing any message — the retry reuses what the first pass settled for each subtree (memoised by node), so nested =not= is linear. Test with a deep nest that must fail fast and with the existing message tests unchanged.
The retry exists to keep a refused literal's message unchanged and re-runs the
subtree rather than the leaf, which is exponential in nested =not= depth on a
program that does not type-check. Moot for anything that compiles; only the
daemon's half-typed recompiles could feel it. A cheaper retry was tried and
shelved because it changes which literal gets the nicer message.
** DONE and's last operand gets a misdirected caret
CLOSED: [2026-09-25]
Already fixed by 3672da2, which blames the arm that is not a compiler temp; the
caret is on the last operand and =test/test_flan.ml= asserts its column. Rules
out relabelling the else arm, a bool sentinel, and inverting the condition.
** NEXT Signature pairing's cold-rebuild edge
Decided 2026-09-25: the type takes precedence, as today. The warning is at the parameter site: where a name in a parameter vector is read as a program-declared type but could also have been read as a parameter name, the parameter vector gets a warning naming the type and where it is declared.
Whether a parameter vector reads as one annotated parameter or two dyn ones
depends on what type names exist, so adding a type can silently re-pair an
existing signature between compiles. A changed-pairing warning was proposed and
not queued.
** DONE A typed container crosses into dyn as a view, and only from permanent storage
CLOSED: [2026-09-20]
The descriptor is pointer, length and element type — a slice plus the piece a
@ -905,6 +870,7 @@ semantics; the refined version needs liveness across control flow, which is the
flow tracking that was repealed.
** NEXT Catching a use-after-release statically
Decided 2026-09-25 (91): build (A) Odin's unsafe-return refusal — returning (addr local), (slice local-array …) or (addr (at local-array i)); (B) the same test on a set into a global; (C) dev fills a fixed arena's freed bytes with poison on free-all; (D) detect_stack_use_after_return=1 for @sanitize. Rules out a with-allocator escape check: the runtime epoch check catches it and a static rule flags building into the caller's arena. Probes: p1-p16 of the study.
Decided 2026-09-25: a study, not a build — how arena memory escapes in real Flan code, and whether a sound lexical check would catch most of it. The result goes in docs/BUILT.md; nothing is built on it without the author.
Open, and for the first time with evidence available: the epoch trap is built, and
there is a =Vec= to write real arena programs with, so whether the escapes that
@ -1005,13 +971,10 @@ at all, which is what the diagnosis predicted. A =map= that *changes* the elemen
type is the one shape that did not come with them: one copy per ordered pair of
types rather than per type.
** NEXT CFn in a struct or a fixed array
Decided 2026-09-25: allowed. A call through a null =CFn= is a named runtime condition on both backends, and parks in a dev build.
A zeroed function value is a null pointer, so a function value is refused in any
position zero-initialisation would conjure one — =CFn= included. An =(Option
(CFn ...))= field is already legal. A table of function pointers is exactly what
=CFn= is for, and the objection is about zero-initialisation rather than about
capture.
** DONE CFn in a struct or a fixed array
CLOSED: [2026-09-25]
A zeroed =CFn= is admitted everywhere and a call through a null one signals
=NullCall= before its arguments run. =(Fn ...)= stays refused in those positions.
** DONE Structural compatibility is identical layout
Same fields, same types, same order, so structural compatibility is "the same
@ -1021,15 +984,6 @@ ignore order, writable access has to alias the real storage. Flexible field orde
waits for classes deliberately, because a class owns its layout and a =Vector2=
should not pay for identity and metadata. Not implemented.
** TODO An error in a called generic's body is reported twice
=(defn g [x $t] u64 (nosuch x))= called once from =main= prints "unknown
function nosuch" twice at the same place and counts 2 errors — once from the
abstract pass and once from the instantiation.
** TODO A type variable is printed without its $
=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort
expects [t] here, found [3 i32]" where the source wrote =[$t]=.
** DONE Two refusals suggested something that does not compile
CLOSED: [2026-09-25]
=vec-new= and =map-new= with no type no longer say "or give the binding a type";
@ -1484,9 +1438,10 @@ out the first element typing the rest.
* Dev loop
** TODO Every evaluated expression leaves its module mapped
Each C-x C-e loads its own =.so= and never unloads it, so a session's mapping count
grows by about four per evaluation; the kernel's limit (65530) ends a long session.
** WAIT A _ caller whose type follows a redefined callee
Its signature changes in the session but its body is not recompiled, so every call
stops on StaleCall naming a type nobody wrote. Proposal: recompile such callers.
Postponed 2026-09-25 while .fln takes priority.
** TODO A prelude function shadowed live is reached by the prelude's own calls
A defn of a prelude function's name sent to a running =flan dev= installs into the
@ -1529,12 +1484,6 @@ A finished program parks instead of dying, and a daemon op wakes it and re-enter
Globals are not reset between runs — the process never died. Rules out a fresh
process per run.
** NEXT Re-run does not work under --two-process
Decided 2026-09-25: re-run under =--two-process= starts a fresh child, installed redefinitions included, and says that globals start over because the process is new.
A finished child process is genuinely gone, so there is nothing to wake. Re-run is
merged-build only, and since the default backend runs merged it is no longer the
blocked case.
** DONE An accepted re-run reads as running
CLOSED: [2026-09-21]
A caller that asked for a re-run and then waited for the program to park was
@ -1570,14 +1519,6 @@ was delivered" is a generation number rather than a name, so evaluating from
inside a break into a thunk that stops on the same condition class is settled by
comparing two integers.
** NEXT Whose break it is, which no counter answers
Decided 2026-09-25: fix it. A stop records whether the thread that stopped was running the evaluation's thunk or the program's own code, so the sentence is decided by the frame and not by the generation counter.
A game loop that signals during the build or the wait bumps the generation exactly
as a thunk would. The machine-readable fields stay right; what is wrong is the
sentence. The per-frame program-or-eval label is computed by the daemon from
ownership, not from anything in the frame, so this is not the shadow-stack gap it
was once written down as. Not queued — the window is narrow.
** DONE The first evaluation no longer stalls behind the agent socket
The accept loop used to sit behind a ten-second wait for the agent socket, so a
program that binds its socket late — or not at all — looked ready and answered
@ -1623,13 +1564,6 @@ prunes a package nothing calls into in a release build. =flan dev= links the
agent's C into every program it builds whether or not the source imports it; a
release build links it only when the program calls into it.
** NEXT FLAN_AGENT_SOCKET in a shell's environment steals the socket
Decided 2026-09-25: narrow the gate. The daemon also exports its own pid, and the constructor binds the socket only when that pid is the program's parent (or the program itself, in a merged build).
Binding unlinks the path first, and before the constructor that unlink was reached
only by an explicit call. A sentence about the shape of the gate rather than an
observed problem: only the daemon sets the variable and it never runs release
builds. The fix, if it is ever felt, is a narrower gate.
** DONE The daemon's "has not called (agent/start ...)" note is unreachable
CLOSED: [2026-09-25]
Retired, with the matching arm of an evaluation's timeout, because it named the
@ -1679,12 +1613,6 @@ a defcustom.
The agent keeps the condition pointer beside its name and a verb hands it back, so
the editor can render the condition's own fields rather than only its class.
** NEXT The type identity of a local is not qualified
Decided 2026-09-25: a local's type prints package-qualified in the break buffer and the inspector, as a field's and a condition's already do.
Settled for conditions and for structs, because =Load= qualifies every declaration
at import. Still open for locals, where the debug information gives a bare name and
nothing qualifies it.
** NEXT The render-thunk-per-inspection design
Decided 2026-09-25: the inspector reads a value through the type layouts the compiler records, with no compile per inspection, which lets it hold a value.
An inspection still compiles a thunk per request. A redesign rather than a
@ -1729,10 +1657,11 @@ out versioned bodies and trampolines, and redirecting a value taken before the
change. =main= stays refused: its caller is startup code no cell reaches.
docs/BUILT.md, "A signature change installs".
** DONE A module carrying a string literal is never unloaded
The transient rule is that a module retaining nothing may go, and a string literal
counts as something retained — which silently stopped every module carrying one
from ever being unloaded. That is why frame descriptors got their own counter.
** DONE An expression's module is unloaded unless it hands out a constant
CLOSED: [2026-09-25]
A thunk's string literal is a copy the process keeps, and registry names and initial
images are copied by the runtime, so none of them pins the module; a condition's
name or a restart's text still does. Rules out unloading on a guess about a literal.
** DONE A redefinition delivered while parked installs on the next re-run
The park used to drain the agent ring only when something had asked it to poll,
@ -1778,13 +1707,6 @@ nothing orders the two. The read raised on a closed socket and the test binary
exited 1 with no failure line, which is the worst shape a failure can have when
a lane is judged on the exit status.
** NEXT A program driven by a real flan dev daemon under a sanitizer
Decided 2026-09-25: =flan dev --sanitize= builds the host under ASan/UBSan on the LLVM backend (refused by name with =--x86=), and the @sanitize alias gains a case driving a real session through reloads and a break.
The daemon builds its host through its own path and the CLI has no way to pass a
sanitizer flag to it. Named as the check worth adding next; a day rather than an
hour. The x86 backend is not a gap here — that pair is refused by name, because
there is no sanitizer pass over hand-written assembly.
** DONE A transient signal 11 on a globals daemon
CLOSED: [2026-09-25]
Not a segfault. The report was OCaml's signal number, and in OCaml's numbering
@ -1836,11 +1758,12 @@ line and every later row unrun.
gone. The dev daemon now removes its own on a clean end; the one-shot commands do
not.
** TODO An x86 dev session's dyn global sometimes reads wrong after an allocating thunk
test_dev's =--x86: after a thunk that allocates (cycle 1) the parked program's dyn
global reads "kept"= failed once in a full =dune test= on 2026-09-25 and passed three
direct reruns. Intermittent and GC-shaped: a dyn global read after a collection a
C-x C-e thunk triggered. Needs reproducing under load and fixing.
** WAIT An x86 dev session's read of a dyn global after an allocating thunk failed once
WAIT on a recurrence; the test now prints the failing read's own reply.
The one failure's message came from a second read, which said "kept"; the failing
reply itself was not recorded. Not reproduced in 350 churn-and-read cycles under
8-way load, three concurrent test_dev runs, or a valgrind run of the cycle, which
was clean.
* Editor
@ -1959,21 +1882,6 @@ CLOSED: [2026-09-25]
=put= on an instance still checks a declared slot's type and still inserts an
undeclared key; only =set= refuses one, since a slot it writes has to exist.
** NEXT update: change a place by applying a function to it
Decided 2026-09-25: every place evaluates each of its subexpressions once, C's compound-assignment rule, which also fixes =++= and =--=; =update= is built on that. Rules out refusing side effects in a place.
=(set (.velocity g) (inc (.velocity g)))= names the place twice. Clojure's
=update= would be a macro over the same two steps, for a struct field and a
class slot alike.
Blocked on the double-evaluation question, which =++=, =--= and any
compound assignment share: =(update (at grid (next-index) c) inc)= evaluates
=(next-index)= twice, and a place with a side effect is then wrong rather than
slow. Either places get a general single-evaluation rule — bind every
subexpression of a place to a temp once, which is what C's compound assignment
does — or the language says a place must be side-effect free and refuses
otherwise. The first is the real fix and it is a change to how every place
lowers, not to one macro.
** TODO A session eval reported (CFn [] ()) does not cross into dyn yet
At =sand.flan:46:20=, the =:pause= in =(when (get state :pause) (return))=,
where =state= is a =defclass= instance with a =pause= slot. =(CFn [] ())= is
@ -2007,15 +1915,6 @@ maps bind =q=, and the diagnostics map binds =RET= and =q=, so those keys are
the mode's own and behave the same under Evil. Every key a mode does not bind
itself, including the rest of =special-mode-map=, stays Evil's.
** NEXT Eval in the frame, from the break loop
Decided 2026-09-25: SLIME's eval-in-frame, as described.
An expression is evaluated at a frame boundary, so it sees globals and not the
stopped frame's locals — which are the values anyone stopped there wants. Wants
SLIME's eval-in-frame: pick a frame, and the expression is checked and run with
its slots in scope. The slots are already on the frame and already readable
(=flan_dev_frame_slot=); what is missing is checking an expression against that
frame's names and types.
** DONE The stack lists prelude frames
CLOSED: [2026-09-25]
A frame whose location is =<prelude>= is hidden by default, and a line in its
@ -2024,14 +1923,15 @@ because =locals= and the inspector are asked by it. The innermost frame is
shown even when it is the prelude's, unless the stop is =(pause)=, because it
is where the program stopped. Rules out renumbering the visible frames.
** NEXT There is no stepper
Decided 2026-09-25: stepping happens inside a stopped frame, so the game loop and its clock are frozen, as under =(pause)=.
=(pause)= stops and offers restarts, frames, locals and the inspector, but
nothing advances a form at a time. CIDER instruments a form and steps the
instrumented copy; the equivalent here is a dev-build-only instrumented
redefinition, which the cell indirection already makes deliverable. Open:
whether stepping suspends the frame loop, and what it does to a game's clock.
** DONE C-c C-c reports one error, not every error in the form
CLOSED: [2026-09-25]
Every error at any depth: a refused subexpression stands as a Never that fits
any want, and what it causes is left unsaid. Rules out stopping at a statement boundary.
** DONE There is no stepper
CLOSED: [2026-09-25]
C-c C-s instruments a defn with a step point before each body form; no step
into a callee, no argument positions, and no value shown after a form.
** DONE A NaN cast says "does not fit", which reads as too big
CLOSED: [2026-09-25]
Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity,
@ -2054,23 +1954,10 @@ rebinds all at once. No other form had the gap: =let= was already sequential,
=dotimes= binds one name, and =fn=, =defn=, =match= and the handler and restart
clauses bind parameters with no initialisers.
** NEXT C-c C-c reports one error, not every error in the form
Decided 2026-09-25: every error in the form, at any depth. A failed subexpression takes an error type that fits any want, so checking continues around it and the errors it would cause are not reported — Rust's, TypeScript's and Elm's shape. Rules out stopping at a statement boundary.
Whole-file paths use =Check.program_all= and report every bad declaration. The
daemon asks for the sink off (=lib/loc.ml:185=) and gets one exception, so a
function with three bad expressions takes three round trips. The sink is
per-phase; making it per-form would need a resync point inside a body.
** DONE A session should start before a program compiles
CLOSED: [2026-09-25]
A file with no =main= starts on a stub =main= that returns and parks; =load-file= (=C-c C-k=, already its key — the inspector stays on =C-c C-i=) keeps what compiles and lists the rest. Rules out =flan dev= with no file at all, and =--two-process= on a file with no =main=.
** NEXT The daemon buffer is navigable but not coloured
Decided 2026-09-25: errors, warnings and notes take compilation-mode's faces, and the program's own output takes a face of its own so it reads apart from the compiler's.
=*flan*= is all plain text. =compilation-minor-mode= is on (=emacs/flan.el:822=)
so =next-error= works, but a minor mode installs no font-lock. Open: whether the
program's output should look different from the compiler's.
** DONE compilation-mode steps over the notes
CLOSED: [2026-09-25]
The daemon buffer and the diagnostics buffer set =compilation-skip-threshold= to

12
bin/main.ml
View File

@ -799,7 +799,11 @@ let () =
which is the point of leaving it readable here — the combination stays
refused by name, it is just no longer somewhere you arrive by typing one
flag. *)
let x86 = backend_x86 ~default:(not debug) rest in
(* --sanitize takes [--llvm]'s side for the reason [--debug] does: the
sanitizers are LLVM passes. [--x86] written as well is refused by name
in [Dev.start]. *)
let sanitize = List.mem sanitize_flag rest in
let x86 = backend_x86 ~default:(not (debug || sanitize)) rest in
let asked_x86 = List.mem x86_flag rest in
let merged = not (List.mem two_process_flag rest) in
let rest = List.filter (fun a -> not (is_flag a)) rest in
@ -809,8 +813,8 @@ let () =
| [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
| _ ->
prerr_endline
"usage: flan dev <program.flan> [-s socket] [--debug] [--llvm] \
[--two-process]";
"usage: flan dev <program.flan> [-s socket] [--debug] [--sanitize] \
[--llvm] [--two-process]";
exit 2
in
(* Only this command hands one over, and only when it chose the backend
@ -826,7 +830,7 @@ let () =
else None
in
with_errors ?x86_hint path (fun () ->
Flan.Dev.start ~debug ~merged ~x86 ~file:path ~sock ())
Flan.Dev.start ~debug ~sanitize ~merged ~x86 ~file:path ~sock ())
(* One redefinition, built the way an editor will ask for it: a session over
the program the process was built from, and a file of the forms that

18
docs/BUILT.md
View File

@ -1045,8 +1045,9 @@ the two builds are *supposed* to differ, since `flan_dev_crash_enable` checks a
install the handler when ASan is in the process. So the case asserts ASan's report and the absence of the handler's
line, built at `-O0` because at `-O2` a store through a zeroed `(Ptr u8)` is undefined and need not fault. That yield had
never run in any build anywhere: it was behind a link that did not happen. Twenty-six seconds of the alias's 2m30 warm.
What it still does not reach is a program driven by a real daemon under ASan: `flan dev` builds its host through its own
path and has no `--sanitize` to pass it.
`dev_session` drives a real `flan dev --sanitize` session — merged, LLVM, the compiler's OCaml in the same process as
the sanitized host — through a break, three reloads and a second break; the modules it sends are still not
instrumented.
**Two aliases were green only because `dune test` runs first, and that is the same disease in a different place.**
`@sanitize` never listed the package directories `pkg-diamond.flan` imports and `@page` never listed `sand.flan`, which
@ -1821,7 +1822,9 @@ shape TODO.org's "The compiler is a thread inside the program" landed on: **the
program's process. It is SLIME's model — you start the image, it serves, the editor connects.
`--two-process` is the escape hatch, for a machine where the compiler object cannot be built (no `ocamlfind`, no
`flan.cmxa` beside the binary). It has its own test and it stays.
`flan.cmxa` beside the binary). It has its own test and it stays. A re-run there is a new child built from the session
as it stands, so the redefinitions are in it and the globals start over; the daemon outlives a finished child to take
that request.
**The editor socket and its wire protocol did not move.** Emacs cannot tell the difference, which is what made the merge
testable: the whole existing suite is the check.
@ -3000,7 +3003,7 @@ fires. The value is two words: the struct's address and the incarnation of it th
| `(slice v)` / `(slice v lo)` / `(slice v lo hi)` | a non-owning `[T]` view — the array names again, extended |
| `(clone v)` / `(clone v a)` | the only copy; assignment moves |
| `(free v)` | consumes its argument |
| `(bytes s)` / `(bytes s a)` | a writable copy of a string's bytes, against the context or a named allocator — an allocating operation like `vec-new`: StorageExhausted with retry, a registry note in dev builds. The answer is a `[u8]` view of the block, so nothing can `free` it through the slice; it lives until its allocator's `free-all` or destroy |
| `(bytes s)` / `(bytes s a)` | a writable copy of a string's bytes, against the context or a named allocator — an allocating operation like `vec-new`: StorageExhausted with retry, a registry note in dev builds. The answer is a `[u8]` view of the block; `(free b)` hands it back to the context allocator, or `(free b a)` to the one named, and a dev build's registry traps on a mismatch |
| `(bytes-view s)` | the string's own storage as a `[const u8]`, costing nothing — the old `(bytes s)` reinterpret, renamed. A store through it is a compile error, because a literal's view points into `.rodata` |
### A view of a `Vec` goes stale at the `push`, and nothing checks it
@ -3887,7 +3890,7 @@ before this landed, so `macro-unless.flan` is a test written after the feature.
### The line between a special form and a macro
A form the prelude itself relies on is built into the parser: `cond`, `when` and `dotimes`. A form only programs use
is a prelude macro: `inc`, `++`, `into`, `unless`, `until` and `comment`. The reason is `Macro.reduce`: a prelude
is a prelude macro: `inc`, `++`, `update`, `into`, `unless`, `until` and `comment`. The reason is `Macro.reduce`: a prelude
function that calls a macro is left out of the module that runs macros, so a form the prelude's own functions use
cannot be a macro without taking those functions away from every macro body. `until` peels an optional leading label
and answers `(while :label (not test) body ...)`.
@ -4336,8 +4339,9 @@ implemented.
refusal's witness now runs. The escape refusal that replaced it is gone too; see "Escape: only an escaping
closure's environment is the collector's".*
- **An `fn` with nothing to say what it takes** (`fn-no-type.flan`), above.
- **A position that would zero one** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element,
`(zeroed)`. ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which
- **A position that would zero an `(Fn ...)`** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element,
`(zeroed)`. A `(CFn ...)` is admitted in all four: every call through one tests for null and signals `NullCall`
(`fn-cfn-table.flan`). ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which
is the one kind of zero that is not a value the type can have** — every other type's zero is one: `0`, `false`, an
empty slice, `None`, a union's first case. A parameter, a return type and a `let` binding are not on the list
because none of them is ever conjured, and an `(Option (Fn ...))` is not either, because a `None`'s tag is what

13
emacs/MANUAL.md
View File

@ -236,6 +236,12 @@ breakpoint is just a condition nobody handled.
hit it as many times as you like; an ordinary `C-c C-c` over the same form (or
`C-c C-k` over the buffer) takes it off.
**Stepping.** `C-c C-s` installs the `defn` at point so that a call stops
before each form of its body. Each stop is a break like `(pause)`, and the
source of the form about to run is shown beside it. `s` goes to the next form,
`c` runs the rest of the call, and the next call steps again. `C-c C-c` over the
same form installs it plain.
`C-u C-x C-e` does the same for the expression before point: it stops *at* the
expression instead of printing its value. That one does not stick, because there
is no definition for it to stick to. `C-u C-c C-c` on a top-level form that is
@ -375,6 +381,9 @@ Keys in that buffer:
| `v` | visit the source of the frame at point |
| `P` | show or hide the prelude's frames |
| `i` | inspect the local or global at point |
| `e` | evaluate an expression in the frame at point; it sees that frame's locals |
| `s` | at a step, go to the next form |
| `c` | take `continue`: at a step, run the rest of the call |
| `a` | abort |
| `g` | read the program again |
| `q` | close the buffer |
@ -1190,6 +1199,7 @@ Use `C-c C-g` if you need frames.
| `C-x C-e` | same, cursor on the line's last character | at a line's end, the innermost statement ending there: a match arm's value, an if/elif/while condition, or the whole statement a header or clause line opens; elsewhere, the term before point |
| `C-c C-e` | same | the statement at point with its body and clauses, or the region's whole lines; on a bare `let x = v`, the `let` and the rest of its block |
| `C-c C-n` | same | `C-c C-e`, then move to the next statement |
| `C-c C-s` | same | step through the top-level `fn` at point |
| `C-c C-k` | same | the whole buffer |
| `C-M-a` / `C-M-e` / `C-M-h` | `[[` / `]]` | top-level form: start, end, mark |
| `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) |
@ -1206,7 +1216,7 @@ Use `C-c C-g` if you need frames.
| — | `is` `as` | statement (`as`: whole lines) |
| — | `ii` `ai` | body / whole statement |
| — | `ik` `ak` | clause's block / clause |
| — | `id` `ad` | top-level form (`ad`: with the blank lines after it) |
| — | `id` `ad` | top-level form with the comment block directly above it (`ad`: and the empty lines after it, or before it for the last form) |
`else`, `elif`, `on` and `restart` snap to their header's column as you type
them. `indent-region` and `C-y` move lines only as a block, never one line
@ -1233,6 +1243,7 @@ on plain `smartparens-mode`, which pairs brackets and strings but not `'`.
| `C-u C-c C-c` | ...and stop at the form point is inside (`C-u C-u`: on entry) |
| `C-M-x` | the same as `C-c C-c`, on the binding SLIME and CIDER use |
| `C-c C-k` | load the whole buffer, as one module; what does not compile is listed |
| `C-c C-s` | install the defn at point to stop before each form of its body |
| `C-x C-e` | the form before point, evaluated — or installed, if it is a declaration |
| `C-u C-x C-e` | ...and stop at it instead of showing its value |
| `C-c C-z` | connect (finds `.flan-dev.sock` upward) |

94
emacs/flan-cnr.el
View File

@ -63,6 +63,7 @@
;;; Code:
(require 'seq)
(require 'pulse)
(require 'subr-x)
(require 'flan-mode)
@ -170,6 +171,15 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the
first place that can tell the difference. Named here rather than spelled at
its use, because it is a fact about the prelude.")
(defconst flan-cnr-step "StepPoint"
"The condition the stepper's `(step-point)' signals, before each form of a
defn sent with `C-c C-s'. A stop like `(pause)', with `next' and `continue'
restarts: `s' takes the first and `c' the second.")
(defun flan-cnr--stepping-p (state)
"Whether STATE is a stop of the stepper."
(equal (plist-get state :condition) flan-cnr-step))
(defun flan-cnr--headline-fields (fields)
"The condition's own numbers, folded into the headline.
FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the
@ -229,7 +239,7 @@ indexing or the division itself, so it sits directly under the headline."
;; only thing that can be wrong here is the word for it. Calling a
;; breakpoint unhandled would be a small lie told at the top of the
;; one buffer that exists to say what happened.
(paused (equal name flan-cnr-breakpoint))
(paused (member name (list flan-cnr-breakpoint flan-cnr-step)))
(numbers (flan-cnr--headline-fields (plist-get state :fields))))
(insert (propertize name 'face (if paused 'warning 'error)))
(when numbers (insert " — " numbers))
@ -240,9 +250,11 @@ indexing or the division itself, so it sits directly under the headline."
(let ((sentence (plist-get state :sentence)))
(when sentence (insert sentence "\n")))
(insert (propertize
(if paused
"stopped at (pause); nothing has been unwound\n"
"unhandled; stopped where it erred, nothing unwound\n")
(cond
((flan-cnr--stepping-p state)
"stepping: stopped before the form below; s steps to the next, c runs the rest of the call\n")
(paused "stopped at (pause); nothing has been unwound\n")
(t "unhandled; stopped where it erred, nothing unwound\n"))
'face 'shadow))
(flan-cnr--insert-site state))
(insert "\n")
@ -439,7 +451,8 @@ breakpoint the program's author wrote, not a step of the program."
(if (and (not flan-cnr--show-prelude)
(flan-cnr--prelude-frame-p fr)
(or (> i 0)
(equal (plist-get state :condition) flan-cnr-breakpoint)))
(equal (plist-get state :condition) flan-cnr-breakpoint)
(flan-cnr--stepping-p state)))
(setq hidden (1+ hidden))
(when (> hidden 0)
(flan-cnr--insert-hidden hidden)
@ -574,7 +587,7 @@ puts the likely culprit on top."
;; an entry is annotated with have to be on screen above it to read.
(flan-cnr--insert-globals state)
(insert (propertize
"RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect a abort g refresh q quit\n"
"RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame s step c continue a abort g refresh q quit\n"
'face 'shadow))
(goto-char (point-min))
;; Point starts on the restart that abandons the evaluation, when there is
@ -833,6 +846,69 @@ drawn from."
(`(:expr ,expr) (flan-inspect expr))
(_ (user-error "flan: this line carries no root the inspector knows")))))
(defun flan-cnr--frame-at-point ()
"The index of the frame point is on, or on a local of, or nil."
(or (get-text-property (point) 'flan-cnr-frame)
(pcase (get-text-property (point) 'flan-cnr-inspect)
(`(:slot ,frame . ,_) frame))))
(defun flan-cnr-eval-in-frame (frame code)
"Evaluate CODE in stopped FRAME, SLIME's eval-in-frame, and show the value.
CODE sees FRAME's locals as well as the globals, and a `set' of a local
changes the frame. Interactively FRAME is the one point is on, or on a
local of, and CODE is read from the minibuffer."
(interactive
(let ((frame (flan-cnr--frame-at-point)))
(unless frame
(user-error "flan: point is not on a frame — e evaluates in the frame point is on"))
(list frame (read-string (format "Eval in frame %d: " frame)))))
(let ((r (funcall flan-cnr-request-function
(list :op "eval-expr" :frame frame :code code))))
(if (equal (plist-get r :status) "ok")
(let ((v (or (plist-get r :value) (plist-get r :note) "")))
;; A set may have changed what an open frame shows, so each is
;; asked again the next time it is opened.
(dolist (fr (plist-get flan-cnr--state :stack))
(when (consp fr) (plist-put fr :fetched nil)))
(message "=> %s" v)
v)
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
(defun flan-cnr--take-named (name)
"Take the innermost restart called NAME, or refuse by name."
(let ((i (seq-position (plist-get flan-cnr--state :restarts) name)))
(unless i (user-error "flan: there is no %s restart at this stop" name))
(flan-cnr--invoke i name)))
(defun flan-cnr-step ()
"Step to the next form: take the stepper's `next' restart."
(interactive)
(flan-cnr--take-named "next"))
(defun flan-cnr-continue ()
"Take the innermost `continue' restart.
At a stepper's stop it runs the rest of the call; at a `(pause)' it resumes."
(interactive)
(flan-cnr--take-named "continue"))
(defun flan-cnr--step-site (state)
"Where a stepper's STATE stopped: the first frame that is not the prelude's."
(seq-some (lambda (fr)
(and (not (flan-cnr--prelude-frame-p fr))
(plist-get fr :loc)))
(plist-get state :stack)))
(defun flan-cnr--show-step-site (state)
"At a stepper's stop, show the form about to run in its source, highlighted.
The break buffer keeps the selection; the source is shown beside it."
(let ((loc (and (flan-cnr--stepping-p state) (flan-cnr--step-site state))))
(when loc
(ignore-errors
(save-selected-window
(with-current-buffer (flan-visit-loc loc "the step")
(pulse-momentary-highlight-region
(point) (save-excursion (ignore-errors (forward-sexp)) (point)))))))))
(defun flan-cnr-refresh ()
"Ask the program again what it is offering."
(interactive)
@ -889,7 +965,12 @@ anyone who would rather TAB always moved."
(define-key map "v" #'flan-cnr-visit)
(define-key map "P" #'flan-cnr-toggle-prelude)
(define-key map "i" #'flan-cnr-inspect)
;; SLIME's `e': evaluate in the frame at point.
(define-key map "e" #'flan-cnr-eval-in-frame)
(define-key map "a" #'flan-cnr-abort)
;; The stepper's two, CIDER's `c' and SLIME's `s' (`n' moves).
(define-key map "s" #'flan-cnr-step)
(define-key map "c" #'flan-cnr-continue)
(define-key map "g" #'flan-cnr-refresh)
(define-key map "q" #'quit-window)
;; Numbered, as SBCL's are, and for SBCL's reason: the names are not
@ -1132,6 +1213,7 @@ walk from a running program."
;; the program running again: see `flan--forget-break-stack'.
(setq next-error-last-buffer buf))
(pop-to-buffer buf)
(flan-cnr--show-step-site (buffer-local-value 'flan-cnr--state buf))
buf)))
(provide 'flan-cnr)

135
emacs/flan-fln-mode.el
View File

@ -39,7 +39,7 @@
;; The client, which every command that sends code needs and which this file
;; must not load merely to edit one.
(declare-function flan--eval "flan" (code what &optional start end pause))
(declare-function flan--eval "flan" (code what &optional start end pause step))
(declare-function flan--eval-expression "flan" (start end arg))
(declare-function flan--text "flan" (start end))
(declare-function flan--text-at "flan" (start end))
@ -669,31 +669,35 @@ pattern names something, so the value cannot be evaluated alone."
(buffer-substring-no-properties
(car value) (cdr value))))))))))))
(defconst flan-fln--name-char "[:alnum:]_?!*/$<>=%+-"
"The characters a name is made of, for a character class.")
(defun flan-fln--names-in (text &optional skip-heads)
"Every name in TEXT, as the syntax table reads names, and each dotted part
of one: `p.x' gives `p.x', `p' and `x'. With SKIP-HEADS, not a name glued to
a `(' -- a pattern's constructor, which binds nothing."
(with-temp-buffer
(set-syntax-table flan-fln-mode-syntax-table)
(insert text)
(goto-char (point-min))
(let (names)
(while (re-search-forward "\\(?:\\sw\\|\\s_\\)+" nil t)
(let ((n (match-string-no-properties 0)))
(unless (and skip-heads (eq (char-after) ?\())
(push n names)
(dolist (part (split-string n "\\." t))
(push part names)))))
(delete-dups names))))
(defun flan-fln--pattern-names (pat)
"The names pattern PAT binds: its lowercase words that are not constants,
fields, keywords, constructors or `_'."
(let ((re (concat "\\(?:\\`\\|[^" flan-fln--name-char ".:]\\)"
"\\([a-z][" flan-fln--name-char "]*\\)"))
(start 0) names)
(while (string-match re pat start)
(let ((n (match-string 1 pat)))
(setq start (match-end 1))
(unless (or (member n flan--constants)
(and (< start (length pat)) (memq (aref pat start) '(?\( ?.))))
(push n names))))
names))
"The names pattern PAT may bind: every name in it but a constructor head.
Numbers are not names. Generous otherwise -- a keyword or a constant counts
too -- because a name
wrongly counted only sends the whole match, and one missed sends a value
that reads a global of the same name and shows a wrong answer."
(seq-remove (lambda (n) (string-match-p "\\`[-+]?[0-9]" n))
(flan-fln--names-in pat t)))
(defun flan-fln--uses-any-p (names text)
"Non-nil if TEXT has any of NAMES as a whole name."
(seq-some (lambda (n)
(string-match-p (concat "\\(?:\\`\\|[^" flan-fln--name-char ".]\\)"
(regexp-quote n)
"\\(?:\\'\\|[^" flan-fln--name-char "]\\)")
text))
names))
"Non-nil if TEXT has any of NAMES as a name, or as part of a dotted one."
(seq-some (lambda (n) (member n names)) (flan-fln--names-in text)))
(defun flan-fln--arm-to-send (l arm)
"What evaluating the match arm at L sends: its value, or, when its pattern
@ -721,6 +725,18 @@ point's line, when it next runs; with two, on entry."
(prog1 (flan--eval-expression (car b) (cdr b) arg)
(pulse-momentary-highlight-region (car b) (cdr b)))))))
;;;###autoload
(defun flan-fln-step-defun ()
"Install the top-level form at point so a call stops before each form.
`flan-step-defun' for a .fln buffer: the same stepper, over this syntax's
top-level form."
(interactive)
(flan-fln--client)
(let* ((b (flan-fln--toplevel-bounds (point)))
(head (and b (flan-fln--declaration-head-at (car b) flan--defun-heads))))
(unless head (user-error "flan: no fn at point to step through"))
(flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t)))
(defun flan-fln--point-for-last ()
"Point, or under Evil's normal state the position after the cursor's char.
The cursor sits *on* the last character of a line, never after it."
@ -1450,6 +1466,7 @@ it, so a block pasted at another depth stays one block."
(define-key map (kbd "C-x C-e") #'flan-fln-eval-last)
(define-key map (kbd "C-c C-e") #'flan-fln-eval-statement)
(define-key map (kbd "C-c C-n") #'flan-fln-eval-statement-and-next)
(define-key map (kbd "C-c C-s") #'flan-fln-step-defun)
;; The sentence keys, because a statement is this syntax's sentence.
;; M-e shadows a global binding of the same key, as any mode's M-e would.
(define-key map (kbd "M-a") #'flan-fln-backward-statement)
@ -1539,17 +1556,53 @@ that says so and otherwise is its own."
"B's lines, from the start of the first to the start of the line after."
(and b (flan-fln--lines (flan-fln--bol (car b)) (flan-fln--bol (cdr b)))))
(defun flan-fln--empty-line-p (pos)
(save-excursion (goto-char (flan-fln--bol pos)) (looking-at-p "[ \t]*$")))
(defun flan-fln--comment-line-p (pos)
(and (flan-fln--blank-p pos) (not (flan-fln--empty-line-p pos))))
(defun flan-fln--with-comments (b)
"Whole lines B, and the comment lines directly above them: a comment block
with no blank line under it belongs to what it sits on."
(and b (save-excursion
(goto-char (car b))
(while (and (zerop (forward-line -1))
(flan-fln--comment-line-p (point)))
(setq b (cons (point) (cdr b))))
b)))
(defun flan-fln--commented-toplevel (pos)
"The top-level form at POS, whole lines with its comment block.
On a comment block that sits directly on a form, that form."
(let ((pos (save-excursion
(goto-char pos)
(beginning-of-line)
(while (and (flan-fln--comment-line-p (point))
(zerop (forward-line 1))))
(if (flan-fln--toplevel-start-p (point)) (point) pos))))
(flan-fln--with-comments
(flan-fln--whole-lines (flan-fln--toplevel-bounds pos)))))
(defun flan-fln--with-trailing-blanks (b)
"B's whole lines and the blank lines after them.
With none after -- the last form -- the blank lines before it instead, as
Vim's `dap' does, so the buffer does not end in empty lines."
(and b (let ((n (flan-fln--next-code (1- (cdr b)))))
(if n
(cons (car b) n)
(let ((p (flan-fln--prev-code (car b))))
(cons (if p (save-excursion (goto-char p) (line-beginning-position 2))
(car b))
(point-max)))))))
"Whole lines B and the empty lines after them.
When nothing follows -- the last form -- the empty lines before it as well,
as Vim's `dap' does, so the buffer does not end in empty lines. A comment
below a form is not taken: it belongs to what follows."
(and b (save-excursion
(goto-char (cdr b))
(while (and (not (eobp)) (flan-fln--empty-line-p (point))
(zerop (forward-line 1))))
(let ((end (point)))
(if (< end (point-max))
(cons (car b) end)
(goto-char (car b))
(while (and (zerop (forward-line -1))
(flan-fln--empty-line-p (point))))
(cons (if (flan-fln--empty-line-p (point))
(point)
(min (car b) (line-beginning-position 2)))
end))))))
(defun flan-fln--term-around (b)
"B and the spaces after it, or before it when none follow."
@ -1578,9 +1631,10 @@ Vim's `dap' does, so the buffer does not end in empty lines."
"A statement, from its first character to its last."
(flan-fln--evil (bounds-of-thing-at-point 'flan-fln-statement) 'exclusive))
(evil-define-text-object flan-fln-a-statement (count &optional _beg _end _type)
"A statement's whole lines."
(flan-fln--evil (flan-fln--whole-lines
(bounds-of-thing-at-point 'flan-fln-statement))
"A statement's whole lines, with the comment block on it."
(flan-fln--evil (flan-fln--with-comments
(flan-fln--whole-lines
(bounds-of-thing-at-point 'flan-fln-statement)))
'line))
(evil-define-text-object flan-fln-inner-body (count &optional _beg _end _type)
"A statement's block, its lines."
@ -1607,15 +1661,12 @@ Vim's `dap' does, so the buffer does not end in empty lines."
(bounds-of-thing-at-point 'flan-fln-clause))
'line))
(evil-define-text-object flan-fln-inner-toplevel (count &optional _beg _end _type)
"A top-level form, its lines."
(flan-fln--evil (flan-fln--whole-lines
(bounds-of-thing-at-point 'flan-fln-toplevel))
'line))
"A top-level form, its lines, with the comment block on it."
(flan-fln--evil (flan-fln--commented-toplevel (point)) 'line))
(evil-define-text-object flan-fln-a-toplevel (count &optional _beg _end _type)
"A top-level form and the blank lines after it."
"A top-level form with its comment block, and the empty lines after it."
(flan-fln--evil (flan-fln--with-trailing-blanks
(flan-fln--whole-lines
(bounds-of-thing-at-point 'flan-fln-toplevel)))
(flan-fln--commented-toplevel (point)))
'line)))
t)
(evil-define-key* '(operator visual) flan-fln-mode-map

3
emacs/flan-mode.el
View File

@ -87,6 +87,7 @@
;; wiring they need.
(autoload 'flan-inspect "flan-inspect" nil t)
(autoload 'flan-cnr-show "flan-cnr" nil t)
(autoload 'flan-step-defun "flan" nil t)
(autoload 'flan-doc "flan" nil t)
(autoload 'flan "flan" nil t)
(autoload 'flan-quit "flan" nil t)
@ -446,6 +447,8 @@ For `syntax-propertize-function'."
(let ((map (make-sparse-keymap)))
;; Autoloaded from flan.el, so the client loads on first use.
(define-key map (kbd "C-c C-k") #'flan-eval-buffer)
;; The stepper: the defn at point, installed to stop before each form.
(define-key map (kbd "C-c C-s") #'flan-step-defun)
(define-key map (kbd "C-c C-z") #'flan-connect)
(define-key map (kbd "C-c C-q") #'flan-disconnect)
(define-key map (kbd "C-c C-d") #'flan-describe)

72
emacs/flan.el
View File

@ -412,6 +412,34 @@ nil keeps everything."
(let ((inhibit-read-only t))
(delete-region (point-min) (line-beginning-position)))))))
(defface flan-output-face '((t :inherit font-lock-string-face))
"Face for the running program's own output in the daemon's buffer.
It sets that output apart from what the compiler and the daemon say, whose
errors, warnings and notes take `compilation-mode''s faces."
:group 'flan)
(defun flan--daemon-buffer-setup ()
"Make the current buffer the daemon's log: navigable and coloured.
The daemon writes a diagnostic as `file:line:col: message', the shape
`compilation-minor-mode' already reads, so it only has to be switched on.
The minor mode adds its font-lock rules but turns nothing on, and a process
buffer is in `fundamental-mode', which global font-lock skips; so font-lock
is switched on here, first, or the rules would never be drawn."
(font-lock-mode 1)
;; A log, not source: a quote the program printed opens no string.
(setq-local font-lock-keywords-only t)
;; Only the compiler's own shape, `file:line:col:', is a diagnostic here.
;; compile.el's other rules are for a build log: one of them draws any
;; line starting `word:' as a program name, which is every `score: 10'
;; the program prints.
(setq-local compilation-mode-font-lock-keywords nil)
(setq-local compilation-error-regexp-alist
'(("^\\([^ \t\n:][^\t\n:]*\\):\\([0-9]+\\):\\([0-9]+\\): \
\\(?:\\(warning\\)\\|\\(note\\|info\\)\\)?"
1 2 3 (4 . 5))))
(compilation-minor-mode 1)
(flan--navigable-notes))
(defun flan--append-output (text)
"Append TEXT, the running program's own output, where it can be read.
Two places. The daemon's log always gets it, so output lands somewhere
@ -423,7 +451,13 @@ open, above its prompt, which is where whoever is typing there is looking."
(inhibit-read-only t))
(save-excursion
(goto-char (point-max))
(insert text))
;; Marked as it is inserted, because nothing in the text says whose
;; it is. A line the program prints in the diagnostic shape is
;; still read as one by `compilation-minor-mode', and takes its
;; face. `face' for a buffer with font-lock off, `font-lock-face'
;; so fontification does not strip it.
(insert (propertize text 'face 'flan-output-face
'font-lock-face 'flan-output-face)))
(flan--trim-lines)
;; Follow the tail only for someone who was already at it; a reader
;; scrolled back is reading something.
@ -893,8 +927,7 @@ It builds the program first, which for a cold project is most of this."
;; program runs, and `compilation-mode' would claim it as the output of
;; one finished command — killing the process on a `recompile', among
;; other things it has no business doing to a live session.
(compilation-minor-mode 1)
(flan--navigable-notes))
(flan--daemon-buffer-setup))
(make-process
:name "flan-daemon" :buffer buf
:command args
@ -2566,7 +2599,7 @@ signature, listed in %s"
(user-error "flan: %s%s" (or msg "rejected")
(if loc (format " (%s)" loc) "")))))
(defun flan--eval (code what &optional start end pause)
(defun flan--eval (code what &optional start end pause step)
"Send CODE to the running program. WHAT names it for the echo area.
START and END, when given, are the region it came from, flashed on success.
PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the
@ -2582,11 +2615,20 @@ breakpoint is marked from the editor, without editing the buffer\"."
(list :op "eval" :code code :file (or buffer-file-name "<buffer>")
:syntax (flan--syntax))
(when pause
(list :pause (flan--wire-position (car pause))))))))
(list :pause (flan--wire-position (car pause))))
(when step (list :step t))))))
;; END as the place a value could go. Every caller of this sends a
;; declaration and declarations have no value, so this is the path that
;; stays open rather than one anybody takes today.
(flan--report reply what end)
;;
;; A form with several errors is refused with all of them under
;; `:errors'; `flan--report' marks and signals the first, and the rest
;; are marked beside it before the signal leaves, as `C-c C-k' does.
(condition-case err
(flan--report reply what end)
(user-error
(flan--report-load-errors (cdr (plist-get reply :errors)) t)
(signal (car err) (cdr err))))
;; `flan--report' signals on a rejection, so reaching here means it
;; landed. Flashing the text that was sent answers "which form did that
;; take?" — the question the echo area cannot, because point may be nowhere
@ -2601,6 +2643,10 @@ breakpoint is marked from the editor, without editing the buffer\"."
(cond
((and pause (plist-get reply :pause))
(flan--show-pause (car pause) (cdr pause)))
;; An instrumented defn is marked whole, as a pause mark is, and an
;; ordinary C-c C-c of it takes the mark down with the instrumentation.
((and step start end (plist-get reply :step))
(flan--show-pause start end))
((and start end) (flan-clear-pause start end)))
reply))
@ -2894,6 +2940,20 @@ declaration for it to live in."
;; `flan--report' signals on a rejection.
(pulse-momentary-highlight-region (car b) end))))))
;;;###autoload
(defun flan-step-defun ()
"Install the defn at point so that a call stops before each form of its body.
A stepper, CIDER's `C-u C-M-x': each stop is a break like `(pause)', with the
program and its clock frozen, and the break buffer shows the form about to
run. There `s' steps to the next form and `c' runs the rest of the call; the
next call steps again. `C-c C-c' on the defn installs it plain."
(interactive)
(let* ((b (flan--defun-bounds))
(head (and (< (car b) (cdr b))
(flan--declaration-head-at (car b) flan--defun-heads))))
(unless head (user-error "flan: no defn at point to step through"))
(flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t)))
;;;###autoload
(defun flan-eval-buffer ()
"Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER.

108
emacs/test-flan-cider.el
View File

@ -1477,6 +1477,114 @@ would be overwritten. Look again and re-do the edit")
(test-flan--check "nothing is evaluated as an expression"
(null (plist-get (car asked) :code))))))
;; `e' evaluates in the frame point is on, or on a local of: the request
;; names that frame, and the value comes back to the echo area.
(let* ((asked nil)
(flan-cnr-request-function
(lambda (form) (push form asked) '(:status "ok" :value "8"))))
(with-current-buffer (test-flan--cnr
(list :condition "Missing" :restarts '("retry")
:stack (list (list :fn "g" :fetched t
:locals '(("b" "i64" "1" 4)))
(list :fn "f" :fetched t
:locals '(("n" "i64" "7" 0))))))
(goto-char (point-min))
(search-forward " 1: > f")
(flan-cnr-toggle-frame)
(goto-char (point-min))
(search-forward " 1: v f")
(search-forward "i64 n")
(let ((said (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ n 1)"))
((symbol-function 'message)
(lambda (fmt &rest args) (apply #'format fmt args))))
(call-interactively #'flan-cnr-eval-in-frame))))
(test-flan--check "`e' on a local evaluates in that local's frame"
(and (equal (plist-get (car asked) :op) "eval-expr")
(= 1 (plist-get (car asked) :frame))
(equal (plist-get (car asked) :code) "(+ n 1)")))
(test-flan--check "and answers the value"
(equal said "8")))
(test-flan--check "`e' is the break buffer's own key"
(eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame))))
;; The stepper's stop: said as a step, the prelude's own frame hidden, and
;; `s' and `c' take its `next' and `continue' by index.
(let* ((asked nil)
(flan-cnr-request-function
(lambda (form) (push form asked) '(:status "ok"))))
(with-current-buffer (test-flan--cnr
(list :condition "StepPoint"
:restarts '("next" "continue" "continue")
:stack (list (list :fn "step-point" :loc "<prelude>:250:3")
(list :fn "step" :loc "/s.flan:1:19"))))
(let ((text (buffer-string)))
(test-flan--check "a step's headline says it is stepping"
(string-match-p "stepping: stopped before the form" text))
(test-flan--check "and the prelude's step-point frame is hidden"
(not (string-match-p "step-point" text))))
(test-flan--check "the step site is the stepped frame's location"
(equal (flan-cnr--step-site flan-cnr--state) "/s.flan:1:19"))
(save-window-excursion (flan-cnr-step))
(test-flan--check "`s' takes next"
(and (equal (plist-get (car asked) :op) "restart-at")
(equal (plist-get (car asked) :name) "next")
(= 0 (plist-get (car asked) :index)))))
(with-current-buffer (test-flan--cnr
(list :condition "StepPoint"
:restarts '("next" "continue" "continue")))
(save-window-excursion (flan-cnr-continue))
(test-flan--check "`c' takes the innermost continue"
(and (equal (plist-get (car asked) :name) "continue")
(= 1 (plist-get (car asked) :index)))))
(test-flan--check "`s' and `c' are the break buffer's own keys"
(and (eq (lookup-key flan-cnr-mode-map "s") #'flan-cnr-step)
(eq (lookup-key flan-cnr-mode-map "c") #'flan-cnr-continue))))
;; Every key flan-mode binds has a row in the manual's key reference.
(let ((text (with-temp-buffer
(insert-file-contents
(expand-file-name "MANUAL.md"
(file-name-directory (locate-library "flan-mode"))))
(buffer-string)))
(missing nil))
(map-keymap
(lambda (k d)
(when (and (eq k ?\C-c) (keymapp d))
(map-keymap
(lambda (k2 d2)
(when (commandp d2)
(let ((desc (replace-regexp-in-string
"RET" "C-m"
(replace-regexp-in-string
"TAB" "C-i" (key-description (vector k k2))))))
(unless (string-match-p (regexp-quote (format "| `%s` |" desc)) text)
(push desc missing)))))
d)))
flan-mode-map)
(test-flan--check (format "every C-c key has a row in the manual (missing %s)" missing)
(null missing)))
;; C-c C-s sends the defn at point for stepping and marks it.
(let ((sent nil))
(with-temp-buffer
(flan-mode)
(insert "(defn step [] i64\n (set ticks 1)\n ticks)\n")
(goto-char (point-min))
(forward-line 1)
(cl-letf (((symbol-function 'flan--request)
(lambda (form) (setq sent form)
'(:status "ok" :fns ("step") :names ("step") :step t)))
((symbol-function 'flan-refresh-defs) #'ignore))
(flan-step-defun))
(test-flan--check "C-c C-s sends the defn with :step"
(and (equal (plist-get sent :op) "eval")
(plist-get sent :step)
(string-prefix-p "(defn step" (plist-get sent :code))))
(test-flan--check "and marks it as instrumented"
(flan--pause-overlays))
(test-flan--check "C-c C-s is flan-mode's key for it"
(eq (lookup-key flan-mode-map (kbd "C-c C-s")) #'flan-step-defun))))
;; `flan-cnr-show' refuses a running program by name rather than opening an
;; empty buffer.
;; The layout without the values: what a `layout' op alone would buy. The

56
emacs/test-flan-fln.el
View File

@ -308,6 +308,20 @@ comment():
fn twice(n: i64) -> i64 = n * 2
")
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "fib(n - 1)")
(test-flan--check "C-c C-s is the .fln stepper"
(eq (key-binding (kbd "C-c C-s")) 'flan-fln-step-defun))
(let ((r (test-flan-fln--sending (flan-fln-step-defun))))
(test-flan--check "which installs the fn at point to step through"
(and (equal (plist-get r :op) "eval")
(eq (plist-get r :step) t)
(string-prefix-p "fn fib" (test-flan-fln--sent-code r))
(string-suffix-p "fib(n - 2)" (test-flan-fln--sent-code r))))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)")
(test-flan--check "and refuses what is not a declaration"
(condition-case nil
(progn (test-flan-fln--sending (flan-fln-step-defun)) nil)
(user-error t))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "fib(n - 1)")
(let ((r (test-flan-fln--sending (flan-fln-eval-defun))))
(test-flan--check "C-c C-c inside a fn installs the whole fn"
@ -487,7 +501,7 @@ comment:
(let ((r (test-flan-fln--sending (funcall fn))))
(and r (test-flan-fln--sent-code r)))))
(test-flan-fln--is "an arm's value wrapped onto a second line goes whole, moved right"
(test-flan-fln--is "an arm's value wrapped onto a second line goes whole"
(test-flan-fln--wrapped-at "None" #'flan-fln-eval-last)
"1 +\n 2")
(test-flan-fln--is "from its second line too"
@ -516,6 +530,17 @@ comment:
(test-flan-fln--wrapped-at "Some(_)" #'flan-fln-eval-last) "5")
(test-flan-fln--is "nor one whose value does not use what it binds"
(test-flan-fln--wrapped-at "Some(m)" #'flan-fln-eval-last) "7")
(dolist (c '(("Some(_v) -> _v + 1" "a name starting with _")
("Some(éé) -> éé" "a name that is not ASCII")
("Some(N) -> N" "a capitalised name")
("Some(p) -> p.x" "a name used as a field's base")))
(test-flan-fln--in (concat "fn f(o: Option(i64)) -> i64\n match o\n " (car c) "\n")
(goto-char (point-max))
(skip-chars-backward "\n")
(test-flan--check (format "an arm binding %s its value uses sends the match" (cadr c))
(string-prefix-p "match o"
(test-flan-fln--sent-code
(test-flan-fln--sending (flan-fln-eval-last)))))))
(test-flan--check "one whose value uses its binding sends the match"
(string-prefix-p "match o"
(test-flan-fln--wrapped-at "Some(n)" #'flan-fln-eval-last)))
@ -835,6 +860,35 @@ comment:
("dad" "fn g" "fn f(x: i64) -> i64\n if x > 0\n a\n else\n 3\n x\n")))
(test-flan-fln--is (format "under Evil, %s leaves no blank line" (car c))
(funcall deleted (car c) (nth 1 c)) (nth 2 c))))
;; Comments: a block directly on a form is the form's; one a
;; blank line away, or below it, is not.
(let ((deleted
(lambda (keys needle)
(let ((b (generate-new-buffer "comments.fln")))
(switch-to-buffer b)
(insert "; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n"
"; on g\nfn g() -> ()\n ; on b\n b()\n")
(flan-fln-mode)
(evil-initialize-state)
(evil-normal-state)
(goto-char (point-min))
(search-forward needle)
(goto-char (match-beginning 0))
(execute-kbd-macro keys)
(prog1 (buffer-string)
(set-buffer-modified-p nil)
(kill-buffer b))))))
(dolist (c '(("dad" "a()"
"; loose\n\n; after f\n\n; on g\nfn g() -> ()\n ; on b\n b()\n")
("dad" "b()"
"; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n")
("did" "on g"
"; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n")
("das" "b()"
"; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n; on g\nfn g() -> ()\n")))
(test-flan-fln--is (format "under Evil, %s on %s keeps comments with their forms"
(car c) (nth 1 c))
(funcall deleted (car c) (nth 1 c)) (nth 2 c))))
(let ((b (generate-new-buffer "keys.fln")))
(switch-to-buffer b)
(insert "fn f() -> i32 = 1\n")

37
emacs/test-flan.el
View File

@ -533,6 +533,43 @@ already rely on it — so nothing here is a stand-in for the real thing."
;; The session is not poisoned by that: a good form still lands.
(flan--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form")
;; The daemon's buffer is coloured: the compiler's errors, warnings and
;; notes take compilation's faces and the program's own output takes
;; `flan-output-face'. Checked on `font-lock-face', which is what
;; fontification writes; batch Emacs cannot turn `font-lock-mode' on, so
;; nothing here aliases it to `face'.
(let ((flan-daemon-buffer " *flan-colour-test*"))
(with-current-buffer (get-buffer-create flan-daemon-buffer)
(insert "flan dev: built x.flan in 3ms\n"
"/tmp/a.flan:2:8: expected i32, found string\n"
"/tmp/a.flan:3:1: warning: w\n"
"/tmp/a.flan:4:1: note: n\n")
(flan--daemon-buffer-setup)
(flan--append-output "said hi\nscore: 10\n")
(font-lock-ensure)
(let ((face-on (lambda (text)
(goto-char (point-min))
(search-forward text)
(get-text-property (match-beginning 0) 'font-lock-face))))
(test-flan--check
"the daemon's buffer draws an error, a warning and a note in compilation's faces"
(and (memq 'compilation-error (ensure-list (funcall face-on "a.flan:2")))
(memq 'compilation-warning (ensure-list (funcall face-on "a.flan:3")))
(memq 'compilation-info (ensure-list (funcall face-on "a.flan:4")))))
(test-flan--check
"the program's output takes its own face"
(eq (funcall face-on "said") 'flan-output-face))
(test-flan--check
"a line of output shaped `word:' is not drawn as a program name"
(progn (goto-char (point-min)) (search-forward "score")
(and (null (get-text-property (match-beginning 0) 'face))
(eq (get-text-property (match-beginning 0) 'font-lock-face)
'flan-output-face))))
(test-flan--check
"the daemon's own line is left plain"
(null (funcall face-on "flan dev:")))))
(kill-buffer flan-daemon-buffer))
;; The program's own output arrives on replies and lands in the daemon's
;; buffer — no REPL is open yet, and the log is the fallback that makes a
;; println never depend on one.

68
lib/ast.ml
View File

@ -24,6 +24,9 @@ and texpr_kind =
them identically — the difference is a fact about the value, and it is
[Check.resolve] that turns it into one. *)
| Tfn of bool * texpr list * texpr
(* An integer written as a generic struct's argument, the 8 in
(Small 8 i32). Parsed only there; it is not a type anywhere else. *)
| Tlen of int64
(* An array length is an integer or a compile-time constant's name. *)
and len =
@ -481,6 +484,71 @@ let map_children f (e : expr) : expr =
let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a
call stops before each form of its body, at any depth of body: the forms of
a [do], a [let], a loop, a [match] arm and each branch of an [if]. Not
inside an argument, an [fn] or a handler clause, which are not forms a
person reads as steps, and the last two are functions of their own. [None]
when there is no [defn] to instrument.
A step is [(step-point)] from the prelude — [error] of a [StepPoint] under a
[restart-case], so the break loop takes it as it takes [(pause)], with the
game loop and its clock frozen. It answers whether to go on stepping: its
[next] restart says yes and its [continue] says no, and the answer is kept
in a local of the call, [flan~step], so [continue] runs the rest of this
call and the next call steps again. [~] cannot occur in a source symbol, so
the local is visibly the compiler's and hidden from the locals listing. *)
let step_flag = "flan~step"
let step_point loc =
let v = { e = Var step_flag; loc } in
{ e =
If (v,
{ e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc });
loc },
None);
loc }
let rec step_body (es : expr list) : expr list =
List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es
and step_expr (e : expr) : expr =
let branch (x : expr) =
match x.e with
| Do _ -> step_expr x
| _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc }
in
match e.e with
| Do es -> { e with e = Do (step_body es) }
| Let (bs, es) -> { e with e = Let (bs, step_body es) }
| If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) }
| While (l, c, es) -> { e with e = While (l, c, step_body es) }
| Loop (bs, es) -> { e with e = Loop (bs, step_body es) }
| Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) }
| Match (sc, arms) ->
{ e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) }
| _ -> e
let instrument_step (ds : decl list) : decl list option =
let hit = ref false in
let ds =
List.map
(fun (d : decl) ->
match d.d with
| Defn f ->
hit := true;
let on =
{ bname = step_flag; bty = None;
bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc }
in
{ d with
d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody);
loc = d.dloc } ] } }
| _ -> d)
ds
in
if !hit then Some ds else None
(* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever
starts at that position, or [None] when nothing does.

2146
lib/check.ml
View File

File diff suppressed because it is too large Load Diff

1
lib/cimport.ml
View File

@ -407,6 +407,7 @@ let rec ty_source (t : Ast.texpr) =
| Ast.Tname n -> n
| Ast.Tapp (n, args) ->
Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args))
| Ast.Tlen n -> Int64.to_string n
| Ast.Tslice (c, e) ->
Printf.sprintf "[%s%s]" (if c then "const " else "") (ty_source e)
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e)

470
lib/dev.ml
View File

@ -28,11 +28,15 @@ type t = {
(* The running program. [Some pid] is the two-process daemon, which launched
it; [None] is the merged build, where the program is *this* process and
the compiler is a thread inside it. That is the whole of the difference at
this layer — see [merged_setup] for why there is no third case. *)
child : int option;
this layer — see [merged_setup] for why there is no third case. A re-run
under --two-process replaces the child with a new one. *)
mutable child : int option;
agent : string; (* where it listens for modules *)
dir : string; (* modules are built here, one per eval *)
stdout : Unix.file_descr; (* the program's output, on its way to here *)
mutable stdout : Unix.file_descr; (* the program's output, on its way here *)
(* --two-process only: build the program again from the session as it is
now and start it, answering the new child and its stdout. *)
relaunch : (unit -> int * Unix.file_descr) option;
out : Buffer.t; (* ...buffered until an editor asks for it *)
mutable n : int; (* dlopen caches by path: never reuse one *)
(* Bookkeeping for disassembly, and the reason it can exist at all: the
@ -268,10 +272,41 @@ let deliver_at_stop t ~gen path =
[None] where the program cannot be reached or answers something else, and
the caller treats that the way it treats a missing refusal count: as no
evidence, not as zero. Zero is a fact — it means running. *)
let stop_gen t : int option =
let stop_reply t =
match request t "stop" with
| exception Unix.Unix_error _ -> None
| text -> int_of_string_opt (String.trim text)
| text ->
(match String.split_on_char ' ' (String.trim text) with
| g :: rest ->
Option.map (fun g -> (g, rest)) (int_of_string_opt g)
| [] -> None)
let stop_gen t : int option = Option.map fst (stop_reply t)
(* How many evaluated expressions the agent has queued, and the highest one
that has returned a value; [None] from an agent without the verb. *)
let calls t : (int * int) option =
match request t "calls" with
| exception Unix.Unix_error _ -> None
| text ->
(match String.split_on_char ' ' (String.trim text) with
| [ q; v ] ->
(match int_of_string_opt q, int_of_string_opt v with
| Some q, Some v -> Some (q, v)
| _ -> None)
| _ -> None)
(* The same stop with whose code it stopped in: [Some true] when the thread
was running an evaluated thunk, [Some false] when it was in the program's
own code, [None] from an agent that does not say. *)
let stop_owner t : (int * bool option) option =
Option.map
(fun (g, rest) ->
(g, match rest with
| [ "eval" ] -> Some true
| [ "program" ] -> Some false
| _ -> None))
(stop_reply t)
(* How many stopped-only modules the program has thrown away for reaching the
game thread while it was running, and the sentence the agent says about it.
@ -669,14 +704,12 @@ let host_loc t name =
that was written finds nothing in the program, and these are how it gets
from that name to what the program does hold. *)
(* Its signature as written, [$] and all — [Types.to_string] prints a variable
bare, and [[t]] is not how anyone wrote it. *)
(* Its signature as written, [$] and all. *)
let generic_signature t name =
match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with
| None -> None
| Some (vars, params, ret) ->
let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in
let show ty = Types.to_string (Check.subst_ty dollar ty) in
| Some (_, params, ret) ->
let show ty = Types.to_string ty in
Some
(Printf.sprintf "%s [%s] %s" name
(String.concat " " (List.map show params)) (show ret))
@ -804,7 +837,8 @@ let build_module (c : Session.change) ~debug ~out =
spelled once so that every op tells the same story.
[gone] is what all of them used to say and is now said only where it is
true: there is no process left and nothing short of a new one will help.
true: there is no process left and nothing short of a new one will help —
which, under --two-process, a re-run is.
[parked] is the new half, and the sentence it appends is the whole point of
the distinction. Somebody reading it has a program that is *there* — its
@ -815,7 +849,7 @@ let build_module (c : Session.change) ~debug ~out =
refused for want of a frame boundary and an op refused for want of a stopped
stack are refused by the same state for different causes, and a reader who
cannot tell them apart cannot tell what to do instead. *)
let gone = "the program exited; restart flan dev"
let gone = "the program exited; M-x flan-rerun starts it again"
let parked_msg why =
why
@ -997,7 +1031,32 @@ let stale_field (ss : Session.stale list) =
(if x.Session.running then " :running t" else ""))
ss) ]
let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
(* Every refusal a check found, one plist each: beside what a load installed,
or beside the first of them when a form sent had several. *)
let errors_field (ds : Loc.diag list) =
match ds with
| [] -> []
| ds ->
[ ":errors "
^ Wire.list
(List.map
(fun (d : Loc.diag) ->
Printf.sprintf "(:loc %s :message %s)"
(Wire.quote (Loc.to_string d.Loc.dloc))
(Wire.quote d.Loc.dmsg))
ds) ]
(* A refusal with several diagnostics: the first where every refusal puts its
message, all of them under [:errors]. *)
let errors_reply (ds : Loc.diag list) =
match ds with
| [] -> error "nothing was refused"
| d :: _ ->
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
String.sub e 0 (String.length e - 1)
^ " " ^ String.concat " " (errors_field ds) ^ ")"
let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause =
let now = liveness t in
let parked_now = now = Parked in
(* A park that is over takes its note with it: the long sentence below is
@ -1018,10 +1077,28 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
nothing that can go wrong after it. *)
let before = Session.held t.session in
let refused msg = Session.restore t.session before; error msg in
if now = Gone then error gone
if now = Gone && t.relaunch <> None then
(* --two-process, the child ended: the form is checked into the session
and nothing is sent, because the next process is built from the
session whole ([rerun]). *)
match
Session.eval ~origin ?base ?forms ?pause ~running:false t.session code
with
| c ->
ok
([ ":names " ^ Wire.strings c.Session.names; ":fns ()";
":note "
^ Wire.quote
"loaded; the program has ended, so this is in it when M-x \
flan-rerun starts it again" ]
@ extra)
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
Session.restore t.session before;
error ~loc:(Loc.to_string l) msg
else if now = Gone then error gone
else
match
Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now)
Session.eval ~origin ?base ?forms ?pause ~step ~running:(not parked_now)
t.session code
with
| c when not c.Session.installs ->
@ -1084,6 +1161,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
| Some (l, c) ->
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
| None -> [])
@ (if step then [ ":step t" ] else [])
@ install_note t ~parked:parked_now
@ unpolled_note t ~parked:parked_now
@ extra)
@ -1102,20 +1180,9 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
Session.restore t.session before;
error ~loc:(Loc.to_string l) msg
(* The refusals a load answered beside what it installed, one plist each. *)
let errors_field (ds : Loc.diag list) =
match ds with
| [] -> []
| ds ->
[ ":errors "
^ Wire.list
(List.map
(fun (d : Loc.diag) ->
Printf.sprintf "(:loc %s :message %s)"
(Wire.quote (Loc.to_string d.Loc.dloc))
(Wire.quote d.Loc.dmsg))
ds) ]
| exception Loc.Errors ds ->
Session.restore t.session before;
errors_reply ds
(* C-c C-k: a whole file into the running session, SBCL's [load]. [eval] with
one difference — a form that does not compile is left out and listed
@ -1143,16 +1210,9 @@ let load_file t ~code ~origin =
(match Session.pruned check forms with
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
error ~loc:(Loc.to_string l) msg
| exception Loc.Errors ({ Loc.dloc = l; dmsg = msg; _ } :: _ as ds) ->
let e = error ~loc:(Loc.to_string l) msg in
String.sub e 0 (String.length e - 1)
^ " " ^ String.concat " " (errors_field ds) ^ ")"
| exception Loc.Errors ds -> errors_reply ds
| (), kept, errs ->
if errs <> [] && kept = [] then
let d = List.hd errs in
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
String.sub e 0 (String.length e - 1)
^ " " ^ String.concat " " (errors_field errs) ^ ")"
if errs <> [] && kept = [] then errors_reply errs
else
eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin
~pause:None)
@ -1193,7 +1253,7 @@ let load_file t ~code ~origin =
state to spawn it beside; the price is that eval races the application and
the race is documented as the programmer's problem. There is no race to
document here, because there is nothing running to race. *)
let eval_expr t ~code ~origin ~pause =
let eval_expr_at t ~code ~origin ~pause ~at =
match liveness t with
| Gone -> error gone
| Live | Parked ->
@ -1209,9 +1269,13 @@ let eval_expr t ~code ~origin ~pause =
let had =
List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns
in
match Session.eval_expr ~origin ~pause t.session code with
match Session.eval_expr ~origin ~pause ?frame:(Option.map snd at) t.session code with
| c ->
let before = match result t with Some (g, _) -> g | None -> 0L in
(* This expression's number among those the agent has queued: an
earlier one resumed by a restart can publish after this one is sent,
and the result counter alone would take its value for this one's. *)
let mine = Option.map (fun (q, _) -> q + 1) (calls t) in
(* Read here, beside [before], and for the same kind of reason: all
three are the "how things stood" half of a difference the wait below
measures. A program already sitting in a break when the request
@ -1225,19 +1289,23 @@ let eval_expr t ~code ~origin ~pause =
the reason [stop_gen]'s note gives at its definition. The name is kept
beside it as the fallback for an agent that cannot answer the verb.
As early as it usefully can be, and still not early enough to be
exact: [build_module] below takes a couple of hundred milliseconds,
and a game loop that signals *on its own* during them — or mid-wait,
while the thunk is still perfectly fine — bumps the generation too.
The reply then says "the expression stopped on X" about an expression
that had not run. Its machine-readable half stays right, so the editor
opens the break the program is actually in; only the sentence is
wrong, and no counter closes this one, because the program's break and
the thunk's are the same kind of event. Separating them wants the
per-frame origin the backtrace carries, which is LLVM-only.
TODO.org, "Whose break it is, which no counter answers" has it. *)
A game loop that signals *on its own* while this is in flight bumps
the generation too, so a fresh stop is not yet the thunk's. The stop
itself says whose it is — see [settled] below. *)
let entered = state t in
let entered_gen = stop_gen t in
(* In a frame the thunk is addressed to one stop, and the agent drops it,
and counts the drop, if that stop has ended by the time it is
claimed. Read before the build, which is when that usually happens. *)
let refused_before = if at = None then None else refusals t in
let dropped () =
match refused_before with
| None -> None
| Some (before, _) ->
(match refusals t with
| Some (now, why) when now > before -> Some why
| _ -> None)
in
t.n <- t.n + 1;
let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in
(* A generic called at a new type makes a copy that is defined in this
@ -1256,7 +1324,14 @@ let eval_expr t ~code ~origin ~pause =
in
(match build_module c ~debug:t.session.Session.debug ~out with
| _ ->
(match deliver t out with
(match
(* In a frame, only at the stop the frame was read at: the thunk
reads that frame's slots by address, and after a resume they
are somebody else's storage. *)
match at with
| Some (gen, _) -> deliver_at_stop t ~gen out
| None -> deliver t out
with
| "ok" ->
if copies <> [] then begin
t.gen <- t.gen + 1;
@ -1323,12 +1398,17 @@ let eval_expr t ~code ~origin ~pause =
re-stop between them could pair a stale name with a fresh
generation; it cannot manufacture one, since the generation only
climbs when a break really was entered. *)
(* A fresh stop in the program's own code is not an answer: the
thunk has not run, and the break loop that stop entered polls
the ring, so the thunk runs inside it and its value arrives on
a later tick. *)
let settled now =
match now with
| Stopped c ->
let fresh =
match stop_gen t, entered_gen with
| Some g, Some g0 -> g > g0
match stop_owner t, entered_gen with
| Some (_, Some false), _ -> false
| Some (g, _), Some g0 -> g > g0
| _ ->
(match entered with Stopped c0 -> c0 <> c | _ -> true)
in
@ -1368,9 +1448,16 @@ let eval_expr t ~code ~origin ~pause =
the sleep has to stay a sleep. *)
drain t;
let value () =
match result t with
| Some (g, v) when Int64.compare g before > 0 -> Some v
| _ -> None
let returned =
match mine, calls t with
| Some m, Some (_, v) -> v >= m
| _ -> true
in
if not returned then None
else
match result t with
| Some (g, v) when Int64.compare g before > 0 -> Some v
| _ -> None
in
match value () with
| Some v -> `Value v
@ -1402,6 +1489,9 @@ let eval_expr t ~code ~origin ~pause =
| Some answer ->
(match value () with Some v -> `Value v | None -> answer)
| None ->
match dropped () with
| Some why -> `Dropped why
| None ->
if ms <= 0 then `Timeout
else begin
ignore (Unix.select [] [] [] 0.005);
@ -1466,6 +1556,7 @@ let eval_expr t ~code ~origin ~pause =
left over, which is the shape it was always about: a program
that is running, is not parked, and produced nothing in five
seconds. *)
| `Dropped why -> error why
| `Timeout ->
if liveness t = Parked then
error
@ -1821,8 +1912,27 @@ let defs t =
~loc:(Loc.to_string loc) ())
classes
in
(* A generic struct is listed by its template, as [(Pair $t)]; its copies
are struct names only the compiler wrote. *)
let structs =
Hashtbl.fold
(fun name _ acc ->
if Hashtbl.mem env.Check.copies name then acc
else entry ~name ~kind:"struct" ~sign:name ~loc:"" () :: acc)
env.Check.structs []
@ Hashtbl.fold
(fun name (g : Check.gstruct) acc ->
entry ~name ~kind:"struct"
~sign:
(Printf.sprintf "(%s %s)" name
(String.concat " "
(List.map (fun (p, _) -> "$" ^ p) g.Check.gparams)))
~loc:"" ()
:: acc)
env.Check.gstructs []
in
List.sort compare
(of_table "struct" env.Check.structs
(structs
@ datas @ classes
@ of_table "union" env.Check.unions
@ of_table "enum" env.Check.enums
@ -1903,13 +2013,19 @@ let defs t =
text about the type and never touches the program. *)
let layout t ~ty =
let structs = t.session.Session.program.Tast.structs in
(* A generic struct's copy answers to the spelling a printed value's head
gives it, [Pair i32], and to its type's, [(Pair i32)], as well as to its
key. *)
let names (s : Tast.structure) =
[ s.Tast.sname; Types.struct_head s.Tast.sname;
Types.to_string (Types.Named s.Tast.sname) ]
in
match
List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty)
structs
List.find_opt (fun (s : Tast.structure) -> List.mem ty (names s)) structs
with
| Some s ->
ok
[ ":type " ^ Wire.quote s.Tast.sname;
[ ":type " ^ Wire.quote (Types.to_string (Types.Named s.Tast.sname));
":fields "
^ Wire.list
(List.map
@ -2406,6 +2522,40 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
name name)
else Ok (name, fn)))
(* [:frame N] on [eval-expr] is SLIME's eval-in-frame: the expression sees
that stopped frame's locals — see [Session.in_frame]. The frame is checked
the way [locals] and [inspect] check it, and the thunk is delivered at this
stop only. *)
let eval_expr ?frame ?at_stop t ~code ~origin ~pause =
match frame with
| None -> eval_expr_at t ~code ~origin ~pause ~at:None
| Some index ->
(match stopped_frame t ~frame:index ~what:"an expression in a frame" with
| Error m -> error m
| Ok (_, fn) ->
(match stop_gen t with
| None | Some 0 ->
error
"the program resumed while this was being asked; there is no frame \
to evaluate in any more"
| Some gen ->
(* A frame with no slots has no locals to bind, and the program
has no table to answer for it: the expression sees globals. *)
let bound =
if Array.length fn.Tast.slots = 0 then Ok []
else bound_slots t ~frame:index
in
(* [at_stop] is the stop the editor drew the frame at. It is not
checked here: the agent refuses a thunk addressed to a stop that
is over, and says so. *)
let gen = Option.value ~default:gen at_stop in
(match bound with
| Error m ->
error ("the program refused to say which slots are bound: " ^ m)
| Ok bound ->
eval_expr_at t ~code ~origin ~pause
~at:(Some (gen, (index, fn, bound))))))
(* [(:op "locals" :frame N)] — what a stopped frame's named locals hold.
The half of a break loop that the author actually wanted, and the reason
@ -3643,7 +3793,54 @@ let abort t =
park, the next request went out while the first run had not started, and the
pair of them produced one run — or, a moment later, a refusal saying the
program was already running. Both faces are gone with the lag. *)
(* Under --two-process a finished child is gone and there is no thread to
wake, so a re-run is a new process: the program is built again from the
session as it stands, which puts every accepted redefinition in it from
the start, and its globals start over. *)
let relaunch_child t relaunch =
match liveness t with
| Live | Parked ->
error
(if parked_break t then
"the program is stopped at a break, so it cannot be started again \
until that ends: resume it or abort it"
else
"the program is still running; a re-run starts it again in a new \
process once this one has finished. Close its window, or let it \
finish, and ask again")
| Gone ->
(* The whole program is checked again first ([Session.rehost]); a caller
left compiled against a signature that has since changed is where
that fails. *)
let refused (d : Loc.diag) =
error ~loc:(Loc.to_string d.Loc.dloc)
("a re-run builds the whole program again, and it does not compile: "
^ d.Loc.dmsg ^ ". Fix this and load it with C-c C-c, then ask again")
in
(match relaunch () with
| child, rd ->
drain t;
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
t.stdout <- rd;
t.child <- Some child;
t.finished <- false;
t.died <- None;
(* Every body is in the new host now, so no module owns one. *)
Hashtbl.reset t.owners;
ok
[ ":note "
^ Wire.quote
"started the program again in a new process, built with every \
change loaded so far; its globals start over, because the \
process is new" ]
| exception Failure m -> error m
| exception Loc.Error d -> refused d
| exception Loc.Errors (d :: _) -> refused d)
let rerun t =
match t.relaunch with
| Some relaunch -> relaunch_child t relaunch
| None ->
match liveness t with
| Gone -> error gone
(* A file started with no [main] runs a stub that returns at once; running
@ -4382,7 +4579,13 @@ and handle_op t req =
let origin =
match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
in
eval t ~code ~origin ~pause:(Wire.pos_field req "pause")
(* [:step t] instruments every defn sent for the stepper. *)
let step =
match Wire.field req "step" with
| Some { Form.v = Form.Sym "nil"; _ } | None -> false
| Some _ -> true
in
eval t ~code ~origin ~pause:(Wire.pos_field req "pause") ~step
| None -> error "eval needs :code")
| Some "eval-expr" ->
(match Wire.string_field req "code" with
@ -4400,7 +4603,8 @@ and handle_op t req =
| Some { Form.v = Form.Sym "nil"; _ } | None -> false
| Some _ -> true
in
eval_expr t ~code ~origin ~pause
eval_expr ?frame:(Wire.int_field req "frame")
?at_stop:(Wire.int_field req "at-stop") t ~code ~origin ~pause
| None -> error "eval-expr needs :code")
(* [:all], absent or [nil] being false and anything else true — the spelling
[:pause], [:on] and [:reset] already use. One step is the default because
@ -5063,8 +5267,11 @@ let accept_loop ?grace t ls =
where a session with no editor attached spends its time. *)
agent_check t;
match liveness t with
| Gone -> ()
| (Live | Parked) as live ->
| Gone when t.relaunch = None -> ()
| live ->
(* A --two-process child that has ended can be started again, so the
session waits as a parked one does, on the parked grace. *)
let live = if live = Gone then Parked else live in
let idle = Unix.gettimeofday () -. !since in
if orphaned ~grace ~served:!served ~idle live then
(* The measured gap and not the threshold it crossed: the threshold is
@ -5077,7 +5284,10 @@ let accept_loop ?grace t ls =
else
(* The program's pipe is in the same select as the listening socket: it
has to be drained whether or not an editor is asking for anything. *)
match Unix.select [ ls; t.stdout ] [] [] 0.2 with
(* Not once it has read EOF: an ended child's pipe is readable for
ever, and the loop would spin on it. *)
let fds = if t.finished then [ ls ] else [ ls; t.stdout ] in
match Unix.select fds [] [] 0.2 with
| [], _, _ -> go ()
| ready, _, _ when not (List.mem ls ready) -> drain t; go ()
| _ ->
@ -5185,19 +5395,21 @@ let need_main ~file (session : Session.t) =
(* The agent's C, in every program [flan dev] builds, whether or not the source
imports the package: its constructor binds the socket before [main], so a
file that never mentions the agent can still be reached from the editor. A
program that imports it already has it, and is left alone — two copies
would collide at the link. A release build is not built here and is not
affected. *)
file that never mentions the agent can still be reached from the editor.
Always this compiler's own copy, in place of any the program vendors. The
agent is the daemon's other half — the stack it snapshots and the verbs it
answers are what this file reads — and a program outside this repository
carries whatever copy of vendor/agent it was given, however old. An old one
builds and answers, and then puts every frame at its function's own line,
because it predates the call-site record, so the stepper never moves. One
copy and not two: two would collide at the link. A release build is not
built here. *)
let with_agent ~dir csrcs lflags =
let c = Filename.concat dir "flan_agent.c" in
write_file c Runtime_src.agent_source;
let csrcs =
if List.exists (fun c -> Filename.basename c = "flan_agent.c") csrcs then
csrcs
else begin
let c = Filename.concat dir "flan_agent.c" in
write_file c Runtime_src.agent_source;
csrcs @ [ c ]
end
List.filter (fun x -> Filename.basename x <> "flan_agent.c") csrcs @ [ c ]
in
let lflags =
lflags
@ -5225,7 +5437,7 @@ let report_dropped ~file = function
deletes it — and silently making every reloaded body -O0 would change the
frame time of the one function you are iterating on, in the loop whose whole
point is watching that number. *)
let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock () =
let t0 = Unix.gettimeofday () in
(* Absolute, because every location this daemon ever reports is derived from
it and an editor is not in this process's working directory. [flan dev
@ -5252,19 +5464,22 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
against each module as it loads either way, but a breakpoint set on a line
in the .flan buffer needs a line table on both sides — the host's to fire
before the first C-c C-c, the module's to follow the reload. *)
let _, kept =
Build.executable
~opts:{ Build.default with Build.dev = true; Build.keep = true;
Build.debug; Build.x86 }
~csrcs ~lflags session.Session.host ~out:exe
in
(* Host and modules are chosen together, which is the whole licence: an
[--x86] host gets [--x86] modules because one flag set both, and the
source [Build.executable] kept is assembly rather than IR. *)
let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in
(match kept with
| Some src -> (try Sys.rename src host_ll with Sys_error _ -> ())
| None -> ());
let build_host () =
let _, kept =
Build.executable
~opts:{ Build.default with Build.dev = true; Build.keep = true;
Build.debug; Build.sanitize; Build.x86 }
~csrcs ~lflags session.Session.host ~out:exe
in
match kept with
| Some src -> (try Sys.rename src host_ll with Sys_error _ -> ())
| None -> ()
in
build_host ();
let agent = Filename.concat dir "agent.sock" in
(* The program's source names some socket path; the daemon is the one that
@ -5272,6 +5487,10 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
environment. Guessing instead would fail silently — everything compiles,
the module is built, and nothing ever receives it. *)
Unix.putenv "FLAN_AGENT_SOCKET" agent;
(* The child binds that path only if this pid is its parent, so a process
that merely inherited the variable leaves the socket alone
(flan_agent.c, [daemon_socket]). *)
Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ()));
(* And who its parent is, which is the child's licence to end itself.
vendor/agent/flan_agent.c carries the argument at length; the half that
belongs here is that this daemon is the only thing that ever kills its
@ -5296,23 +5515,39 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
the pipe it was writing to; that also meant the pipe could never reach
EOF while the child lived, so "wait for EOF on the daemon's end" was never
the mechanism it looked like it could be. *)
let rd, wr = Unix.pipe ~cloexec:true () in
let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in
Unix.close wr;
Unix.set_nonblock rd;
(* Wait for it to bind before accepting an evaluation. One that arrives first
would fail for a reason that reads like a compiler bug. *)
if not (await (fun () -> Sys.file_exists agent)) then begin
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
failwith
("the program did not open its agent socket at " ^ agent
^ ". Under --two-process every edit reaches the program through that \
socket.")
end;
let spawn () =
(* A socket file a previous child left behind would answer the wait below
before this child has bound anything. *)
(try Unix.unlink agent with Unix.Unix_error _ -> ());
let rd, wr = Unix.pipe ~cloexec:true () in
let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in
Unix.close wr;
Unix.set_nonblock rd;
(* Wait for it to bind before accepting an evaluation. One that arrives
first would fail for a reason that reads like a compiler bug. *)
if not (await (fun () -> Sys.file_exists agent)) then begin
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
(try Unix.close rd with Unix.Unix_error _ -> ());
failwith
("the program did not open its agent socket at " ^ agent
^ ". Under --two-process every edit reaches the program through that \
socket.")
end;
(child, rd)
in
let child, rd = spawn () in
(* A re-run: the host is built again from the session as it stands, so
every redefinition accepted so far is in the new process from its first
instruction rather than delivered to it later. *)
let relaunch () =
Session.rehost session;
build_host ();
spawn ()
in
let t =
{ session; child = Some child; agent; dir; stdout = rd;
relaunch = Some relaunch;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false; died = None; dropped = 0 }
@ -5326,9 +5561,12 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
((Unix.gettimeofday () -. t0) *. 1000.);
Fun.protect
~finally:(fun () ->
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ());
(match t.child with
| Some child ->
(try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ())
| None -> ());
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.close rd with Unix.Unix_error _ -> ());
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ()))
(fun () -> accept_loop t ls);
(* Here only when the loop returned: an exception out of it has already
@ -6171,7 +6409,7 @@ let merged_setup () =
with Unix.Unix_error _ -> Sys.executable_name
in
let t =
{ session; child = None; agent; dir; stdout = rd;
{ session; child = None; agent; dir; stdout = rd; relaunch = None;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false; died = None; dropped = 0 }
@ -6254,7 +6492,7 @@ let merged_serve () =
(* The merged build is made here and then [exec]'d, so what an editor talks to
is the program itself rather than something that launched it. The launcher
does not survive: there is one process from the first reply onwards. *)
let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
let start_merged ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock () =
let t0 = Unix.gettimeofday () in
let dir = session_dir ~file ~sock in
let given = file in
@ -6272,7 +6510,8 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in
ignore
(merged_executable
~opts:{ Build.default with Build.dev = true; Build.debug; Build.x86 }
~opts:{ Build.default with Build.dev = true; Build.debug;
Build.sanitize; Build.x86 }
~csrcs ~lflags ~pnames:[]
session.Session.host ~out:exe ~ll:host_ll);
(* Read by the park, so the first one says the session is waiting rather
@ -6285,6 +6524,9 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
that the game thread's [getenv] cannot race the compiler thread's
[putenv]: there is no ordering left to get wrong. *)
Unix.putenv "FLAN_AGENT_SOCKET" agent;
(* This pid, because the exec below keeps it: the program is the owner
flan_agent.c's [daemon_socket] looks for. *)
Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ()));
Unix.putenv "FLAN_DEV_SOURCE" file;
Unix.putenv "FLAN_DEV_SOCK" sock;
Unix.putenv "FLAN_DEV_DIR" dir;
@ -6310,7 +6552,17 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
flan.cmxa beside the binary — and it is what every behaviour in this file
was written against, so it stays until the transport it exists to drive is
actually deleted. *)
let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () =
let start ?(debug = false) ?(sanitize = false) ?(merged = true) ?(x86 = true)
~file ~sock () =
(* The sanitizers are LLVM passes, and the x86 backend's host is written
by hand with no pass run over it. The modules a session sends are not
instrumented on either backend; what is checked is the host and the
runtime, which is where a dev session's own bookkeeping lives. *)
if x86 && sanitize then
failwith
"flan dev --x86 --sanitize: the sanitizers instrument LLVM's output, and \
the x86 backend writes its code by hand, so the program's own code \
would not be checked. Drop --x86 to build this session with LLVM.";
(* x86 unless told otherwise, and the default is here rather than only in
[bin/main.ml] so that there is one answer to "what backend is a dev
session". A library caller that starts a daemon starts the same daemon the
@ -6360,5 +6612,5 @@ let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () =
[--x86 --debug] above is still refused, and for a reason that has nothing
to do with this one. *)
if merged then start_merged ~debug ~x86 ~file ~sock ()
else two_process ~debug ~x86 ~file ~sock ()
if merged then start_merged ~debug ~sanitize ~x86 ~file ~sock ()
else two_process ~debug ~sanitize ~x86 ~file ~sock ()

109
lib/emit.ml
View File

@ -370,7 +370,7 @@ let rec ll (t : Types.t) =
integer spelling costs no casts and keeps the emitter honest about not
knowing whether the bits are a pointer. *)
| Types.Dyn -> "i64"
| Types.Var _ ->
| Types.Var _ | Types.Len _ | Types.LArray _ ->
(* The checker rejects it by name — nothing reaches here. *)
internal "no layout for %s" (Types.to_string t)
@ -539,6 +539,12 @@ type m = {
[annot]. *)
ann : bool;
mutable nstr : int;
(* Set while an expression thunk's module is emitted: a string literal's
value is then a copy [flan_dev_literal] keeps for the life of the
process, so storing it anywhere leaves nothing pointing into the module,
and the literal is not counted in [nstr]. Without it every C-x C-e that
wrote a string or a keyword kept its mapping. *)
mutable pool : bool;
(* The frame descriptors a dev build's shadow stack points at, counted apart
from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide
whether an expression thunk's module may be unloaded — a string literal in
@ -641,7 +647,8 @@ let rec lay m (t : Types.t) : int * int =
| Some u -> union_lay m u
| None -> internal "no layout for struct %s" n)
| Types.Dyn -> 8, 8
| Types.Var _ -> internal "no layout for %s" (Types.to_string t)
| Types.Var _ | Types.Len _ | Types.LArray _ ->
internal "no layout for %s" (Types.to_string t)
(* Size, alignment, and the offset of every member. *)
and lay_fields m tys =
@ -1204,7 +1211,7 @@ let rec dty m d (t : Types.t) : int =
reading: it prints, and the person reading it can hand it to the
runtime's own printer. *)
| Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned"
| Types.Var _ ->
| Types.Var _ | Types.Len _ | Types.LArray _ ->
internal "no debug type for %s" (Types.to_string t)
in
Hashtbl.replace d.dtys key n;
@ -2591,6 +2598,16 @@ and value_at f (e : Tast.expr) : string =
| Tast.Int (n, _) -> Int64.to_string n
| Tast.Float (x, k) -> float_const k x
| Tast.Bool b -> if b then "true" else "false"
| Tast.Str s when f.md.pool ->
(* See [pool]: the bytes are still this module's, but only the copy
leaves it, so they are [fi_bytes]' kind of constant and not
[string_bytes']. The copy carries the NUL. *)
let id, n = fi_bytes f.md s in
let p = fresh f in
ins f "%s = call ptr @flan_dev_literal(ptr %s, i64 %d)" p id n;
let v = fresh f in
ins f "%s = insertvalue %%slice { ptr poison, i64 %d }, ptr %s, 0" v n p;
v
| Tast.Str s -> string_const f.md s
| Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer"
| Tast.Uninit _ -> "poison"
@ -3161,6 +3178,9 @@ and call_ptr ?at f ret callee args =
code, Some ("ptr " ^ env)
| _ -> c, None
in
(match callee.Tast.ty, at with
| Types.CFn _, Some loc -> null_check f loc callee.Tast.ty code
| _ -> ());
let vs = map_lr (fun (a : Tast.expr) ->
let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in
Option.iter (mark_call f) at;
@ -3168,6 +3188,19 @@ and call_ptr ?at f ret callee args =
if at <> None then clear_call f;
r
(* A (CFn ...) may be a zeroed field, array element or global, and a zeroed
one is a null address. Tested before the arguments are evaluated, so a
call that is not going to be made runs none of them — the x86 backend
tests at the same point. [flan_null_call] signals [NullCall] and returns
only when something transferred, the shape of a bounds failure. *)
and null_check f loc ty code =
let ok = fresh f in
ins f "%s = icmp ne ptr %s, null" ok code;
signal_block f loc ~guard:(fun () -> guard f) ok (fun id n ->
let tys = fst (fi_bytes f.md (Types.to_string ty ^ "\000")) in
ins f "call void @flan_null_call(ptr %s, i64 %d, ptr %s, ptr %s)"
id n tys xfer_param)
(* The code address behind one of the three [fnref]s, which is the same string
whether it is wanted as a bare [(Ptr ())] or as the first word of a
function value.
@ -4909,10 +4942,14 @@ declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold
; as C strings, then the cell and the channel. Signals StaleCall; returns when
; something answered.
declare void @flan_stale_call(ptr, ptr, ptr, ptr, ptr) cold
; A call through a (CFn ...) holding null: the site, the value's type as a C
; string and the channel. Signals NullCall; returns when something answered.
declare void @flan_null_call(ptr, i64, ptr, ptr) cold
declare ptr @flan_context_allocator()
declare ptr @flan_context_use(ptr, i64)
declare void @flan_context_value(ptr)
declare void @flan_free_temp()
declare void @flan_slice_free(ptr, i64, i64, i64, ptr, ptr, i64)
declare i8 @flan_i64_temp(i64, ptr)
declare i8 @flan_f64_temp(double, ptr)
declare void @flan_alloc_seal(ptr, ptr)
@ -4992,6 +5029,8 @@ declare void @flan_dev_watch_emit_i64(i64)
declare void @flan_dev_watch_emit_u64(i64)
declare void @flan_dev_watch_emit_f64(double)
declare void @flan_dev_watch_end()
; An expression thunk's string literals, copied to storage the process keeps.
declare ptr @flan_dev_literal(ptr, i64)
declare i64 @flan_dyn_need_i64(i64)
declare double @flan_dyn_need_f64(i64)
declare i32 @flan_dyn_need_bool(i64)
@ -5018,6 +5057,7 @@ declare void @flan_dyn_root_globals_end()
declare void @flan_gc_init()
declare void @flan_dev_reg_enable()
declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_slice(ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64)
declare void @flan_dev_reg_note_res_acquire(i64, ptr, i64, ptr, i64)
declare void @flan_dev_reg_note_res_release(i64, ptr, i64, ptr, i64)
@ -5309,7 +5349,7 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
globals = Hashtbl.create 16;
externs = Hashtbl.create 32;
checks; dev; gcfn = dev || makes_closures p;
known; nstr = 0; nfi = 0; sanitize; ann = annotate;
known; nstr = 0; pool = false; nfi = 0; sanitize; ann = annotate;
descs = Hashtbl.create 8;
dbg = (if debug then Some (new_dbg p) else None);
fsigs = fsigs_of p;
@ -5752,6 +5792,43 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
String literals still have to come along: they are this module's own
constants, and omitting them is an undefined [@.str.N] at link time. *)
(* Whether an expression thunk makes a function value anywhere in its body or
in the clauses lifted out of it. Such a value's code address is in this
module — a lambda's body, or the thick wrapper a named function is handed
out through — and it may be stored anywhere, so the module must stay
mapped. Both backends ask this before marking a thunk's module
unloadable. *)
let thunk_makes_fn_values (p : Tast.program) name =
let mine = Hashtbl.create 8 in
Hashtbl.replace mine name ();
(* Lifted clauses nest: a lambda inside a lambda is lifted out of the
outer one's body, so the set grows until nothing new joins it. *)
let rec close () =
let grew = ref false in
List.iter
(fun (f : Tast.fn) ->
match f.Tast.fparent with
| Some q when Hashtbl.mem mine q && not (Hashtbl.mem mine f.Tast.name) ->
Hashtbl.replace mine f.Tast.name (); grew := true
| _ -> ())
p.Tast.fns;
if !grew then close ()
in
close ();
let found = ref false in
List.iter
(fun (f : Tast.fn) ->
if Hashtbl.mem mine f.Tast.name then
List.iter
(Tast.walk (fun (e : Tast.expr) ->
match e.Tast.e with
| Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _ -> found := true
| _ -> ()))
f.Tast.body)
p.Tast.fns;
!found
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
?(known = fun _ -> true) ?(retains = true)
?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns
@ -5791,6 +5868,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
in
let m = new_module ~checks ~dev ~known ~debug ~annotate p in
m.pool <- call <> None && retains;
(* A thunk the module runs itself is excluded from all of this: it is called
directly by [flan_reload_call], so it needs no cell, must not be published
into one, and must not take a registry slot — there are 4096 of those and
@ -5910,7 +5988,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
let t = fresh () in
Buffer.add_string b
(Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n"
t (cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name)))
t (fi_cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name)))
new_fns;
List.iter
(fun (g : Tast.global) ->
@ -5929,8 +6007,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
match initial_image p g with
| None -> "null"
| Some v ->
let init = Printf.sprintf "@\".init.%d\"" m.nstr in
m.nstr <- m.nstr + 1;
(* Copied by the runtime and not kept, so not counted in
[nstr]; a string inside it is, through [const]. *)
let init = Printf.sprintf "@\".init.%d\"" m.nfi in
m.nfi <- m.nfi + 1;
Buffer.add_string m.strs
(Printf.sprintf "%s = private constant %s %s\n" init
(ll g.Tast.gty) (const m v));
@ -5940,7 +6020,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
(Printf.sprintf
" %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \
store ptr %s, ptr %s\n"
t (cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
t (fi_cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t
(globalptr g.Tast.gname)))
new_globals;
(* A constant whose value the checker never consumed is just bytes in the
@ -6009,10 +6089,12 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
expression may store one anywhere it likes — [(set msg "tuned")] on a
string global leaves that global pointing into the mapping the agent
is about to drop. The next thunk can be mapped at the same address, so
the result is silent garbage rather than a fault. A module with no
string constants has nothing in its image anyone could still be
pointing at; one with any keeps its mapping, which costs a page and is
the same bargain every redefinition already makes. *)
the result is silent garbage rather than a fault. So a thunk's
literal is a copy the process keeps (see [pool]) and is not counted;
what [nstr] still counts is a constant something may go on pointing
at, such as a condition's name, and a module with one keeps its
mapping. The registry names above are not counted: flan_dev.c copies
a name it keeps, and an initial image is copied on allocation. *)
(* [retains = false] is a caller saying it knows where every literal in
this module goes. The [m.nstr] test below is a conservative stand-in
for that — an expression may store a string literal anywhere it likes,
@ -6022,7 +6104,8 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
into the result buffer, so nothing outside the module holds an address
inside it once the call has returned. Without this, clicking through
the frames of a break loop costs a permanent mapping per click. *)
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) then
if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0)
&& not (thunk_makes_fn_values p fn) then
Buffer.add_string m.out "\n@flan_reload_transient = global i8 1\n"
| None -> ()
end;

11
lib/indent_printer.ml
View File

@ -200,13 +200,17 @@ and inline_text ?(lvl = 0) (f : Form.t) =
w ^ " :" ^ k
| Form.List [ { v = Form.Sym "return"; _ }; v ] -> "return " ^ at (max lvl 1) v
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v
| Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; w ]
when not (R.simple_place t) ->
at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
| _ -> at lvl f
(* [t = v], or [t += w] when [v] is [(+ t w)]. *)
and assign_text ?(lvl = 0) t v =
let tt = at 9 t in
match v.v with
| Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ] when same a t ->
| Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ]
when same a t && R.simple_place t ->
tt ^ " " ^ op ^ "= " ^ at (max lvl 1) w
| _ -> tt ^ " = " ^ at (max lvl 1) v
@ -325,7 +329,7 @@ let body_split (h : Form.t) args =
let sugar_heads =
[ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match";
"handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do";
"quasiquote" ]
"quasiquote"; "update" ]
let rec block n (fs : Form.t list) : string list =
let rec go = function
@ -441,6 +445,9 @@ and sugar n ~last (f : Form.t) : string list option =
(match pairs bs with
| None | Some [] -> None
| Some prs -> Some (let_lines n ~last prs body))
| Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym ("+" | "-" | "*" | "/"); _ }; _ ]
when not (R.simple_place t) ->
Some [ i ^ guard (inline_text f) ]
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] ->
let line = i ^ guard (assign_text t v) in
if String.length line <= width then Some [ line ]

40
lib/indent_reader.ml
View File

@ -64,6 +64,35 @@ let is_op_word s = is_binop s || s = "not" || s = "="
let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ]
(* A place whose parts are all names and literals reads the same however
often it is evaluated, so [x += v] over one is [(set x (+ x v))], the form
the Lisp side writes. Any other place — an index that is a call — reads
[(update p + v)], which evaluates each part of the place once. The printer
asks the same question, so the round trip is exact either way. *)
let rec simple_place (f : Form.t) =
let atom (x : Form.t) =
match x.v with
| Form.Sym _ | Form.Int _ | Form.Kw _ | Form.Byte _ -> true
| _ -> false
in
match f.v with
| Form.Sym _ -> true
| Form.List [ { v = Form.Sym h; _ }; t ]
when (String.length h > 1 && h.[0] = '.') || h = "deref" ->
simple_place t
| Form.List ({ v = Form.Sym "at"; _ } :: t :: (_ :: _ as idx)) ->
simple_place t && List.for_all atom idx
| _ -> false
let compound (at : Loc.t) op (e : Form.t) (v : Form.t) span =
if simple_place e then
Form.List
[ Form.make (Form.Sym "set") at; e;
Form.make (Form.List [ Form.make (Form.Sym op) at; e; v ]) span ]
else
Form.List
[ Form.make (Form.Sym "update") at; e; Form.make (Form.Sym op) at; v ]
(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything
else keeps the Lisp reading, so [--], [->] and [-=] stay names. *)
let is_neg_char c =
@ -724,11 +753,7 @@ and inline_stmt p : Form.t =
| NAME op when List.mem_assoc op assign_ops ->
let eq = advance p in
let v, _ = expr p in
mk p t.loc
(Form.List
[ sym eq.loc "set"; e;
Form.make (Form.List [ sym 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))
| _ -> e
(* [fn(a, b) = body] is a lambda; [fn(...)] followed by anything else is the
@ -1125,10 +1150,7 @@ and expr_stmt (s : st) : Form.t =
let eq = advance p in
let v = value_line s ~after:(text_of e ^ " " ^ op) in
let o = List.assoc op assign_ops in
mk p t0.loc
(Form.List
[ sym eq.loc "set"; e;
Form.make (Form.List [ sym eq.loc o; e; v ]) (span p e.loc) ])
mk p t0.loc (compound eq.loc o e v (span p e.loc))
| COLON ->
let before = (last p).tok in
let c = advance p in

2
lib/js.ml
View File

@ -249,6 +249,8 @@ let rec refuse_ty loc (t : Types.t) =
host's own, and that work has not been done"
| Types.Var n ->
at loc "a type variable (%s) reached the backend, which cannot happen" n
| Types.Len _ | Types.LArray _ ->
at loc "a length variable reached the backend, which cannot happen"
(* Aggregates in the sense that matters here: the types whose assignment
copies in Flan and would alias in JS. A slice is deliberately not one —

9
lib/load.ml
View File

@ -213,8 +213,11 @@ let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr =
Ast.Tarray (rename_len owned alias l, rename_texpr owned alias e)
| Ast.Tmap (k, v) ->
Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v)
(* The head too, when it is a generic struct the package declares. *)
| Ast.Tapp (n, args) ->
let n = if List.mem n owned then qualify alias n else n in
Ast.Tapp (n, List.map (rename_texpr owned alias) args)
| Ast.Tlen _ as k -> k
| Ast.Tfn (env, ps, r) ->
Ast.Tfn (env, List.map (rename_texpr owned alias) ps,
rename_texpr owned alias r)
@ -800,8 +803,11 @@ let rec texpr_uses acc (t : Ast.texpr) =
(match l with Ast.Lname n -> acc := (n, t.Ast.tloc) :: !acc | Ast.Lint _ -> ());
texpr_uses acc e
| Ast.Tmap (k, v) -> texpr_uses acc k; texpr_uses acc v
| Ast.Tapp (_, args) -> List.iter (texpr_uses acc) args
| Ast.Tapp (n, args) ->
acc := (n, t.Ast.tloc) :: !acc;
List.iter (texpr_uses acc) args
| Ast.Tfn (_, ps, r) -> List.iter (texpr_uses acc) ps; texpr_uses acc r
| Ast.Tlen _ -> ()
let rec expr_uses acc (e : Ast.expr) =
let go = expr_uses acc in
@ -1618,6 +1624,7 @@ let program ?(parse = Parse.program) ~file (forms : Form.t list) : t =
in
let decls =
Parse.with_imported ~decls:(imported.decls @ !Parse.imported_decls)
~fns:!Parse.shadowing_fns
(macro_union imported.macros !Parse.imported_macros)
(fun () -> parse forms)
in

1
lib/loc.ml
View File

@ -205,6 +205,7 @@ let caught s f =
match f () with
| x -> Some x
| exception Error d -> s.found <- d :: s.found; None
| exception Errors ds -> s.found <- List.rev_append ds s.found; None
(** Raise everything found, in the order it was found, or return if the pass
was clean. *)

29
lib/macro.ml
View File

@ -585,10 +585,39 @@ let with_module (l : loaded) (f : unit -> 'a) : 'a =
left in them, so a second pass only reaches the calls to the new names. A
macro that defines a macro whose expansion defines another costs one pass
per level, and the fuel is the same bound [settle] uses. *)
(* The names these forms define as functions. A program's [defn] shadows a
macro of the same name — the prelude's [clamp] or [update], or an
imported one — as it shadows a prelude function: every call in the file
reaches the definition, and [Check.shadow_prelude] says so. So such a
name is not expanded here. A [defmacro] is a [defn] too once parsed, but
not yet: [macro_name] is what finds those, and they are left alone. *)
let defined_fns (forms : Form.t list) =
List.filter_map
(fun (f : Form.t) ->
match f.Form.v with
| Form.List ({ Form.v = Form.Sym ("defn" | "defn-"); _ }
:: { Form.v = Form.Sym n; _ } :: _) -> Some n
| _ -> None)
forms
let rec program_n left (forms : Form.t list) : Form.t list =
match loaded_for forms with
| None -> forms
| Some l ->
(* Never the prelude's own forms: they are parsed inside a session's
evaluation too, and their calls are to their own macros. *)
let prelude =
match forms with
| f :: _ -> String.equal f.Form.loc.Loc.file Prelude.file
| [] -> false
in
let shadowed =
if prelude then [] else defined_fns forms @ !Parse.shadowing_fns
in
let l =
if shadowed = [] then l
else { l with fns = List.filter (fun (n, _) -> not (List.mem n shadowed)) l.fns }
in
let before = macros_in forms in
let out = with_module l (fun () -> List.map (expand_form l) forms) in
let fresh = List.filter (fun n -> not (List.mem n before)) (macros_in out) in

204
lib/parse.ml
View File

@ -30,6 +30,32 @@ let no_sigil (f : Form.t) =
let dname (f : Form.t) = no_sigil f; sym f
(* A global's name. One spelled like a built-in type would stand where the
type is written — [(vec-new u8)] — and change what that means, in the
program and in the prelude alike, so it is refused where it is declared. *)
let gname (f : Form.t) =
(match f.v with
| Sym s when List.mem s Types.primitive_names ->
Loc.failk "parse/global-named-type" f.loc
"%s is a type, so it cannot also name a global — (vec-new %s) would \
not know which was meant. Name it %s-value, or any name that is not \
a type"
s s s
| _ -> ());
dname f
(* A type's name. A built-in type's is taken: a second [u8] would stand for
one or the other wherever a type is written, the prelude's included. *)
let tname (f : Form.t) =
(match f.v with
| Sym s when List.mem s Types.primitive_names ->
Loc.failk "parse/type-named-builtin" f.loc
"%s is a built-in type, so it cannot be declared again. Give the new \
type a name of its own"
s
| _ -> ());
dname f
(* Names for the temporaries this file mints — the value is bound once and
everything that needs it reads *that*, so a destructuring pattern over a
call calls it once and a short-circuit operand is evaluated once. [~] is a
@ -73,6 +99,16 @@ let no_pattern (f : Form.t) =
(* ── Type expressions ──────────────────────────────────────────────── *)
(* A type constructor's spelling: its last segment starts with a capital. *)
let capitalised_name name =
let base =
match String.rindex_opt name '/' with
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
| None -> name
in
base <> "" && Char.uppercase_ascii base.[0] = base.[0]
&& Char.lowercase_ascii base.[0] <> base.[0]
let rec texpr (f : Form.t) : Ast.texpr =
let mk t = { Ast.t; tloc = f.loc } in
match f.v with
@ -135,8 +171,44 @@ let rec texpr (f : Form.t) : Ast.texpr =
| [ { v = Vec params; _ }; ret ] ->
mk (Ast.Tfn (env, List.map texpr params, texpr ret))
| _ -> fail f "a function type is (%s [T ...] R)" which)
| List ({ v = Sym name; _ } :: args) when args <> [] ->
mk (Ast.Tapp (name, List.map texpr args))
| List ({ v = Sym name; _ } :: args)
when args <> [] || capitalised_name name ->
(* An integer argument is a generic struct's length, and a type
constructor is capitalised. A lowercase head is a body form in the
return slot — (+ x 1) — and its integer is the type parser's reason to
give up, which is the refusal that slot is built on. *)
let capitalised = capitalised_name name in
(* Integer arithmetic over literals is a length too — [(Small (+ 4 4)
i32)] — folded here, since nothing later reads it as a value. *)
let rec fold (a : Form.t) =
match a.v with
| Int n -> Some n
| List ({ v = Sym (("+" | "-" | "*") as op); _ } :: (_ :: _ as xs)) ->
let vs = List.map fold xs in
if List.for_all Option.is_some vs then
let vs = List.map Option.get vs in
match op, vs with
| "-", [ x ] -> Some (Int64.neg x)
| "+", v :: rest -> Some (List.fold_left Int64.add v rest)
| "-", v :: rest -> Some (List.fold_left Int64.sub v rest)
| "*", v :: rest -> Some (List.fold_left Int64.mul v rest)
| _ -> None
else None
| _ -> None
in
let arg (a : Form.t) =
match a.v, fold a with
| _, Some n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc }
| List _, None when capitalised ->
(try texpr a with
| Loc.Error _ ->
fail a
"%s is not a type or a length. An argument here is a type, or a \
length: an integer, a constant's name or a length variable"
(Form.to_string a))
| _ -> texpr a
in
mk (Ast.Tapp (name, List.map arg args))
| _ -> fail f "expected a type, found %s" (Form.to_string f)
and len (f : Form.t) : Ast.len =
@ -449,6 +521,14 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
| [ target; value ] -> mk (Ast.Set (place target, expr value))
| _ -> fail f "set is (set place value)")
(* What [update], [++] and [--] expand into: (update~ PLACE g NEW), where
NEW is written over the name [g]. The name has a [~] in it so no program
can write it; only a prelude macro builds one. See [modify]. *)
| Sym "update~" ->
(match args with
| [ target; { v = Sym g; _ }; value ] -> modify f target g value
| _ -> fail f "internal: update~ is (update~ place name value) — a compiler bug")
(* ── (vec-new [u8]) and (map-new string [u8]) ───────────────────────
The type positions of these two take a type expression. Whether this call
is the builtin at all is the checker's to know — a program may define its
@ -1174,17 +1254,10 @@ and cond f (args : Form.t list) : Ast.expr =
[f.loc] would blame the enclosing (and ...) for whichever operand is
actually wrong.
What answering the operand costs, for both forms alike: the two arms are
now both real values, so mixing a dyn operand with a typed bool one makes
check_if unify them, and the then arm decides. A non-bool dyn value on
the losing side then meets the strict bool boundary at run time —
(or false (box "s")) and (and (box nil) some-bool) both trap, verified on
this tree. Each form used to be safe in exactly one of those directions,
because the sentinel it answered was a bool literal that boxed to fit
whatever the real branch was; neither is now, and they are at least
symmetric about it. Making bool and dyn arms join as dyn is a check_if
question, noted in TODO.org, "A bool arm and a dyn arm joining as dyn",
and not decided here.
The two arms are both real values, so mixing a dyn operand with a typed
bool one makes check_if unify them: a bool arm and a dyn arm meet at dyn
with the bool boxed, whichever side each is on, so (or false (box "s"))
answers "s" and (and (box nil) some-bool) answers nil.
One known wart, measured rather than guessed, and left alone deliberately.
In a want-free position — [(println (and true true (vec-new i32)))] — the
@ -1252,6 +1325,65 @@ and place (f : Form.t) : Ast.place =
(deref p), or a class slot (get inst :slot)"
(Form.to_string f)
(* A read-modify-write of a place, with every subexpression of the place
evaluated once — C's rule for compound assignment. (update (at grid (next)
c) inc) calls [next] once, and the read and the write land on the same
element.
Each index, key and pointer is bound to a temp first, outermost and
leftmost first. The container a field or an index is taken from is not: it
has to stay a path to the storage, since a temp would be a copy of a struct
or an array and the write would land in the copy. Only a path made of
names, fields, indexes and derefs stays one; anything else in container
position — a call answering a Vec, say — is a value, and is bound like an
index. Then [g] is bound to the place's current value, and [value], written
over [g], is stored back through the same path. *)
and modify f target g value : Ast.expr =
let mk e = { Ast.e; loc = f.loc } in
let binds = ref [] in
let temp (e : Ast.expr) =
match e.Ast.e with
| Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ -> e
| _ ->
let t = fresh_temp "place" in
binds := { Ast.bname = t; bty = None; bval = e; bloc = e.Ast.loc } :: !binds;
{ e with Ast.e = Ast.Var t }
in
let rec path (e : Ast.expr) =
match e.Ast.e with
| Ast.Var _ -> e
| Ast.Field (t, n) -> { e with Ast.e = Ast.Field (path t, n) }
| Ast.Call (({ Ast.e = Ast.Var "at"; _ } as h), t :: idx) when idx <> [] ->
let t = path t in
{ e with Ast.e = Ast.Call (h, t :: List.map temp idx) }
| Ast.Call (({ Ast.e = Ast.Var "deref"; _ } as h), [ p ]) ->
{ e with Ast.e = Ast.Call (h, [ temp p ]) }
| _ -> temp e
in
let p =
match place target with
| Ast.Pvar _ as p -> p
| Ast.Pfield (t, n) -> Ast.Pfield (path t, n)
| Ast.Pindex (t, idx) ->
let t = path t in
Ast.Pindex (t, List.map temp idx)
| Ast.Pderef p -> Ast.Pderef (temp p)
| Ast.Pslot (t, k) ->
let t = temp t in
Ast.Pslot (t, temp k)
in
let at e = { Ast.e; loc = target.loc } in
let read =
match p with
| Ast.Pvar n -> at (Ast.Var n)
| Ast.Pfield (t, n) -> at (Ast.Field (t, n))
| Ast.Pindex (t, idx) -> at (Ast.Call (at (Ast.Var "at"), t :: idx))
| Ast.Pderef p -> at (Ast.Call (at (Ast.Var "deref"), [ p ]))
| Ast.Pslot (t, k) -> at (Ast.Call (at (Ast.Var "get"), [ t; k ]))
in
let old = { Ast.bname = g; bty = None; bval = read; bloc = target.loc } in
mk (Ast.Let (List.rev (old :: !binds), [ mk (Ast.Set (p, expr value)) ]))
and arms f (items : Form.t list) : Ast.arm list =
let rec go = function
| [] -> []
@ -1343,7 +1475,13 @@ let rec decl (f : Form.t) : Ast.decl =
| List ({ v = Sym "defalias"; _ } :: args) ->
(match args with
| [ n; t ] -> mk (Ast.Defalias (dname n, texpr t))
(* int and float restate a builtin alias, which the checker takes up;
any other built-in type's name is refused as tname refuses it. *)
| [ n; t ] ->
let name =
match n.v with Sym ("int" | "float") -> dname n | _ -> tname n
in
mk (Ast.Defalias (name, texpr t))
| _ -> fail f "defalias is (defalias Name Type)")
(* A parent comes before the fields, where Common Lisp's define-condition
@ -1353,16 +1491,16 @@ let rec decl (f : Form.t) : Ast.decl =
| List ({ v = Sym "defstruct"; _ } :: args) ->
(match args with
| [ n; { v = Vec fs; _ } ] ->
mk (Ast.Defstruct (dname n, fields f fs, None))
mk (Ast.Defstruct (tname n, fields f fs, None))
| [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] when fs <> [] ->
mk (Ast.Defstruct (dname n, fields f fs, Some (texpr p)))
mk (Ast.Defstruct (tname n, fields f fs, Some (texpr p)))
(* An empty field vector is the same category as none. *)
| [ n; { v = Kw "parent"; _ }; p ] | [ n; { v = Kw "parent"; _ }; p; { v = Vec []; _ } ] ->
let str name =
{ Ast.fname = name; fty = { Ast.t = Ast.Tname "string"; tloc = f.loc };
floc = f.loc }
in
mk (Ast.Defstruct (dname n, [ str "name"; str "message" ], Some (texpr p)))
mk (Ast.Defstruct (tname n, [ str "name"; str "message" ], Some (texpr p)))
| _ ->
fail f
"defstruct is (defstruct Name [field Type ...]), or with a parent \
@ -1370,7 +1508,7 @@ let rec decl (f : Form.t) : Ast.decl =
| List ({ v = Sym "defdata"; _ } :: args) ->
(match args with
| [ n; { v = Vec vs; _ } ] -> mk (Ast.Defdata (dname n, List.map variant vs))
| [ n; { v = Vec vs; _ } ] -> mk (Ast.Defdata (tname n, List.map variant vs))
| _ -> fail f "defdata is (defdata Name [(Case [field Type ...]) ...])")
(* C's union: one storage, as many ways of reading it as there are members.
@ -1413,7 +1551,7 @@ let rec decl (f : Form.t) : Ast.decl =
[member Type ...]). This reads as a tagged sum — write \
(defdata Name [(Case [field Type ...]) ...])")
ms;
mk (Ast.Defunion (dname n, fields f ms))
mk (Ast.Defunion (tname n, fields f ms))
| _ -> fail f "defunion is (defunion Name [member Type ...])")
(* The slot after the parameters is unconditionally the return type. It used
@ -1538,7 +1676,7 @@ let rec decl (f : Form.t) : Ast.decl =
List.iter
(fun (s : Form.t) -> match s.v with Sym _ -> no_sigil s | _ -> ())
slots;
mk (Ast.Defclass (dname n, pitems slots))
mk (Ast.Defclass (tname n, pitems slots))
| _ -> fail f "defclass is (defclass Name [slot Type ...])")
| List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) ->
@ -1631,7 +1769,7 @@ let rec decl (f : Form.t) : Ast.decl =
| List ({ v = Sym "defenum"; _ } :: args) ->
(match args with
| [ n; { v = Form.Vec ms; _ } ] ->
let ename = dname n in
let ename = tname n in
(* An enum member is an [i32] at run time. [Shim] lowers the type to
int32_t for C's benefit and [Check] builds every member as a
[Tast.Int (v, I32)] -- but the reader hands this pass an [int64], so
@ -1781,11 +1919,11 @@ let rec decl (f : Form.t) : Ast.decl =
(match args with
| [ n; t ] ->
let ty, init = defvar3 t in
mk (Ast.Defvar (dname n, Some ty, init, kind))
mk (Ast.Defvar (gname n, Some ty, init, kind))
| [ n; t; { v = Sym "uninit"; _ } ] ->
mk (Ast.Defvar (dname n, Some (texpr t), Ast.Uninit, kind))
mk (Ast.Defvar (gname n, Some (texpr t), Ast.Uninit, kind))
| [ n; t; v ] ->
mk (Ast.Defvar (dname n, Some (texpr t), Ast.Init (expr v), kind))
mk (Ast.Defvar (gname n, Some (texpr t), Ast.Init (expr v), kind))
| _ ->
fail f
"%s is (%s name Type value?) or (%s name value) — a third element \
@ -1824,8 +1962,8 @@ let rec decl (f : Form.t) : Ast.decl =
| List ({ v = Sym "defconst"; _ } :: args) ->
(match args with
| [ n; v ] -> mk (Ast.Defconst (dname n, None, expr v))
| [ n; t; v ] -> mk (Ast.Defconst (dname n, Some (texpr t), expr v))
| [ n; v ] -> mk (Ast.Defconst (gname n, None, expr v))
| [ n; t; v ] -> mk (Ast.Defconst (gname n, Some (texpr t), expr v))
| _ -> fail f "defconst is (defconst name Type? value)")
(* A macro is an ordinary function, and this is where it becomes one:
@ -2002,15 +2140,25 @@ let expansion_macros : Form.t list ref = ref []
written twice, in the file where the two copies could disagree silently. *)
let imported_decls : Ast.decl list ref = ref []
let with_imported ?(decls = []) (ms : Form.t list) (f : unit -> 'a) : 'a =
(* Functions a session already holds, by name. A program's [defn] shadows a
macro of its name, and a session's form is expanded alone, long after the
[defn] that shadows — so the session says which names those are, as it
says which macros it has. *)
let shadowing_fns : string list ref = ref []
let with_imported ?(decls = []) ?(fns = []) (ms : Form.t list)
(f : unit -> 'a) : 'a =
let saved = !imported_macros in
let saved_decls = !imported_decls in
let saved_fns = !shadowing_fns in
imported_macros := ms;
imported_decls := decls;
shadowing_fns := fns;
Fun.protect
~finally:(fun () ->
imported_macros := saved;
imported_decls := saved_decls)
imported_decls := saved_decls;
shadowing_fns := saved_fns)
f
(* Two entry points and not one function with a flag, and the reason is the

80
lib/prelude.ml
View File

@ -197,6 +197,17 @@ let source = {flan|
;; nothing a handler supplies makes the old arguments fit the new body.
(defstruct StaleCall :parent Error [callee string compiled string current string])
;; A call through a (CFn ...) that holds no function. A CFn may be a struct
;; field, a fixed array's element or a global, and each of those starts out
;; zeroed, which for a function value is no address at all. Every call
;; through one tests first and signals this instead of jumping to nothing.
;; `type` is the value's type as written, "(CFn [i32] i32)".
;;
;; Signalled from the runtime — flan_null_call in runtime/flan_rt.c — so
;; **this field is a C struct that has to agree with this one**. No restart is
;; established at the call, BoundsError's decision for BoundsError's reason.
(defstruct NullCall :parent Error [type string])
;; What a generic function signals when no method answers. `generic` is the
;; name written at the defgeneric or defmulti, and `value` is what the
;; dispatch actually produced -- the class of the first argument for a
@ -240,6 +251,18 @@ let source = {flan|
(defn pause [] ()
(restart-case (error (Pause {}))
(continue [] (do))))
;; The stepper's stop, which C-c C-s puts before each form of a defn's body
;; (Ast.instrument_step). It is (pause) with an answer: next goes on stepping
;; and continue runs the rest of the call, and the instrumented body keeps
;; that answer in a local of its own. Like Pause it is not under Error.
;; Named so a program's own step or Step is not what the instrumented body
;; calls.
(defstruct StepPoint [])
(defn step-point [] bool
(restart-case (error (StepPoint {}))
(next [] :report "stop at the next form" true)
(continue [] :report "run the rest of this call" false)))
;; A seeded PRNG in Flan rather than libc's, because a grid hash is only a
;; regression test if the sequence is byte-identical on native and wasm32
@ -2287,16 +2310,12 @@ let source = {flan|
;; because a macro does not have a type at all; the expansion is checked at the
;; call site as if it had been written there.
;;
;; **++ and -- read the place twice, and that is an accepted cost.** The
;; expansion is (set PLACE (+ PLACE 1)), so PLACE is evaluated once to read
;; and once to write. For a variable, a field or a deref that is free and
;; means nothing. For (at arr (next-index)) — an index with a side effect —
;; it means next-index runs twice and the read and the write land on different
;; elements. That is not a bug to be fixed here: macros are non-hygienic by
;; decision (plan.org, open decision 2), a macro cannot bind a temporary for
;; the *place* without a reference type it does not have, and
;; rl/with-drawing and rl/with-mode-2d already take the same trade on their
;; arguments. Write the index out first if it does anything.
;; **++ and -- evaluate the place once.** Each index, key and pointer in the
;; place is bound to a temp before the read, so (++ (at arr (next-index)))
;; calls next-index once and reads and writes the same element — C's rule for
;; compound assignment. They are update with + and -, spelled as the form
;; update~ that update itself expands into (a prelude macro may not call a
;; macro); lib/parse.ml's [modify] is where the place is taken apart.
(defmacro inc [& args]
(if (!= (length args) 1)
`(inc-takes-one-number)
@ -2310,12 +2329,31 @@ let source = {flan|
(defmacro ++ [& args]
(if (!= (length args) 1)
`(++-takes-one-place)
`(set ~(at args 0) (+ ~(at args 0) 1))))
(let [g (gensym)]
`(~(Form.Sym {.s "update~"}) ~(at args 0) ~g (+ ~g 1)))))
(defmacro -- [& args]
(if (!= (length args) 1)
`(---takes-one-place)
`(set ~(at args 0) (- ~(at args 0) 1))))
(let [g (gensym)]
`(~(Form.Sym {.s "update~"}) ~(at args 0) ~g (- ~g 1)))))
;; ── update: change a place by applying a function to it ────────────────
;;
;; (update (.velocity g) inc)
;; (update (at grid r c) + 10)
;;
;; (update place f args ...) stores (f old args ...) back into the place, where
;; old is what the place held. f is written as the head of a call, so it may be
;; a function, an operator or a macro such as inc. Every place set takes is a
;; place here too — a name, a field, an element, a deref, a class slot — and
;; the place is evaluated once, as ++ says above. It answers what set answers.
(defmacro update [& args]
(if (< (length args) 2)
`(update-takes-a-place-and-a-function)
(let [g (gensym)]
`(~(Form.Sym {.s "update~"}) ~(at args 0) ~g
(~(at args 1) ~g ~@(form-rest args 2))))))
;; ── into: a fused transformation, and not a transducer ────────────────
;;
@ -2388,6 +2426,15 @@ let source = {flan|
(form-sym? head "filter") (recur (- k 1) `(when (~f ~x) ~body))
:else `(into-transform-is-map-or-filter ~t))))))))
;; Whether any transform in the chain is a (map f).
(defn into-maps? [ts [Form]] bool
(loop [k 0]
(cond
(= k (length ts)) false
(let [items (form-items (at ts k))]
(and (> (length items) 0) (form-sym? (at items 0) "map"))) true
:else (recur (+ k 1)))))
;; The items of a list form, and the empty slice for anything else — a
;; non-list transform falls into the arity complaint above rather than needing
;; a case of its own.
@ -2440,10 +2487,19 @@ let source = {flan|
named? (form-is-sym? from)
src (if named? from (gensym))
bind (if named? (form-nil) (form-pair src from))
;; With no (map f) in the chain every element pushed is a source
;; element as it stands, which copies only its header: the checker
;; refuses that for an element that owns storage. The destination and
;; the transforms ride along unevaluated, to be written back in the fix.
shares (if (into-maps? (form-rest args 2))
(form-nil)
(form-cons `(into-copies-elements ~src ~(at args 1) ~@(form-rest args 2))
(form-nil)))
dst (gensym)
x (gensym)
i (gensym)]
`(let [~dst ~(at args 1) ~@bind]
~@shares
(dotimes [~i (length ~src)]
(let [~x (at ~src ~i)]
~(into-wrap (form-rest args 2) dst x)))

5
lib/program.ml
View File

@ -98,6 +98,5 @@ let rerun ?(stopped = false) () =
its window, or let it finish, and ask again"
| _ ->
Error
"this session's program is a process of its own, so there is no parked \
thread here to send round again; it is the merged build that can re-run \
a program, not --two-process"
"this process has no program thread of its own, so there is nothing \
here to run again"

8
lib/render.ml
View File

@ -103,6 +103,12 @@ let print_refusal _loc t =
Printf.sprintf "no printer for %s — print the values you want out of it"
(Types.to_string t)
(* The head a struct value prints under: its name, or for a generic struct's
copy the template and its arguments, [Pair i32], so the value reads
[(Pair i32 {.a 1 .b 2})] the way its type is written. Every renderer of a
struct value goes through this, so they all print the same text. *)
let head n = Types.struct_head n
let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list =
let render c depth e = render ~refuse c depth e in
let loc = e.Tast.loc in
@ -333,7 +339,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis
@ render c (depth + 1) v)
shown)
in
[ do_ ((lit ("(" ^ n ^ " {") :: parts)
[ do_ ((lit ("(" ^ head n ^ " {") :: parts)
@ (if List.length fields > max_span then [ lit " ..." ] else [])
@ [ lit "})" ]) ])
(* A fixed array's length is in its type, so it unrolls — capped, because

174
lib/session.ml
View File

@ -65,7 +65,7 @@ type t = {
mutable decls : Ast.decl list; (* post-Load: flat, one namespace *)
mutable program : Tast.program; (* the last thing that checked *)
mutable env : Check.env; (* the same, as the checker sees it *)
host : Tast.program; (* what the process was built from *)
mutable host : Tast.program; (* what the process was built from *)
pkgs : Load.pkg list; (* alias, directory, names owned *)
(* Every [defmacro] this session can expand a call to: the imports', under
their aliases, and the buffer's own, under the names the buffer writes.
@ -597,7 +597,7 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) =
if not same then
fail loc
"%s changes layout. Restart to change it."
s.Tast.sname
(Types.to_string (Types.Named s.Tast.sname))
| None -> ())
new_.Tast.structs
@ -782,19 +782,49 @@ let restore t h =
newest one and no older activation is left running. *)
let rerun t = t.live <- SM.empty
(* The process is about to be built again from what the session holds now
(a --two-process re-run), so that becomes what it was built from. Checked
whole rather than taken from [program], which can hold a caller's old body
beside a callee whose signature changed (see [eval]); a fresh build of that
pair would be wrong, so it raises the checker's error instead. *)
let rehost t =
let p, env =
let was = !Check.print_warnings in
Check.print_warnings := false;
Fun.protect ~finally:(fun () -> Check.print_warnings := was)
(fun () -> Check.program_with_env t.decls)
in
t.program <- p;
t.env <- env;
t.host <- p;
t.built <- record_built env p p.Tast.fns SM.empty;
t.live <- SM.empty
(* The session's own functions whose names a macro also has — see
[Parse.shadowing_fns]. A [defmacro] is a [defn] once parsed, so the
session's macros are taken back out. *)
let shadowing_fns t origin =
let macros = List.filter_map Macro.macro_name (macros_for t origin) in
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defn fn when not (List.mem fn.Ast.name macros) -> Some fn.Ast.name
| _ -> None)
t.decls
(* [forms], when given, are [src] already read — [pruned] runs this over a
file a form fewer each round and has no text for the subset. [base] is the
file an [(import ...)] in them is resolved against, the session's own when
absent: a file loaded from another directory names its packages from
there. *)
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : change =
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = true) t src : change =
let forms =
match forms with Some f -> f | None -> Source.read_code ~file:origin src
in
(* What an annotated listing quotes for this form is what was sent, not what
the file on disk said when it was last read. *)
Loc.remember ~file:origin src;
Parse.with_imported ~decls:(package_decls t) (macros_for t origin) @@ fun () ->
Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () ->
(* Through [Load] like any other source, so an evaluated (import ...) means
what it means in a file. Its expansion is what gets spliced, which is also
why the accumulated list is the post-Load one: re-evaluating a file that
@ -877,6 +907,15 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
fail loc "nothing to pause at line %d, column %d of the form sent"
line col)
in
(* [step]: every defn sent stops before each form of its body — see
[Ast.instrument_step]. After [qualify_decl] for the reason [pause] is. *)
let incoming =
if not step then incoming
else
match Ast.instrument_step incoming with
| Some ds -> ds
| None -> fail loc "there is no defn in the form sent to step through"
in
(* A method declares a name of its own — that is what makes evaluating one
twice a replacement and evaluating a new one an append, through the same
kept/added logic every other declaration goes through. But no function is
@ -968,8 +1007,13 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
&& List.exists stale_site b.sites)
t.built
in
(* Every error in the form sent, not the first: [keep_going] checks past a
refused subexpression (see [Check.check]). One error is still raised as
[Loc.Error], which is what every caller of one form expects. *)
let program, env, tolerated =
Check.program_tolerant ~tolerate:stale_owner decls
match Check.program_tolerant ~keep_going:true ~tolerate:stale_owner decls with
| r -> r
| exception Loc.Errors [ d ] -> raise (Loc.Error d)
in
let program =
if tolerated = [] then program
@ -1499,6 +1543,15 @@ let shown_names (fn : Tast.fn) : string option array =
Array.init n (fun i ->
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None)
in
(* A name the compiler gave a local of its own, such as the stepper's
[flan~step], is hidden like an unnamed slot: [~] cannot be typed. *)
let raw =
Array.map
(function
| Some n when String.starts_with ~prefix:"flan~" n -> None
| x -> x)
raw
in
let stripped = Array.map (Option.map strip_rebind) raw in
let count name =
Array.fold_left
@ -1543,7 +1596,7 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
let loc = fn.Tast.floc in
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -1655,7 +1708,7 @@ let render_condition t ~(st : Tast.structure) : change * (string * string) list
let loc = Loc.unknown in
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -1916,7 +1969,7 @@ let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
| Some name ->
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2233,7 +2286,7 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
in
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums =
@ -2270,11 +2323,15 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
Array.append bnames
(Array.make (List.length !extra) None) }
in
(* A struct copy the values named first, laid out in this
module and kept, as [eval_expr] keeps one. *)
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program =
{ t.program with
Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname
@ [ thunk ];
structs = t.program.Tast.structs @ copies;
externs = t.program.Tast.externs @ externs }
in
let ir =
@ -2287,7 +2344,9 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
[eval_expr] says why, and the caller takes the same [held]
around this that it takes around one. *)
t.program <-
{ t.program with Tast.fns = t.program.Tast.fns @ fresh };
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
where, Types.to_string shown.Tast.ty))))
@ -2359,7 +2418,7 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
in
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2400,17 +2459,22 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
slots = Array.append base (Array.of_list (List.rev !extra));
snames = Array.append bnames (Array.make (List.length !extra) None) }
in
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program =
{ t.program with
Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ];
structs = t.program.Tast.structs @ copies;
externs = t.program.Tast.externs @ externs }
in
let ir =
redefinition t ~call:tname program
~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ])
in
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh };
t.program <-
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
List.map Types.to_string params)
@ -2443,7 +2507,7 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
let loc = Loc.unknown in
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2507,7 +2571,68 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
sticks — a thunk is built and thrown away, so the mark lasts exactly one
evaluation, which is the truthful thing for an expression that has no
declaration to live in. *)
let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
(* [frame] is SLIME's eval-in-frame: a stopped frame's index, the function it
is running and which of its slots were bound when it stopped. The
expression is then checked with that frame's named locals in scope — the
innermost of two of one name winning, as it does in the source — and every
use of one reads or writes the frame's own storage through [flan/dev-slot],
so a [set] changes the frame and a vec is not copied. A local not bound
yet is refused where it is named: its address is null. *)
let in_frame t ~frame:(index, (fn : Tast.fn), bound) (parsed : Ast.expr) =
let n = Array.length fn.Tast.slots in
let nparams = List.length fn.Tast.params in
let named =
List.filter_map
(fun i ->
match if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None with
| Some raw -> Some (i, strip_rebind raw)
| None -> None)
(List.init n Fun.id)
in
(* Unbound first, so that of two slots one name the bound one shadows. *)
let order =
List.filter (fun (i, _) -> not (List.mem i bound)) named
@ List.filter (fun (i, _) -> List.mem i bound) named
in
let scope =
List.map (fun (i, name) -> (name, fn.Tast.slots.(i), i >= nparams)) order
in
let checked, base, bnames, syn = Check.expression_in_scope t.env ~scope parsed in
let table = List.map2 (fun (i, name) (_, j) -> (j, (i, name))) order syn in
let idx loc k =
{ Tast.e = Tast.Int (Int64.of_int k, Types.I64); ty = Types.Int Types.I64; loc }
in
let pointer i loc =
let ty = fn.Tast.slots.(i) in
{ Tast.e =
Tast.Prim
(Tast.Cast (Types.Ptr (Types.Mut, ty)),
[ { Tast.e = Tast.Call ("flan/dev-slot", [ idx loc index; idx loc i ]);
ty = Types.Ptr (Types.Mut, Types.Int Types.U8); loc } ]);
ty = Types.Ptr (Types.Mut, ty); loc }
in
let checked =
Tast.rewrite_locals
(fun j loc ->
match List.assoc_opt j table with
| None -> None
| Some (i, name) when not (List.mem i bound) ->
fail loc
"%s is not bound yet where the program stopped, so there is no \
value to read" name
| Some (i, _) -> Some (pointer i loc))
checked
in
(* The slots the frame's names were bound to are read through the pointer
now, never directly; a byte keeps each from costing its type's size. *)
let base =
Array.mapi (fun j ty -> if List.mem_assoc j table then Types.Int Types.U8 else ty) base
and bnames =
Array.mapi (fun j nm -> if List.mem_assoc j table then None else nm) bnames
in
(checked, base, bnames)
let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
let form =
match Source.read_code ~expr:true ~file:origin src with
| [ f ] -> f
@ -2526,7 +2651,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
a cold macro module costs its ~300ms before that clock starts,
and the non-termination refusals raise [Loc.Error] out of this call, which
the daemon already answers as an error rather than a silence. *)
let parsed = Parse.with_imported ~decls:(package_decls t) (macros_for t origin) (fun () -> Parse.expr form) in
let parsed = Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) (fun () -> Parse.expr form) in
(* CIDER's rule: an expression sent from a package's file means what it
would mean written in that file, so [(integrate 1.0)] in physics/step.flan
reaches [physics/integrate]. The qualification [eval] gives a declaration
@ -2556,7 +2681,11 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
and the host has no cell for. *)
let mark = Check.instance_mark t.env in
let lmark = Check.lifted_mark t.env in
let checked, base, bnames = Check.expression t.env parsed in
let checked, base, bnames =
match frame with
| None -> Check.expression t.env parsed
| Some frame -> in_frame t ~frame parsed
in
let fresh = Check.instances_since t.env mark in
let lifted = Check.lifted_since t.env lmark in
(* The thunk's frame starts at whatever [Check.expression] needed and grows
@ -2564,7 +2693,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
appended past [base] and collected here to size the frame below. *)
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
{ Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2610,10 +2739,12 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
let placed =
List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed
in
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program =
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh @ placed;
structs = t.program.Tast.structs @ Check.env_structs t.env lifted;
structs =
t.program.Tast.structs @ copies @ Check.env_structs t.env lifted;
externs = t.program.Tast.externs @ externs }
in
let ir =
@ -2639,7 +2770,10 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
caller closes that half by taking a [held] before this and restoring it
when either fails — a copy the session holds and no module defines is a
null cell exactly as a stranded declaration is. *)
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh };
t.program <-
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
{ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }
(* ── What a macro call expands to ──────────────────────────────────── *)
@ -2699,7 +2833,7 @@ let macroexpand ?(origin = "<eval>") ~(all : bool) t (src : string) : expansion
let before = Expand.quasiquote form in
(* And the session's macros in front of it, as [eval] and [eval_expr] both
put them: [Macro.program] reads [Parse.imported_macros] directly. *)
Parse.with_imported ~decls:(package_decls t) (macros_for t origin) @@ fun () ->
Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () ->
let after, name =
if all then Macro.expand_all before else Macro.expand_step before
in

119
lib/shim.ml
View File

@ -177,6 +177,106 @@ let prim_cty = function
| "bool" -> Some "bool"
| _ -> None
(* ── Generic structs ──────────────────────────────────────────────────
A defstruct whose fields introduce [$t] is a template, and C only ever sees
one of its copies: the fields with the arguments written in, laid out the
way [Check] lays the same copy out. The copy is registered here under its
written spelling, [(G u8)], which [ctype_name] turns into a C name. *)
let sigil n = n <> "" && n.[0] = '$'
let bare n = if sigil n then String.sub n 1 (String.length n - 1) else n
(* A template's parameters, in the order its fields first introduce them, and
whether each is a length — [Check]'s reading, repeated over the AST
because this runs before [Check] does. *)
let rec template_params ?(fuel = 16) env n =
match Hashtbl.find_opt env.structs n with
| None -> []
| Some fs ->
let acc = ref [] in
let add m is_len =
if sigil m && not (List.mem_assoc (bare m) !acc) then
acc := (bare m, is_len) :: !acc
in
let rec walk (t : Ast.texpr) =
match t.Ast.t with
| Ast.Tname m -> add m false
| Ast.Tslice (_, e) -> walk e
| Ast.Tarray (Ast.Lname m, e) -> add m true; walk e
| Ast.Tarray (_, e) -> walk e
| Ast.Tmap (k, v) -> walk k; walk v
| Ast.Tapp (h, args) ->
let kinds =
if fuel = 0 || String.equal h n then []
else List.map snd (template_params ~fuel:(fuel - 1) env h)
in
if List.length kinds = List.length args then
List.iter2
(fun is_len (a : Ast.texpr) ->
match a.Ast.t with
| Ast.Tname m when is_len -> add m true
| _ -> walk a)
kinds args
else List.iter walk args
| Ast.Tfn (_, ps, r) -> List.iter walk ps; walk r
| Ast.Tlen _ -> ()
in
List.iter (fun (f : Ast.field) -> walk f.Ast.fty) fs;
List.rev !acc
let rec source (t : Ast.texpr) =
match t.Ast.t with
| Ast.Tname n -> n
| Ast.Tlen n -> Int64.to_string n
| Ast.Tapp (n, args) ->
Printf.sprintf "(%s %s)" n (String.concat " " (List.map source args))
| Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (source e)
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (source e)
| Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (source e)
| Ast.Tmap (k, v) -> Printf.sprintf "(Map %s %s)" (source k) (source v)
| Ast.Tfn (env, ps, r) ->
Printf.sprintf "(%s [%s] %s)" (if env then "Fn" else "CFn")
(String.concat " " (List.map source ps)) (source r)
(* The copy of template [n] at [args], registered and named. *)
let copy env ~loc n (args : Ast.texpr list) =
let ps = template_params env n in
if List.length ps <> List.length args then
fail loc "%s takes %d argument%s, and this gives %d" n (List.length ps)
(if List.length ps = 1 then "" else "s") (List.length args);
let key = source { Ast.t = Ast.Tapp (n, args); tloc = loc } in
if not (Hashtbl.mem env.structs key) then begin
let sub = List.combine (List.map fst ps) args in
let rec go (t : Ast.texpr) =
let k =
match t.Ast.t with
| Ast.Tname m when List.mem_assoc (bare m) sub ->
(List.assoc (bare m) sub).Ast.t
| Ast.Tname _ | Ast.Tlen _ -> t.Ast.t
| Ast.Tslice (c, e) -> Ast.Tslice (c, go e)
| Ast.Tarray (Ast.Lname m, e) when List.mem_assoc (bare m) sub ->
let l =
match (List.assoc (bare m) sub).Ast.t with
| Ast.Tlen k -> Ast.Lint k
| Ast.Tname c -> Ast.Lname c
| _ -> fail loc "%s's $%s is a length" n (bare m)
in
Ast.Tarray (l, go e)
| Ast.Tarray (l, e) -> Ast.Tarray (l, go e)
| Ast.Tmap (k, v) -> Ast.Tmap (go k, go v)
| Ast.Tapp (h, a) -> Ast.Tapp (h, List.map go a)
| Ast.Tfn (b, ps, r) -> Ast.Tfn (b, List.map go ps, go r)
in
{ t with Ast.t = k }
in
Hashtbl.replace env.structs key
(List.map (fun (f : Ast.field) -> { f with Ast.fty = go f.Ast.fty })
(Hashtbl.find env.structs n))
end;
key
let is_template env n = template_params env n <> []
(* [needed] collects the structs whose typedefs this signature pulls in, in the
order they were first met. Order is the program's and never a hash fold's:
the object cache keys on the generated text, so a reordering would be a
@ -184,6 +284,14 @@ let prim_cty = function
let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
let t = unalias env t in
match t.Ast.t with
| Ast.Tname n when Hashtbl.mem env.structs n && is_template env n ->
fail loc "%s is %s, a generic struct, which is a type only at its \
arguments — write them, as in (%s %s)" what n n
(String.concat " "
(List.map (fun (_, l) -> if l then "8" else "i32")
(template_params env n)))
| Ast.Tapp (n, args) when Hashtbl.mem env.structs n && is_template env n ->
cty env ~needed ~loc ~what { t with Ast.t = Ast.Tname (copy env ~loc n args) }
| Ast.Tname n ->
(match prim_cty n with
| Some c -> c
@ -256,6 +364,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
fail loc "%s is a function type, and a C callback is not implemented" what
| Ast.Tapp (n, _) ->
fail loc "%s is %s, which is not a type this shim generator knows" what n
| Ast.Tlen n -> fail loc "%s is %Ld, which is not a type" what n
(* ── What one parameter does at the boundary ────────────────────────── *)
@ -268,6 +377,14 @@ let classify env ~needed ~loc ~what (t : Ast.texpr) =
let t' = unalias env t in
match t'.Ast.t with
| Ast.Tname "string" -> (Pstr, "const char *")
(* A copy crosses behind a pointer only: by value, the Flan half this
generator writes would have to spell the copy's type, and it builds its
wrapper from struct names. *)
| Ast.Tapp (n, _) when Hashtbl.mem env.structs n && is_template env n ->
fail loc
"%s is %s, a generic struct's copy, which crosses to C behind a pointer \
only — declare (Ptr %s) and let the C side read it"
what (source t') (source t')
| Ast.Tname n when Hashtbl.mem env.structs n ->
ignore (cty env ~needed ~loc ~what t');
(Pstruct n, ctype_name n)
@ -545,6 +662,8 @@ let typedefs env needed =
(fun (f : Ast.field) ->
match (unalias env f.Ast.fty).Ast.t with
| Ast.Tname m when Hashtbl.mem env.structs m -> define m
| Ast.Tapp (m, args) when Hashtbl.mem env.structs m && is_template env m ->
define (copy env ~loc:f.Ast.floc m args)
| _ -> ())
fs;
Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n;

59
lib/tast.ml
View File

@ -506,6 +506,65 @@ and walk_place f (p : place) =
| Pfield (t, _) | Pderef t -> walk f t
| Pindex (t, idx) -> walk f t; List.iter (walk f) idx
(* [e] with every read, store and address of a local slot [f] answers for
replaced: a read of slot [i] by [Deref p], its place by [Pderef p], where
[f i loc] is [Some p], a pointer to where the value really lives. The one
caller is evaluating in a stopped frame, whose locals are the other frame's
slots reached by address. Slots [f] answers [None] for are left alone, and
so is every binder: only the slots [f] names are replaced, and none of them
is bound inside [e]. *)
let rec rewrite_locals (f : int -> Loc.t -> expr option) (e : expr) : expr =
let go = rewrite_locals f in
let gos = List.map go in
let kind =
match e.e with
| Local i ->
(match f i e.loc with Some p -> Deref p | None -> e.e)
| Int _ | Float _ | Bool _ | Str _ | Unit | Zero _ | Uninit _ | Global _
| None_ | FnAddr _ | Break _ | Continue _ -> e.e
| Fill (t, b) -> Fill (t, go b)
| DeadBeef (t, b) -> DeadBeef (t, go b)
| Prim (p, es) -> Prim (p, gos es)
| Call (n, es) -> Call (n, gos es)
| Do es -> Do (gos es)
| Make (n, es) -> Make (n, gos es)
| MakeCase (d, c, es) -> MakeCase (d, c, gos es)
| Arr es -> Arr (gos es)
| InvokeRestart (a, b, es, c, d, l) -> InvokeRestart (a, b, gos es, c, d, l)
| CallPtr (c, es) -> CallPtr (go c, gos es)
| Let (bs, body) -> Let (List.map (fun (s, v) -> (s, go v)) bs, gos body)
| If (a, b, c) -> If (go a, go b, go c)
| While (c, body, latch) -> While (go c, gos body, gos latch)
| Return v -> Return (Option.map go v)
| Set (p, v) -> Set (rewrite_place f e.loc p, go v)
| Addr p -> Addr (rewrite_place f e.loc p)
| Field (t, i) -> Field (go t, i)
| Deref t -> Deref (go t)
| CaseField (t, c, i) -> CaseField (go t, c, i)
| Some_ t -> Some_ (go t)
| UnwrapSome t -> UnwrapSome (go t)
| Signal (k, d, t) -> Signal (k, d, go t)
| Closure (r, t) -> Closure (r, go t)
| Thicken (n, t) -> Thicken (n, go t)
| Match (sc, arms) ->
Match (go sc, List.map (fun a -> { a with abody = gos a.abody }) arms)
| Handled (hs, body) ->
Handled
(List.map (fun h -> { h with henv = Option.map go h.henv }) hs, gos body)
| RestartCase (cs, body) ->
RestartCase (List.map (fun c -> { c with rbody = gos c.rbody }) cs, go body)
| WithAlloc (a, body) -> WithAlloc (go a, gos body)
in
{ e with e = kind }
and rewrite_place f loc (p : place) : place =
match p with
| Plocal i -> (match f i loc with Some ptr -> Pderef ptr | None -> p)
| Pglobal _ -> p
| Pfield (t, i) -> Pfield (rewrite_locals f t, i)
| Pderef t -> Pderef (rewrite_locals f t)
| Pindex (t, idx) -> Pindex (rewrite_locals f t, List.map (rewrite_locals f) idx)
(* ── What the object image can hold ─────────────────────────────────── *)
(* Whether an initialiser is a value a linker can write into the program's

37
lib/types.ml
View File

@ -106,6 +106,15 @@ type t =
| Fn of t list * t (* (Fn [T ...] R) *)
| CFn of t list * t (* (CFn [T ...] R) *)
| Var of string (* a type variable — milestone 5 *)
(* The two halves of a length parameter, and neither is the type of a value.
[Len] is a length standing where a generic struct's argument goes — the 8
in (Small 8 i32) — and what a length variable is bound to. [LArray] is a
fixed array whose length is a variable, [[$n $t]], and exists only in a
generic signature, as the pattern a call site binds [n] from. A generic
body is checked with its lengths at [Check.abstract_len], so neither ever
reaches a backend. *)
| Len of int64
| LArray of string * t
(* [dyn]: one machine word whose contents the runtime knows and this module
does not. It is a written type — [(defonce x dyn 5)] boxes the 5 — and it
is also what an unannotated [defn] parameter means, which is why it is a
@ -206,8 +215,29 @@ let rec equal a b =
&& List.for_all2 equal ps ps'
&& equal r r'
| Var x, Var y -> String.equal x y
| Len x, Len y -> Int64.equal x y
| LArray (n, x), LArray (m, y) -> String.equal n m && equal x y
| _ -> false
(* How a generic struct's copy is spelled to a reader. The copy is an
ordinary struct under a symbol-safe key — [Small-8-i32] — and this is the
key's written form, [(Small 8 i32)], filled in as each copy is made. Global
rather than on a checker's env because every message that prints a type
comes through here with no env in hand. The key determines the spelling,
so an entry left from an earlier program in the same process is wrong only
for a struct that program's successor declares under a copy's key by hand,
and then only in how a message spells it. *)
let display : (string, string) Hashtbl.t = Hashtbl.create 16
(* A struct's name as a printed value's head: its own name, or for a generic
struct's copy the template and its arguments, [Pair i32] — so a value
prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *)
let struct_head n =
match Hashtbl.find_opt display n with
| Some d when String.length d >= 2 && d.[0] = '(' ->
String.sub d 1 (String.length d - 2)
| _ -> n
let rec to_string = function
| Int k -> ikind_name k
| Float k -> fkind_name k
@ -215,7 +245,8 @@ let rec to_string = function
| String -> "string"
| Unit -> "()"
| Never -> "Never"
| Named n | Enum n -> n
| Named n -> (match Hashtbl.find_opt display n with Some d -> d | None -> n)
| Enum n -> n
| Slice (Mut, t) -> "[" ^ to_string t ^ "]"
| Slice (Const, t) -> "[const " ^ to_string t ^ "]"
| Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t)
@ -231,7 +262,9 @@ let rec to_string = function
| CFn (ps, r) ->
Printf.sprintf "(CFn [%s] %s)"
(String.concat " " (List.map to_string ps)) (to_string r)
| Var n -> n
| Var n -> "$" ^ n
| Len n -> Int64.to_string n
| LArray (n, t) -> Printf.sprintf "[$%s %s]" n (to_string t)
| Dyn -> "dyn"
let is_numeric = function Int _ | Float _ -> true | _ -> false

57
lib/x86.ml
View File

@ -491,7 +491,8 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m =
globals; externs = Hashtbl.create 1; checks;
dev; gcfn = dev || Emit.makes_closures p;
known = (fun _ -> true); dbg = None; sanitize = false; ann = false;
nstr = 0; nfi = 0; descs = Hashtbl.create 8; fsigs = Emit.fsigs_of p }
nstr = 0; pool = false; nfi = 0; descs = Hashtbl.create 8;
fsigs = Emit.fsigs_of p }
let sizeof md t = fst (Emit.lay md t)
@ -532,6 +533,7 @@ let is_agg (t : Types.t) =
the arithmetic. *)
| Types.Dyn -> false
| Types.Var v -> unsupported "type variable %s" v
| Types.Len _ | Types.LArray _ -> unsupported "length variable"
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false
@ -1812,6 +1814,16 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
let l = float_const f x ~f64 in
fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64;
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
| Tast.Str s when f.md.Emit.pool ->
(* [Emit]'s [pool]: an expression thunk's literal is a copy the process
keeps, so nothing is left pointing into the module. *)
let l, n = fi_bytes f s in
lea f.b ~dst:rdi ~mm:(Sym (l, 0));
imm_into f ~reg:rsi (Int64.of_int n);
call_sym f.b "flan_dev_literal";
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
imm_into f ~reg:rax (Int64.of_int n);
store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
| Tast.Str s ->
(* A string and a [u8] slice are the same two words, which is why [Bytes]
below is a non-instruction. *)
@ -1916,6 +1928,9 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
| Types.Fn _ -> Some (Aint (shift c 8, Types.Ptr (Types.Mut, Types.Unit)))
| _ -> None
in
(match callee.Tast.ty with
| Types.CFn _ -> null_check f e.Tast.loc callee.Tast.ty c
| _ -> ());
call_flan f ?env ~at:e.Tast.loc ~target:(`Loc c) ~args ~rty:t dst
| Tast.Do body -> block f body dst t
| Tast.Let (bs, body) ->
@ -2702,6 +2717,26 @@ and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc =
That is also the answer to "does a bounds trap run defers": an answered one
does, because it leaves through the innermost pad; an unanswered one still
does not, because it is a die inside C. Identical on both backends. *)
(* [Emit.null_check]: a (CFn ...) holding null is not called. Tested before
the arguments, as the LLVM backend does, and [flan_null_call] returns only
when something transferred. *)
and null_check f (loc : Loc.t) ty (c : loc) =
load_loc f ~reg:rax c ty;
test_rr f.b ~a:rax ~c:rax;
let ok = new_label f "fnok" in
jcc_lbl f.b ~cc:cc_ne ok;
note f "A null (CFn ...): the site, the type as a C string and the channel.";
str_args f ~preg:rdi ~nreg:rsi (Loc.to_string loc);
let tys, _ = fi_bytes f (Types.to_string ty ^ "\000") in
lea f.b ~dst:rdx ~mm:(Sym (tys, 0));
chan_into f ~reg:rcx;
mark_at f loc;
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_null_call";
guard f;
ud2 f.b;
lbl f.b ok
and bounds_call f sym (loc : Loc.t) (extra : int list) =
note f (Printf.sprintf
"Out of bounds: the location string, the operands, and this frame's channel, \
@ -5316,6 +5351,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
p.Tast.globals
in
let md = layout_ctx ~checks ~dev p in
md.Emit.pool <- call <> None && retains;
let externs = Hashtbl.create 16 in
List.iter
(fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym)
@ -5420,7 +5456,10 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
the same and [test_reload.ml] checks it there by grepping the IR text;
there is no text to grep on this side, so the guarantee is this loop
order and this comment. *)
let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
(* Not counted in [nstr]: flan_dev.c's registry copies a name it keeps, so
nothing is left pointing at these once the lookup returns. Counted, every
module after the session's first new name would keep its mapping. *)
let cstr sym = let l = fi_cstring f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in
List.iter
(fun (fn : Tast.fn) ->
cstr (Mangle.sym fn.Tast.name);
@ -5599,16 +5638,14 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
store one anywhere it likes -- [(set msg "tuned")] on a string global
leaves that global pointing into the mapping the agent is about to drop.
The next thunk can be mapped at the same address, so the result is silent
garbage rather than a fault. A module with no string constants has nothing
in its image anyone could still be pointing at; one with any keeps its
mapping, which costs a page and is the same bargain every redefinition
already makes. [string_const] is where the count is kept, and the install
function's own registry names go through it too -- which is right rather
than incidental, since a module that interned a name left something
behind. *)
garbage rather than a fault. So a thunk's literal is a copy the process
keeps ([Emit]'s [pool]) and is not counted; what [string_const] still
counts is a constant something may go on pointing at, such as a
condition's name, and a module with one keeps its mapping. The install
function's registry names are not counted: the registry copies them. *)
(match call with
| Some fn
when fns = [ fn ] && consts = []
when fns = [ fn ] && consts = [] && not (Emit.thunk_makes_fn_values p fn)
&& ((not retains) || md.Emit.nstr = 0) ->
Buffer.add_string out
"\n\t.data\n\t.globl\tflan_reload_transient\n\

11
plan.org
View File

@ -248,11 +248,12 @@ and on a managed ~class~ instance. An ordinary ~struct~ never carries one.
already refused so nothing else it could be. ~sort~ declares ~ordered?~ of its
variable, the abstract pass then allows ~<~ in the body, and each instantiation
checks the concrete type satisfies the predicate and refuses the call site if it
does not. There are *five* predicates — ~ordered?~, ~equal?~, ~hashable?~,
~numeric?~, ~integer?~ — against Odin's forty-one, and they entail one another
in one direction, so one clause usually does: ~integer?~ gives ~numeric?~,
~numeric?~ gives ~ordered?~, and ~ordered?~ gives ~equal?~. ~integer?~ exists
because ~numeric?~ admits floats.
does not. There are *six* predicates — ~ordered?~, ~equal?~, ~hashable?~,
~numeric?~, ~integer?~, ~enum?~ — against Odin's forty-one, and they entail one
another in one direction, so one clause usually does: ~integer?~ gives
~numeric?~, ~numeric?~ gives ~ordered?~, and ~ordered?~ gives ~equal?~.
~integer?~ exists because ~numeric?~ admits floats. ~enum?~ gives ~ordered?~
and a conversion to a number, and not arithmetic.
~hashable?~ is what lets a variable *key a map*: without it the type
~(Map $t i32)~ is refused where it is written, and with it the refusal moves to
the call site that names an unhashable key.

110
runtime/flan_dev.c
View File

@ -436,6 +436,56 @@ void flan_dev_result_end(void) {
* when it was sizing something to send through a socket. */
uint64_t flan_dev_result_cap(void) { return RESULT_MAX; }
/* ── An expression thunk's string literals ──────────────────────────── */
/* A literal in an evaluated expression is a copy made here and kept for the
* life of the process, one per distinct text, NUL after the bytes as the
* module's own constants have. The expression may store it anywhere, so
* pointing it into the thunk's module would keep that module mapped for ever
* (Emit's [pool]); pointing it here lets the agent unload the module once the
* thunk returns. Game thread only: thunks run there. */
typedef struct lit { struct lit *next; int64_t len; uint8_t bytes[]; } lit;
static lit **lits;
static size_t lits_cap, lits_n;
static uint64_t lit_hash(const uint8_t *p, int64_t n) {
uint64_t h = 1469598103934665603ULL; /* FNV-1a */
for (int64_t i = 0; i < n; i++) { h ^= p[i]; h *= 1099511628211ULL; }
return h;
}
const uint8_t *flan_dev_literal(const uint8_t *p, int64_t n) {
if (n < 0) n = 0;
if (lits_n >= lits_cap / 2) {
size_t cap = lits_cap ? lits_cap * 2 : 64;
lit **t = calloc(cap, sizeof *t);
if (t == NULL) die("out of memory", "a string literal");
for (size_t i = 0; i < lits_cap; i++)
for (lit *e = lits[i], *nx; e != NULL; e = nx) {
nx = e->next;
size_t b = lit_hash(e->bytes, e->len) & (cap - 1);
e->next = t[b];
t[b] = e;
}
free(lits);
lits = t;
lits_cap = cap;
}
size_t b = lit_hash(p, n) & (lits_cap - 1);
for (lit *e = lits[b]; e != NULL; e = e->next)
if (e->len == n && memcmp(e->bytes, p, (size_t)n) == 0) return e->bytes;
lit *e = malloc(sizeof *e + (size_t)n + 1);
if (e == NULL) die("out of memory", "a string literal");
e->len = n;
if (n > 0) memcpy(e->bytes, p, (size_t)n);
e->bytes[n] = 0;
e->next = lits[b];
lits[b] = e;
lits_n++;
return e->bytes;
}
/* Called between the copy and the second read of the counter, when set. It
* exists for test/dev_limits.c and nothing else sets it: the losing side of
* the race is a write landing inside that window, and a second thread cannot
@ -1213,6 +1263,14 @@ typedef struct {
int64_t seq; /* when it was made */
int64_t died; /* when it was released, or 0 while it is live */
uint64_t gen; /* this slot's own seqlock; odd while it is written */
/* The allocator the block came from, where the note knew it — a Vec's, or
* the temp arena's — and NULL where it did not. (free s) on a slice asks
* it, so a block is never handed to an allocator it did not come from. */
const void *owner;
/* Set for a block handed out as a slice — (bytes s), (clone xs), a
* formatted number — and clear for a Vec's or a Map's storage, which only
* their own free releases. */
int32_t sliced;
} flan_reg_entry;
/* ── Why this table has a seqlock and the watch table's is the model ───
@ -1505,6 +1563,8 @@ static void flan_reg_compact(void) {
e->type = old[i].type; e->typelen = old[i].typelen;
e->base = old[i].base; e->bytes = old[i].bytes;
e->elem = old[i].elem; e->seq = old[i].seq; e->died = old[i].died;
e->owner = old[i].owner;
e->sliced = old[i].sliced;
flan_reg_end(e);
flan_reg_used++;
break;
@ -1518,8 +1578,31 @@ static void flan_reg_compact(void) {
/* One note per allocation. [base] replaces whatever was recorded there, live
* or dead: the allocator handing out an address is the event that makes any
* older answer about it wrong. */
static void flan_reg_note_full(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen,
const void *owner, int32_t sliced);
void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen) {
flan_reg_note_full(base, bytes, elem, type, typelen, NULL, 0);
}
void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen,
const void *owner) {
flan_reg_note_full(base, bytes, elem, type, typelen, owner, 0);
}
/* A block handed out as a slice, which (free s) may release. */
void flan_dev_reg_note_sliced(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen,
const void *owner) {
flan_reg_note_full(base, bytes, elem, type, typelen, owner, 1);
}
static void flan_reg_note_full(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen,
const void *owner, int32_t sliced) {
uintptr_t a = (uintptr_t)base;
size_t s;
int64_t probe;
@ -1549,6 +1632,8 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem,
flan_reg[j].elem = elem;
flan_reg[j].seq = ++flan_reg_seq;
flan_reg[j].died = 0;
flan_reg[j].owner = owner;
flan_reg[j].sliced = sliced;
flan_reg_end(&flan_reg[j]);
return;
}
@ -1575,6 +1660,31 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem,
int flan_dev_reg_overflowed(void) { return flan_reg_full; }
/* (free s) on a slice, asked before the block is handed back: 0 when it may
* go to [owner] — or when the registry cannot say, because this is not a dev
* build, the table is full, or the note did not know the allocator — 1 when
* [p] is not the start of a block any allocator handed out, 2 when the block
* came from another allocator (whose record goes to [*found]), 3 when it was
* already released, 4 when it is a Vec's or a Map's storage rather than a
* block handed out as a slice. */
static flan_reg_entry *flan_reg_find(uintptr_t a);
int32_t flan_dev_reg_owner_check(const void *p, const void *owner,
const void **found) {
flan_reg_entry *e;
if (!flan_reg_on) return 0;
e = flan_reg_find((uintptr_t)p);
if (e == NULL) return flan_reg_full ? 0 : 1;
if (e->base != (uintptr_t)p) return 1;
if (e->died != 0) return 3;
if (!e->sliced) return 4;
if (e->owner != NULL && e->owner != owner) {
if (found) *found = e->owner;
return 2;
}
return 0;
}
/* The block containing [a], live or dead, or NULL. A linear scan, because the
* reader is a person pressing a key and the writer is a game loop: the cost
* belongs on this side of the table. */

110
runtime/flan_rt.c
View File

@ -1538,6 +1538,51 @@ void flan_stale_call(const char *site, const char *callee, const char *want,
rt_die();
}
/* ── A call through a null (CFn ...) ───────────────────────────────────
*
* A (CFn ...) may sit in a struct field, a fixed array or a global, all of
* which zero-initialise, and a zeroed one is a null address. Every call
* through a CFn value tests it first and lands here on null, so the call is
* not made. It signals NullCall with `error` — BoundsError's shape and its
* decision about restarts: no value a handler supplies turns into a function
* to call, so what answers it is a restart the program already has, or the
* break loop in a dev build.
*
* `type` is copied and never freed, for flan_stale_call's reason: the text
* lives in the image of the module that compiled the call, which may be a
* thunk that is unloaded once it returns. Must agree with the prelude's
* (defstruct NullCall :parent Error [type string]). */
typedef struct { flan_slice type; } flan_nullcall_cond;
static const uint8_t flan_nullcall_name[] = "NullCall";
#define FLAN_NULLCALL_NAMELEN 8
static void nullcall_sentence(const char *ty) {
rt_sentence("this call is through a %s that holds no function — a field, "
"an array element or a global of that type starts out empty. "
"Store a function in it before calling it, or hold it as an "
"(Option %s) and match on it",
ty, ty);
}
void flan_null_call(const uint8_t *loc, int64_t loclen, const char *ty,
void *xfer) {
flan_nullcall_cond c;
flan_condesc d;
uint32_t chain[2];
c.type = flan_stale_copy(ty);
nullcall_sentence(ty);
rt_condesc(&d, chain, flan_nullcall_name, FLAN_NULLCALL_NAMELEN, loc,
loclen);
flan_signal(&d, &c, xfer);
if (*(void **)xfer != NULL) return;
nullcall_sentence(ty); /* in full; see flan_bounds_signal */
if (rt_error_break(&d, &c, xfer)) return;
rt_print_sentence(loc, loclen);
rt_die();
}
/* ── Allocators, spec-memory.md ────────────────────────────────────────
*
* One type-erased procedure plus an opaque data pointer, which is Odin's
@ -1677,6 +1722,14 @@ static int flan_over_budget(flan_allocator *a, int64_t size) {
*/
void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen);
void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen,
const void *owner);
int32_t flan_dev_reg_owner_check(const void *p, const void *owner,
const void **found);
void flan_dev_reg_note_sliced(void *base, int64_t bytes, int64_t elem,
const char *type, int64_t typelen,
const void *owner);
void flan_dev_reg_dead(void *base);
void flan_dev_reg_dead_range(void *base, int64_t bytes);
/* flan_dev.c: a dev build fills a block a resize moved away from, so that a
@ -2481,7 +2534,7 @@ static int8_t flan_temp_text(flan_render render, const void *x,
if (!q) return 0;
memcpy(q, buf, (size_t)len);
}
flan_dev_reg_note(q, len, 1, "u8", 2);
flan_dev_reg_note_sliced(q, len, 1, "u8", 2, a);
out->ptr = q;
out->len = len;
return 1;
@ -2733,6 +2786,50 @@ int8_t flan_bytes_dup(flan_vec *v, flan_allocator *a, const uint8_t *p,
return 1;
}
/* (free s) on a slice (bytes s) or (clone xs) made: the block goes back to
* [a], the allocator the compiler passes — the context's, or the one named.
* The slice carries no allocator, so a dev build checks the registry first and
* traps on a slice that is not the start of a live block, or on a block from
* another allocator; a release build trusts the program, as Odin's delete
* does. An allocator that cannot free one block keeps it, as flan_vec_free
* does: free-all is how its region is released. */
_Noreturn static void flan_slice_free_fail(const uint8_t *loc, int64_t loclen,
int32_t why) {
rt_flush_out();
fprintf(stderr, "%.*s: %s\n", (int)loclen, (const char *)loc,
why == 5 ? "this slice is text in the temp allocator, which is "
"released all at once by (free-temp), not one slice at a "
"time"
: why == 2 ? "this slice's block came from another allocator — free "
"it through the allocator it was made with, (free s a)"
: why == 3 ? "this slice's block was already freed"
: why == 4 ? "this slice views a Vec's or a Map's storage, which "
"only freeing the Vec or the Map releases"
: "this slice is not a block an allocator handed out — "
"only a slice (bytes s) or (clone xs) made can be freed");
rt_trap((const uint8_t *)"BadFree", 7);
}
void flan_slice_free(const void *p, int64_t n, int64_t size, int64_t align,
flan_allocator *a, const uint8_t *loc, int64_t loclen) {
int32_t why;
int64_t bytes;
if (p == NULL || n <= 0) return;
if (!a) flan_null_alloc_fail(loc, loclen);
{
const void *found = NULL;
why = flan_dev_reg_owner_check(p, a, &found);
if (why == 2 && found != NULL
&& ((flan_allocator *)found)->proc == flan_arena_proc
&& ((flan_arena *)((flan_allocator *)found)->data)->grow)
why = 5;
if (why != 0) flan_slice_free_fail(loc, loclen, why);
}
if (!(a->caps & FLAN_CAN_FREE)) return;
if (!flan_mul_bytes(n, size, &bytes)) return;
a->proc(a, FLAN_ALLOC_FREE, (void *)p, bytes, 0, align);
}
int8_t flan_vec_clone(flan_vec *dst, flan_vec *src, flan_allocator *a,
int64_t size, int64_t align, const uint8_t *loc,
int64_t loclen) {
@ -3660,9 +3757,18 @@ int8_t flan_map_clone(flan_map *dst, flan_map *src, flan_allocator *a,
* A container with no storage yet notes nothing: flan_dev_reg_note ignores a
* null base, so an empty Vec needs no branch on this side. */
/* The note for a (bytes s) or (clone xs) block: the hidden Vec that made it,
* marked as a block handed out as a slice. */
void flan_dev_reg_note_slice(flan_vec *v, int64_t size, const char *type,
int64_t typelen) {
if (v) flan_dev_reg_note_sliced(v->ptr, v->cap * size, size, type, typelen,
v->alloc);
}
void flan_dev_reg_note_vec(flan_vec *v, int64_t size, const char *type,
int64_t typelen) {
if (v) flan_dev_reg_note(v->ptr, v->cap * size, size, type, typelen);
if (v) flan_dev_reg_note_owned(v->ptr, v->cap * size, size, type, typelen,
v->alloc);
}
void flan_dev_reg_note_map(flan_map *m, int64_t ksize, int64_t vsize,

12
spec-memory.md
View File

@ -268,12 +268,14 @@ instantiates it:
> field-free storage. It does **not** support `=`, `<`, `+`, or `hash`.
What makes that liveable is a `where` clause of compile-time type predicates,
written as a map at the head of the body. There are five — `ordered?`,
`equal?`, `hashable?`, `numeric?`, `integer?` — they are not type classes
written as a map at the head of the body. There are six — `ordered?`,
`equal?`, `hashable?`, `numeric?`, `integer?`, `enum?` — they are not type classes
because a predicate carries no implementations and merely gates a builtin the
compiler already has, and they entail one another in one direction, so one
clause usually does: `integer?` admits every integer kind and no float, and
entails `numeric?`, which entails `ordered?`, which entails `equal?`.
`enum?` admits exactly the enums and entails `ordered?` and `equal?`, not
`numeric?`.
`integer?` is what admits the bitwise operators, the shifts and an
integer-only body like `abs`'s — under `numeric?` those bodies would be
instantiated at the floats too (TODO.org, "abs is one generic, and a bound joins
@ -354,14 +356,14 @@ where the type is written, so neither is refused at the variable. A conversion
was never a claim that the value survives. The conversion *to* an enum needs
`integer?` exactly, because an enum is an `i32` and a float has no enum
reading, and `numeric?` would admit an `f32` copy the concrete rule refuses.
The conversion *from* an enum to a number needs `enum?` or `numeric?`, and
its refusal names both.
`ordered?`, `equal?` and `hashable?` admit no conversion at all: they say what
can be compared or keyed, not what is a number — and that is a claim about
what the predicate says, not about the set it denotes today, which currently
does admit only numbers and enums. The refusal names the predicate to write
(TODO.org, "A conversion is legal at a bounded variable when it is legal at every
type the bound admits"). One consequence is recorded as open: no predicate now
licenses a generic enum → integer conversion (TODO.org, "There is now no generic
enum to integer conversion").
type the bound admits").
**A type variable is not instantiated at `dyn`.** Two models answer "one body,
many types" and they are not rivals: this one copies per written type at

5
spec-syntax.md
View File

@ -155,8 +155,9 @@ Each item: the proposal, then the reason in one line.
`a < b <= c`, is refused. An operator glued to `(` is always a call.
- **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v`
reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads
`(set x (+ x v))`; like `++` today, the place is evaluated twice. **Built**
(also `-=`, `*=`, `/=`).
`(set x (+ x v))` where every part of the place is a name or a literal, and
`(update x + v)` otherwise, so the place is evaluated once either way, as
with `++`. **Built** (also `-=`, `*=`, `/=`).
- **A run of the same operator flattens** (variadics, section 3):
`a + b + c` reads `(+ a b c)`, `a < b < c` reads `(< a b c)` (Flan's chain
semantics, `test/programs/chain.flan`). This keeps the converter round trip

4
test/dune
View File

@ -140,7 +140,9 @@
; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one
; translation unit here that frees the most, which is what makes it worth a
; sanitized run at all. See [dyn_sweep].
(file dyn_ops.c))
(file dyn_ops.c)
; [dev_session] drives a real flan dev --sanitize.
(file %{workspace_root}/bin/main.exe))
(action (run ./test_sanitize.exe)))
; The corpus a third time, under Valgrind's memcheck. Its own alias for the

14
test/programs/bytes-copy.flan
View File

@ -14,13 +14,17 @@
b (bytes s)]
(set (at b 0) \Z)
(println (string b)) ; ZNSERTIONSORT
(println s)) ; INSERTIONSORT
(println s) ; INSERTIONSORT
;; The copy's block came from the context allocator, and free hands it
;; back there — which is what keeps this program leak-free.
(free b))
;; 2. A literal's copy is writable — the exact form that used to segfault
;; at -O0 and silently do nothing at -O2.
(let [b (bytes "hi")]
(set (at b 0) \H)
(println (string b))) ; Hi
(println (string b)) ; Hi
(free b))
;; 3. The view still costs nothing and reads the string's own storage.
(let [v (bytes-view "abc")]
@ -35,4 +39,10 @@
(println (string b))) ; arenA
(free-all frame)
(arena-destroy frame)
;; 5. (clone xs) with no allocator is the context's too, and free releases
;; it the same way.
(let [c (clone (slice [1 2 3]))]
(println (at c 2)) ; 3
(free c))
0)

26
test/programs/dev-break-nullcall.flan Normal file
View File

@ -0,0 +1,26 @@
;;;; A program that stops on a call through a null CFn, for driving the break
;;;; loop over one. Nothing handles NullCall here, so the signal reaches the
;;;; break hook and the program parks, as a bad index does in
;;;; dev-break-bounds.flan; the program's own continue is the way on.
(import agent "vendor:agent")
(defonce table [2 (CFn [i32] i32)])
(defonce skipped i64)
(defonce ticks i64)
(defn call-slot [i i32] i32 ((at table i) 5))
(defn frame [i i32] ()
(restart-case
(do (println (call-slot i)) (println "frame done"))
(continue [] (set skipped (+ skipped 1)))))
(defn main [] i32
(agent/start "/tmp/flan-dev-break-nullcall-fallback.sock")
;; Slot 1 was never set, so it is null.
(frame 1)
(print skipped) (println "")
(dotimes [i 4000]
(agent/wait 5)
(set ticks (+ ticks 1)))
0)

7
test/programs/dev-inspect.flan
View File

@ -11,8 +11,10 @@
;;;; The other locals are the shapes a path step has to walk and that an
;;;; expression cannot reach at all: an option's payload, which has no
;;;; accessor form in the language, and a union case's field, whose offset
;;;; depends on which case the value is in.
;;;; depends on which case the value is in. And a local of a package's type,
;;;; which is named as the checker names it everywhere else: qualified.
(import agent "vendor:agent")
(import shape "pkgs/shape")
(defstruct Point [x f32 y f32])
(defstruct Boom [why i32])
@ -38,7 +40,8 @@
(let [mark (Point {.x 1.5 .y 2.5})
xs [10 20 30]
box (Some (Point {.x 4.5 .y 5.5}))
s (Shape.Rect {.w 3 .h 6})]
s (Shape.Rect {.w 3 .h 6})
pk (shape/box 3 4)]
(deeper)))
(defonce ticks i64)

22
test/programs/dev-own-break.flan Normal file
View File

@ -0,0 +1,22 @@
;;;; A program that stops on its own while an evaluation is in flight.
;;;;
;;;; Setting [go] from the editor starts it: the loop sees it, sleeps without
;;;; polling for longer than a module takes to build, and then signals. An
;;;; expression evaluated just after [go] is therefore waiting in the ring
;;;; when the program's own break is entered, and runs inside that break's
;;;; loop. The stop is the program's and the value is the expression's.
(import agent "vendor:agent")
(declare-c usleep [us i32] i32 "usleep")
(defstruct Late [])
(defonce go i64)
(defn main [] i32
(while (= go 0)
(agent/wait 5))
(usleep 1500000)
(restart-case
(do (error (Late {})) 0)
(carry-on [] 0)))

7
test/programs/dyn-if-truthy.flan
View File

@ -92,6 +92,13 @@
;; used to trap trying to unbox "x" as a strict bool.
(println (or (box nil) (box "x")))
(println (or (box 5) (box "unreached")))
;; A typed bool operand beside a dyn one: the two meet at dyn, the bool
;; boxed, so the dyn one comes back whichever side of the if it lands on.
(println (or false (box "s")))
(println (or (= 1 2) (box nil)))
(println (and (box nil) (= 1 1)))
(println (and true (box "y")))
(println (or true (box "unreached")))
;; One operand is that operand, whatever it is -- no test, no sentinel.
(println (and (box nil)))

28
test/programs/enum-generic.flan Normal file
View File

@ -0,0 +1,28 @@
;;;; A generic conversion from an enum, licensed by {:where (enum? $t)}. enum?
;;;; admits exactly the enums and entails ordered? and equal?, so a body under
;;;; it may convert, compare and test for equality, at any enum.
(defenum Color [red green blue])
(defenum Size [small 10 large 20])
(defn code [x $t] i32
{:where (enum? $t)}
(i32 x))
(defn later? [a $t b $t] bool
{:where (enum? $t)}
(> a b))
(defn same? [a $t b $t] bool
{:where (enum? $t)}
(and (= a b) (<= a b)))
(defn main [] i32
(let [c (Color 2)
s (Size 20)]
(println (code c)) ; 2
(println (code s)) ; 20
(println (later? c (Color 0))) ; true
(println (same? (Color 1) (Color 1))) ; true
(println (f64 (code s)))) ; 20
0)

55
test/programs/fn-cfn-table.flan Normal file
View File

@ -0,0 +1,55 @@
;; A (CFn ...) in the places that zero-initialise: a struct field, a fixed
;; array's element and a global. A table of bare code addresses is what the
;; narrow function type is for, and the zero is the only objection there ever
;; was — a zeroed CFn is a null address. So a call through one tests it first
;; and signals NullCall rather than jumping to nothing.
;;
;; With no argument the empty calls are answered and the program carries on;
;; with "1" nothing answers and it dies, with the site and the type.
(defn double [x i32] i32 (* x 2))
(defn negate [x i32] i32 (- 0 x))
(defstruct Ops [name string run (CFn [i32] i32)])
(defonce table [3 (CFn [i32] i32)])
(defonce hook (CFn [i32] i32))
(defonce evaluated i32 0)
(defonce caught i32 0)
(defonce seen string "")
(defn arg [x i32] i32
(set evaluated (+ evaluated 1))
x)
(defn try-call [f (CFn [i32] i32) x i32] ()
(restart-case
(do (print (f (arg x))) (println ""))
(continue [] (println "empty"))))
(defn main [args [string]] i32
(set (at table 0) double)
(set (at table 2) negate)
(let [ops (Ops {.name "half-built"})]
(if (> (length args) 1)
;; Unanswered: the process dies at the call.
(do (print ((at table 1) 5)) (println "") 0)
(do
(handler-bind
[(NullCall [c]
(set caught (+ caught 1))
(set seen (.type c))
(invoke-restart 'continue))]
(dotimes [i 3] (try-call (at table i) 7)) ; 14, empty, -7
(try-call (.run ops) 1) ; empty
(try-call hook 2) ; empty
(set hook double)
(try-call hook 2)) ; 4
;; The argument of a call that is not made is never evaluated.
(print evaluated) (println "") ; 3
(print caught) (println "") ; 3
(println seen) ; (CFn [i32] i32)
;; And a filled field calls as any CFn does.
(let [full (Ops {.name "full" .run negate})]
(print ((.run full) 9)) (println "")) ; -9
0))))

6
test/programs/fn-in-struct.flan
View File

@ -9,10 +9,8 @@
;; the collector and may be kept anywhere, and (Option (Fn ...)) is the field
;; that holds one — see fn-escape.flan.
;;
;; Which means a (CFn ...) field is refused too, and for the zero alone —
;; a table of function pointers is exactly what that type is for, and nothing
;; about capture stands in its way. An (Option (CFn ...)) field is already
;; legal and is the shape that works; TODO.org, "CFn in a struct or a fixed array", carries the rest as its own item.
;; A (CFn ...) field is not refused: every call through one tests for null and
;; signals NullCall, so its zero is an empty slot — fn-cfn-table.flan.
(defstruct Ops [run (Fn [i32] i32)])
(defn main [] i32 0)

35
test/programs/free-slice.flan Normal file
View File

@ -0,0 +1,35 @@
;;;; (free s) on a slice hands its block back to the context allocator, or to
;;;; the one named. A slice does not carry its allocator, so a dev build checks
;;;; the block against the allocation registry and traps rather than hand one
;;;; allocator another's block. Argument 0 frees correctly both ways; 1 frees
;;;; an arena's copy through the context allocator; 2 frees one copy twice;
;;;; 3 frees a view of an array, which no allocator handed out; 4 frees a
;;;; Vec's storage through a let-bound view of it; 5 frees a formatted
;;;; number's text, which the temp allocator holds.
(defn main [args [string]] i32
(let [which (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0)
a (arena-new 4096)]
(cond
(= which 1) (let [b (bytes "arena" a)] (free b))
(= which 2) (let [b (bytes "twice")] (free b) (free b))
(= which 3) (let [arr [1 2 3]
s (slice arr)]
(free s))
(= which 4) (let [v (vec-new i32)]
(push v 1)
(push v 2)
(let [s (slice v)] (free s))
(println (at v 1))
(free v))
(= which 5) (let [t (i64->bytes 42)] (free t))
:else
(let [b (bytes "heap")
c (bytes "arena" a)
d (clone (slice [1.5 2.5]) (heap-allocator))]
(println (string b) (string c) (at d 1))
(free b)
(free c a)
(free d (heap-allocator))))
(println "done")
(arena-destroy a))
0)

109
test/programs/generic-struct.flan Normal file
View File

@ -0,0 +1,109 @@
;;;; Generic structs, end to end: type parameters and length parameters.
;;;;
;;;; A defstruct whose fields introduce $t is a template, and each set of
;;;; arguments it is given is a copy — an ordinary struct. A parameter is a
;;;; length when it stands in an array's length slot, and a type anywhere else;
;;;; the arguments are written in the order the fields first introduce them.
;;;;
;;;; Small is Odin's Small_Array: a fixed-capacity array with a count, and no
;;;; allocation anywhere.
(defstruct Small [items [$n $t] count i32])
;; A generic function over a generic struct binds both of its parameters from
;; the argument, and reads the length back as a value.
(defn append! [s (Ptr (Small $n $t)) x $t] bool
(if (< (.count s) n)
(do (set (at (.items s) (.count s)) x)
(set (.count s) (+ (.count s) 1))
true)
false))
;; One generic over the struct calling another at its own variables.
(defn append-all! [s (Ptr (Small $n $t)) xs [$t]] ()
(dotimes [i (length xs)]
(append! s (at xs i))))
(defn pop! [s (Ptr (Small $n $t))] (Option $t)
(if (= (.count s) 0)
None
(do (set (.count s) (- (.count s) 1))
(Some (at (.items s) (.count s))))))
(defn capacity [s (Ptr (Small $n $t))] i32 n)
(defn total [s (Ptr (Small $n $t))] $t {:where (numeric? $t)}
(let [acc (the $t 0)]
(dotimes [i (.count s)]
(set acc (+ acc (at (.items s) i))))
acc))
;; A type parameter alone, built positionally with the type read off the
;; fields, and returned under a variable.
(defstruct Pair [a $t b $t])
(defn swapped [p (Pair $t)] (Pair $t) (Pair (.b p) (.a p)))
;; A copy that names itself through a pointer, and a literal field that
;; takes its width from the one beside it.
(defstruct Node [v $t next (Option (Ptr (Node $t)))])
(defn sum-list [n (Ptr (Node i64))] i64
(loop [at n acc (the i64 0)]
(let [acc (+ acc (.v at))]
(match (.next at)
(Some p) (recur p acc)
None acc))))
;; A template naming another at its own parameters.
(defstruct Twice [x (Small $m $u) y (Small $m $u)])
;; A copy as a map key, and a named function over one handed where a
;; function value is wanted.
(defn pair-sum [p (Pair i32)] i32 (+ (.a p) (.b p)))
(defn apply-to [f (Fn [(Pair i32)] i32) p (Pair i32)] i32 (f p))
;; A length variable straight on an array parameter.
(defn len-of [a [$k $e]] i32 k)
(defconst cap 3)
(defn main [] i32
(let [s (the (Small 4 i32) (zeroed))
f (the (Small cap f64) (zeroed))]
(append! (addr s) 10)
(append! (addr s) 20)
(append! (addr s) 30)
(println (total (addr s)) (.count s) (capacity (addr s)))
(append! (addr f) 1.5)
(append! (addr f) 2.5)
(append! (addr f) 3.5)
(println (append! (addr f) 4.5) (total (addr f)) (capacity (addr f)))
(println (pop! (addr f)) (pop! (addr f)) (.count f))
(let [p (Pair 1 2)
q (swapped p)
r (swapped (Pair {.a 1.5 .b 2.5}))]
(println (.a q) (.b q) (.a r) (.b r))
(println q (Pair 1 2.5)))
(let [c (the (Node i64) {.v 3})
b (Node 2 (Some (addr c)))
a (Node 1 (Some (addr b)))]
(println (sum-list (addr a))))
(let [w (the (Twice 2 u8) (zeroed))]
(append! (addr (.y w)) 7)
(println (.count (.x w)) (.count (.y w)) (capacity (addr (.x w)))))
(println (len-of [1 2 3]) (len-of [1.5 2.5]))
(let [v (vec-new (Pair i32))]
(push v (Pair 5 6))
(println (.b (at v 0)))
(free v))
(let [t (the (Small 5 i64) (zeroed))
xs (the [3 i64] [1 2 3])]
(append-all! (addr t) (slice xs))
(println (total (addr t)) (.count t)))
(let [m (map-new (Pair i32) i32)]
(put m (Pair 1 2) 12)
(put m (Pair 3 4) 34)
(println (get m (Pair 3 4)) (get m (Pair 2 1)) (apply-to pair-sum (Pair 7 8)))
(free m))
0))

35
test/programs/grow-param.flan Normal file
View File

@ -0,0 +1,35 @@
;;;; A container parameter is a copy of the caller's header. Growing it grows
;;;; the copy, so the caller's container does not see the push; the function
;;;; is warned at, at the parameter, and the fix it names is the (Ptr ...)
;;;; below, which reaches the caller's own header. A struct passed by value
;;;; is a copy too, with its Vec fields in it, and is warned at the same way.
(defstruct Bag [items (Vec i32) n i32])
(defstruct Box [bag Bag])
(defn add-copy [v (Vec i32)] () (push v 1) (free v))
(defn add-ptr [v (Ptr (Vec i32))] () (push (deref v) 2))
(defn put-ptr [m (Ptr (Map i32 i32))] () (put (deref m) 7 8))
(defn bag-copy [b Bag] () (push (.items b) 1) (free (.items b)))
(defn bag-ptr [x (Ptr Box)] () (push (.items (.bag x)) 3))
(defn main [] i32
(let [v (vec-new i32)
m (map-new i32 i32)]
(add-copy v)
(println (length v)) ; 0
(add-ptr (addr v))
(add-ptr (addr v))
(println (length v)) ; 2
(println (at v 1)) ; 2
(put-ptr (addr m))
(println (length m)) ; 1
(free v)
(free m))
(let [x (Box {.bag (Bag {.items (vec-new i32) .n 0})})]
(bag-copy (.bag x))
(println (length (.items (.bag x)))) ; 0
(bag-ptr (addr x))
(println (at (.items (.bag x)) 0)) ; 3
(free (.items (.bag x))))
0)

22
test/programs/into-owning.flan Normal file
View File

@ -0,0 +1,22 @@
;;;; into over elements that own storage. Without a (map f) in the chain the
;;;; elements are pushed as they stand, which copies their headers and shares
;;;; their blocks — so that is refused, and (map clone) is the copy that
;;;; compiles. The outer Vecs are in an arena, as a container of owning
;;;; elements has to be; the inner ones are on the heap, where growing one
;;;; through a shared header would free the block the other still points at.
(defn main [] i32
(let [a (arena-new 65536)
v (vec-new (Vec i32) a)]
(push v (vec-new i32))
(push (at v 0) 1)
(let [w (into v (vec-new (Vec i32) a) (map clone))]
(dotimes [i 100] (push (at w 0) i))
(println (at (at v 0) 0)) ; 1
(println (length (at v 0))) ; 1
(println (length (at w 0))) ; 101
(println (at (at w 0) 100)) ; 99
(free (at w 0)))
(free (at v 0))
(arena-destroy a)
0))

22
test/programs/prelude-names.flan Normal file
View File

@ -0,0 +1,22 @@
;;;; A program's names do not change what the prelude means. The prelude's
;;;; generics write their type variable bare, (vec-new t), and name
;;;; parameters t, k and v; a global or a type the program declares under one
;;;; of those names is the program's, and the prelude's own reading stands.
(defonce t [4 i32])
(defstruct k [x i32])
(defenum v [lo hi])
(defn even? [x i32] bool (= (% x 2) 0))
(defn main [] i32
(set (at t 0) 7)
(let [xs [1 2 3 4 5 6]
evens (filter (slice xs) even?)]
(println (length evens)) ; 3
(println (at evens 2)) ; 6
(free evens))
(println (at t 0)) ; 7
(println (.x (k {.x 5}))) ; 5
(println (i32 (v 1))) ; 1
0)

14
test/programs/shadow-prelude-global.flan Normal file
View File

@ -0,0 +1,14 @@
;;;; A program's global named as a prelude function takes the name over for
;;;; its own file, as a program's function does, and the prelude's own calls
;;;; keep the prelude's: sort still swaps with the prelude's swap.
(defonce swap i32 3)
(defonce clamp i32 4)
(defconst reverse i32 5)
(defn main [] i32
(println (+ swap clamp reverse)) ; 12
(let [xs [3 1 2]]
(sort (slice xs))
(println (at xs 0)) ; 1
(println (at xs 2))) ; 3
0)

10
test/programs/shadow-prelude.flan
View File

@ -1,13 +1,23 @@
;;;; A program's function named as a prelude function takes the name over for
;;;; the calls in its own file, and the prelude's own calls keep the prelude's:
;;;; ceil-f32 is written over the prelude's floor-f32, and still answers 3.
;;;; A prelude macro is taken over the same way: clamp and update below are
;;;; the program's functions, and format-f64, which the prelude writes with
;;;; its own clamp, still clamps its precision to 9.
(defn abs-f32 [v f32] f32 (if (< v 0.0) (- v) (+ v (f32 100.0))))
(defn floor-f32 [x f32] f32 (f32 999.0))
(defn abs [x i32] i32 (* x 10))
(defn clamp [x i32 lo i32 hi i32] i32 (+ x lo hi))
(defn update [x i32] i32 (* x 7))
(defn main [] i32
(println (abs-f32 (f32 -2.5)))
(println (abs-f32 (f32 2.5)))
(println (floor-f32 (f32 2.3)))
(println (ceil-f32 (f32 2.3)))
(println (abs -3))
(println (clamp 1 2 3))
(println (update 6))
(let [s (format-f64 0.5 40)]
(println (length s))
(free s))
0)

55
test/programs/update-place.flan Normal file
View File

@ -0,0 +1,55 @@
;;;; update, ++ and -- evaluate every subexpression of their place once, as
;;;; C's compound assignment does. `calls` counts the index function: one call
;;;; per form, and the read and the write land on the same element.
(defonce calls i32 0)
(defn next-index [] i32
(set calls (+ calls 1))
(- calls 1))
(defstruct Body [velocity i32 hits [3 i32]])
(defn add [x i32 y i32] i32 (+ x y))
(defclass counter [n i32])
(defn which-slot [] dyn
(set calls (+ calls 1))
:n)
(defn main [] i32
(let [xs [10 20 30]
v (vec-new i32)
g (Body {.velocity 5})]
(push v 1) (push v 2) (push v 3)
;; next-index answers 0, then 1, then 2.
(++ (at xs (next-index)))
(-- (at v (next-index)))
(update (at xs (next-index)) * 3)
(println calls) ; 3
(println (at xs 0) (at xs 1) (at xs 2)) ; 11 20 90
(println (at v 0) (at v 1) (at v 2)) ; 1 1 3
;; A field, with a macro as the function, and with arguments after it.
(update (.velocity g) inc)
(update (.velocity g) add 10)
(println (.velocity g)) ; 16
;; A path through a field into an element: the struct is written in place,
;; not in a copy.
(set calls 0)
(update (at (.hits g) (next-index)) + 7)
(++ (at (.hits g) (next-index)))
(println calls) ; 2
(println (at (.hits g) 0) (at (.hits g) 1)) ; 7 1
;; Through a pointer.
(let [p (addr (.velocity g))]
(update (deref p) * 2)
(println (.velocity g))) ; 32
(free v))
;; A class slot, with the key computed once.
(let [c (counter 4)]
(set calls 0)
(++ (get c (which-slot)))
(update (get c (which-slot)) * 10)
(println calls (get c :n))) ; 2 50
0)

160
test/test_acceptance.ml
View File

@ -432,6 +432,13 @@ let () =
match_enum_out;
outputs ~dev:true "match over an enum, dev" "programs/match-enum.flan"
match_enum_out;
(* update, ++ and -- evaluate their place's subexpressions once: the
counts are the number of calls an index or a key function got. *)
let update_out = "3\n11 20 90\n1 1 3\n16\n2\n7 1\n32\n2 50\n" in
outputs "update evaluates its place once" "programs/update-place.flan"
update_out;
outputs ~x86:true "update evaluates its place once, --x86"
"programs/update-place.flan" update_out;
(* The count is [length] so that [len] is left to programs, and this is
the claim that it really is one: a local holding a count, a
parameter, and a defn the program calls by its bare name, all of
@ -581,10 +588,15 @@ let () =
"programs/array-mixed.flan" mixed_out;
(* A program's function named as a prelude function takes the name over
for its own file; the prelude's own calls keep the prelude's. *)
let sp_out = "2.5\n102.5\n999\n3\n-30\n" in
let sp_out = "2.5\n102.5\n999\n3\n-30\n6\n42\n11\n" in
outputs "a prelude function shadowed" "programs/shadow-prelude.flan" sp_out;
outputs ~x86:true "a prelude function shadowed, x86"
"programs/shadow-prelude.flan" sp_out;
(* And by a program's global, the same way. *)
outputs "a prelude function shadowed by a global"
"programs/shadow-prelude-global.flan" "12\n1\n3\n";
outputs ~x86:true "a prelude function shadowed by a global, x86"
"programs/shadow-prelude-global.flan" "12\n1\n3\n";
(* (max-value T) and (min-value T), concrete and inside a generic. *)
let maxof_out =
"255\n0\n127\n-128\n2147483647\n-9223372036854775808\n\
@ -613,6 +625,20 @@ let () =
source transformed in two orders, which have to differ. *)
outputs "into" "programs/into.flan"
"7 8 9 \n2 4 6 8 10 12 \n4 8 12 \n21\n6 2 4 \n3 1 2 \n3 4 \n2 4 \n1\n";
(* The fix into's refusal names for owning elements, (map clone): the
copy's inner Vec grows on the heap and the source's is untouched. *)
(* Program names that spell the prelude's own leave the prelude alone. *)
outputs "a program's names and the prelude's" "programs/prelude-names.flan"
"3\n6\n7\n5\n1\n";
outputs ~x86:true "a program's names and the prelude's, --x86"
"programs/prelude-names.flan" "3\n6\n7\n5\n1\n";
(* A grown container parameter reaches the caller only through a Ptr. *)
outputs "a grown parameter" "programs/grow-param.flan" "0\n2\n2\n1\n0\n3\n";
outputs ~x86:true "a grown parameter, --x86" "programs/grow-param.flan"
"0\n2\n2\n1\n0\n3\n";
outputs "into with (map clone)" "programs/into-owning.flan" "1\n1\n101\n99\n";
outputs ~x86:true "into with (map clone), --x86" "programs/into-owning.flan"
"1\n1\n101\n99\n";
(* The prelude's slice algorithms. Every assertion here is over an input a
wrong implementation fails: unsorted with duplicates, negatives and an
odd length; a reverse-sorted slice; and a sort of a subslice whose
@ -881,7 +907,7 @@ let () =
*by* build shape (trap at -O0, silent no-op at -O2) and the copy must
not. *)
let bytes_copy_out =
"ZNSERTIONSORT\nINSERTIONSORT\nHi\n3\n99\narenA\n"
"ZNSERTIONSORT\nINSERTIONSORT\nHi\n3\n99\narenA\n3\n"
in
outputs "bytes copies, bytes-view aliases" "programs/bytes-copy.flan"
bytes_copy_out;
@ -889,6 +915,37 @@ let () =
"programs/bytes-copy.flan" bytes_copy_out;
outputs ~x86:true "bytes copies, bytes-view aliases, --x86"
"programs/bytes-copy.flan" bytes_copy_out;
(* (free s) on a slice: through the context allocator and through a named
one, every backend; and in a dev build, the registry's three refusals —
another allocator's block, a block freed twice, a view no allocator
handed out. *)
let fs = "programs/free-slice.flan" in
outputs "free on a slice" fs "heap arena 2.5\ndone\n";
outputs ~opt:"-O0" "free on a slice, -O0" fs "heap arena 2.5\ndone\n";
outputs ~x86:true "free on a slice, --x86" fs "heap arena 2.5\ndone\n";
List.iter
(fun (x86, tag) ->
let exe = compile ~x86 ~dev:true fs in
List.iter
(fun (arg, line, want) ->
let code, text = run exe (Some arg) in
if code <> 134
|| not (contains text
(Printf.sprintf "programs/free-slice.flan:%d:" line))
|| not (contains text want) || contains text "done"
then begin
incr failures;
Printf.printf
"FAIL a dev build refuses a bad free of a slice, argument \
%s%s\n got: %S (exit %d)\n" arg tag text code
end)
[ ("1", 13, "came from another allocator");
("2", 14, "was already freed");
("3", 17, "not a block an allocator handed out");
("4", 21, "views a Vec's or a Map's storage");
("5", 24, "released all at once by (free-temp)") ];
(try Sys.remove exe with Sys_error _ -> ()))
[ (false, ", dev"); (true, ", dev --x86") ];
(* The other half of the same ruling: a store through a bytes-view is
refused before anything is built, because bytes-view answers a
[const u8]. It used to compile and trap at -O0 on both backends, and be
@ -1916,7 +1973,7 @@ let () =
let dyn_if_truthy_out =
"falsey\nfalsey\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\n\
truthy\ntruthy\ntruthy\nwhen 0 ran\nwhen empty-string ran\nb\nb\n\
:kw\nfalse\nnil\n\n0\nfalse\nx\n5\n\
:kw\nfalse\nnil\n\n0\nfalse\nx\n5\ns\nnil\nnil\ny\ntrue\n\
nil\n\nnil\n0\ntrue\nfalse\n\
nil\nand-reached\n2\n7\nor-reached\n1\n\
and-decider\nnil\nor-decider\n9\n\
@ -3466,6 +3523,19 @@ let () =
outputs "generics" "programs/generics.flan" generics_out;
outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out;
(* Generic structs — see the program's header. The third line is two pops
printed in one call, which is also the pin for a printed call being
evaluated once: the walk reads an option's tag and then its payload,
and each read used to make the call again. *)
let generic_struct_out =
"60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\
(Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\
0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n"
in
outputs "generic structs" "programs/generic-struct.flan" generic_struct_out;
outputs ~x86:true "generic structs, --x86" "programs/generic-struct.flan"
generic_struct_out;
(* integer?, end to end — see the program's own header. The first eight
lines are the collapsed abs at six widths and both signed minimums
(which answer themselves; the negation wraps). The [0 0] after them is
@ -3608,7 +3678,7 @@ let () =
chain of instantiations and not a depth it gave up at. *)
refuses "an unconstrained operator in a generic body"
"programs/generic-reject.flan"
"nothing declares t numeric?";
"nothing declares $t numeric?";
refuses "an unconstrained operator names the way out"
"programs/generic-reject.flan" "{:where (numeric? $t)}";
refuses "a runaway instantiation" "programs/generic-runaway.flan"
@ -4166,6 +4236,11 @@ level "1"
lo\nmid\nhi\nother\n"
in
outputs "enum conversion" "programs/enum-convert.flan" enum_conv_out;
(* The generic enum-to-number conversion enum? licenses. *)
outputs "a generic enum conversion" "programs/enum-generic.flan"
"2\n20\ntrue\ntrue\n20\n";
outputs ~x86:true "a generic enum conversion, --x86"
"programs/enum-generic.flan" "2\n20\ntrue\ntrue\n20\n";
outputs ~opt:"-O0" "enum conversion, -O0" "programs/enum-convert.flan"
enum_conv_out;
@ -4217,6 +4292,36 @@ level "1"
end
in
let v2 = "(defstruct Vector2 [x f32 y f32])\n" in
(* A generic struct's copy crosses behind a pointer, as a typedef of its
own with the arguments written in, and one held by value inside a
struct is defined before that struct. clang reads the text, so the
typedef is C and not only a spelling. *)
let gsrc =
"(defstruct G [x $t count i32])\n\
(defstruct O [v i32 inner (G u8)])\n\
(declare-c c-g [s (Ptr (G u8))] i32 \"c_g\")\n\
(declare-c c-o [o (Ptr O)] i32 \"c_o\")\n"
in
shim_case "declare-c: a generic struct's copy crosses behind a pointer" gsrc
[ "/* (G u8) */\n uint8_t x;\n int32_t count;\n"; "inner;\n" ];
(match shim_of gsrc with
| c ->
let file = Filename.temp_file "flan-shim-generic" ".c" in
let oc = open_out file in
output_string oc c;
close_out oc;
if Sys.command (Printf.sprintf "clang -fsyntax-only %s" (Filename.quote file)) <> 0
then begin
incr failures;
print_endline "FAIL declare-c: a generic struct's copy is C clang accepts"
end;
Sys.remove file
| exception Loc.Error _ -> ());
shim_refuses "declare-c: a generic struct's copy by value"
"(defstruct G [x $t])\n(declare-c c-v [s (G u8)] i32 \"c_v\")"
"crosses to C behind a pointer only";
let img =
"(defstruct Image [data (Ptr u8) width i32 height i32])\n"
in
@ -4660,6 +4765,35 @@ level "1"
outputs ~dev:true "the two function types, dev" "programs/fn-cfn.flan"
fn_ptr_out;
(* A CFn in a struct field, a fixed array and a global, each zeroed until
stored into. A call through an empty one signals NullCall, before its
arguments run; answered, the program carries on, and unanswered it dies
naming the site and the type — on both backends. *)
let cfn_table_out =
"14\nempty\n-7\nempty\nempty\n4\n3\n3\n(CFn [i32] i32)\n-9\n"
in
outputs "a CFn table" "programs/fn-cfn-table.flan" cfn_table_out;
outputs ~x86:true "a CFn table, --x86" "programs/fn-cfn-table.flan"
cfn_table_out;
outputs ~dev:true "a CFn table, dev" "programs/fn-cfn-table.flan"
cfn_table_out;
List.iter
(fun x86 ->
let exe = compile ~x86 "programs/fn-cfn-table.flan" in
let code, text = run exe (Some "1") in
if code <> 134
|| not (contains text "programs/fn-cfn-table.flan:")
|| not (contains text "this call is through a (CFn [i32] i32) \
that holds no function")
then begin
incr failures;
Printf.printf "FAIL an unanswered empty CFn call dies%s\n \
got: %S (exit %d)\n"
(if x86 then ", --x86" else "") text code
end;
(try Sys.remove exe with Sys_error _ -> ()))
[ false; true ];
(* Two signatures that flatten to one string under [mangle_ty], which is
how the thunk memo used to be keyed. Keyed on the name, the second
widening reuses the first's thunk at the wrong arity — a miscompile
@ -4694,10 +4828,10 @@ level "1"
the easier of the two to leave open. *)
refuses "a nested function type does not widen"
"programs/fn-generic-nested.flan"
"hof expects (Fn [(Fn [t] t)] i32) here";
"hof expects (Fn [(Fn [$t] $t)] i32) here";
refuses "and neither does one in return position"
"programs/fn-generic-nested-return.flan"
"call-twice expects (Fn [] (Fn [] t)) here";
"call-twice expects (Fn [] (Fn [] $t)) here";
outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan"
fn_capture_out;
@ -4915,6 +5049,17 @@ level "1"
"(defn main [] i32 (++) 0)" "++-takes-one-place";
macro_arity "-- with two arguments"
"(defn main [] i32 (let [a 1 b 2] (-- a b)) 0)" "---takes-one-place";
macro_arity "update with no function"
"(defn main [] i32 (let [a 1] (update a)) 0)"
"update-takes-a-place-and-a-function";
(* A place update takes is a place set takes, and is refused the same way. *)
macro_arity "update of something that is not a place"
"(defn main [] i32 (update 5 inc) 0)" "5 is not assignable";
macro_arity "update of a parameter"
"(defn f [a i32] () (update a inc))" "a is a parameter";
macro_arity "update whose function answers the wrong type"
"(defn yes [x i32] bool true)\n(defn f [] () (let [a 1] (update a yes)))"
"expected i32";
(* unless keeps a guard, and it is now the narrower one: a body may be
missing, a test may not. *)
macro_arity "unless with no test at all"
@ -7109,6 +7254,9 @@ level "1"
(let code, text = cli "check programs/shadow-prelude.flan" in
if code <> 0 || contains text "prelude~"
|| not (contains text "defn floor-f32")
(* A macro taken over is warned about as a function is. *)
|| not (contains text "clamp shadows the prelude's clamp")
|| not (contains text "update shadows the prelude's update")
then begin
incr failures;
Printf.printf

89
test/test_agent.ml
View File

@ -61,6 +61,14 @@ let send path line =
Unix.close s;
Buffer.contents b
(* The pair the daemon sets: the path, and the pid it is meant for. This test
binary is the parent of every program it starts, which is the
--two-process shape. *)
let daemon_env path =
let me = string_of_int (Unix.getpid ()) in
[| "FLAN_AGENT_SOCKET=" ^ path; "FLAN_AGENT_OWNER=" ^ me;
"FLAN_DEV_PARENT=" ^ me |]
let () =
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
| 0 ->
@ -298,7 +306,7 @@ let () =
let bad = tmp "bad.out" in
let bfd' = ofd bad in
let benv =
Array.append aenv [| "FLAN_AGENT_SOCKET=/nonexistent-dir/agent.sock" |]
Array.append aenv (daemon_env "/nonexistent-dir/agent.sock")
in
let bpid' = Unix.create_process_env aexe [| aexe |] benv Unix.stdin bfd' bfd' in
Unix.close bfd';
@ -325,6 +333,79 @@ let () =
"cannot listen\n"
end;
(* ── The variable inherited by a process the daemon did not start ── *)
(* A shell opened from inside a [flan dev] program carries its
FLAN_AGENT_SOCKET, and so does anything run from that shell. Binding
unlinks the path first, so honouring it there would take the session's
socket from its program. FLAN_AGENT_OWNER names the process the daemon
launched; pid 1 is neither this program nor its parent, so the variable
is not this program's, and it picks and announces a path of its own as
if nothing were set. The file standing in for the session's socket has
to still be the same file afterwards. *)
let inherited ~shape ~owner =
let stolen = tmp "stolen.sock" and serr = tmp "stolen.err" in
Out_channel.with_open_bin stolen (fun oc ->
output_string oc "the session's");
let senv =
Array.append aenv
[| "FLAN_AGENT_SOCKET=" ^ stolen; "FLAN_AGENT_OWNER=" ^ owner |]
in
let s1 = ofd (tmp "stolen.out") and s2 = ofd serr in
let spid = Unix.create_process_env aexe [| aexe |] senv Unix.stdin s1 s2 in
Unix.close s1;
Unix.close s2;
let prefix = "flan agent: listening on " in
let sannounced () =
let text = In_channel.with_open_bin serr In_channel.input_all in
List.find_map
(fun l ->
if String.length l > String.length prefix
&& String.sub l 0 (String.length prefix) = prefix
then Some (String.sub l (String.length prefix)
(String.length l - String.length prefix))
else None)
(String.split_on_char '\n' text)
in
(match
if await (fun () -> sannounced () <> None) then sannounced () else None
with
| None ->
fail "%s: a program with someone else's FLAN_AGENT_SOCKET announced no \
socket of its own" shape;
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ())
| Some p ->
if p = stolen then fail "%s: the inherited path was bound: %S" shape p;
if not (await (fun () -> Sys.file_exists p)) then
fail "%s: nothing was bound at the announced %S" shape p
else ignore (send p aso);
let reaped =
await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] spid with
| 0, _ -> false
| _ -> true)
in
if not reaped then begin
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ());
fail "%s: the program with an inherited variable never finished" shape
end);
(match In_channel.with_open_bin stolen In_channel.input_all with
| "the session's" -> ()
| _ -> fail "%s: the inherited FLAN_AGENT_SOCKET's file was replaced" shape
| exception Sys_error _ ->
fail "%s: the inherited FLAN_AGENT_SOCKET's file was removed" shape);
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ stolen; serr; tmp "stolen.out" ]
in
(* Nobody's pid. *)
inherited ~shape:"an owner that is not this process" ~owner:"1";
(* A merged build's owner is the program itself, so a process the program
starts has the owner as its parent; with no FLAN_DEV_PARENT naming it,
that is not the --two-process shape and the socket is not its. Here the
test binary stands in for the program. *)
inherited ~shape:"a child of a merged program"
~owner:(string_of_int (Unix.getpid ()));
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ aexe; aso; aout; aerr; bad ];
@ -359,7 +440,7 @@ let () =
let nc = Session.eval nt "(defn tick [] i64 1000)" in
ignore (Build.shared ~opts:dev ~ir:nc.Session.ir ~out:nso ());
let nenv =
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ nsock |]
Array.append (Unix.environment ()) (daemon_env nsock)
in
let nfd =
Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
@ -412,7 +493,7 @@ let () =
bt.Session.host ~out:bexe);
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let env =
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ bsock |]
Array.append (Unix.environment ()) (daemon_env bsock)
in
let bpid =
Unix.create_process_env bexe [| bexe |] env Unix.stdin bfd bfd
@ -753,7 +834,7 @@ let () =
lt.Session.host ~out:lexe);
let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let lenv =
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ lsock |]
Array.append (Unix.environment ()) (daemon_env lsock)
in
let lpid = Unix.create_process_env lexe [| lexe |] lenv Unix.stdin lfd lfd in
Unix.close lfd;

638
test/test_dev.ml
View File

@ -127,6 +127,166 @@ let status r =
let contains_sub = Test_support.contains
(* The stepper, against a running program whose [step] is dev-pause.flan's
and dev-repl.flan's: sent with [:step t], a call stops before each form of
its body — the (set ...), then after [next] the [ticks] it answers.
[continue] runs the rest of the call and the next call steps again, and a
plain evaluation takes it out. Run in a daemon of each backend that another
block already started, so it costs no build of its own. *)
let stepper_checks ~what ask =
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in
let col sub =
let n = String.length sub in
let rec find i =
if String.equal (String.sub body i n) sub then i + 1 else find (i + 1)
in
find 0
in
(* Where the stepped frame is: the frame of [step], whose location is
the step point's, which is the form about to run. *)
let at () =
match Wire.field (ask "(:op \"backtrace\")") "frames" with
| Some { Form.v = Form.List l; _ } ->
List.find_map
(fun (f : Form.t) ->
match f.Form.v with
| Form.List ({ Form.v = Form.Str "step"; _ }
:: { Form.v = Form.Str loc; _ } :: _) -> Some loc
| _ -> None)
l
| _ -> None
in
let stops_at sub =
let want = Printf.sprintf ":1:%d" (col sub) in
await (fun () ->
stopped (ask "(:op \"describe\")")
&& (match at () with Some l -> contains_sub l want | None -> false))
in
let r =
ask
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)"
(Wire.quote body))
in
if status r <> "ok" then
fail "%sinstrumenting for the stepper: %s" what
(Option.value ~default:"" (Wire.string_field r "message"))
else begin
if Wire.field r "step" = None then
fail "%san instrumented defn did not echo :step" what;
if not (stops_at "(set ticks") then
fail "%sthe stepper did not stop before the first form (at %s)" what
(Option.value ~default:"<none>" (at ()))
else begin
(match Wire.string_field (ask "(:op \"describe\")") "condition" with
| Some "StepPoint" -> ()
| c -> fail "%sa step stopped on %s" what (Option.value ~default:"<none>" c));
(* The stepper's own local is not one of the frame's. *)
let fr = ask "(:op \"locals\" :frame 1)" in
(match Wire.string_field fr "frame" with
| Some "step" ->
(match Wire.field fr "locals" with
| Some { Form.v = Form.List []; _ } | None -> ()
| _ -> fail "%sthe stepper's flag is listed as a local" what)
| f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"<none>" f));
let r = ask "(:op \"restart\" :name \"next\")" in
if status r <> "ok" then
fail "%snext at a step: %s" what
(Option.value ~default:"" (Wire.string_field r "message"));
if not (stops_at "ticks)") then
fail "%snext did not stop before the second form (at %s)" what
(Option.value ~default:"<none>" (at ()));
let r = ask "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "%scontinue at a step: %s" what
(Option.value ~default:"" (Wire.string_field r "message"));
(* The next call, 5ms on, steps again from the top. *)
if not (stops_at "(set ticks") then
fail "%sthe next call did not step again" what;
let r =
ask
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")"
(Wire.quote body))
in
if status r <> "ok" then
fail "%sinstalling the plain defn: %s" what
(Option.value ~default:"" (Wire.string_field r "message"));
ignore (ask "(:op \"restart\" :name \"continue\")");
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "%sthe program did not resume from the last step" what;
let deadline = Unix.gettimeofday () +. 0.5 in
let rec run_on () =
if Unix.gettimeofday () > deadline then ()
else if stopped (ask "(:op \"describe\")") then
fail "%sthe plain defn still steps" what
else begin
ignore (Unix.select [] [] [] 0.01);
run_on ()
end
in
run_on ()
end
end
(* Eval-in-frame against dev-locals.flan's [look], stopped at its (error ...):
the expression sees that frame's locals, the inner of two [label]s wins, a
[set] writes the frame's own storage, and a local not bound yet is refused
by name. [ask] sends one request. Run under each backend. *)
let eval_in_frame_checks ~backend ask =
let value code =
let r =
ask (Printf.sprintf "(:op \"eval-expr\" :frame 0 :code %S)" code)
in
if status r = "ok" then Ok (Option.value ~default:"" (Wire.string_field r "value"))
else Error (Option.value ~default:(status r) (Wire.string_field r "message"))
in
let expect code want =
match value code with
| Ok v when v = want -> ()
| Ok v -> fail "%s eval-in-frame %s answered %S, wanted %S" backend code v want
| Error m -> fail "%s eval-in-frame %s: %s" backend code m
in
expect "(+ n 1)" "4";
expect "(.y p)" "2.5";
expect "label" "\"inner\"";
expect "(do (set flag false) flag)" "false";
(match
Wire.field (ask "(:op \"locals\" :frame 0)") "locals"
with
| Some { Form.v = Form.List rows; _ } ->
if not
(List.exists
(fun (e : Form.t) ->
match e.Form.v with
| Form.List ({ Form.v = Form.Str "flag"; _ } :: _
:: { Form.v = Form.Str "false"; _ } :: _) -> true
| _ -> false)
rows)
then fail "%s eval-in-frame: a set did not reach the frame" backend
| _ -> fail "%s eval-in-frame: no locals after the set" backend);
expect "(do (set flag true) flag)" "true";
(match value "(+ after 1)" with
| Error m when contains_sub m "after is not bound yet" -> ()
| Error m -> fail "%s eval-in-frame of an unbound local said %s" backend m
| Ok v -> fail "%s eval-in-frame read an unbound local as %s" backend v);
(match value "(+ n \"x\")" with
| Error _ -> ()
| Ok v -> fail "%s eval-in-frame accepted a type error: %s" backend v);
(* Addressed to a stop that is over: the agent drops it, and the reply says
why at once rather than timing out. *)
let t0 = Unix.gettimeofday () in
let r = ask "(:op \"eval-expr\" :frame 0 :at-stop 999999 :code \"n\")" in
let m = Option.value ~default:"" (Wire.string_field r "message") in
if status r = "ok" then fail "%s eval-in-frame ran at a stop that is over" backend
else if not (contains_sub m "resumed" || contains_sub m "stopped again") then
fail "%s eval-in-frame at a stop that is over said %s" backend m
else if Unix.gettimeofday () -. t0 > 4.0 then
fail "%s eval-in-frame at a stop that is over waited out the clock" backend
(* ── The one verb whose reply races the process it ends ─────────────── *)
(* [abort] is answered twice over, and the two answers are not ordered. On the
@ -194,7 +354,21 @@ let () =
explain and is quoted as it stands. *)
let other = Dev.refusal ~parked:true "err flan.abi.x86: the module is x86" in
if not (contains_sub other "flan.abi.x86") then
fail "a parked program's other refusals were rewritten too: %S" other
fail "a parked program's other refusals were rewritten too: %S" other;
(* The agent is always this compiler's, never the copy a program vendors:
an old copy answers every frame at its function's own line. *)
let dir = tmp "agent-dir" in
(try Unix.mkdir dir 0o700 with Unix.Unix_error _ -> ());
let csrcs, _ =
Dev.with_agent ~dir [ "/far/vendor/agent/flan_agent.c"; "/far/x.c" ] []
in
let own = Filename.concat dir "flan_agent.c" in
if csrcs <> [ "/far/x.c"; own ] then
fail "a vendored agent was linked in place of the compiler's: %s"
(String.concat " " csrcs)
else if In_channel.with_open_bin own In_channel.input_all
<> Runtime_src.agent_source then
fail "the agent linked is not the compiler's own"
(* A daemon's death is reported by the signal's name. [WSIGNALED] carries
OCaml's own numbering, in which SIGTERM is -11, and a SIGTERM printed as
@ -628,6 +802,28 @@ let () =
| Some { Form.v = Form.Sym "t"; _ } -> ()
| _ -> fail "an expression against the park reported the program live");
(* A generic struct's copy prints the way its type is written, with the
arguments after the template's name, and [layout] answers to that
spelling. *)
let r =
request c
"(:op \"eval\" :code \"(defstruct GPair [a $t b $t])\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "a generic struct at the daemon: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let r =
request c
"(:op \"eval-expr\" :code \"(GPair 1 2)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "(GPair i32 {.a 1 .b 2})" then
fail "a generic struct's copy printed as %s"
(Option.value ~default:(status r) (Wire.string_field r "value"));
let r = request c "(:op \"layout\" :type \"GPair i32\")" in
if Wire.string_field r "type" <> Some "(GPair i32)" then
fail "layout of a copy by its printed head: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* And the half that needs the process rather than only the compiler.
[extra] is a global this session introduced and the first run left at
105 — the third reload's [step] does not touch it — so this is the
@ -2202,6 +2398,88 @@ let () =
pointer: the bytes-view write that first crashed no longer compiles. *)
trap_park ~refault:true "segfault" "dev-segv.flan" "SegFault" [];
(* ── A break over a call through a null CFn ─────────────────────────
NullCall is a condition, signalled as a bad index is: nothing handles
it in dev-break-nullcall.flan, so the program parks with NullCall
named, the program's own continue on offer and takeable, and taking it
resumes — the transcript's 1 is continue's clause having run. On both
backends, since the null test before the call is emitted by each. *)
let null_park backend =
let nsock = tmp ("nullcall" ^ backend ^ ".sock")
and nout = tmp ("nullcall" ^ backend ^ ".out") in
(try Sys.remove nsock with Sys_error _ -> ());
let nfd =
Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let npid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-break-nullcall.flan"; "-s"; nsock; backend |]
Unix.stdin nfd Unix.stderr
in
Unix.close nfd;
if not (listening ~pid:npid nsock) then begin
fail "the null-call daemon (%s) %s" backend !listen_why;
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let out = Buffer.create 64 in
let c = connect nsock in
let ask sexp =
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string out t
| None -> ());
r
in
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let last = ref (Wire.parse "()") in
if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last))
then fail "a null CFn call never stopped the program (%s)" backend
else begin
(match Wire.string_field !last "condition" with
| Some "NullCall" -> ()
| c ->
fail "a null CFn call is reported as %S (%s)"
(Option.value ~default:"" c) backend);
let r = ask "(:op \"break\")" in
(match Wire.field r "restarts" with
| Some { Form.v = Form.List l; _ }
when List.exists
(fun (n : Form.t) -> n.Form.v = Form.Str "continue") l -> ()
| _ -> fail "a null CFn call offers no continue (%s)" backend);
let r = ask "(:op \"restart\" :name \"continue\")" in
if status r <> "ok" then
fail "continuing past a null CFn call (%s): %s" backend
(Option.value ~default:"" (Wire.string_field r "message"));
if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
List.mem "1"
(String.split_on_char '\n' (Buffer.contents out))))
then fail "the program never resumed past a null CFn call (%s)" backend
end;
ignore (ask "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] npid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ())
end
end
in
null_park "--llvm";
null_park "--x86";
(* ── The locals of a stopped frame ─────────────────────────────── *)
(* A third daemon, over a program that stops with something worth looking
@ -2324,6 +2602,7 @@ let () =
(String.concat ", "
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused")))
end;
eval_in_frame_checks ~backend:"llvm" ask;
(* A frame whose every slot the compiler invented is not an error and
is not an empty answer either: it says which it is. *)
let r = ask "(:op \"locals\" :frame 1)" in
@ -2556,6 +2835,21 @@ let () =
want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})";
want "box" "(some \"x\")" "f32" "4.5";
want "s" "(\"Shape.Rect.w\")" "i32" "3";
(* A package's type is its qualified name, in the inspector and in
the listing both, as a field's and a condition's already are:
two packages may each declare a Box. *)
want "pk" "()" "shape/Box" "(shape/Box {.w 3 .h 4})";
(match Wire.field listing "locals" with
| Some { Form.v = Form.List l; _ }
when List.exists
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
({ Form.v = Form.Str "pk"; _ }
:: { Form.v = Form.Str "shape/Box"; _ } :: _) -> true
| _ -> false)
l -> ()
| _ -> fail "the listing does not name pk's type as shape/Box");
(* Where each value is stored. The struct and its first field share
an address and the second field is one f32 further on, so the
number is the layout's and not a label. *)
@ -4372,6 +4666,7 @@ let () =
end
else begin
let c = connect sigsock in
stepper_checks ~what:"llvm " (request c);
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
@ -4836,6 +5131,13 @@ let () =
if not (List.exists (String.equal "continue") names) then
fail "a break at (pause) offers %s, wanted continue among them"
(String.concat ", " names);
(* [step] has no slots at all, so there is nothing to bind and no
table for the program to answer from: an expression evaluated
in its frame sees the globals. Frame 0 is [pause]'s own. *)
(let r = ask "(:op \"eval-expr\" :frame 1 :code \"(+ ticks 0)\")" in
if status r <> "ok" then
fail "eval-in-frame of a frame with no slots: %s"
(Option.value ~default:(status r) (Wire.string_field r "message")));
(* The second claim, and the one this block exists for. A plain
re-evaluation of the same form replaces the stored declaration
@ -4881,6 +5183,7 @@ let () =
end
end
end;
stepper_checks ~what:"x86 " ask;
(* The other way a thunk reaches a [(pause)], and the one no flag asks
for: an ordinary [C-x C-e] over an expression that calls a body
@ -5161,20 +5464,124 @@ let () =
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "42"))
then fail "--two-process: the reload was never installed";
(* And the one verb this shape cannot have. Running [main] again means
waking a thread that parked inside this process, and here the program
is a child: when it finishes it is gone, and there is nothing to wake.
Refused by naming what this daemon is rather than with the message a
merged one gives, because "the program is already running" would send
somebody back to try again after it had exited — and [--x86] arrives
here too, since it refuses the merged daemon for the -rdynamic reason
given below. *)
(* A re-run here is a new process. Refused while the child runs; once
it has finished, the program is built again from the session, so the
redefined [step] is what the new run's first line prints — the host
the daemon started with would print 1. *)
let r = ask "(:op \"rerun\")" in
let why = Option.value ~default:(status r) (Wire.string_field r "message") in
if status r <> "error" then
fail "--two-process answered a rerun it cannot perform"
else if not (contains_sub why "two-process") then
fail "--two-process refuses a rerun as: %s" why;
if status r <> "error" || not (contains_sub why "still running") then
fail "--two-process: a rerun while the child runs answered %s: %s"
(status r) why;
(* Two more deliveries take the program past its last two waits. *)
List.iter
(fun n ->
let r =
ask
(Printf.sprintf
"(:op \"eval\" :code \"(defn step [] i64 %d)\" \
:file \"/tmp/buf.flan\")" n)
in
if status r <> "ok" then fail "--two-process: eval %d was refused" n;
if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) (string_of_int n)))
then fail "--two-process: %d was never installed" n)
[ 43; 44 ];
(* 44 was the old child's last line, so anything from here on is the
new child's. *)
Buffer.clear seen;
let taken = ref (ask "(:op \"describe\")") in
if not
(await ~ms:10000 (fun () ->
taken := ask "(:op \"rerun\")";
status !taken = "ok"))
then
fail "--two-process: a rerun after the child finished: %s"
(Option.value ~default:(status !taken)
(Wire.string_field !taken "message"))
else begin
let note = Option.value ~default:"" (Wire.string_field !taken "note") in
if not (contains_sub note "globals start over") then
fail "--two-process: the rerun's note does not say the globals \
start over: %S" note;
if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "\n"))
then fail "--two-process: the new child printed nothing"
else if not (String.starts_with ~prefix:"44\n" (Buffer.contents seen))
then
fail "--two-process: the new child did not start with the \
redefinition: %S" (Buffer.contents seen);
(* And it is reachable: a delivery to the new child installs. *)
let r =
ask
"(:op \"eval\" :code \"(defn step [] i64 45)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then fail "--two-process: eval after rerun refused";
if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "45"))
then fail "--two-process: the new child never installed a delivery";
(* A signature change leaves [user] compiled for the old one. The
next build is of the whole program, so the re-run is refused at
the stale call; a fix evaluated while the child has ended goes
into the session, and the re-run after it builds. *)
let ev code =
ask
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\")"
(Wire.quote code))
in
let alive () =
match Wire.field (ask "(:op \"describe\")") "alive" with
| Some { Form.v = Form.Sym "nil"; _ } -> false
| _ -> true
in
List.iter
(fun code ->
if status (ev code) <> "ok" then
fail "--two-process: %s was refused" code)
[ "(defn helper [] i64 1)"; "(defn user [] i64 (helper))" ];
if not (await ~ms:10000 (fun () -> not (alive ()))) then
fail "--two-process: the new child did not finish"
else begin
let r = ev "(defn helper [x i64] i64 x)" in
if status r <> "ok" then
fail "--two-process: a change while the child has ended: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
let r = ask "(:op \"rerun\")" in
if status r <> "error"
|| not (contains_sub
(Option.value ~default:"" (Wire.string_field r "loc"))
"/tmp/buf.flan:1:")
then
fail "--two-process: a re-run over a stale caller answered %s \
(%s)" (status r)
(Option.value ~default:"" (Wire.string_field r "message"));
List.iter
(fun code ->
if status (ev code) <> "ok" then
fail "--two-process: %s was refused" code)
[ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ];
Buffer.clear seen;
let r = ask "(:op \"rerun\")" in
if status r <> "ok" then
fail "--two-process: the re-run after the fix: %s"
(Option.value ~default:"" (Wire.string_field r "message"))
else if not
(await (fun () ->
ignore (ask "(:op \"describe\")");
contains_sub (Buffer.contents seen) "\n"))
|| not (String.starts_with ~prefix:"5\n"
(Buffer.contents seen))
then
fail "--two-process: the fixed program printed %S"
(Buffer.contents seen)
end
end;
ignore (ask "(:op \"close\")");
Unix.close tc
end;
@ -6181,6 +6588,7 @@ let () =
(String.concat ", "
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused")))
end;
eval_in_frame_checks ~backend:"x86" (request c);
(* One slot by index, which is the inspector's own root rather than
[locals]' listing, and an aggregate for it: an x86 frame passes every
aggregate by pointer, so a struct is where a recorded address could
@ -6595,12 +7003,12 @@ let () =
let answer r =
Option.value ~default:"" (Wire.string_field r "value")
in
let read () =
answer
(request c
"(:op \"eval-expr\" :code \"(get config :s)\" \
:file \"programs/dev-dyn-global.flan\")")
let read_reply () =
request c
"(:op \"eval-expr\" :code \"(get config :s)\" \
:file \"programs/dev-dyn-global.flan\")"
in
let read () = answer (read_reply ()) in
(* A hundred thousand small maps: flan_dyn.c collects at a
one-megabyte floor, so this is several collections and not a
heap that merely grew. *)
@ -6620,11 +7028,17 @@ let () =
if status r <> "ok" then
fail "--%s: the churning thunk (cycle %d): %s" backend cycle
(said r)
else if not (contains_sub (read ()) "kept") then
fail
"--%s: after a thunk that allocates (cycle %d) the parked \
program's dyn global reads %S"
backend cycle (read ());
else begin
(* The failing reply itself, and not a second read: the one
recorded failure here re-read and got "kept", so what the
first read answered is the whole of the evidence. *)
let r = read_reply () in
if not (contains_sub (answer r) "kept") then
fail
"--%s: after a thunk that allocates (cycle %d) the \
parked program's dyn global read %S (%s: %s)"
backend cycle (answer r) (status r) (said r)
end;
(* And round main again, which re-enters the very code that
pushed those roots. *)
let r = request c "(:op \"rerun\")" in
@ -6633,7 +7047,79 @@ let () =
if not (await ~ms:20000 parked) then
fail "--%s: the program did not park again (cycle %d)" backend
cycle
done
done;
(* An expression's module is unloaded once it returns, string
literals and all: a literal is a copy the process keeps, so a
global left holding one still reads it after the module that
wrote it is gone and later ones have been mapped where it
was. The mapping count is what the kernel limits. *)
let ev code =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %s \
:file \"programs/dev-dyn-global.flan\")" (Wire.quote code))
in
let r =
request c
"(:op \"eval\" :code \"(defonce msg string)\" \
:file \"programs/dev-dyn-global.flan\")"
in
if status r <> "ok" then fail "--%s: defonce msg: %s" backend (said r)
else begin
ignore (ev "(do (set msg \"tuned\") 0)");
let maps () =
List.length
(String.split_on_char '\n'
(In_channel.with_open_bin
(Printf.sprintf "/proc/%d/maps" dpid)
In_channel.input_all))
in
let m0 = maps () in
for i = 1 to 20 do
ignore (ev (Printf.sprintf "(do (println \"other %d\") %d)" i i))
done;
let m1 = maps () in
if m1 - m0 >= 20 then
fail "--%s: twenty expressions with a string literal left %d \
more mappings" backend (m1 - m0);
let r = ev "msg" in
if Wire.string_field r "value" <> Some "\"tuned\"" then
fail "--%s: a literal stored by an unloaded module reads %S \
(%s)" backend
(Option.value ~default:"" (Wire.string_field r "value"))
(said r)
end;
(* A function value an expression makes has its code in that
expression's module — a lambda's body, or the wrapper a named
function is handed out through — so that module stays mapped.
Later expressions are mapped between the store and the call,
where an unloaded one would have been. *)
let defd code =
let r =
request c
(Printf.sprintf
"(:op \"eval\" :code %s \
:file \"programs/dev-dyn-global.flan\")" (Wire.quote code))
in
if status r <> "ok" then fail "--%s: %s: %s" backend code (said r)
in
defd "(defonce kept (Option (Fn [i64] i64)))";
defd "(defn twice [x i64] i64 (* x 2))";
let call_kept want what =
for i = 1 to 3 do
ignore (ev (Printf.sprintf "(do (println \"pad %d\") %d)" i i))
done;
let r = ev "(match kept (Some f) (f 1) (None) -1)" in
if Wire.string_field r "value" <> Some want then
fail "--%s: %s kept by an unloaded expression answered %S \
(%s)" backend what
(Option.value ~default:"" (Wire.string_field r "value"))
(said r)
in
ignore (ev "(do (set kept (Some (fn [x] (+ x 7)))) 0)");
call_kept "8" "a lambda";
ignore (ev "(do (set kept (Some twice)) 0)");
call_kept "2" "a named function"
end;
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
@ -8752,6 +9238,110 @@ let () =
hook_block ~llvm:false;
hook_block ~llvm:true;
(* ── --sanitize on the backend it cannot instrument ───────────── *)
(* Refused before anything is built, by name and with the way out. The
session itself is driven under the sanitizers by @sanitize. *)
let zerr = tmp "x86san.err" in
let zfd = Unix.openfile zerr [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let zpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-loop.flan"; "-s"; tmp "x86san.sock";
"--x86"; "--sanitize" |]
Unix.stdin zfd zfd
in
Unix.close zfd;
(match Unix.waitpid [] zpid with
| _, Unix.WEXITED 1 ->
let said = In_channel.with_open_bin zerr In_channel.input_all in
if not (contains_sub said "--x86 --sanitize"
&& contains_sub said "Drop --x86") then
fail "flan dev --x86 --sanitize was refused as: %S" said
| _ -> fail "flan dev --x86 --sanitize was not refused");
(try Sys.remove zerr with Sys_error _ -> ());
(* ── Whose break it is ─────────────────────────────────────────── *)
(* The program stops on its own while an evaluation is in flight: [go]
makes it sleep for longer than a module takes to build and then
signal, without polling in between. The stop is fresh, as a thunk's
would be, and it is not the expression's; the expression runs inside
the program's break loop and its value is the answer. On the default
backend, because the stop's owner is the agent's and not the
backend's. *)
let osock = tmp "ownbreak.sock" and oout = tmp "ownbreak.out" in
(try Sys.remove osock with Sys_error _ -> ());
let ofd = Unix.openfile oout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let opid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-own-break.flan"; "-s"; osock |]
Unix.stdin ofd Unix.stderr
in
Unix.close ofd;
if not (listening ~pid:opid osock) then begin
fail "the own-break daemon %s" !listen_why;
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect osock in
let said r =
Option.value ~default:(status r) (Wire.string_field r "message")
in
let ev code =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %s :file \"programs/dev-own-break.flan\")"
(Wire.quote code))
in
(* An expression stopped in a break and resumed by a restart finishes
after the restart's reply, and here it finishes after the next
expression has been sent: its value must not answer for that one. *)
let r =
ev "(restart-case (do (error (Late {})) 0) \
(slow [] (do (usleep 500000) 5)))"
in
if status r <> "error" then
fail "resumed value: the first expression did not stop: %s" (said r)
else begin
let r = request c "(:op \"restart\" :name \"slow\")" in
if status r <> "ok" then fail "resumed value: restart: %s" (said r);
let r = ev "(do (usleep 300000) 23)" in
if Wire.string_field r "value" <> Some "23" then
fail "resumed value: the next expression answered %S (%s)"
(Option.value ~default:"" (Wire.string_field r "value")) (said r)
end;
let r = ev "(do (set go 1) 0)" in
if status r <> "ok" then fail "own break: setting go: %s" (said r)
else begin
(* The sleep keeps the thunk running inside the program's break for
many of the daemon's ticks, so a wait that took any fresh stop for
the thunk's would answer before the value exists. *)
let r = ev "(do (usleep 300000) 42)" in
if status r <> "ok"
|| Wire.string_field r "value" <> Some "42" then
fail "own break: an expression in flight when the program stopped \
on its own answered %s %S (value %S)"
(status r) (said r)
(Option.value ~default:"" (Wire.string_field r "value"));
(match Wire.field r "condition" with
| Some { Form.v = Form.Str "Late"; _ } -> ()
| _ -> fail "own break: the reply does not carry the program's stop")
end;
ignore (aborted c);
(try Unix.close c with Unix.Unix_error _ -> ());
if not
(await ~ms:10000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] opid with
| 0, _ -> false
| _ -> true))
then begin
fail "own break: the daemon did not end on abort";
(try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] opid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ osock; oout ];
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ];
Test_support.report ~label:"dev" ()

468
test/test_flan.ml
View File

@ -1417,7 +1417,7 @@ let () =
accepts "all-distinct over a type variable"
"(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))";
rejects_check "a chain still wants the right predicate"
~needle:"nothing declares t ordered?"
~needle:"nothing declares $t ordered?"
"(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))";
(* One operand and none. Both would have to be [true] whatever they were
handed, which is a typo carrying a value. *)
@ -1470,10 +1470,10 @@ let () =
can actually be written there; the parameter-vector suggestion survives
where it works, which the return-type pin further down exercises. *)
rejects_check "a real type variable at a field" "(defstruct Holder [x elem])"
~needle:"a field is built at one type for every value";
~needle:"in a defstruct's fields that makes the struct generic over it";
rejects_check "and the field message offers what a field can hold"
"(defstruct Holder [x elem])"
~needle:"Write a concrete type here, or dyn to hold any value";
~needle:"Write $elem, a concrete type, or dyn to hold any value";
rejects_check "an unknown concrete type" "(defn f [x Widget] ())"
~needle:"unknown type Widget";
@ -2508,12 +2508,14 @@ let () =
rejects_check "slice-from-ptr with a negative literal length"
"(defn f [p (Ptr i32)] i32 (length (slice-from-ptr p -1)))"
~needle:"is negative";
(* The storage stays C's. A slice carries no allocator, so free refuses one
by the rule it already had — this pins that the new form did not become
a thing anybody could hand to free. *)
(* The storage stays C's, and a view made in place is refused at free
without running anything. *)
rejects_check "free of a slice made from a pointer"
"(defn f [p (Ptr i32)] () (free (slice-from-ptr p 3)))"
~needle:"free takes an owning container";
~needle:"is a view of storage something else owns";
rejects_check "free of a slice written in place"
"(defn f [v (Vec i32)] () (free (slice v)))"
~needle:"is a view of storage something else owns";
(* ── Structs, fields and auto-deref ────────────────────────────── *)
let cursor = "(defstruct Cursor [src [u8] pos i32]) " in
@ -2871,13 +2873,11 @@ let () =
(* [(Pair i32)] in a defonce falls down the value fork now that the third
element takes either reading, and the generics answer the type fork gave
it has to be reachable from here too. *)
(* A capitalised head with arguments is a *type* given type arguments, and
that is the half of generics that is not built — Types.Named is a bare
string with no room for parameters. The sentence says which half, since
generic functions are here and pointing at them is the useful part. *)
(* A capitalised head with arguments is a *type* given type arguments; with
no such struct declared, the sentence says how one is. *)
rejects_check "a capitalised call with arguments is a generic type"
"(defonce x (Pair i32)) (defn f [] i32 0)"
~needle:"is a generic type, which is not there yet";
~needle:"no struct or generic struct Pair is declared";
accepts "and the generic function it points at is"
"(defn pair-fst [a $t b $u] $t (do b a))\n\
(defn main [] () (println (pair-fst 1 true)))";
@ -3188,6 +3188,45 @@ let () =
rejects_check "clone on a slice of owning elements"
"(defn f [v [(Vec i32)]] i32 (length (clone v)))"
~needle:"[(Vec i32)] cannot be cloned";
(* into with no (map f) pushes the source's elements as they stand, which
for an owning element shares its block — pushing through the copy then
frees the source's. The fix it names is programs/into-owning.flan. *)
rejects_check "into copying owning elements, refused at the source"
"(defn f [a Allocator] i32\n\
\ (let [v (vec-new (Vec i32) a)\n\
\ w (into v (vec-new (Vec i32) a) (filter nonempty?))] (length w)))\n\
(defn nonempty? [x (Vec i32)] bool (> (length x) 0))"
~needle:"into copies each element of v as it stands, and an element of v \
is a (Vec i32), which owns storage — the copy would share each \
element's block with v, and growing either one frees the block \
the other points at. Add (map clone) to the chain, which copies \
what each element owns: (into v (vec-new (Vec i32) a) (filter \
nonempty?) (map clone))";
accepts "into with (map clone) over owning elements"
"(defn f [a Allocator] i32\n\
\ (let [v (vec-new (Vec i32) a)\n\
\ w (into v (vec-new (Vec i32) a) (map clone))] (length w)))";
accepts "into of plain elements is untouched"
"(defn f [v [i32]] () (let [w (into v (vec-new i32))] (free w)))";
rejects_check "into copying elements clone cannot copy, explained"
"(defstruct B [xs (Vec i32)])\n\
(defn f [v [B] a Allocator] i32 (let [w (into v (vec-new B a))] (length w)))"
~needle:"Nothing copies what a B owns, so no copy of v can stand on its \
own";
rejects_check "clone's refusal names a clone of each element"
"(defn f [v [(Vec i32)]] i32 (length (clone v)))"
~needle:"push a (clone x) of each element into it";
(* A program's names cannot change what the prelude means: a global or a
type spelled like a built-in type is refused where it is declared, and
the rest are programs/prelude-names.flan. *)
rejects_check "a global named like a built-in type"
"(defonce u8 i32)"
~needle:"u8 is a type, so it cannot also name a global";
rejects_check "a type named like a built-in type"
"(defstruct i32 [x i32])"
~needle:"i32 is a built-in type, so it cannot be declared again";
accepts "a global and a type named after the prelude's type variables"
"(defonce t [4 i32])\n(defstruct k [x i32])\n(defenum v [lo hi])";
accepts "clone on a slice, with and without an allocator"
"(defn f [v [f64] a Allocator] i32 (+ (length (clone v)) (length (clone v a))))";
@ -3567,6 +3606,23 @@ let () =
"(defn h [x i32] i32 x) (defn g [i i32] (Fn [i32] i32) h)\n\
(defn f [] i32 (let [a (array-gen [2] g)] 0))"
~needle:"a fixed array's element cannot be (Fn [i32] i32)";
(* A (CFn ...) is not refused in any of them: a call through one tests for
null and signals NullCall, so its zero is an empty slot. *)
accepts "a CFn struct field"
"(defstruct Ops [run (CFn [i32] i32)])\n\
(defn f [o Ops] i32 ((.run o) 1))";
accepts "a fixed array of CFn"
"(defonce tbl [4 (CFn [i32] i32)])\n(defn f [] i32 ((at tbl 0) 1))";
accepts "a CFn global with no initialiser"
"(defonce hook (CFn [] ()))\n(defn f [] () (hook))";
accepts "(zeroed) at a CFn"
"(defn f [] i32 (let [g (the (CFn [i32] i32) (zeroed))] (g 1)))";
accepts "an array-gen of CFn"
"(defn h [x i32] i32 x) (defn g [i i32] (CFn [i32] i32) h)\n\
(defn f [] i32 (let [a (array-gen [2] g)] ((at a 1) 3)))";
rejects_check "an Fn struct field is still refused"
"(defstruct Ops [run (Fn [i32] i32)])"
~needle:"the field run cannot be (Fn [i32] i32)";
(* The inline form, the design's canonical one. An fn normally takes its
types from a (Fn ...) want, and this position has none — the *form*
@ -5637,6 +5693,42 @@ let () =
rejects_check "and offers no comparison at all for a type that has none"
"(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (if p 1 0)))"
~needle:"a condition is a bool or a dyn, and this is P";
(* A deep nest of not over a condition that is refused. Each level retries
the level below it for its message, and a refusal already settled is
answered from memory, so two hundred levels fail at once — re-walking
each subtree doubled the work per level. The message is the innermost
condition's, as it is at one level. *)
(let deep =
let rec nest k e = if k = 0 then e else nest (k - 1) ("(not " ^ e ^ ")") in
"(defn g [x i32] bool " ^ nest 200 "x" ^ ")"
in
let t0 = Unix.gettimeofday () in
match checked deep with
| _ -> check "a deep not nest over an i32 is refused" false
| exception Loc.Error { Loc.dmsg; _ } ->
check "a deep not nest over an i32 fails fast"
(Unix.gettimeofday () -. t0 < 3.0);
check "a deep not nest keeps the one-level message"
(dmsg = "a condition is a bool or a dyn, and this is i32 — test it, as \
(!= x 0)"));
(* A long or chain refused at its last operand, with nothing expected of it.
Each if tries its else arm on its own terms before checking it at bool,
and a refused if is answered from memory, so a thousand operands fail
at once rather than in the square of that. *)
(let deep =
"(defn g [x i32] bool (let [b (or "
^ String.concat " " (List.init 1000 (Printf.sprintf "(= x %d)"))
^ " 5)] b))"
in
(* Timed rather than under [Watchdog.within]: a catch-all inside the
checker can swallow the alarm's exception. *)
let t0 = Unix.gettimeofday () in
match checked deep with
| _ -> check "a refused or chain is refused" false
| exception Loc.Error { Loc.dmsg; _ } ->
check "a refused or chain fails fast" (Unix.gettimeofday () -. t0 < 3.0);
check "a refused or chain keeps the one-operand message"
(dmsg = "expected bool, found the integer literal 5"));
(* A literal still names itself: that message knows something the rule does
not, so the re-check's answer is kept wherever it is more specific. *)
rejects_check "a literal condition keeps its own message"
@ -5752,6 +5844,97 @@ let () =
(match checked shadow_src with
| _ -> true
| exception Loc.Error _ -> false);
(* A parameter vector paired by a lowercase type the program declares reads
as two dyn parameters the day the type goes, so the pairing is warned at,
naming the type and where it is declared. A capitalised type cannot be a
parameter name, so it has nothing to warn about. *)
(match
checked "(defstruct point [x i32])\n(defstruct Vec2 [x i32])\n\
(defn px [p point] i32 (.x p))\n(defn vx [v Vec2] i32 (.x v))"
with
| _ ->
(match !Check.pairing_warnings with
| [ d ] ->
check "a lowercase declared type in a parameter vector is warned at"
(d.Loc.kind = "check/parameter-reads-a-type"
&& d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 13
&& d.Loc.dmsg
= "[p point] is one parameter p of type point, the struct \
declared at <test>:1:1, and not two dyn parameters. If two \
were meant, give the second a name no type has")
| ds ->
check
(Printf.sprintf "one pairing warning, not %d" (List.length ds))
false)
| exception Loc.Error _ -> check "the paired program checks" false);
(* A Vec or Map parameter is the caller's header copied, so growing it is
warned at the parameter, once, naming the (Ptr ...) that reaches the
caller's own. A pointer parameter and a local are not warned at. The
running side is programs/grow-param.flan. *)
let grown src =
match checked src with
| _ -> Some !Check.grow_warnings
| exception Loc.Error _ -> None
in
(match
grown "(defn f [v (Vec i32) m (Map i32 i32)] ()\n\
\ (push v 1) (reserve v 8) (put m 1 2))"
with
| Some [ dm; dv ] ->
check "a grown Vec parameter is warned at the parameter"
(dv.Loc.kind = "check/grown-parameter"
&& dv.Loc.dloc.Loc.line = 1 && dv.Loc.dloc.Loc.col = 10
&& dv.Loc.dmsg
= "v is a (Vec i32) passed by value, a copy of the caller's header, \
so the push at <test>:2:3 grows this function's copy and the \
caller's container never sees it. Take it as (Ptr (Vec i32)) \
and write (push (deref v) ...), and each caller passes (addr c) \
for its container c");
check "and a grown Map parameter names put"
(dm.Loc.dloc.Loc.col = 22
&& Test_support.contains dm.Loc.dmsg "the put at <test>:2:28")
| Some ds ->
check (Printf.sprintf "two grow warnings, not %d" (List.length ds)) false
| None -> check "the grown-parameter program checks" false);
(* A struct parameter is a copy with its Vec fields in it, through any
depth of fields taken by value; through a pointer, not. *)
(match
grown "(defstruct Bag [items (Vec i32)])\n(defstruct Box [bag Bag])\n\
(defn f [x Box] () (push (.items (.bag x)) 1))\n\
(defn g [x (Ptr Box)] () (push (.items (.bag x)) 1))"
with
| Some [ d ] ->
check "a grown field of a struct parameter is warned at the parameter"
(d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 10
&& d.Loc.dmsg
= "x is a Box passed by value, a copy of the caller's, so the push \
at <test>:3:20 grows (.items (.bag x)) in this function's copy \
and the caller's never sees it. Take it as (Ptr Box), where \
(.items (.bag x)) reaches the caller's own, and each caller \
passes (addr c) for its Box c")
| Some ds ->
check (Printf.sprintf "one field grow warning, not %d" (List.length ds)) false
| None -> check "the grown-field program checks" false);
(* Not when the grown copy goes back to the caller — the parameter, or the
struct holding the field, is what the function answers — nor when the
field is given a container of the function's own before it grows. *)
check "a grown parameter the function returns is not warned at"
(grown "(defstruct Bag [items (Vec i32)])\n\
(defn add [v (Vec i32) x i32] (Vec i32) (push v x) v)\n\
(defn early [v (Vec i32) c bool] (Vec i32) (push v 1) \
(when c (return v)) v)\n\
(defn bag [b Bag] Bag (push (.items b) 1) b)\n\
(defn items [b Bag] (Vec i32) (push (.items b) 1) (.items b))"
= Some []);
check "a field reassigned before it grows is not warned at"
(grown "(defstruct Bag [items (Vec i32)])\n\
(defn f [b Bag] ()\n\
\ (set (.items b) (vec-new i32)) (push (.items b) 1) (free (.items b)))"
= Some []);
check "a pointer parameter and a local are not warned at"
(grown "(defn f [v (Ptr (Vec i32))] ()\n\
\ (push (deref v) 1) (let [w (vec-new i32)] (push w 1) (free w)))"
= Some []);
check "a program that shadows nothing is warned at not at all"
(Check.shadowed_builtins (program "(defn f [] i32 1)") = []);
(* A prelude function's name is taken over the same way, for the calls in
@ -5770,6 +5953,20 @@ let () =
| _ -> check "a defn of a prelude function's name warns exactly once" false);
accepts "a defn of a prelude function's name is not defined twice"
prelude_src;
(* A global takes the name over the same way, with the same warning. *)
(match
snd (Check.shadow_prelude (Parse.program (Prelude.forms ()))
(program "(defonce swap i32 3)"))
with
| [ d ] ->
check "a global of a prelude function's name warns once"
(d.Loc.kind = "check/shadows-prelude"
&& d.Loc.dmsg
= "swap shadows the prelude's swap — every use in this file now \
reaches your definition")
| _ -> check "a global of a prelude function's name warns exactly once" false);
accepts "a global of a prelude function's name is not defined twice"
"(defonce swap i32 3)\n(defn f [] i32 swap)";
rejects_check "a struct of a prelude type's name is still defined twice"
"(defstruct Form [x i32])" ~needle:"Form is defined twice";
(* An operator is a builtin like any other and shadows like any other.
@ -5988,6 +6185,110 @@ let () =
check "and they are in source order"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ]));
(* A generic whose abstract pass was refused is not checked again at each
copy: the refusal is one error, however many types call it, and the
caller's own later refusal is still found. *)
(match
Check.program_all
(Parse.program_all
(read "(defn g [x $t] u64 (nosuch x))\n\
(defn main [] i32 (g 3) (g true) nope 0)\n"))
with
| _ -> check "a refused generic body is refused" false
| exception Loc.Errors ds ->
check "a refused generic body is one error, and its caller's is another"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2 ]));
(* A refusal inside a copy names the call that asked for it, and each copy
between: the chain walks back to the line the programmer wrote. *)
(match
checked
"(defn show [v $t] () (println v)) \
(defn outer [v $t] () (show v)) \
(defn main [] i32 (outer main) 0)"
with
| _ -> check "a copy with no printer is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refusal in a copy names both instantiations"
(contains d.Loc.dmsg "no printer for"
&& notes
= [ "show is instantiated at $t = (CFn [] i32) here";
"outer is instantiated at $t = (CFn [] i32) here" ]));
(* A refusal made while collecting declarations — a generic struct that
holds itself, one that grows without end, a where clause over a length —
is one error among the rest of the file's, not the end of the check. *)
let all_lines src =
match Check.program_all (Parse.program_all (read src)) with
| _ -> []
| exception Loc.Errors ds ->
List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds
in
check "a self-containing generic struct is one error of several"
(all_lines
"(defstruct Loop [next (Loop $t)])\n\
(defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a generic struct that grows without end is one error of several"
(all_lines
"(defstruct Grow [next (Ptr (Grow [$t]))])\n\
(defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a where clause over a length is one error of several"
(all_lines
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\
(defn h [] i32 nope2)\n"
= [ 1; 1; 2 ]);
(* A literal that does not fit what a typed field decided names that field. *)
(match
checked
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))"
with
| _ -> check "a float literal where a typed field decided i32" false
| exception Loc.Error d ->
check "the refusal names the field that decided the variable"
(contains d.Loc.dmsg "Pair's .b is $t, which is i32 here"
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg ".a is i32 here, which decides $t")
d.Loc.notes));
(* A copy that cannot be built at a closure's type: the zeroed value in the
body is refused there, and the call that asked is named. *)
(match
checked
"(defn blank [x $t] $t (let [z (the $t (zeroed))] z)) \
(defn use-it [f (Fn [i32] i32)] i32 (blank f) 0)"
with
| _ -> check "a zeroed closure in a copy is refused" false
| exception Loc.Error d ->
check "a copy at a closure type names the call that asked"
(List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "blank is instantiated at $t = (Fn [i32] i32) here")
d.Loc.notes));
(* A prelude generic's body is nobody's source at the call: the refusal is
at the call, and the prelude's line is a note. *)
(match
checked
"(defn keep [g (Vec u8)] bool true) \
(defn use-it [xs [(Vec u8)]] i32 (length (filter xs keep)))"
with
| _ -> check "a prelude copy that cannot be built is refused" false
| exception Loc.Error d ->
check "a prelude copy's refusal is at the user's call"
(d.Loc.dloc.Loc.file <> Prelude.file
&& contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)"
&& not (contains d.Loc.dmsg "clone")
&& List.exists
(fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file)
d.Loc.notes));
(* The parser resynchronises on a top-level form, so two bad declarations are
two errors rather than one. *)
(match Parse.program_all (read "(defn a)\n(defn b)\n") with
@ -6046,7 +6347,7 @@ let () =
accepts "numeric? admits +"
"(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))";
rejects_check "equal? does not admit <"
~needle:"nothing declares t ordered?"
~needle:"nothing declares $t ordered?"
"(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))";
(* The entailments, which are the reason a signature is one predicate long
rather than two. Every type the language orders is a number or an enum,
@ -6074,10 +6375,10 @@ let () =
accepts "integer? admits the shifts"
"(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))";
rejects_check "numeric? does not admit bit-and"
~needle:"nothing declares t integer?"
~needle:"nothing declares $t integer?"
"(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))";
rejects_check "nor the shifts"
~needle:"nothing declares t integer?"
~needle:"nothing declares $t integer?"
"(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))";
(* An integer?-bounded caller satisfies a numeric?-bounded callee: the
entailment carries across generic calls exactly as ordered?-over-equal?
@ -6143,7 +6444,8 @@ let () =
and the message says which predicate to write. *)
rejects_check "ordered? does not admit a conversion"
~needle:"The where clause says t is ordered?, and that does not make it \
a number — add (numeric? $t) to the where clause"
a number or an enum — add (numeric? $t) to the where clause, or \
(enum? $t) for an enum"
"(defn to32 [x $t] i32 {:where (ordered? $t)} (i32 x))";
rejects_check "nor does equal?"
~needle:"add (numeric? $t) to the where clause"
@ -6154,9 +6456,28 @@ let () =
(* With no clause at all the message hands over the whole clause rather
than a predicate to add to one that is not there. *)
rejects_check "an unbounded variable does not convert"
~needle:"i32 converts a number. Nothing here says t is a number — write \
{:where (numeric? $t)} at the head of the body"
~needle:"i32 converts a number or an enum. Nothing here says t is a \
number or an enum — write {:where (numeric? $t)} at the head of \
the body, or {:where (enum? $t)} for an enum"
"(defn to32 [x $t] i32 (i32 x))";
(* enum? is the other bound a conversion to a number takes: it admits the
enums, which convert as an i32, and entails ordered? and equal? but not
numeric?. The running side is programs/enum-generic.flan. *)
accepts "enum? admits the conversion from an enum"
"(defn code [x $t] i32 {:where (enum? $t)} (i32 x))";
accepts "and compares, being ordered? and equal?"
"(defn later? [a $t b $t] bool {:where (enum? $t)} (and (> a b) (= a b)))";
rejects_check "but is not a number"
~needle:"$t"
"(defn sum [a $t b $t] $t {:where (enum? $t)} (+ a b))";
rejects_check "and admits no integer at the call"
~needle:"i32 is not enum?"
"(defn code [x $t] i32 {:where (enum? $t)} (i32 x))\n\
(defn f [] i32 (code (i32 3)))";
rejects_check "nor the conversion to an enum, which needs an integer"
~needle:"add (integer? $t) to the where clause"
"(defenum K [lo -1 hi 1])\n\
(defn as-k [n $t] K {:where (enum? $t)} (K n))";
(* The operand of a cast to a *variable* target is asked the same question
the target was: the target's bound says nothing about a second variable
standing in the argument. *)
@ -6660,19 +6981,118 @@ let () =
bound, because inside a signature that introduces one the mistake is
nearly always the second spelling of the first. *)
rejects_check "vec-new over a sigil that names no variable in scope"
~needle:"this signature introduces t, so write t here"
~needle:"this signature introduces $t, so write $t here"
"(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))";
rejects_check "and a cast over one tells the same story"
~needle:"this signature introduces t, so write t here"
~needle:"this signature introduces $t, so write $t here"
"(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))";
rejects_check "two variables in scope are both named"
~needle:"introduces t and u, so write one of those"
~needle:"introduces $t and $u, so write one of those"
"(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))";
(* Where no variable is in scope there is none to name, and the answer is
the rule: a sigil binds, and only a defn signature is a binding site. *)
rejects_check "a sigil in a struct field, where nothing can bind one"
~needle:"only a defn signature can"
"(defstruct S [v $t])";
rejects_check "a sigil in a data case's field, where nothing can bind one"
~needle:"only a defn signature or a defstruct's fields can"
"(defdata D [(C [v $t])])";
(* ── Generic structs: what is refused, and where ─────────────────── *)
rejects_check "a generic struct given the wrong number of arguments"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 2"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair i32 i64)] i32 0)";
rejects_check "a generic struct named with no arguments"
~needle:"Pair is generic, and a type only once it is given its arguments"
"(defstruct Pair [a $t b $t]) (defn f [p Pair] i32 0)";
rejects_check "a type where a length argument goes"
~needle:"Small's $n is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small i32 4)] i32 0)";
rejects_check "a length where a type argument goes"
~needle:"Small's $t is a type, and 4 is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small 4 4)] i32 0)";
rejects_check "a negative length argument"
~needle:"-1 is negative"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small -1 i32)] i32 0)";
rejects_check "one variable as both a length and a type"
~needle:"$t stands for a length in one place here and a type in another"
"(defstruct Bad [x $t y [$t i32]])";
rejects_check "a length variable where a type goes"
~needle:"n is a length, not a type"
"(defn f [a [$n i32]] i32 (let [x (the n 0)] 0))";
rejects_check "a where clause over a length variable"
~needle:"$n is a length, and a where clause takes type predicates only"
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} 0)";
rejects_check "a generic struct that contains itself by value"
~needle:"(Loop $t) contains itself by value"
"(defstruct Loop [next (Loop $t)])";
rejects_check "a generic struct that asks for bigger copies of itself"
~needle:"Grow names a copy of itself at a type built around its own"
"(defstruct Grow [next (Ptr (Grow [$t]))]) (defn f [p (Grow i32)] i32 0)";
rejects_check "a copy whose key is already a struct's name"
~needle:"Pair at these arguments is called Pair-i32, and Pair-i32 is \
already defined"
"(defstruct Pair [a $t b $t]) (defstruct Pair-i32 [x i32]) \
(defn f [p (Pair i32)] i32 0)";
rejects_check "a generic struct literal whose fields decide nothing"
~needle:"Pair's $t is not decided by the fields given here"
"(defstruct Pair [a $t b $t]) (defn f [] i32 (let [p (Pair {})] 0))";
rejects_check "two fields that disagree about the variable"
~needle:"(Pair $t)'s .b is i32 here, and this is f64"
"(defstruct Pair [a $t b $t]) \
(defn f [] i32 (let [p (Pair (the i32 1) (the f64 2.5))] 0))";
accepts "a literal field takes its width from a typed one beside it"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 (the f64 2.5))] (.a p)))";
rejects_check "a generic struct as a condition"
~needle:"Pair is generic, and a condition struct is not"
"(defstruct Pair :parent Error [a $t])";
rejects_check "an operator a generic body's struct field does not support"
~needle:"+ over the type variable $t"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair $t)] $t (+ (.a p) (.b p)))";
accepts "the same body with the predicate declared"
"(defstruct Pair [a $t b $t]) \
(defn f [p (Pair $t)] $t {:where (numeric? $t)} (+ (.a p) (.b p))) \
(defn main [] i32 (f (Pair 1 2)))";
accepts "a copy wanted where it is built takes its type from there"
"(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))";
(* A copy whose field is refused names each use that asked for it. *)
(match
checked
"(defstruct Box [f $t]) (defstruct Outer [b (Box $w)]) \
(defn go [g (Fn [i32] i32)] i32 \
(.x (the (Outer (Fn [i32] i32)) (zeroed))) 0)"
with
| _ -> check "a copy with a zeroed function field is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refused copy names each use that made it"
(List.mem "(Box (Fn [i32] i32)) is made here" notes
&& List.mem "(Outer (Fn [i32] i32)) is made here" notes));
rejects_check "a bare generic struct in ordinary code suggests real arguments"
~needle:"write (Pair i32)"
"(defstruct Pair [a $t b $t]) (defn main [] i32 (let [p (the Pair (zeroed))] 0))";
rejects_check "a generic struct applied to nothing"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 0"
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (the (Pair) (zeroed))] 0))";
rejects_check "a length argument that is not one"
~needle:"(+ n 1) is not a type or a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [n 3 p (the (Small (+ n 1) i32) (zeroed))] 0))";
accepts "a length argument of literal arithmetic is folded"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [p (the (Small (+ 1 2) i32) (zeroed))] \
(length (.items p))))";
accepts "two literal fields meet at the wider type"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 2.5)] (+ (.a p) (.b p))))";
rejects_check "a callee's predicate names the caller's variable with its $"
~needle:"passes the type variable $t, which nothing here declares ordered?"
"(defn f [s [$t]] () (sort s))";
accepts "a defonce of a generic struct's copy"
"(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \
(defn main [] i32 (.a g))";
(* ── The builtin table against the arms it describes ──────────────
[Check.builtins] is what the editor's C-c C-v and M-. read for a name no

97
test/test_sanitize.ml
View File

@ -376,13 +376,8 @@ let dyn_sweep () =
part that carries the weight; the run is what says the constructor the fix
introduced actually calls both of the things it replaced.
Not covered, and worth naming rather than leaving to be discovered the way
this bug was: a program driven by [flan dev] under ASan. The daemon builds
its host through its own path and the CLI has no [--sanitize] to pass it,
so that one wants a flag and a way through [Dev.serve]. See TODO.org, "A
program driven by a real flan dev daemon under a sanitizer". The faulting
dev build, which was on that list too, is covered now — see
[dev_segv] below. *)
A program driven by a real [flan dev] session is [dev_session] below, and
the faulting dev build is [dev_segv]. *)
let dev_corpus =
[ (* The only [dev-*] program with no agent import: it prints and returns.
Here because it is the one program in the tree written for a dev
@ -474,6 +469,93 @@ let dev_segv () =
prevent\n%s" text;
(try Sys.remove exe with Sys_error _ -> ())
(* A program driven by a real [flan dev --sanitize] session: the host and the
runtime under ASan and UBSan, the modules the session sends built as
always (llc and ld, not instrumented). dev-break stops on its first frame,
so the session starts at a break; it is resumed, [step] is redefined three
times with an expression evaluated after each, an expression is evaluated
into a second break and resumed out of it, and the session is closed. The
daemon's own output is the program's stderr, so a report anywhere in the
session lands in it. *)
let dev_session () =
let flan = "../bin/main.exe" in
let sock = Filename.concat scratch "flan-san-dev.sock" in
let log = Filename.concat scratch "flan-san-dev.log" in
let src = "programs/dev-break.flan" in
(try Sys.remove sock with Sys_error _ -> ());
let fd = Unix.openfile log [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let env =
Array.append (Unix.environment ())
[| "ASAN_OPTIONS=detect_leaks=0"; "UBSAN_OPTIONS=print_stacktrace=1" |]
in
let pid =
Unix.create_process_env flan
[| flan; "dev"; src; "-s"; sock; "--sanitize" |]
env Unix.stdin fd fd
in
Unix.close fd;
let said () = In_channel.with_open_bin log In_channel.input_all in
if not (Test_support.listening ~ms:180000 ~pid sock) then begin
fail "dev session: flan dev --sanitize %s\n%s" !Test_support.listen_why
(said ());
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = Test_support.connect sock in
let ask q = Wire.parse (Wire.send c q; Wire.recv c) in
let field r k = Option.value ~default:"" (Wire.string_field r k) in
let stopped () =
match Wire.field (ask "(:op \"describe\")") "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let expect what r =
if field r "status" <> "ok" then
fail "dev session: %s: %s" what (field r "message")
in
let f = Printf.sprintf ":file %S" src in
if not (Test_support.await ~ms:30000 stopped) then
fail "dev session: the program never reached its first break"
else begin
expect "retry" (ask "(:op \"restart\" :name \"retry\")");
if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then
fail "dev session: the program did not resume";
for i = 1 to 3 do
expect "a redefinition"
(ask
(Printf.sprintf
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks \
%d)) ticks)\" %s)" (100 * i) f));
expect "an expression"
(ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ ticks 1)\" %s)" f))
done;
let r = ask (Printf.sprintf "(:op \"eval-expr\" :code \"(divide 1 0)\" %s)" f) in
if not (contains (field r "condition") "ArithError") then
fail "dev session: (divide 1 0) did not stop on ArithError: %s"
(field r "message");
expect "use-zero" (ask "(:op \"restart\" :name \"use-zero\")");
if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then
fail "dev session: the program did not resume from the second break";
expect "an expression after both breaks"
(ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ 1 2)\" %s)" f))
end;
(try ignore (ask "(:op \"close\")") with _ -> ());
(try Unix.close c with Unix.Unix_error _ -> ());
if not
(Test_support.await ~ms:30000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] pid with
| 0, _ -> false
| _ -> true))
then begin
fail "dev session: the daemon did not end on close";
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
end;
if reported (said ()) then
fail "dev session: sanitizer report\n%s" (said ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; log ]
(* The positive controls, which are the only evidence that a clean sweep means
anything. Both are written here rather than kept in test/programs because
neither is a program anybody should build: one reads off the end of an
@ -600,6 +682,7 @@ let () =
dyn_sweep ();
dev_sweep ();
dev_segv ();
dev_session ();
unchecked_controls ();
if !failures = 0 then print_endline "sanitizer sweep: clean"
else Printf.printf "%d sanitizer failure(s)\n" !failures;

173
test/test_session.ml
View File

@ -64,6 +64,19 @@ let () =
fail "%s left a caller behind that nothing has" name
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" name m
in
(* A session's defn named as a prelude macro shadows it for a later form
sent alone, as the same defn does in a file. *)
(let t, _ = Session.create ~file:"programs/reload.flan" () in
match
ignore (Session.eval t "(defn clamp [x i64] i64 (+ x 1))");
Session.eval t "(defn clamped [] i64 (clamp 4))"
with
| c ->
if not (List.mem "clamped" c.Session.fns) then
fail "a call to a session's clamp installed %s"
(String.concat " " c.Session.fns)
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a call to a session's clamp was expanded as the macro: %s" m);
installs "a changed parameter type" "(defn outer [x i64] i64 (bump))";
installs "a changed return type" "(defn outer [] i32 (i32 (bump)))";
installs "a changed arity" "(defn outer [a i64 b i64] i64 (bump))";
@ -354,6 +367,76 @@ let () =
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "the session was poisoned by a bad expression: %s" m);
(* A generic struct's copy first named by an expression typed at the
session: the module built for it has to lay the copy out, and the
session keeps it, as it keeps a generic function's copy. *)
(let gt, _ = Session.create ~file:"programs/reload.flan" () in
(match Session.eval gt "(defstruct Pair [a $t b $t])" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a generic struct was refused at the session: %s" m);
match Session.eval_expr gt "(println (.b (Pair 7 8)))" with
| e ->
if not (has e.Session.ir "%\"Pair-i32\" = type") then
fail "the expression's module did not carry the struct copy";
if not
(List.exists
(fun (s : Tast.structure) -> String.equal s.Tast.sname "Pair-i32")
gt.Session.program.Tast.structs)
then fail "the session did not keep the struct copy an expression made"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "an expression building a generic struct was refused: %s" m);
(* And the same for the other two modules the break loop builds out of
typed-in values: a store into a frame slot, and a restart's arguments.
A copy first named in one of them is laid out there and kept. *)
(let keeps t what =
List.exists
(fun (s : Tast.structure) -> String.equal s.Tast.sname what)
t.Session.program.Tast.structs
in
let lays_out (c : Session.change) what =
has c.Session.ir ("%\"" ^ what ^ "\" = type")
in
let st, _ = Session.create ~file:"programs/reload.flan" () in
(match Session.eval st "(defstruct Pair [a $t b $t])" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "Pair: %s" m);
(match Session.eval st "(defn holder [] i64 (let [x (the i64 0)] x))" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "holder: %s" m);
let fn =
List.find (fun (f : Tast.fn) -> f.Tast.name = "holder")
st.Session.program.Tast.fns
in
let slot =
let r = ref (-1) in
Array.iteri (fun i n -> if n = Some "x" then r := i) fn.Tast.snames;
!r
in
(match
Session.write_slot st ~frame:0 ~fn ~slot ~path:[]
~edits:[ ([], "(.a (Pair (the i64 5) 6))") ]
with
| Ok (c, _, _) ->
if not (lays_out c "Pair-i64") then
fail "a store's module did not carry the struct copy its value made";
if not (keeps st "Pair-i64") then
fail "the session did not keep the struct copy a store made"
| Error why -> fail "a store building a generic struct was refused: %s" why
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a store building a generic struct was refused: %s" m);
match
Session.arm_restart st ~index:0 ~params:[ Types.Int Types.U16 ]
~codes:[ "(.b (Pair (the u16 5) 6))" ]
with
| Ok (c, _) ->
if not (lays_out c "Pair-u16") then
fail "a restart's module did not carry the struct copy its argument made"
| Error why -> fail "a restart building a generic struct was refused: %s" why
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a restart building a generic struct was refused: %s" m);
(* The other half of "a refusal costs nothing", and the half that used to be
missing: a form can check and *then* fail, in the build or at the agent,
and the session that already accepted it has no way to hear about it
@ -1315,17 +1398,25 @@ let () =
if has c.Session.ir "@flan_reload_transient" then
fail "a module that publishes a body claimed to be unloadable";
(* And a third condition, about data rather than text. A string literal lives
in the evaluating module's own image, and an expression may store one
anywhere: [(set msg "x")] on a string global would leave that global
pointing into a mapping the agent then drops — and since the next thunk can
be mapped at the same address, the result is silent garbage rather than a
fault. A module carrying any string constant keeps its mapping. *)
(* And a third condition, about data rather than text. An expression may
store a string literal anywhere — [(set msg "x")] on a string global — so
a literal's value is a copy [flan_dev_literal] keeps for the process, and
nothing is left pointing into the module. A string constant the module
does hand out still keeps its mapping: a condition's name, which a handler
may carry away. *)
let str = Session.eval_expr t "(println \"tuned\")" in
if not (has str.Session.ir ".str.0") then
fail "the fixture stopped carrying a string constant, so it proves nothing";
if has str.Session.ir "@flan_reload_transient" then
fail "an expression holding a string claimed to be unloadable";
if not (has str.Session.ir "@flan_dev_literal(ptr") then
fail "an expression's string literal is not a kept copy";
if has str.Session.ir ".str." then
fail "an expression's string literal is still a constant of its module";
if not (has str.Session.ir "@flan_reload_transient") then
fail "an expression whose only string is a literal kept its mapping";
let held =
Session.eval_expr t
"(restart-case (+ 1 2) (use-zero [] :report \"Answer 0\" 0))"
in
if has held.Session.ir "@flan_reload_transient" then
fail "an expression establishing a restart claimed to be unloadable";
(* ── Generics in the dev loop ─────────────────────────────────────────
A generic [defn] produces no [Tast.fn] of its own — only its copies do —
@ -1523,7 +1614,7 @@ let () =
(* And the slot names, in the packed form the runtime splits — which is
what says the call carries *this* class's new list and not some
other module's leftovers. *)
if not (has c.Session.ir "c\"x\\0Ay\\0Az\\00\"") then
if not (has c.Session.ir "c\"x\\0Ay\\0Az\"") then
fail "the registration did not carry the new slot list"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "adding a slot to a class was refused: %s" m);
@ -1556,7 +1647,7 @@ let () =
| c ->
if not (has c.Session.ir "call void @flan_dyn_class_def") then
fail "an unchanged class definition registered nothing";
if not (has c.Session.ir "c\"x\\0Ay\\00\"") then
if not (has c.Session.ir "c\"x\\0Ay\"") then
fail "an unchanged class registered some other slot list"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "re-evaluating an unchanged class was refused: %s" m);
@ -1620,7 +1711,7 @@ let () =
ignore (Session.eval t "(defn origin [] dyn (point 0 0))");
match Session.eval t "(defclass point [x i64 y])" with
| c ->
if not (has c.Session.ir "c\"x i64\\0Ay\\00\"") then
if not (has c.Session.ir "c\"x i64\\0Ay\"") then
fail "a slot's new type did not reach the registration"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a slot's type changed under a compiled caller was refused: %s" m);
@ -1764,4 +1855,60 @@ let () =
| _ -> fail "a package's bare name resolved from the program's own file"
| exception Loc.Error _ -> ());
(* ── Every error in the form sent ───────────────────────────────────
A refused subexpression stands as a value that fits anywhere, so the
check goes on past it: three bad expressions are three errors, one three
levels down is still found, and what a failure causes is not reported. *)
(let errors src =
let t, _ = Session.create ~file:"programs/reload.flan" () in
match Session.eval t src with
| _ -> fail "a form with errors was accepted: %s" src; []
| exception Loc.Error d -> [ d ]
| exception Loc.Errors ds -> ds
in
let msgs ds = String.concat " | " (List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds) in
let three =
errors
"(defn three [] i64 (println (+ 1 \"a\")) (println (nope 2)) (+ 3 \"c\"))"
in
if List.length three <> 3 then
fail "three bad expressions gave %d errors: %s" (List.length three) (msgs three);
let deep =
errors
"(defn deep [] i64 (+ 1 \"a\") (if true (let [x (do (println (nope 2)) 1)] x) 0))"
in
if List.length deep <> 2 || not (has (msgs deep) "nope") then
fail "an error three levels down was not reported: %s" (msgs deep);
(* The failed call poisons the let's [x]; the field read of it and the sum
it flows into are consequences, and are not said. *)
let caused =
errors "(defn caused [] i64 (let [x (nope 1)] (+ (.foo x) (+ x 1))))"
in
if List.length caused <> 1 || not (has (msgs caused) "nope") then
fail "a failure's consequences were reported: %s" (msgs caused);
(* A local bound to a refused initialiser and then called is the same
consequence: no "unknown function p". *)
let called = errors "(defn called [] i64 (let [p (nope 1)] (p 3)))" in
if List.length called <> 1 then
fail "calling a local bound to a failure was reported: %s" (msgs called);
(* A call refused for its argument count still has its arguments checked. *)
let arity =
errors "(defn arity [] i64 (bump (nope2) 7 8))"
in
if List.length arity <> 2 || not (has (msgs arity) "nope2") then
fail "an error inside a miscounted call was not reported: %s" (msgs arity);
(* And the whole-file path: fn-no-type.flan has one mistake, reported once. *)
(match Front.checked ~all:true "programs/fn-no-type.flan" with
| _ -> fail "fn-no-type.flan checked"
| exception Loc.Error _ -> ()
| exception Loc.Errors ds ->
if List.length ds <> 1 then
fail "fn-no-type.flan gave %d errors: %s" (List.length ds) (msgs ds));
(* One error is the [Loc.Error] every caller of one form expects. *)
let t, _ = Session.create ~file:"programs/reload.flan" () in
(match Session.eval t "(defn one [] i64 (nope 1))" with
| _ -> fail "an unknown function was accepted"
| exception Loc.Error _ -> ()
| exception Loc.Errors _ -> fail "one error came as a list"));
Test_support.report ~label:"session" ()

5
test/test_syntax.ml
View File

@ -354,6 +354,9 @@ let () =
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 "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
(* A place with a call in it is evaluated once: it reads as update. *)
reads "assignment op over a call's place" "a[next()] += 1"
"(update (at a (next)) + 1)";
reads "for" "for :outer i in range(1, n)\n f(i)" "(dotimes :outer [i 1 n] (f i))";
reads "unit statement" "restart-case\n f()\nrestart continue()\n ()"
"(restart-case (f) (continue [] (do)))";
@ -413,6 +416,8 @@ let () =
| exception e -> fail "%s: %s" name (diag_text e)
in
prints "compound assignment" "(defn f [] () (set x (+ x 1)))" " x += 1";
prints "compound update" "(defn f [] () (update (at a (next)) + 1))"
" a[next()] += 1";
prints "arm statements" "(defn f [] () (match s 1 (break) _ (return 2)))"
"1 -> break\n _ -> return 2";
prints "then and else statements" "(defn f [] () (if c (return 1) (set x 2)))"

105
vendor/agent/flan_agent.c vendored
View File

@ -214,8 +214,19 @@ typedef struct {
void *handle;
int stopped_only;
int32_t at_stop;
uint32_t call_id; /* its place among jobs with a call; 0 if none */
} job;
/* Which evaluated expression the result buffer holds. Every job with a call
* is numbered as the listener queues it, and a call that returns records its
* number, so a daemon waiting for its own expression's value is not answered
* by an earlier expression that a restart resumed and that published after
* the new one was sent. The highest wins: an expression run inside another's
* break returns first, and the outer one only resumes on a later request.
* The [calls] verb answers both counts. */
static _Atomic uint32_t calls_queued;
static _Atomic uint32_t calls_valued;
/* Said once, in one place, and shipped to the daemon over [refusals] rather
* than written down again at the other end. A refusal is a sentence naming
* what actually happened, and the thing that actually happened is not "the
@ -437,6 +448,15 @@ static const uint8_t abandon_report[] =
* saved and restored around the call like [eval_boundary]. */
static sigjmp_buf *eval_escape;
/* Whether the game thread is inside an evaluated thunk's call, at any depth,
* rather than in the program's own code. A break records it, and it is what
* says whose break that is: a game loop that signals on its own while an
* evaluation is in flight stops exactly as a thunk would, and the stop
* counter cannot tell the two apart. Not [eval_boundary], which a class
* migration clears inside a thunk, nor [frame_floor], which it sets outside
* one. Game thread only, saved and restored around the call. */
static int in_thunk;
/* What the chains looked like when the evaluation was called, weak for the
* reason the frame walk below is: the runtime is linked into every program
* that links this, but not every build carries the dev and dyn halves. */
@ -505,6 +525,7 @@ static int migrate_call(void *fn, uint64_t instance, uint64_t added,
void flan_agent_run_reset(void) {
eval_boundary = NULL;
eval_escape = NULL;
in_thunk = 0;
restart_floor = 0;
frame_floor = -1;
}
@ -567,6 +588,7 @@ static _Atomic int aborting;
typedef struct {
int32_t gen; /* never reused, never 0 */
int32_t in_eval; /* stopped inside a thunk */
/* Whether *any* restart on this list can be taken, which is a property of
* the break and not of the restarts. [reachable] answers a different
* question — that one is per restart, and it is about the thunk boundary.
@ -773,6 +795,7 @@ static int snap_push(int resumable, void *cond) {
snapshot *s = &snaps[d];
int32_t n = flan_restart_count();
s->gen = ++snap_gen;
s->in_eval = in_thunk;
s->resumable = resumable;
s->cond = cond;
s->sitelen = 0;
@ -1310,6 +1333,7 @@ int32_t flan_agent_poll(void) {
* signal handler, and the jump leaves the handler. */
sigjmp_buf escape;
sigjmp_buf *oescape = eval_escape;
int othunk = in_thunk;
void *mh = NULL, *mr = NULL, *mf = NULL;
int32_t md = 0;
int64_t mroots = 0;
@ -1318,9 +1342,12 @@ int32_t flan_agent_poll(void) {
if (flan_dyn_root_mark) mroots = flan_dyn_root_mark();
uint64_t mctx[2] = { 0, 0 };
if (flan_context_save) flan_context_save(mctx);
in_thunk = 1;
if (sigsetjmp(escape, 1) == 0) {
eval_escape = &escape;
j.call();
if (j.call_id > atomic_load(&calls_valued))
atomic_store(&calls_valued, j.call_id);
} else {
if (flan_condition_stacks_restore) flan_condition_stacks_restore(mh, mr, md);
if (flan_dev_frames_restore) flan_dev_frames_restore(mf);
@ -1328,6 +1355,7 @@ int32_t flan_agent_poll(void) {
if (flan_context_load) flan_context_load(mctx);
}
eval_escape = oescape;
in_thunk = othunk;
/* Popped whichever way the thunk left — returning with a value, or
* unwinding past this frame because someone abandoned it. */
flan_restart_pop_c(eval_boundary);
@ -1903,10 +1931,23 @@ static void handle_line(char *line, sink *o) {
* of those have readers in flight and a reply format is a thing two ends
* agree on. Answered while running as well, for [status]'s reason: an
* editor polls this without knowing the state already. */
/* After the number, whose code stopped: "eval" when the thread was inside
* an evaluated thunk, "program" when it was in the program's own code. */
if (strcmp(line, "calls") == 0) {
char hdr[48];
int k = snprintf(hdr, sizeof hdr, "%u %u\n",
(unsigned)atomic_load(&calls_queued),
(unsigned)atomic_load(&calls_valued));
if (k > 0) emit(o, hdr, (size_t)k);
return;
}
if (strcmp(line, "stop") == 0) {
snapshot *s = (atomic_load(&depth) > 0) ? snap_top() : NULL;
char hdr[32];
int k = snprintf(hdr, sizeof hdr, "%d\n", s == NULL ? 0 : s->gen);
int k = s == NULL
? snprintf(hdr, sizeof hdr, "0\n")
: snprintf(hdr, sizeof hdr, "%d %s\n", s->gen,
s->in_eval ? "eval" : "program");
if (k > 0) emit(o, hdr, (size_t)k);
return;
}
@ -2179,7 +2220,9 @@ static void handle_line(char *line, sink *o) {
* is the failure being fixed. */
if (!publish((job){ .install = f, .call = c,
.handle = transient == NULL ? NULL : h,
.stopped_only = stopped_only, .at_stop = at_stop }))
.stopped_only = stopped_only, .at_stop = at_stop,
.call_id = c == NULL ? 0
: atomic_fetch_add(&calls_queued, 1) + 1 }))
fprintf(stderr, "flan: reload queue full after it was checked\n");
return;
}
@ -2459,17 +2502,49 @@ failed:
return -1;
}
/* The daemon's socket for this process, or NULL when there is none.
*
* FLAN_AGENT_SOCKET alone is not enough, because an environment is inherited:
* a shell started from inside a [flan dev] program, or anything that program
* starts, carries it too, and binding unlinks the path first, so such a
* process would take the session's socket from the program it belongs to. So
* the daemon also names the process it launched, in FLAN_AGENT_OWNER, and the
* path is honoured only there: the owner is this process in a merged build,
* where the launcher execs into the program, and this process's parent under
* --two-process, where the daemon started it. */
static const char *daemon_socket(void) {
const char *env = getenv("FLAN_AGENT_SOCKET");
const char *own = getenv("FLAN_AGENT_OWNER");
char *end;
long pid;
if (env == NULL || env[0] == '\0' || own == NULL || own[0] == '\0')
return NULL;
pid = strtol(own, &end, 10);
if (end == own || *end != '\0' || pid <= 0) return NULL;
if (pid == (long)getpid()) return env;
/* The parent only under --two-process, which is the one shape that sets
* FLAN_DEV_PARENT, and to the same pid. In a merged build the owner is the
* program itself, so a process it starts has the owner as its parent and
* must not take the socket. */
{
const char *par = getenv("FLAN_DEV_PARENT");
if (par != NULL && strcmp(par, own) == 0 && pid == (long)getppid())
return env;
}
return NULL;
}
/* [path] is a Flan string: ptr and len, not NUL-terminated.
*
* FLAN_AGENT_SOCKET overrides it. A program's source has to name some path,
* and the daemon that launches the program is the one that knows where it
* The daemon's socket overrides it (see [daemon_socket]). A program's source
* has to name some path, and the daemon that launches the program is the one that knows where it
* wants to talk to it — without the override the daemon would have to guess,
* and guessing wrong fails silently: everything compiles, the module is built,
* and nothing ever receives it. */
int32_t flan_agent_start(const uint8_t *path, int64_t len) {
char buf[sizeof(((struct sockaddr_un *)0)->sun_path)];
const char *env = getenv("FLAN_AGENT_SOCKET");
if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0;
const char *env = daemon_socket();
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
if (len <= 0 || (size_t)len >= sizeof buf) return -1;
memcpy(buf, path, (size_t)len);
buf[len] = '\0';
@ -2493,8 +2568,8 @@ int32_t flan_agent_start_auto(void) {
char path[sizeof(((struct sockaddr_un *)0)->sun_path)];
struct timespec ts;
int32_t r;
const char *env = getenv("FLAN_AGENT_SOCKET");
if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0;
const char *env = daemon_socket();
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
if (clock_gettime(CLOCK_REALTIME, &ts) != 0) ts.tv_nsec = 0;
snprintf(path, sizeof path, "/tmp/flan-agent-%ld-%08lx.sock",
(long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL));
@ -2511,11 +2586,11 @@ int32_t flan_agent_start_auto(void) {
/* And the call itself, gone. A program under [flan dev] that imports this
* package gets the listener before main, without asking.
*
* FLAN_AGENT_SOCKET is the whole condition, and it is the right one: the
* daemon sets it in both shapes — before the fork in --two-process, before the
* exec in the merged build — and nothing else on a machine sets it. So an
* ordinary run of an ordinary program falls straight through here and this
* costs it one getenv. (Not FLAN_DEV_PARENT, which is deliberately unset in
* [daemon_socket] is the condition: the daemon sets both of its variables in
* both shapes — before the fork in --two-process, before the exec in the
* merged build — so an ordinary run of an ordinary program falls straight
* through here, and so does a process that only inherited them. (Not
* FLAN_DEV_PARENT, which is deliberately unset in
* the merged build; gating on it would quietly skip half the daemon.)
*
* WHAT THIS DOES NOT REACH, because it is a fact about linking rather than a
@ -2540,8 +2615,8 @@ int32_t flan_agent_start_auto(void) {
* cannot, in either shape — it has an editor to hear from first, and a module
* to compile after that. */
__attribute__((constructor)) static void auto_start(void) {
const char *env = getenv("FLAN_AGENT_SOCKET");
if (env == NULL || env[0] == '\0') return;
const char *env = daemon_socket();
if (env == NULL) return;
/* The answer is dropped because there is nobody to give it to: this is ELF
* init, before main, before the program has decided anything. What matters
* is that a failure here is not final — [start_on] gives [started] back, so

12
web/index.html
View File

@ -842,8 +842,10 @@ is allocated. <code>(bytes-view s)</code> is the string's own storage seen as a
<code>[const u8]</code> and costs nothing; it aliases the string, and a store through
it is a compile error. <code>(bytes s)</code> and
<code>(bytes s allocator)</code> make a writable copy through the allocator — never a
hidden <code>malloc</code>, which is the rule every allocating operation follows. The
example above wants a view and takes one.</p>
hidden <code>malloc</code>, which is the rule every allocating operation follows.
<code>(free b)</code> hands the copy back to the current allocator and
<code>(free b allocator)</code> to the one named. The example above wants a view and
takes one.</p>
<p>An enum is an <code>i32</code> at run time and its own type in the checker. A
keyword at a call site resolves against the parameter's enum type at compile time, so a
@ -1275,13 +1277,14 @@ $t)} at the head of the body, or take the operation as a parameter — a
<p>What makes that liveable is a <code>where</code> clause, written as a Clojure-style
map at the head of the body — <code>{:where (ordered? $t)}</code>, or a vector when
there is more than one: <code>{:where [(ordered? $t) (hashable? $u)]}</code>. There
are five predicates, and each gates builtins the compiler already has:</p>
are six predicates, and each gates builtins the compiler already has:</p>
<div class="scroll">
<table>
<tr><th>Predicate</th><th>What it admits</th></tr>
<tr><td><code>integer?</code></td><td><code>bit-and</code> <code>bit-or</code> <code>bit-xor</code> <code>&lt;&lt;</code> <code>&gt;&gt;</code> — every integer type, no float</td></tr>
<tr><td><code>numeric?</code></td><td><code>+</code> <code>-</code> <code>*</code> <code>/</code> <code>%</code>, and a cast <code>(t x)</code></td></tr>
<tr><td><code>enum?</code></td><td>a cast to a number, <code>(i32 x)</code> — every enum type</td></tr>
<tr><td><code>ordered?</code></td><td><code>&lt;</code> <code>&lt;=</code> <code>&gt;</code> <code>&gt;=</code> <code>min</code> <code>max</code></td></tr>
<tr><td><code>equal?</code></td><td><code>=</code> and <code>!=</code></td></tr>
<tr><td><code>hashable?</code></td><td>the variable as a <code>Map</code> key — <code>(map-new t V)</code>, <code>get</code>, <code>put</code>, <code>has-key?</code></td></tr>
@ -1290,7 +1293,8 @@ are five predicates, and each gates builtins the compiler already has:</p>
<p>They entail each other in one direction, so one clause usually does:
<code>integer?</code> gives <code>numeric?</code>, <code>numeric?</code> gives
<code>ordered?</code>, and <code>ordered?</code> gives <code>equal?</code>. A
<code>ordered?</code>, and <code>ordered?</code> gives <code>equal?</code>;
<code>enum?</code> gives <code>ordered?</code> too. A
<code>sort</code> that compares its elements declares <code>ordered?</code> and
nothing else, and the prelude's <code>abs</code> declares <code>integer?</code>
alone — the bound is what keeps its integer body away from the floats, whose