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

Raylib runs, Heckin yeah

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-10 18:55:55 +07:00
parent 542e5d5fbc
commit 60a1928ee3
21 changed files with 1388 additions and 322 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

399
NEXT.md
View File

@ -1,11 +1,12 @@
# Where this is # Where this is
Milestones 2 and 3 of `plan.org` were merged: the interpreter was dropped Milestone 4 is done: **sand.flan builds, links raylib and runs**, and its
(open decision #7, settled — see below) and the compiled path is the only simulation has a headless acceptance case that runs on the `dune test` path at
backend. **calc-me.flan compiles and runs.** `-O0` and `-O2`. Milestones 2 and 3 are behind it (`calc-me.flan` compiles and
runs; the interpreter was dropped — open decision #7, settled, see below).
``` ```
reader ✅ → parse ✅ → check ✅ → emit ✅ → clang ✅ reader ✅ → parse ✅ → load ✅ → check ✅ → emit ✅ → clang ✅
``` ```
| File | What it does | | File | What it does |
@ -15,46 +16,184 @@ reader ✅ → parse ✅ → check ✅ → emit ✅ → clang ✅
| `lib/reader.ml` | hand-written S-expression reader, no menhir/ocamllex | | `lib/reader.ml` | hand-written S-expression reader, no menhir/ocamllex |
| `lib/ast.ml` | AST: `texpr`, `expr`, `place`, `pattern`, `decl` | | `lib/ast.ml` | AST: `texpr`, `expr`, `place`, `pattern`, `decl` |
| `lib/parse.ml` | forms → AST; special forms, desugaring, declarations | | `lib/parse.ml` | forms → AST; special forms, desugaring, declarations |
| `lib/load.ml` | **imports: a package directory → qualified declarations** |
| `lib/types.ml` | resolved types; structural equality, `Never` fits anywhere | | `lib/types.ml` | resolved types; structural equality, `Never` fits anywhere |
| `lib/tast.ml` | the typed IR the backend consumes | | `lib/tast.ml` | the typed IR the backend consumes |
| `lib/check.ml` | AST → typed IR; two passes, bidirectional | | `lib/check.ml` | AST → typed IR; two passes, bidirectional |
| `lib/prelude.ml` | `print-str`/`print-f64`/`print-line`, written in Flan | | `lib/prelude.ml` | printers + `rand-f32`, written in Flan |
| `lib/emit.ml` | typed IR → LLVM IR text | | `lib/emit.ml` | typed IR → LLVM IR text |
| `lib/build.ml` | `.ll` + the shim → clang → executable | | `lib/build.ml` | `.ll` + the shim + the packages' C → clang → executable |
| `runtime/flan_rt.c` | the whole host ABI: argv, stdout, exit, 4 conversions | | `runtime/flan_rt.c` | the host ABI: argv, stdout, exit, 4 conversions |
| `vendor/raylib/` | **the raylib package: `raylib.flan`, `shim.c`, `link`** |
| `sand-sim/` | **the falling-sand simulation, with no raylib in it** |
| `bin/main.ml` | `flan read \| parse \| check \| emit \| build \| run` | | `bin/main.ml` | `flan read \| parse \| check \| emit \| build \| run` |
| `test/test_flan.ml` | reader, parser and checker | | `test/test_flan.ml` | reader, parser and checker |
| `test/test_acceptance.ml` | 20 expression/result pairs + 3 whole programs + the traps | | `test/test_acceptance.ml` | expression/result pairs + whole programs + the traps |
| `test/programs/*.flan` | the milestone-2 surface calc-me does not reach |
``` ```
$ flan run calc-me.flan "1 + 2 * (3 - 0.5) / 2" $ flan run calc-me.flan "1 + 2 * (3 - 0.5) / 2"
3.5 3.5
$ flan run test/programs/sand-headless.flan
2256461126764447066
$ flan run sand.flan # a window, 120 fps, hold space
``` ```
`dune build && dune test` is green, and the whole-program cases run at `-O2` ## What milestone 4 added
*and* `-O0` — `mem2reg` launders a sloppy alloca, so -O0 is what tests the IR
actually emitted. `flan emit` is byte-reproducible. `flan check sand.flan` fails on **`dotimes`** desugars in `check.ml` to a `Let` plus a `While` — no new IR node.
`(import rl ...)`, which is milestone 4 — as it should. The bound is evaluated once into a hidden slot before the loop, so a body that
changes it cannot change the trip count, and the loop variable is not
assignable, which makes the generated step its only writer.
**`defer`** is recognised in `check_fn` and nowhere else, because that is the
only place that knows a form is at the top level of a function body. Each one
is checked in place, then registered on the context; it emits nothing where it
stands. Function exit runs them innermost-first, and an explicit `return` runs
the ones registered *above* it — a defer written below a return has not
executed yet and must not fire. A trap runs none of them, which follows from
the bounds-check shape (`noreturn` then `unreachable`) rather than being a
separate decision.
`defer` inside a `let`, a loop or a branch is **rejected**, not accepted with
function scope. It would run once at function exit rather than once per
iteration, and that is the silent-wrongness class the rule below is about.
Block-scoped defer is real work and is not done.
**New builtins:** `zeroed` (takes its type from the place it is stored into),
`min`/`max` (each operand through a slot, so neither is evaluated twice),
`bit-and`/`bit-or`/`bit-xor`/`<<`/`>>` (integers only; `>>` is arithmetic on a
signed type and logical on an unsigned one), and `rand-f32`.
**`rand-f32` is in the prelude, in Flan** — PCG-XSH-RR 32 over a `u64` state.
It is not libc's, because a grid hash is only a regression test if the sequence
is byte-identical on native and wasm32 (plan.org, RNG is ours). `rand-seed`
sets the state. This is what the bitwise operators were added for.
**Enums and keywords.** `(defenum Name [member value ...])` gives a type that
is an `i32` at run time and its own type in the checker, so `:space` at a call
site resolves against the parameter's enum and a typo is an error there rather
than a wrong number later. A keyword means nothing where no enum is expected —
there is no keyword type to fall back on.
## Why the FFI goes through a C shim
The decision that shapes the whole raylib package. What clang generates for
raylib's own prototypes on x86-64:
```
Vector2 {float,float} → declare <2 x float> @GetMousePosition()
Color {u8,u8,u8,u8} → declare void @ClearBackground(i32)
Rectangle {4 × int} → declare { i64, i64 } @mkrect()
```
None of those is the struct's own LLVM type. A small aggregate's calling
convention is not part of its layout — it is a per-target classification the
*caller* has to reproduce, and x86-64, arm64 and wasm32 classify differently.
Putting that in `emit.ml` is three classifiers to write and then keep correct
forever, and a mistake shows up as `(.y m)` returning garbage rather than as a
link error.
So `vendor/raylib/shim.c` has one wrapper per binding, each one flattening the
aggregates: a struct returns through an out-pointer, a struct argument is
passed by pointer, a Flan string crosses as ptr+len and the shim NUL-terminates
a copy. clang classifies all of it, per target, for free. `check.ml` enforces
the rule — an aggregate in a `declare` signature is rejected with the reason —
so the boundary cannot quietly acquire one. This is plan.org's "one narrow host
ABI, implemented twice", and `flan_rt.c` is the same pattern.
The price is a hand-written wrapper per raylib call. They are one-liners and
mechanical enough to generate if that ever becomes the bottleneck.
`raylib.flan` declares each `-raw` entry point and wraps it in an ordinary Flan
function just below, so the surface sand.flan sees is `(rl/get-mouse-position)`
returning a `Vector2`. Verified end to end, headless: `GetColor(0x11223344)`
comes back as `17 34 51 68`, four separate bytes — a `Color` is *not* the
little-endian reading of the packed integer, so an identity would have passed a
weaker test. That case is in the acceptance table, skipped if `libraylib` is
not installed.
No raylib headers are needed: `shim.c` declares the prototypes it uses, so the
build depends on the shared library being linkable and not on `raylib-devel`.
`vendor/raylib/link` carries `-l:libraylib.so.550` because Fedora ships the
runtime library without the `.so` symlink.
## Packages
`lib/load.ml` resolves `(import rl "vendor:raylib")` before the checker runs.
The directory is the package; `vendor:` is a collection, resolved by walking up
from the importing file until a directory of that name is found; a path with no
collection is relative to the importing file. Importing is a **rename**: every
top-level name the package declares becomes `alias/name`, and every use of one
— in a type, in a body, in a struct literal, in an *array length* — is
rewritten to match. Local bindings shadow. Nothing downstream knows a package
existed; the checker sees one flat list of declarations whose names contain a
slash.
A package may also carry the C it binds to: every `.c` file in the directory is
compiled into the build, and a file named `link` lists extra linker arguments.
This is not a module system yet. No visibility (hence `rl/get-color-raw` being
callable), no cycle detection, and a package cannot import another one.
## sand.flan is two programs
plan.org wants sand tested twice — interactive at 120 fps, and headless over N
frames with the grid hashed, the version CI runs on native *and* wasm32. Those
cannot be one binary: `Load` collects a package's C sources and linker
arguments unconditionally, so anything importing the raylib package links
libraylib on every target regardless of what its `main` does, and on wasm32
that link cannot succeed.
So the simulation moved to `sand-sim/`, which imports nothing. `sand.flan`
imports it as `sim/` and adds the window, the mouse and the drawing;
`test/programs/sand-headless.flan` imports it and adds a seed, four
deterministic clouds, 40 frames and an FNV-1a hash. One copy of the physics.
The headless case is what actually *verifies* milestone 4 — running the
interactive build only proves it enters its loop, because with no mouse input
the grid stays empty and `paint-at`, `settle` and `move-grain` never execute on
real data. Measured through the probe: 168 grains painted around row 4–8, still
168 after 40 frames, lowest occupied row 68. Grains fall, and none are lost.
**Three edits were made to sand.flan's own text**, and they are language
decisions rather than fixes:
- `(defconst gravity 0.05)` → `(defconst gravity f32 0.05)`. An untyped float
constant is `f64`, `velocity` is `[f32]`, and there is no implicit widening.
- `(defvar current-color u32)` → `i32`. It is an index into `colors`, and
`(len colors)` is an `i32`.
- The file was split as above, so its body now says `sim/rows` and so on.
`(defn main [])` is unchanged — the short form, as plan.org says.
## Bounds checks — done at milestone 3
`at` and `slice` emit `icmp` → `br` → cold block → `call` → `unreachable`; a
failure names the source location. Three check sites: `at` on `[n T]` (static
bound, folded by LLVM for a literal index — and a literal that is out of bounds
never reaches emit, `check.ml` rejects it), `at` on a slice or string (runtime
len), and `slice` (two comparisons — `lo <= hi` is not redundant, without it a
reversed range yields a huge unsigned length). All comparisons unsigned.
`Build.opts.checks` is on by default and **not** tied to `opts.opt`, which is
what lets the acceptance table run the same programs at `-O0` and `-O2` with
identical checks. The flag is `--no-bounds-checks`.
The write path is its own case: `(set (at arr n) …)` lowers through
`place`/`Pindex`, not through `At`, so a refactor that split them would break
the write check silently. The test covers both.
Cost, measured: a 50M-iteration dependency chain over a 1024-element array runs
at 0.11–0.12s checked against 0.12–0.13s unchecked. Indistinguishable.
## Why there is no interpreter ## Why there is no interpreter
Open decision #7 is settled: **the compiled path is the only backend.** The two Open decision #7 is settled: **the compiled path is the only backend.** Both
arguments for a permanent interpreter had both already expired in `plan.org` — arguments for a permanent interpreter had expired — the instrumentation step
the instrumentation step debugger that wanted it is cut, and compiled debugger that wanted it is cut, and compiled redefinition measured at ~16ms,
redefinition measured at ~16ms, which is perceptually instant for expression perceptually instant for expression eval too. Milestone 3 did not need an
eval too. CCL and SBCL both do full interactive development without leaning on oracle either: the acceptance table is hand-written, so the table *is* the
an interpreter; what makes a live image work is a fast compiler callable at oracle. Consequences already applied: milestone 2's "interpreted calls per
runtime. second" criterion is dropped, and the host ABI moved onto the critical path.
The remaining argument was that milestone 3 needs an oracle to check the
compiler against. It does not: the acceptance test is a hand-written table of
expression/result pairs, so the table *is* the oracle.
Consequences, both already applied: milestone 2's "measured interpreted calls
per second" exit criterion is dropped — milestone 4 runs on the compiled build
and nothing depended on that number — and the host ABI moved onto the critical
path, which is why `runtime/flan_rt.c` exists now rather than at milestone 3.
## The layout, which is the whole backend design ## The layout, which is the whole backend design
@ -62,6 +201,7 @@ path, which is why `runtime/flan_rt.c` exists now rather than at milestone 3.
i8..i64 / u8..u64 i8..i64 signedness lives in the ops i8..i64 / u8..u64 i8..i64 signedness lives in the ops
f32 f64 float double f32 f64 float double
bool i1 bool i1
an enum i32
[T] and string { ptr, i64 } ptr+len, non-owning [T] and string { ptr, i64 } ptr+len, non-owning
[n T] [n x T] inline, a value [n T] [n x T] inline, a value
(Ptr T) ptr opaque pointers (Ptr T) ptr opaque pointers
@ -75,91 +215,38 @@ nothing marshals. Two consequences carry the semantics:
- **Every slot is an `alloca`.** Reading a local is a `load`, assigning is a - **Every slot is an `alloca`.** Reading a local is a `load`, assigning is a
`store`, and a `store` of an aggregate *is* the copy `spec-memory.md` `store`, and a `store` of an aggregate *is* the copy `spec-memory.md`
requires — value structs and fixed arrays copy, a slice copies only its view. requires. `addr` of a local is then just the alloca, and `mem2reg` removes
`addr` of a local is then just the alloca, and `mem2reg` removes the ones the ones nobody addressed. `test/programs/values.flan` pins this down.
nobody addressed. `test/programs/values.flan` pins this down: mutate the
original, the copy is unchanged.
- **A place is a pointer, a value is a load from it.** `(set (.pos c) …)` - **A place is a pointer, a value is a load from it.** `(set (.pos c) …)`
through a `(Ptr Cursor)` becomes a `getelementptr` on the pointer, not on a through a `(Ptr Cursor)` becomes a `getelementptr` on the pointer, not on a
copy. This is the split that would have made a tree-walker silently wrong. copy. This is the split that would have made a tree-walker silently wrong.
Non-local exit is lowered explicitly: `return` and `some` are branches to a Non-local exit is lowered explicitly: `return`, `some` and a failed bounds
`ret`, never platform unwinding, so wasm32 needs no exception proposal. check are branches, never platform unwinding, so wasm32 needs no exception
proposal.
## Bounds checks — done ## Sharp edges found and left visible
`at` and `slice` no longer emit a bare `getelementptr`. A failure is a branch - **An index converts from a narrower integer and never from a wider one.**
to a `noreturn cold` call and then `unreachable` — the same explicit shape as `(nth colors current-color)` with a `u32` index works — anything above 2³¹
`return` and `some`, so wasm32 needs nothing extra for it either. The message truncates to a negative `i32` and the unsigned bounds check rejects it. An
carries the source location, because `Tast.expr` keeps a `Loc.t` and a language `i64` index is refused with the reason: 2³²+5 truncates to 5 and would read
that threads locations through the whole frontend should not trap anonymously: the wrong element with no trap at all.
- **A `u64` literal is its 64-bit pattern**, so `0xcbf29ce484222325` is a real
``` `u64` and not an error. The cost is that a negative *decimal* literal is
$ flan run test/programs/bounds.flan 2 accepted as a `u64` too, because the reader records the value and not how it
test/programs/bounds.flan:25:29: slice [2 1) is out of bounds for length 5 (exit 134) was written. Narrower unsigned types keep the strict check, which is where a
``` typo like `300` for a `u8` actually shows up.
- **A folded constant skips `check`.** `(defconst rows (/ h c))` is emitted
Three check sites, and the third is the one with the trap in it: from the folding pass's value, because a global's initialiser has to be a
compile-time constant and only that pass knows this one is. Its range check
- **`at` on `[n T]`** — the bound is static, so LLVM folds the check away for a is therefore its own call to `in_range`; there is a regression test.
literal index. A literal that is *out* of bounds never reaches emit at all: - A `let` binding takes no type annotation, which is why `sand-sim` names its
`check.ml` rejects it, along with a negative literal index (wrong whatever FNV constants instead of writing them inline.
the target) and a literal `slice` range that runs backwards. Only literals — - `(defn f [] f65 0.0)` still says *unknown name* rather than *did you mean
a `defconst` is a global in the typed IR, not a folded constant, so f64*: with a single body form the parser cannot tell a return type from the
`(at a k)` stays a runtime trap. A slice bound may sit one past the end and first expression. Only the parameter position and `(Option …)` are
an index may not, which is the one place the two rules differ. unambiguous.
- **`at` on a slice or string** — the bound is the runtime len.
- **`slice`** — *two* comparisons, `lo <= hi` and `hi <= len`, both non-strict
because a slice ending at len (or an empty one at `lo = len`) is legal and
its one-past-the-end gep is defined. `lo <= hi` is not redundant: without it
a reversed range yields `hi - lo` as a huge unsigned length, which is a worse
hole than the missing check was.
All comparisons are unsigned. Indices are i32 sign-extended to i64 for the gep,
so a negative one arrives as a huge unsigned value and one test catches both
directions; the runtime still prints the signed value in the message.
`Build.opts.checks` is on by default and **is not tied to `opts.opt`** — dev
traps, release does not, and that is a release decision rather than an
optimisation one. Keeping them separate is what lets the acceptance table go on
running the same programs at `-O0` and `-O2` with identical checks. The CLI
flag is `--no-bounds-checks`, on `build` and `emit`.
The write path is its own case. `(set (at arr n) …)` lowers through
`place`/`Pindex`, not through `At`, so a refactor that split them would break
the write check silently — the test covers both.
`test/programs/bounds.flan` is one program with one case per argument, because
a trap ends the process. The acceptance test asserts the exit code, that the
message names the file, and the reason — but not line and column, so editing
the program does not break the test that reads it. It runs at both `-O0` and
`-O2`, and one more case checks the IR directly: `--no-bounds-checks` emits no
`call` to either failure function. (The two `declare`s stay in the header
unconditionally; LLVM drops the unused ones.)
## The IR, inspected
Verified by reading `flan emit` output rather than by trusting the tests:
- Every check site is `icmp` → `br` → cold block → `call` → `unreachable`. The
verifier accepts it; no dominance or phi problems.
- `-O2` folds the two literal-index checks in `bounds.flan` and keeps the other
seven, which is exactly the intent.
- **A redundant check is not eliminated, and `index_ty` is why.** calc-me's
`peek` already guards with `(< (.pos c) (len (.src c)))`, yet the bounds check
survives `-O2`. `len` truncates the i64 length to i32 and the index is a
*signed* i32, so the guard emits `icmp slt i32 %pos, (trunc %len)` while the
check emits `icmp ult i64 (sext %pos), %len`. LLVM cannot bridge those and is
right not to: the trunc loses bits above 2³¹, and `slt` does not imply
`pos >= 0`. Lengths as i64, or unsigned indices, would let the two merge —
but that is `index_ty`, a plan.org-level decision, so it is left alone.
- Cost, measured: a 50M-iteration serial dependency chain over a 1024-element
array, argv-seeded so nothing folds, runs at 0.11–0.12s checked against
0.12–0.13s unchecked. Indistinguishable. The branch predicts perfectly and
the loop is latency-bound.
- Cosmetic: the fail block is emitted *before* the continuation block, so at
`-O0` the cold path sits inline in the hot path. `cold` plus LLVM's block
placement fixes it at `-O2`; nothing fixes it at `-O0`.
## Where build time goes ## Where build time goes
@ -167,83 +254,51 @@ Verified by reading `flan emit` output rather than by trusting the tests:
| Step | Cost | | Step | Cost |
|---|---| |---|---|
| frontend: read → parse → check → emit | <10ms, below the timer | | frontend: read → parse → load → check → emit | <10ms, below the timer |
| `clang` on the `.ll` | 60ms — `llc` does the same codegen in **20ms** | | `clang` on the `.ll` | 60ms — `llc` does the same codegen in **20ms** |
| `clang` on `flan_rt.c` | 40ms — recompiled every build, and it never changes | | `clang` on `flan_rt.c` | 40ms — recompiled every build, never changes |
| link | 20ms | | link | 20ms |
Two cheap wins take it to ~60ms: cache `flan_rt.o`, and skip the clang driver sand.flan additionally recompiles `shim.c` every build. Two cheap wins take the
for the `.ll` (`llc` + link directly). This reproduces plan.org's own base to ~60ms: cache `flan_rt.o` (and the packages' `.o`), and skip the clang
measurement — the driver is the cost, not codegen — and it is a subset of the driver for the `.ll` (`llc` + link directly). Both are a subset of the dev
dev path's machinery, so doing it now is not wasted work. path's machinery, so doing them now is not wasted work.
**There is still no REPL.** Nothing in `lib/` or `bin/` does redefinition, **There is still no REPL.** Nothing does redefinition, `dlopen`, or nREPL.
`dlopen`, or nREPL; `build.ml`'s docstring describes the dev path and says `build` is the only way to run code.
nothing at milestone 2 needs it yet. `build` is the only way to run code, so
its 140ms is what you actually pay.
## Diagnostics
A lowercase name is a type variable (plan.org, Types), which meant a mistyped
primitive — `f65` for `f64` — was reported as *unimplemented generics, see
plan.org*, sending you to the plan instead of to the character you mistyped.
`resolve_name` now tries `near_miss` first: one edit (substitution, insertion,
deletion, or a transposed pair) against the primitives, aliases, structs and
unions. Bounded at one edit, because two is a guess, and because a real
single-letter type variable like `t` must still reach the milestone-5 message.
```
(defn f [x f65]) unknown type f65 — did you mean f64?
(defn f [x stirng]) unknown type stirng — did you mean string?
(defn f [x t]) generic code over the type variable t … milestone 5
(defn f [x Widget]) unknown type Widget
```
`Types.primitive_names` exists now because the list had only ever been match
arms. Caveat found while testing: a bare `(defn f [] f65 0.0)` says *unknown
name* instead, because with a single body form the parser cannot tell a return
type from the first expression. Only the parameter position and `(Option …)`
are unambiguous.
## Next ## Next
Recommended order — start with milestone 4; wasm32 needs a system install only 1. **wasm32.** The user installed `wasi-libc-devel` and `wasi-libc-static`; the
you can authorize, and the REPL is worth more once there is a frame loop for it sysroot is `/usr/wasm32-wasi` and `wasm-ld` is present. `clang
to not stutter. --target=wasm32-wasi --sysroot=/usr/wasm32-wasi` gets past the headers and
then **fails to link**: it wants
1. **Milestone 4 — sand.flan.** `dotimes`, `defer`, and typed raylib FFI with `lib/clang/20/lib/wasm32-unknown-wasi/libclang_rt.builtins.a`, which no
keyword→enum coercion. Fixed 2-D arrays are done. `flan check sand.flan` Fedora package provides (`dnf provides '*libclang_rt.builtins*wasm*'` finds
already fails on `(import rl ...)`, as it should. FFI is the part most likely nothing). It has to come from a wasi-sdk release, dropped into clang's
to expose layout bugs the calc-me surface cannot reach. resource directory. After that: teach `build.ml` `--sysroot`, and run the
2. **wasm32.** The backend is there (`llc` lists `wasm32`) and acceptance table — `sand-headless.flan` included, which is exactly why it
`Build.opts.target` already plumbs `--target`, but there is **no wasi does not import raylib — on both targets in CI.
sysroot on this machine** — `clang --target=wasm32-wasi` cannot find Note plan.org has the *web* build linking raylib via emscripten, which
`stdio.h`. Install `wasi-sdk`/`wasi-libc` (`dnf search wasi` for the Fedora brings its own sysroot: wasi-sdk is right for the headless table, not
package name), then run the same acceptance table on both targets in CI. necessarily for the eventual game build.
That is milestone 3's real remaining work. The bounds work above was written 2. **The dev path / REPL.** `llc` + `ld -shared` + `dlopen` ≈ 16ms, a compiler
to survive the port — no unwinding, and `exit(134)` rather than `abort()`, daemon plus an in-game reload agent (plan.org, Dev architecture). There is
so the same trap assertion should hold on wasm32 — but that is intent, not a now a frame loop for it to not stutter, which was the reason to do it after
tested result: nothing here has ever been built for wasm32. milestone 4.
WASI is the syscall interface wasm has to import to get stdout, argv and 3. **Loose ends from milestone 4**, none of them blocking: block-scoped
exit at all; `flan_rt.c` calls libc (`fwrite`, `snprintf`, `strtod`, `defer`; package visibility, so `rl/get-color-raw` is not callable; a
`malloc`), so it needs `wasi-libc`. The alternative is a second freestanding package importing a package; imported unions.
shim that imports host functions directly and links no libc — which is what
"one narrow host ABI, implemented twice" points at, and the ABI is small
enough to make it plausible. Note plan.org has the *web* build linking
raylib via emscripten, which brings its own sysroot: wasi-sdk is right for
the headless acceptance table, not necessarily for the eventual game build.
3. **The dev path / REPL.** `llc` + `ld -shared` + `dlopen` ≈ 16ms, a compiler
daemon plus an in-game reload agent (plan.org, Dev architecture). The build
wins above are a down payment on this.
## Watch for ## Watch for
The rule that caught the two misparse bugs applies unchanged: **anything that The rule that caught the two misparse bugs applies unchanged: **anything that
binds a name, alters control flow, or is not yet implemented must be recognised binds a name, alters control flow, or is not yet implemented must be recognised
explicitly and rejected if unsupported.** `check.ml` rejects `Vec`, `Map`, explicitly and rejected if unsupported.** `check.ml` rejects `Vec`, `Map`,
`Result`/`try`, union values, closures, `dotimes`, `defer`, keywords at call `Result`/`try`, union values, closures, quoted symbols, generics and function
sites, imports, generics and function values *by name*, each with the milestone values *by name*, each with the milestone it belongs to; `load.ml` rejects the
it belongs to. The tests assert on the reason, not just on the failure. package shapes it does not handle; and the FFI boundary rejects an aggregate.
The tests assert on the reason, not just on the failure.
## Untracked on purpose ## Untracked on purpose

41
bin/main.ml
View File

@ -17,12 +17,24 @@ let summarise (d : Flan.Ast.decl) =
| Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs) | Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs)
| Defvar (n, _, _) -> Printf.sprintf "defvar %s" n | Defvar (n, _, _) -> Printf.sprintf "defvar %s" n
| Defconst (n, _, _) -> Printf.sprintf "defconst %s" n | Defconst (n, _, _) -> Printf.sprintf "defconst %s" n
| Declare (fn, csym) ->
Printf.sprintf "declare %s (%d params) = %s" fn.name (List.length fn.params)
csym
| Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms)
| Defn fn -> | Defn fn ->
Printf.sprintf "defn %s (%d params, %s return, %d body forms)" Printf.sprintf "defn %s (%d params, %s return, %d body forms)"
fn.name (List.length fn.params) fn.name (List.length fn.params)
(match fn.ret with None -> "Unit" | Some _ -> "explicit") (match fn.ret with None -> "Unit" | Some _ -> "explicit")
(List.length fn.fbody) (List.length fn.fbody)
(* Every path past [parse] goes through [Load]: an import is resolved into the
declarations it stands for, and the package's C shim and linker arguments
come back with them. *)
let load path : Flan.Load.t =
Flan.Load.program ~file:path (Flan.Parse.program (Flan.Reader.read_file path))
let checked path = Flan.Check.program (load path).decls
(* Bounds checks are on unless a build asks for them off — the release (* Bounds checks are on unless a build asks for them off — the release
decision, not the optimisation level (NEXT.md, Bounds checks). *) decision, not the optimisation level (NEXT.md, Bounds checks). *)
let no_checks_flag = "--no-bounds-checks" let no_checks_flag = "--no-bounds-checks"
@ -48,11 +60,7 @@ let () =
List.iter List.iter
(fun path -> (fun path ->
with_errors path (fun () -> with_errors path (fun () ->
let p = let p = checked path in
Flan.Reader.read_file path
|> Flan.Parse.program
|> Flan.Check.program
in
List.iter List.iter
(fun (g : Flan.Tast.global) -> (fun (g : Flan.Tast.global) ->
Printf.printf "%s %s %s\n" Printf.printf "%s %s %s\n"
@ -73,11 +81,7 @@ let () =
List.iter List.iter
(fun path -> (fun path ->
with_errors path (fun () -> with_errors path (fun () ->
Flan.Reader.read_file path checked path |> Flan.Emit.program ~checks |> print_string))
|> Flan.Parse.program
|> Flan.Check.program
|> Flan.Emit.program ~checks
|> print_string))
files files
| _ :: "build" :: path :: rest -> | _ :: "build" :: path :: rest ->
let checks = not (List.mem no_checks_flag rest) in let checks = not (List.mem no_checks_flag rest) in
@ -91,22 +95,19 @@ let () =
exit 2 exit 2
in in
with_errors path (fun () -> with_errors path (fun () ->
Flan.Reader.read_file path let l = load path in
|> Flan.Parse.program let p = Flan.Check.program l.decls in
|> Flan.Check.program ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks }
|> fun p -> ~csrcs:l.csrcs ~lflags:l.lflags p ~out))
ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks } p ~out))
| _ :: "run" :: path :: args -> | _ :: "run" :: path :: args ->
with_errors path (fun () -> with_errors path (fun () ->
let exe = let exe =
Filename.concat (Filename.get_temp_dir_name ()) Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-run-%d" (Unix.getpid ())) (Printf.sprintf "flan-run-%d" (Unix.getpid ()))
in in
Flan.Reader.read_file path let l = load path in
|> Flan.Parse.program let p = Flan.Check.program l.decls in
|> Flan.Check.program ignore (Flan.Build.executable ~csrcs:l.csrcs ~lflags:l.lflags p ~out:exe);
|> fun p ->
ignore (Flan.Build.executable p ~out:exe);
let code = let code =
Sys.command (String.concat " " (List.map Filename.quote (exe :: args))) Sys.command (String.concat " " (List.map Filename.quote (exe :: args)))
in in

7
lib/ast.ml
View File

@ -94,6 +94,13 @@ and decl_kind =
| Defstruct of string * field list | Defstruct of string * field list
| Defunion of string * variant list | Defunion of string * variant list
| Defn of fn | Defn of fn
(* No body, so no [defn]: a foreign function, and the string is the C symbol
it is actually called by (plan.org, Types — [declare] is kept only where
there is no body). *)
| Declare of fn * string
(* Inline name/value pairs, as everywhere else. The members are what a
keyword at a call site resolves against. *)
| Defenum of string * (string * int64) list
(* value is optional: ZII. `uninit` opts out and is recorded as Uninit. *) (* value is optional: ZII. `uninit` opts out and is recorded as Uninit. *)
| Defvar of string * texpr option * init | Defvar of string * texpr option * init
| Defconst of string * texpr option * expr | Defconst of string * texpr option * expr

11
lib/build.ml
View File

@ -38,7 +38,11 @@ type opts = {
checks. Dropping them is a release decision, not an optimisation one. *) checks. Dropping them is a release decision, not an optimisation one. *)
let default = { target = None; opt = "-O2"; keep = false; checks = true } let default = { target = None; opt = "-O2"; keep = false; checks = true }
let executable ?(opts = default) (p : Tast.program) ~out = (* [csrcs] and [lflags] come from the imported packages (see [Load]): the C
shim a package binds through, and the arguments needed to link the library
it binds to. *)
let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
(p : Tast.program) ~out =
let dir = workdir () in let dir = workdir () in
let ll = Filename.concat dir (Filename.basename out ^ ".ll") in let ll = Filename.concat dir (Filename.basename out ^ ".ll") in
let rt = Filename.concat dir "flan_rt.c" in let rt = Filename.concat dir "flan_rt.c" in
@ -48,7 +52,10 @@ let executable ?(opts = default) (p : Tast.program) ~out =
String.concat " " String.concat " "
([ Filename.quote clang; opts.opt; "-Wno-override-module" ] ([ Filename.quote clang; opts.opt; "-Wno-override-module" ]
@ (match opts.target with None -> [] | Some t -> [ "--target=" ^ t ]) @ (match opts.target with None -> [] | Some t -> [ "--target=" ^ t ])
@ [ Filename.quote ll; Filename.quote rt; "-o"; Filename.quote out ]) @ [ Filename.quote ll; Filename.quote rt ]
@ List.map Filename.quote csrcs
@ lflags
@ [ "-o"; Filename.quote out ])
in in
let code = Sys.command cmd in let code = Sys.command cmd in
if code <> 0 then if code <> 0 then

284
lib/check.ml
View File

@ -47,6 +47,12 @@ type env = {
aliases : (string, Ast.texpr) Hashtbl.t; aliases : (string, Ast.texpr) Hashtbl.t;
consts : (string, int64) Hashtbl.t; (* compile-time array lengths *) consts : (string, int64) Hashtbl.t; (* compile-time array lengths *)
locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *) locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *)
(* Enum name -> its members, in declaration order. A keyword at a call site
resolves against this and nothing else. *)
enums : (string, (string * int64) list) Hashtbl.t;
(* Flan name -> the C symbol it is really called by. A foreign function is an
ordinary entry in [fns] as well; this only records how to name it. *)
externs : (string, string) Hashtbl.t;
fns : (string, Types.t list * Types.t) Hashtbl.t; fns : (string, Types.t list * Types.t) Hashtbl.t;
globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *) globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *)
} }
@ -57,6 +63,8 @@ let new_env () = {
aliases = Hashtbl.create 16; aliases = Hashtbl.create 16;
consts = Hashtbl.create 16; consts = Hashtbl.create 16;
locs = Hashtbl.create 16; locs = Hashtbl.create 16;
enums = Hashtbl.create 8;
externs = Hashtbl.create 32;
fns = Hashtbl.create 32; fns = Hashtbl.create 32;
globals = Hashtbl.create 16; globals = Hashtbl.create 16;
} }
@ -71,6 +79,10 @@ type ctx = {
frame — nothing else records it, since the IR refers to slots by index. *) frame — nothing else records it, since the IR refers to slots by index. *)
mutable slot_tys : Types.t list; mutable slot_tys : Types.t list;
mutable scope : (string * binding) list; (* innermost first *) mutable scope : (string * binding) list; (* innermost first *)
(* Deferred forms, most recently registered first — which is also the order
they run in. At milestone 4 [defer] is function-scoped (see [check_fn]),
so this list belongs to the function and not to a block. *)
mutable defers : Tast.expr list;
} }
let fresh_slot ctx ty = let fresh_slot ctx ty =
@ -148,6 +160,7 @@ and near_miss env n =
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.aliases [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.aliases []
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.structs [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.structs []
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.unions [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.unions []
@ Hashtbl.fold (fun k _ acc -> k :: acc) env.enums []
in in
List.find_opt (fun c -> c <> n && one_edit n c) candidates List.find_opt (fun c -> c <> n && one_edit n c) candidates
@ -169,6 +182,7 @@ and resolve_name env ~seen loc n =
else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n) else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n)
| _ when Hashtbl.mem env.structs n || Hashtbl.mem env.unions n -> | _ when Hashtbl.mem env.structs n || Hashtbl.mem env.unions n ->
Types.Named n Types.Named n
| _ when Hashtbl.mem env.enums n -> Types.Enum n
(* A typo in a primitive is lowercase too, and the type-variable rule (* A typo in a primitive is lowercase too, and the type-variable rule
below would otherwise report [f65] as unimplemented generics and send below would otherwise report [f65] as unimplemented generics and send
you to plan.org instead of to the character you mistyped. *) you to plan.org instead of to the character you mistyped. *)
@ -245,8 +259,27 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
in in
mk loc (Types.Float k) (Tast.Float (x, k)) mk loc (Types.Float k) (Tast.Float (x, k))
| Ast.Str s -> expect loc ~want (mk loc Types.String (Tast.Str s)) | Ast.Str s -> expect loc ~want (mk loc Types.String (Tast.Str s))
| Ast.Kw _ -> | Ast.Kw k ->
unimplemented loc "a keyword at a call site (keyword->enum coercion)" 4 (* A keyword resolves at compile time against the enum the site expects,
and a typo is an error here rather than a wrong number at run time
(plan.org, settled: keywords at typed call sites). It has no meaning
without that expectation — there is no keyword type to fall back on. *)
(match want with
| Some (Types.Enum name) ->
let members = Hashtbl.find ctx.env.enums name in
(match List.assoc_opt k members with
| Some v -> mk loc (Types.Enum name) (Tast.Int (v, Types.I32))
| None ->
fail loc "%s has no member :%s — it has %s" name k
(String.concat " "
(List.map (fun (m, _) -> ":" ^ m) members)))
| Some other ->
fail loc ":%s is an enum member, but %s is expected here" k
(Types.to_string other)
| None ->
fail loc
":%s only means something where an enum type is expected — there is \
no keyword type" k)
| Ast.Quote _ -> | Ast.Quote _ ->
unimplemented loc "a quoted symbol (restart names)" 6 unimplemented loc "a quoted symbol (restart names)" 6
| Ast.Var name -> var ctx loc ~want name | Ast.Var name -> var ctx loc ~want name
@ -267,7 +300,12 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
None None
| Some v -> Some (check ctx ~want:ctx.ret v) | Some v -> Some (check ctx ~want:ctx.ret v)
in in
mk loc Types.Never (Tast.Return v) (* Whatever has been deferred *so far* runs first: a defer written below
this return has not executed yet and must not fire. *)
let r = mk loc Types.Never (Tast.Return v) in
(match ctx.defers with
| [] -> r
| ds -> mk loc Types.Never (Tast.Do (ds @ [ r ])))
| Ast.Set (p, v) -> | Ast.Set (p, v) ->
let p, pty = check_place ctx loc p in let p, pty = check_place ctx loc p in
let v = check ctx ~want:pty v in let v = check ctx ~want:pty v in
@ -301,8 +339,15 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
Option; this one returns %s" (Types.to_string other)) Option; this one returns %s" (Types.to_string other))
| Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6 | Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6
| Ast.Fn _ -> unimplemented loc "fn values" 5 | Ast.Fn _ -> unimplemented loc "fn values" 5
| Ast.Dotimes _ -> unimplemented loc "dotimes" 4 | Ast.Dotimes (name, count, body) -> check_dotimes ctx ~want loc name count body
| Ast.Defer _ -> unimplemented loc "defer" 4 | Ast.Defer _ ->
(* Registered by [check_fn], which is the only place that sees a form's
position. A defer anywhere else would run at function exit rather than
at the exit of the block it is written in — once for a loop body that
runs a thousand times — so it is rejected instead of quietly differing. *)
fail loc
"defer must be a top-level form in a function body — block-scoped defer \
is not implemented yet (milestone 4)"
and int_literal loc ~want ?(default = Types.I32) n = and int_literal loc ~want ?(default = Types.I32) n =
match want with match want with
@ -325,9 +370,18 @@ and in_range loc k n =
bits = 64 bits = 64
|| (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0 || (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0
&& Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0) && Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0)
else if bits = 64 then
(* A u64 literal is its 64-bit pattern, so anything at or above 2^63
arrives here as a negative [int64] and is still in range —
0xcbf29ce484222325 is a real u64 and not an error. The cost is that a
negative *decimal* literal is accepted as a u64 too, because the
reader records only the value and not how it was written. Narrower
unsigned types keep the strict check, which is where a typo like 300
for a u8 actually shows up. *)
true
else else
Int64.compare n 0L >= 0 Int64.compare n 0L >= 0
&& (bits = 64 || Int64.compare n (Int64.shift_left 1L bits) < 0) && Int64.compare n (Int64.shift_left 1L bits) < 0
in in
if ok then n if ok then n
else fail loc "%Ld does not fit in %s" n (Types.ikind_name k) else fail loc "%Ld does not fit in %s" n (Types.ikind_name k)
@ -390,6 +444,32 @@ and check_let ctx ?want loc bs body =
let body = block ctx ?want loc body in let body = block ctx ?want loc body in
mk loc body.Tast.ty (Tast.Let (bs, [ body ]))) mk loc body.Tast.ty (Tast.Let (bs, [ body ])))
(* (dotimes [i n] body...) is a counting loop, not a new IR node: bind [i] to 0
and the bound to a hidden slot — [n] is evaluated once, before the loop, so
a body that changes it cannot change the trip count — then step [i] at the
end of the body. [i] is not assignable, so the step below is the only writer. *)
and check_dotimes ctx ~want loc name count body =
let count = check ctx ~want:index_ty count in
scoped ctx (fun () ->
let i = bind ctx name index_ty ~assignable:false in
let limit = fresh_slot ctx index_ty in
let body = map_lr (fun b -> check ctx b) body in
let iv = mk loc index_ty (Tast.Local i) in
let one = mk loc index_ty (Tast.Int (1L, Types.I32)) in
let cond =
mk loc Types.Bool
(Tast.Prim (Tast.Lt, [ iv; mk loc index_ty (Tast.Local limit) ]))
in
let step =
mk loc Types.Unit
(Tast.Set (Tast.Plocal i,
mk loc index_ty (Tast.Prim (Tast.Add, [ iv; one ]))))
in
let zero = mk loc index_ty (Tast.Int (0L, Types.I32)) in
let loop = mk loc Types.Unit (Tast.While (cond, body @ [ step ])) in
expect loc ~want
(mk loc Types.Unit (Tast.Let ([ (i, zero); (limit, count) ], [ loop ]))))
and check_if ctx ?want loc c t e = and check_if ctx ?want loc c t e =
let c = check ctx ~want:Types.Bool c in let c = check ctx ~want:Types.Bool c in
match e with match e with
@ -585,6 +665,32 @@ and static_index loc (ty : Types.t) ~past_end what k =
and literal (e : Tast.expr) = and literal (e : Tast.expr) =
match e.Tast.e with Tast.Int (k, _) -> Some k | _ -> None match e.Tast.e with Tast.Int (k, _) -> Some k | _ -> None
(* An index is [i32] internally, but a *narrower* integer may be written as
one: indexing is not arithmetic on the value, so there is nothing for a
visible cast to warn about, and requiring (i32 c) at every subscript would
be noise. A u32 is included because it cannot lose a value the bounds check
would then miss — anything above 2^31 truncates to a negative i32, which
the unsigned comparison rejects. i64 and u64 are not: 2^32 + 5 truncates to
5 and would read the wrong element with no trap at all, so those need the
cast written out. *)
and index_expr ctx (e : Ast.expr) =
(* No [want]: an expectation of [i32] would reject a [u32] index outright,
before there is anything here to convert. An untyped literal still
defaults to [i32] on its own. *)
let v = check ctx e in
match v.Tast.ty with
| Types.Int Types.I32 -> v
| Types.Int k when Types.bits k <= 32 ->
{ v with Tast.ty = index_ty;
Tast.e = Tast.Prim (Tast.Cast index_ty, [ v ]) }
| Types.Int k ->
fail e.Ast.loc
"an index is an i32, and %s is wider — write (i32 …), because a value \
that does not fit truncates to one that does and would read the wrong \
element without tripping the bounds check" (Types.ikind_name k)
| other ->
fail e.Ast.loc "an index is an integer, found %s" (Types.to_string other)
(* [(at a i)] and [(at grid row col)]: one index per dimension. *) (* [(at a i)] and [(at grid row col)]: one index per dimension. *)
and indexed ctx (target : Tast.expr) (idx : Ast.expr list) = and indexed ctx (target : Tast.expr) (idx : Ast.expr list) =
let rec go ty = function let rec go ty = function
@ -597,7 +703,7 @@ and indexed ctx (target : Tast.expr) (idx : Ast.expr list) =
fail i.Ast.loc "%s cannot be indexed" (Types.to_string other) fail i.Ast.loc "%s cannot be indexed" (Types.to_string other)
in in
let loc = i.Ast.loc in let loc = i.Ast.loc in
let i = check ctx ~want:index_ty i in let i = index_expr ctx i in
(match literal i with (match literal i with
| Some k -> static_index loc ty ~past_end:false "index" k | Some k -> static_index loc ty ~past_end:false "index" k
| None -> ()); | None -> ());
@ -648,6 +754,45 @@ and named_call ctx ~want loc name args =
| "not" -> | "not" ->
arity loc name 1 args; arity loc name 1 args;
prim Tast.Not Types.Bool [ check ctx ~want:Types.Bool (List.hd args) ] prim Tast.Not Types.Bool [ check ctx ~want:Types.Bool (List.hd args) ]
(* Bitwise operators are integers-only, and the shift count has the same type
as the value shifted — there is no implicit widening anywhere else either. *)
| "bit-and" | "bit-or" | "bit-xor" | "<<" | ">>" ->
let p = match name with
| "bit-and" -> Tast.BitAnd | "bit-or" -> Tast.BitOr
| "bit-xor" -> Tast.BitXor | "<<" -> Tast.Shl | _ -> Tast.Shr
in
arity loc name 2 args;
let a, b = binary ctx name loc ~want:(numeric_want want) args in
(match a.Tast.ty with
| Types.Int _ -> ()
| other -> fail loc "%s takes integers, found %s" name
(Types.to_string other));
prim p a.Tast.ty [ a; b ]
(* (min a b) and (max a b) evaluate each operand once — hence the slots —
because a min over two calls must not call either of them twice. *)
| "min" | "max" ->
arity loc name 2 args;
let a, b = binary ctx name loc ~want:(numeric_want want) args in
if not (Types.is_numeric a.Tast.ty) then
fail loc "%s takes numbers, found %s" name (Types.to_string a.Tast.ty);
let ty = a.Tast.ty in
let sa = fresh_slot ctx ty and sb = fresh_slot ctx ty in
let la = mk loc ty (Tast.Local sa) and lb = mk loc ty (Tast.Local sb) in
let cmp = if String.equal name "min" then Tast.Lt else Tast.Gt in
let pick = mk loc Types.Bool (Tast.Prim (cmp, [ la; lb ])) in
expect loc ~want
(mk loc ty (Tast.Let ([ (sa, a); (sb, b) ],
[ mk loc ty (Tast.If (pick, la, lb)) ])))
(* (zeroed) is the all-bytes-zero value of whatever it is being stored into,
so it only means anything where a type is expected of it. *)
| "zeroed" ->
arity loc name 0 args;
(match want with
| Some ty when ty <> Types.Never -> mk loc ty (Tast.Zero ty)
| _ ->
fail loc
"zeroed needs to know the type it is zeroing — use it where one is \
expected, as in (set grid (zeroed))")
(* ── containers ────────────────────────────────────────────────── *) (* ── containers ────────────────────────────────────────────────── *)
| "len" -> | "len" ->
@ -875,14 +1020,58 @@ let collect env (decls : Ast.decl list) =
every other signature in hand — so they are deferred to a pass of their every other signature in hand — so they are deferred to a pass of their
own below. *) own below. *)
let untyped = ref [] in let untyped = ref [] in
(* Enums come first, in a pass of their own: a signature below may name one,
and [resolve] has to find it before it resolves that signature. *)
List.iter
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defenum (n, members) ->
let names = List.map fst members in
if List.length (List.sort_uniq compare names) <> List.length names then
fail d.Ast.dloc "%s declares the same member twice" n;
Hashtbl.replace env.enums n members;
Hashtbl.replace env.locs n d.Ast.dloc
| _ -> ())
decls;
List.iter List.iter
(fun (d : Ast.decl) -> (fun (d : Ast.decl) ->
let loc = d.Ast.dloc in let loc = d.Ast.dloc in
match d.Ast.d with match d.Ast.d with
| Ast.Package _ -> () | Ast.Package _ -> ()
| Ast.Defenum _ -> ()
(* Imports are gone by now: [Load] resolved them into these very decls,
so one reaching the checker is a driver that skipped that step. *)
| Ast.Import (alias, _) -> | Ast.Import (alias, _) ->
unimplemented loc fail loc "internal: the import of %s was not resolved before checking"
(Printf.sprintf "the cross-package import (import %s ...)" alias) 4 alias
| Ast.Declare (fn, csym) ->
if Hashtbl.mem env.fns fn.Ast.name then
fail loc "%s is declared twice" fn.Ast.name;
let params =
List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params
in
let ret =
match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t
in
(* What may cross the boundary. A slice or a string goes as ptr+len,
a scalar as itself; an aggregate does not go at all, because how
one is passed differs per target and reproducing that here would
be three calling conventions to maintain. Pass (Ptr T) instead and
let the C shim dereference it — that is what the shim is for. *)
let crossable what (t : Types.t) =
match t with
| Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _
| Types.Enum _ | Types.Unit -> ()
| Types.String | Types.Slice _ when what = "a parameter" -> ()
| _ ->
fail loc
"%s of %s is %s, which cannot cross to C directly — pass (Ptr %s) and let the shim read it" what fn.Ast.name
(Types.to_string t) (Types.to_string t)
in
List.iter (crossable "a parameter") params;
crossable "the return type" ret;
Hashtbl.replace env.fns fn.Ast.name (params, ret);
Hashtbl.replace env.externs fn.Ast.name csym
| Ast.Defalias _ -> () | Ast.Defalias _ -> ()
| Ast.Defstruct (n, fs) -> | Ast.Defstruct (n, fs) ->
let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in
@ -921,7 +1110,7 @@ let collect env (decls : Ast.decl list) =
not check once no progress is left has a real error, so the last round is not check once no progress is left has a real error, so the last round is
run without swallowing it. *) run without swallowing it. *)
let infer (_, v) = let infer (_, v) =
(check { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = [] } v).Tast.ty (check { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = [] } v).Tast.ty
in in
let pending = ref (List.rev !untyped) in let pending = ref (List.rev !untyped) in
let rec settle () = let rec settle () =
@ -973,7 +1162,7 @@ let check_finite env =
let check_fn env (fn : Ast.fn) : Tast.fn = let check_fn env (fn : Ast.fn) : Tast.fn =
let params, ret = Hashtbl.find env.fns fn.Ast.name in let params, ret = Hashtbl.find env.fns fn.Ast.name in
let ctx = { env; ret; slots = 0; slot_tys = []; scope = [] } in let ctx = { env; ret; slots = 0; slot_tys = []; scope = []; defers = [] } in
List.iter2 List.iter2
(fun (p : Ast.field) ty -> (fun (p : Ast.field) ty ->
if List.mem_assoc p.Ast.fname ctx.scope then if List.mem_assoc p.Ast.fname ctx.scope then
@ -990,19 +1179,59 @@ let check_fn env (fn : Ast.fn) : Tast.fn =
(* The last form is the return value, unless the function returns Unit, (* The last form is the return value, unless the function returns Unit,
in which case whatever it evaluates to is discarded. *) in which case whatever it evaluates to is discarded. *)
let want = if Types.equal ret Types.Unit then None else Some ret in let want = if Types.equal ret Types.Unit then None else Some ret in
(* [defer] is recognised here and nowhere else, because this is the only
place that knows a form is at the top level of the function body. Each
one is checked in place — so it sees the scope it is written in — and
then registered on the context; it emits nothing where it stands. *)
let defer_here (e : Ast.expr) =
match e.Ast.e with
| Ast.Defer forms ->
let forms = map_lr (fun d -> check ctx d) forms in
let d = mk e.Ast.loc Types.Unit (Tast.Do forms) in
ctx.defers <- d :: ctx.defers;
Some (unit_at e.Ast.loc)
| _ -> None
in
let rec go = function let rec go = function
| [ last ] -> [ check ctx ?want last ] | [ last ] ->
| x :: rest -> check ctx x :: go rest (match defer_here last with
| Some u -> [ u ]
| None -> [ check ctx ?want last ])
| x :: rest ->
let x = match defer_here x with Some u -> u | None -> check ctx x in
x :: go rest
| [] -> assert false | [] -> assert false
in in
go body go body
in in
(* Function exit runs the defers, innermost first. An explicit [return] ran
its own (see [check]); this is the fall-off-the-end path. A trap does not
run them — it is [noreturn] and then [unreachable] — and that is the same
rule the bounds checks already follow. *)
let body =
match ctx.defers with
| [] -> body
| ds when Types.equal ret Types.Unit -> body @ ds
| ds ->
(* The result is computed before the defers run and returned after, so it
goes through a slot rather than staying the last form. *)
let rec split = function
| [ last ] -> ([], last)
| x :: rest -> let (init, last) = split rest in (x :: init, last)
| [] -> assert false
in
let init, last = split body in
let s = fresh_slot ctx ret in
let loc = last.Tast.loc in
init @ [ mk loc ret
(Tast.Let ([ (s, last) ], ds @ [ mk loc ret (Tast.Local s) ])) ]
in
{ Tast.name = fn.Ast.name; params; { Tast.name = fn.Ast.name; params;
slots = Array.of_list (List.rev ctx.slot_tys); slots = Array.of_list (List.rev ctx.slot_tys);
ret; body; floc = fn.Ast.nloc } ret; body; floc = fn.Ast.nloc }
let check_global env (d : Ast.decl) : Tast.global option = let check_global env (d : Ast.decl) : Tast.global option =
let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = [] } in let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = [] } in
match d.Ast.d with match d.Ast.d with
| Ast.Defvar (n, _, init) -> | Ast.Defvar (n, _, init) ->
let ty, _ = Hashtbl.find env.globals n in let ty, _ = Hashtbl.find env.globals n in
@ -1015,8 +1244,21 @@ let check_global env (d : Ast.decl) : Tast.global option =
Some { Tast.gname = n; gty = ty; ginit; gconst = false } Some { Tast.gname = n; gty = ty; ginit; gconst = false }
| Ast.Defconst (n, _, v) -> | Ast.Defconst (n, _, v) ->
let ty, _ = Hashtbl.find env.globals n in let ty, _ = Hashtbl.find env.globals n in
Some { Tast.gname = n; gty = ty; ginit = check (ctx ()) ~want:ty v; (* [collect] already folded the integer constants, because an array length
gconst = true } has to be known before any type resolves. Use that value here rather
than the expression it came from: a global's initialiser has to be a
compile-time constant, and [(/ screen-height cell-size)] is one — the
folding pass is the only thing that knows it. *)
let ginit =
match Hashtbl.find_opt env.consts n, ty with
| Some k, Types.Int kind ->
(* Still range-checked: this path skips [check], and [in_range] is the
only thing that rejects 300 as a u8. *)
{ Tast.e = Tast.Int (in_range d.Ast.dloc kind k, kind); ty;
loc = d.Ast.dloc }
| _ -> check (ctx ()) ~want:ty v
in
Some { Tast.gname = n; gty = ty; ginit; gconst = true }
| _ -> None | _ -> None
(* The entry point, plan.org: (defn main [args [string]] i32), with both the (* The entry point, plan.org: (defn main [args [string]] i32), with both the
@ -1061,6 +1303,14 @@ let program (decls : Ast.decl list) : Tast.program =
Hashtbl.fold (fun _ v acc -> v :: acc) tbl [] Hashtbl.fold (fun _ v acc -> v :: acc) tbl []
|> List.sort (fun a b -> String.compare (name a) (name b)) |> List.sort (fun a b -> String.compare (name a) (name b))
in in
let externs =
Hashtbl.fold
(fun name esym acc ->
let eparams, eret = Hashtbl.find env.fns name in
{ Tast.ename = name; esym; eparams; eret } :: acc)
env.externs []
|> List.sort (fun (a : Tast.extern) b -> String.compare a.Tast.esym b.Tast.esym)
in
{ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs; { Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs;
unions = values (fun (u : Tast.union) -> u.Tast.uname) env.unions; unions = values (fun (u : Tast.union) -> u.Tast.uname) env.unions;
globals; fns } globals; externs; fns }

70
lib/emit.ml
View File

@ -64,6 +64,8 @@ let rec ll (t : Types.t) =
| Types.String | Types.Slice _ -> "%slice" | Types.String | Types.Slice _ -> "%slice"
| Types.Unit | Types.Never -> "{}" | Types.Unit | Types.Never -> "{}"
| Types.Named n -> sname n | Types.Named n -> sname n
(* A C enum is an i32 — its own type in the checker, nothing at all here. *)
| Types.Enum _ -> "i32"
| Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e) | Types.Array (n, e) -> Printf.sprintf "[%Ld x %s]" n (ll e)
| Types.Ptr _ -> "ptr" | Types.Ptr _ -> "ptr"
| Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e) | Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e)
@ -80,6 +82,9 @@ type m = {
strs : Buffer.t; (* string literal constants *) strs : Buffer.t; (* string literal constants *)
structs : (string, Tast.structure) Hashtbl.t; structs : (string, Tast.structure) Hashtbl.t;
globals : (string, Types.t) Hashtbl.t; globals : (string, Types.t) Hashtbl.t;
(* Flan name -> C symbol, for the foreign functions. A call to one names the
symbol directly; there is no thunk. *)
externs : (string, string) Hashtbl.t;
checks : bool; (* emit bounds checks *) checks : bool; (* emit bounds checks *)
mutable nstr : int; mutable nstr : int;
} }
@ -232,7 +237,10 @@ let rec value f (e : Tast.expr) : string =
load f (addr f e) e.Tast.ty load f (addr f e) e.Tast.ty
| Tast.Addr p -> fst (place f p) | Tast.Addr p -> fst (place f p)
| Tast.Prim (p, args) -> prim f e p args | Tast.Prim (p, args) -> prim f e p args
| Tast.Call (name, args) -> call f e.Tast.ty (fname name) args | Tast.Call (name, args) ->
(match Hashtbl.find_opt f.md.externs name with
| Some sym -> extern_call f e.Tast.ty ("@" ^ sym) args
| None -> call f e.Tast.ty (fname name) args)
| Tast.Do body -> block f body | Tast.Do body -> block f body
| Tast.Let (bs, body) -> | Tast.Let (bs, body) ->
List.iter List.iter
@ -377,6 +385,31 @@ and call f ret name args =
ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs); ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs);
t t
(* A foreign call, where the same rule applies as to the runtime shims: a slice
or a string crosses as ptr+len and never as a struct by value. Every other
argument type is a scalar, because [check.ml] rejects an extern signature
that would need an aggregate — that is the shim's job, in C, where clang
knows the target's calling convention. *)
and extern_call f ret name args =
let vs =
List.concat_map
(fun (a : Tast.expr) ->
match a.Tast.ty with
| Types.String | Types.Slice _ ->
let p, n = explode f a in
[ Printf.sprintf "ptr %s" p; Printf.sprintf "i64 %s" n ]
| ty -> [ Printf.sprintf "%s %s" (ll ty) (value f a) ])
args
in
if is_void ret then begin
ins f "call void %s(%s)" name (String.concat ", " vs);
"zeroinitializer"
end else begin
let t = fresh f in
ins f "%s = call %s %s(%s)" t (ll ret) name (String.concat ", " vs);
t
end
and emit_if f ty c t e = and emit_if f ty c t e =
let cv = value f c in let cv = value f c in
let lt = fresh_label f "then" and le = fresh_label f "else" let lt = fresh_label f "then" and le = fresh_label f "else"
@ -513,6 +546,18 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
(ll x.Tast.ty) a b (ll x.Tast.ty) a b
| t' -> failwith ("comparison on " ^ Types.to_string t')); | t' -> failwith ("comparison on " ^ Types.to_string t'));
t t
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ] ->
let a = value f x in
let b = value f y in
let op = match x.Tast.ty, p with
| _, Tast.BitAnd -> "and" | _, Tast.BitOr -> "or"
| _, Tast.BitXor -> "xor" | _, Tast.Shl -> "shl"
| Types.Int k, _ -> if Types.signed k then "ashr" else "lshr"
| t, _ -> failwith ("bitwise on " ^ Types.to_string t)
in
let t = fresh f in
ins f "%s = %s %s %s, %s" t op (ll x.Tast.ty) a b;
t
| Tast.Not, [ x ] -> | Tast.Not, [ x ] ->
let a = value f x in let a = value f x in
let t = fresh f in let t = fresh f in
@ -678,6 +723,9 @@ let emit_fn m (fn : Tast.fn) =
fn.Tast.params; fn.Tast.params;
let last = ref "zeroinitializer" in let last = ref "zeroinitializer" in
List.iter (fun e -> last := value f e) fn.Tast.body; List.iter (fun e -> last := value f e) fn.Tast.body;
(* A Unit function's body may end on a form of any type — the value is
discarded, so the return is the Unit constant rather than that value. *)
if Types.equal fn.Tast.ret Types.Unit then last := "zeroinitializer";
term f "ret %s %s" (ll fn.Tast.ret) !last; term f "ret %s %s" (ll fn.Tast.ret) !last;
let params = let params =
List.mapi (fun i ty -> Printf.sprintf "%s %%p%d" (ll ty) i) fn.Tast.params List.mapi (fun i ty -> Printf.sprintf "%s %%p%d" (ll ty) i) fn.Tast.params
@ -770,12 +818,15 @@ let program ?(checks = true) (p : Tast.program) : string =
let m = { let m = {
out = Buffer.create 8192; strs = Buffer.create 512; out = Buffer.create 8192; strs = Buffer.create 512;
structs = Hashtbl.create 16; globals = Hashtbl.create 16; structs = Hashtbl.create 16; globals = Hashtbl.create 16;
externs = Hashtbl.create 32;
checks; nstr = 0; checks; nstr = 0;
} in } in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s) List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
p.Tast.structs; p.Tast.structs;
List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty) List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty)
p.Tast.globals; p.Tast.globals;
List.iter (fun (e : Tast.extern) -> Hashtbl.replace m.externs e.Tast.ename e.Tast.esym)
p.Tast.externs;
List.iter List.iter
(fun (s : Tast.structure) -> (fun (s : Tast.structure) ->
Buffer.add_string m.out Buffer.add_string m.out
@ -784,6 +835,23 @@ let program ?(checks = true) (p : Tast.program) : string =
(List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields)))) (List.map (fun (f : Tast.field) -> ll f.Tast.fty) s.Tast.fields))))
p.Tast.structs; p.Tast.structs;
Buffer.add_char m.out '\n'; Buffer.add_char m.out '\n';
(* The foreign declarations. Every struct that crosses this boundary was
flattened by a C shim, so each of these is scalars only and no calling
convention has to be reproduced here. *)
List.iter
(fun (e : Tast.extern) ->
Buffer.add_string m.out
(Printf.sprintf "declare %s @%s(%s)\n"
(ll e.Tast.eret) e.Tast.esym
(String.concat ", "
(List.concat_map
(fun (t : Types.t) ->
match t with
| Types.String | Types.Slice _ -> [ "ptr"; "i64" ]
| t -> [ ll t ])
e.Tast.eparams))))
p.Tast.externs;
if p.Tast.externs <> [] then Buffer.add_char m.out '\n';
List.iter (emit_global m) p.Tast.globals; List.iter (emit_global m) p.Tast.globals;
List.iter (emit_fn m) p.Tast.fns; List.iter (emit_fn m) p.Tast.fns;
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with

279
lib/load.ml Normal file
View File

@ -0,0 +1,279 @@
(** Imports: {v (import rl "vendor:raylib") v} resolved into ordinary
declarations, before the checker ever runs.
The directory is the package (plan.org, Modules), so a path is a directory
and every [.flan] file in it contributes. [vendor:] and [core:] are
collections — root-directory aliases, as in Odin — and are resolved by
walking up from the importing file until a directory of that name is found.
No project file, no manifest: a loose file in a scratch directory is still
a package of one.
Importing is a rename, done here: every top-level name the package declares
becomes [alias/name], and every use of one of its own names — in a type, in
a body, in a struct literal — is rewritten to match. Local bindings shadow,
so a parameter named like a package function stays the parameter. Nothing
downstream knows a package existed; the checker sees one flat list of
declarations with names that happen to contain a slash.
That is not a module system yet. There is no visibility, no cycle
detection, and a package cannot import another one — milestone 4 needs one
package, imported once, and the rest can wait for a use that exercises it.
A package may also carry the C it binds to. Every [.c] file in the
directory is compiled into the build, and a file named [link] lists extra
linker arguments, one per line. That is where the aggregate calling
convention lives: a shim written in C means clang classifies [Vector2] and
[Color] correctly on x86-64, arm64 and wasm32 alike, and [emit.ml] never
learns the difference. *)
type t = {
decls : Ast.decl list;
csrcs : string list; (* C sources compiled into the build *)
lflags : string list; (* extra linker arguments *)
}
let fail loc fmt = Printf.ksprintf (fun m -> raise (Loc.Error (loc, m))) fmt
(* "vendor:raylib" -> the collection "vendor" and the subpath "raylib". A path
with no colon is relative to the importing file's own directory. *)
let split_path path =
match String.index_opt path ':' with
| None -> None, path
| Some i ->
Some (String.sub path 0 i),
String.sub path (i + 1) (String.length path - i - 1)
(* Walk up from [dir] looking for a subdirectory named [name]. Stops at the
filesystem root, so a missing collection is an error and never a silent
search of the whole machine. *)
let rec find_collection dir name =
let candidate = Filename.concat dir name in
if Sys.file_exists candidate && Sys.is_directory candidate then Some candidate
else
let parent = Filename.dirname dir in
if String.equal parent dir then None else find_collection parent name
let resolve_dir ~file loc path =
let here =
let d = Filename.dirname file in
if Filename.is_relative d then Filename.concat (Sys.getcwd ()) d else d
in
match split_path path with
| None, rel ->
let d = Filename.concat here rel in
if Sys.file_exists d && Sys.is_directory d then d
else fail loc "no package directory at %s" d
| Some collection, rel ->
(match find_collection here collection with
| None ->
fail loc
"the collection %s: is a directory named %s somewhere above %s, and \
there is none" collection collection here
| Some root ->
let d = Filename.concat root rel in
if Sys.file_exists d && Sys.is_directory d then d
else fail loc "the package %s is not at %s" path d)
let entries dir suffix =
Sys.readdir dir
|> Array.to_list
|> List.filter (fun f -> Filename.check_suffix f suffix)
|> List.sort String.compare
|> List.map (Filename.concat dir)
(* ── Qualifying an imported package ────────────────────────────────── *)
let qualify alias n = alias ^ "/" ^ n
(* The type names the package itself declares. Only these are rewritten: a
reference to [i32] or to [Ptr] must survive untouched. *)
let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr =
let k =
match t.Ast.t with
| Ast.Tname n when List.mem n owned -> Ast.Tname (qualify alias n)
| Ast.Tname _ as k -> k
| Ast.Tslice e -> Ast.Tslice (rename_texpr owned alias e)
(* The length too: [rows] in [[rows [cols u32]]] is an ordinary
compile-time constant of the package, not part of the type syntax. *)
| Ast.Tarray (l, e) ->
let l =
match l with
| Ast.Lname n when List.mem n owned -> Ast.Lname (qualify alias n)
| l -> l
in
Ast.Tarray (l, rename_texpr owned alias e)
| Ast.Tmap (k, v) ->
Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v)
| Ast.Tapp (n, args) ->
Ast.Tapp (n, List.map (rename_texpr owned alias) args)
| Ast.Tfn (ps, r) ->
Ast.Tfn (List.map (rename_texpr owned alias) ps, rename_texpr owned alias r)
in
{ t with Ast.t = k }
(* Bodies too, once a package may define and not only declare. A package-local
name is qualified wherever it is *used*; a local binding shadows it, which is
why [bound] is carried down through [let], [fn] and [dotimes]. Everything
else — field names, keywords, enum members — is not a top-level name and is
left alone. *)
let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
let go = rename_expr owned alias bound in
let gos = List.map go in
let name n = if List.mem n owned && not (List.mem n bound) then qualify alias n else n in
let k =
match e.Ast.e with
| Ast.Int _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _
| Ast.Quote _ -> e.Ast.e
| Ast.Var n -> Ast.Var (name n)
| Ast.Do body -> Ast.Do (gos body)
| Ast.Let (bs, body) ->
(* Sequential, as [let] itself is: each initialiser sees the bindings
before it and not its own. *)
let bound, bs =
List.fold_left
(fun (bound, acc) (b : Ast.binding) ->
let b =
{ b with
Ast.bty = Option.map (rename_texpr owned alias) b.Ast.bty;
bval = rename_expr owned alias bound b.Ast.bval }
in
(b.Ast.bname :: bound, b :: acc))
(bound, []) bs
in
Ast.Let (List.rev bs, List.map (rename_expr owned alias bound) body)
| Ast.If (c, t, e') -> Ast.If (go c, go t, Option.map go e')
| Ast.While (c, body) -> Ast.While (go c, gos body)
| Ast.Return v -> Ast.Return (Option.map go v)
| Ast.Set (p, v) -> Ast.Set (rename_place owned alias bound p, go v)
| Ast.Field (t, f) -> Ast.Field (go t, f)
| Ast.Call (h, args) -> Ast.Call (go h, gos args)
| Ast.Match (sc, arms) ->
Ast.Match (go sc,
List.map (fun (a : Ast.arm) ->
let bound =
match a.Ast.pat with
| Ast.Pctor (_, ns) -> ns @ bound
| Ast.Pwild -> bound
in
{ a with Ast.body = List.map (rename_expr owned alias bound)
a.Ast.body }) arms)
| Ast.Struct (n, kvs) ->
Ast.Struct (name n, List.map (fun (k, v) -> (k, go v)) kvs)
| Ast.Arr items -> Ast.Arr (gos items)
| Ast.Fn (ps, body) ->
Ast.Fn (ps, List.map (rename_expr owned alias (ps @ bound)) body)
| Ast.Dotimes (i, n, body) ->
Ast.Dotimes (i, go n, List.map (rename_expr owned alias (i :: bound)) body)
| Ast.Defer body -> Ast.Defer (gos body)
| Ast.Unwrap (u, v) -> Ast.Unwrap (u, go v)
in
{ e with Ast.e = k }
and rename_place owned alias bound (p : Ast.place) : Ast.place =
let go = rename_expr owned alias bound in
match p with
| Ast.Pvar n ->
Ast.Pvar (if List.mem n owned && not (List.mem n bound) then qualify alias n else n)
| Ast.Pfield (t, f) -> Ast.Pfield (go t, f)
| Ast.Pindex (t, idx) -> Ast.Pindex (go t, List.map go idx)
| Ast.Pkey (m, k) -> Ast.Pkey (go m, go k)
| Ast.Pderef t -> Ast.Pderef (go t)
let rename_field owned alias (f : Ast.field) : Ast.field =
{ f with Ast.fty = rename_texpr owned alias f.Ast.fty }
let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
let loc = d.Ast.dloc in
let k =
match d.Ast.d with
| Ast.Declare (fn, csym) ->
Ast.Declare
({ fn with
Ast.name = qualify alias fn.Ast.name;
params = List.map (rename_field owned alias) fn.Ast.params;
ret = Option.map (rename_texpr owned alias) fn.Ast.ret },
csym)
| Ast.Defenum (n, ms) -> Ast.Defenum (qualify alias n, ms)
| Ast.Defalias (n, t) ->
Ast.Defalias (qualify alias n, rename_texpr owned alias t)
| Ast.Defconst (n, t, v) ->
Ast.Defconst (qualify alias n,
Option.map (rename_texpr owned alias) t,
rename_expr owned alias [] v)
| Ast.Defstruct (n, fs) ->
Ast.Defstruct (qualify alias n, List.map (rename_field owned alias) fs)
| Ast.Defvar (n, t, init) ->
Ast.Defvar (qualify alias n, Option.map (rename_texpr owned alias) t,
(match init with
| Ast.Init v -> Ast.Init (rename_expr owned alias [] v)
| other -> other))
| Ast.Defn fn ->
let params = List.map (rename_field owned alias) fn.Ast.params in
let bound = List.map (fun (p : Ast.field) -> p.Ast.fname) fn.Ast.params in
Ast.Defn
{ fn with
Ast.name = qualify alias fn.Ast.name;
params;
ret = Option.map (rename_texpr owned alias) fn.Ast.ret;
fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody }
| Ast.Package _ -> Ast.Package alias
| Ast.Import _ ->
fail loc "an imported package may not import another one yet (milestone 4)"
| Ast.Defunion (n, _) ->
fail loc "%s is a union, and an imported union is not implemented yet \
(milestone 4)" n
in
{ d with Ast.d = k }
(* Every top-level name the package declares — types and values alike, since a
use site is rewritten by name and the two never collide in one namespace. *)
let owned_names (ds : Ast.decl list) =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defenum (n, _) | Ast.Defalias (n, _) | Ast.Defstruct (n, _)
| Ast.Defunion (n, _) | Ast.Defvar (n, _, _) | Ast.Defconst (n, _, _) ->
Some n
| Ast.Declare (fn, _) | Ast.Defn fn -> Some fn.Ast.name
| Ast.Package _ | Ast.Import _ -> None)
ds
let import ~loc alias dir =
let files = entries dir ".flan" in
if files = [] then fail loc "the package at %s has no .flan file" dir;
let ds = List.concat_map (fun f -> Parse.program (Reader.read_file f)) files in
let owned = owned_names ds in
let decls = List.map (qualify_decl owned alias) ds in
let lflags =
let path = Filename.concat dir "link" in
if not (Sys.file_exists path) then []
else begin
let ch = open_in path in
let rec go acc =
match input_line ch with
| line ->
let line = String.trim line in
go (if line = "" || line.[0] = '#' then acc else line :: acc)
| exception End_of_file -> List.rev acc
in
let r = go [] in
close_in ch; r
end
in
{ decls; csrcs = entries dir ".c"; lflags }
(* ── The one entry point ───────────────────────────────────────────── *)
let program ~file (decls : Ast.decl list) : t =
List.fold_left
(fun acc (d : Ast.decl) ->
match d.Ast.d with
| Ast.Import (alias, path) ->
let dir = resolve_dir ~file d.Ast.dloc path in
let p = import ~loc:d.Ast.dloc alias dir in
{ decls = acc.decls @ p.decls;
csrcs = acc.csrcs @ p.csrcs;
lflags = acc.lflags @ p.lflags }
| _ -> { acc with decls = acc.decls @ [ d ] })
{ decls = []; csrcs = []; lflags = [] }
decls

31
lib/parse.ml
View File

@ -349,6 +349,37 @@ let rec decl types (f : Form.t) : Ast.decl =
fbody = body; nloc = n.loc }) fbody = body; nloc = n.loc })
| _ -> fail f "defn is (defn name [param Type ...] ReturnType? body ...)") | _ -> fail f "defn is (defn name [param Type ...] ReturnType? body ...)")
| List ({ v = Sym "declare"; _ } :: args) ->
(* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is
last and is always written: a foreign name is not derivable from a Flan
one, and guessing it would fail at link time rather than here. *)
(match List.rev args with
| { v = Str csym; _ } :: rest ->
(match List.rev rest with
| [ n; { v = Form.Vec ps; _ } ] ->
mk (Ast.Declare ({ Ast.name = sym n; params = fields f ps;
ret = None; fbody = []; nloc = n.loc }, csym))
| [ n; { v = Form.Vec ps; _ }; r ] ->
mk (Ast.Declare ({ Ast.name = sym n; params = fields f ps;
ret = Some (texpr r); fbody = []; nloc = n.loc },
csym))
| _ -> fail f "declare is (declare name [param Type ...] ReturnType? \"c_symbol\")")
| _ -> fail f "declare is (declare name [param Type ...] ReturnType? \"c_symbol\")")
| List ({ v = Sym "defenum"; _ } :: args) ->
(match args with
| [ n; { v = Form.Vec ms; _ } ] ->
let rec pairs = function
| [] -> []
| { v = Form.Sym m; _ } :: { v = Form.Int k; _ } :: rest ->
(m, k) :: pairs rest
| bad :: _ ->
fail bad "an enum member is a name followed by an integer, found %s"
(Form.to_string bad)
in
mk (Ast.Defenum (sym n, pairs ms))
| _ -> fail f "defenum is (defenum Name [member value ...])")
| List ({ v = Sym "defvar"; _ } :: args) -> | List ({ v = Sym "defvar"; _ } :: args) ->
(match args with (match args with
| [ n; t ] -> mk (Ast.Defvar (sym n, Some (texpr t), Ast.Zeroed)) | [ n; t ] -> mk (Ast.Defvar (sym n, Some (texpr t), Ast.Zeroed))

22
lib/prelude.ml
View File

@ -29,6 +29,28 @@ let source = {flan|
(defn newline [] (defn newline []
(write-stdout (bytes "\n"))) (write-stdout (bytes "\n")))
;; 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
;; (plan.org, RNG is ours). PCG-XSH-RR 32: one u64 LCG step per draw, folded
;; down to 32 bits by an xorshift and rotated by the state's top five bits.
(defvar rand-state u64 6364136223846793005)
(defn rand-seed [seed u64]
(set rand-state (+ (* seed 6364136223846793005) 1442695040888963407)))
(defn rand-u32 [] u32
(let [s rand-state]
(set rand-state (+ (* s 6364136223846793005) 1442695040888963407))
;; The rotate is masked to 5 bits: a 32-bit shift by 32 is poison in LLVM,
;; and r = 0 is the case that would ask for it.
(let [x (u32 (>> (bit-xor (>> s 18) s) 27))
r (u32 (>> s 59))]
(bit-or (>> x r) (<< x (bit-and (- 32 r) 31))))))
;; In [0, 1). The divisor is 2^32 exactly, so the result never reaches 1.0.
(defn rand-f32 [] f32
(/ (f32 (rand-u32)) 4294967296.0))
;; Prints s and then a newline. Takes a string, not an Option or an any — ;; Prints s and then a newline. Takes a string, not an Option or an any —
;; there is nothing to dispatch on yet. ;; there is nothing to dispatch on yet.
(defn print-line [s string] (defn print-line [s string]

15
lib/tast.ml
View File

@ -19,6 +19,9 @@ type prim =
| Add | Sub | Mul | Div | Rem | Add | Sub | Mul | Div | Rem
| Eq | Ne | Lt | Le | Gt | Ge | Eq | Ne | Lt | Le | Gt | Ge
| Not | Not
(* bitwise, integers only. [Shr] is arithmetic on a signed type and logical
on an unsigned one, which is what the operand's own kind already says. *)
| BitAnd | BitOr | BitXor | Shl | Shr
(* containers: fixed arrays and slices only at milestone 2 *) (* containers: fixed arrays and slices only at milestone 2 *)
| Len | At | Slice | Len | At | Slice
(* the milestone-2 host primitives, plan.org. The four conversions are (* the milestone-2 host primitives, plan.org. The four conversions are
@ -90,10 +93,22 @@ type fn = {
type global = { gname : string; gty : Types.t; ginit : expr; gconst : bool } type global = { gname : string; gty : Types.t; ginit : expr; gconst : bool }
(* A foreign function: no body, and [esym] is the symbol the linker sees. The
aggregate calling convention is not modelled here — a C shim flattens every
struct that crosses the boundary, so clang classifies it per target and
nothing in the backend has to know x86-64 from arm64 from wasm32. *)
type extern = {
ename : string; (* the Flan name, e.g. rl/init-window *)
esym : string; (* the C symbol *)
eparams : Types.t list;
eret : Types.t;
}
type program = { type program = {
structs : structure list; structs : structure list;
unions : union list; unions : union list;
globals : global list; (* in declaration order *) globals : global list; (* in declaration order *)
externs : extern list;
fns : fn list; fns : fn list;
} }

9
lib/types.ml
View File

@ -23,6 +23,9 @@ type t =
| Unit (* the zero-sized type, not C's void *) | Unit (* the zero-sized type, not C's void *)
| Never (* return, exit, error: no value at all *) | Never (* return, exit, error: no value at all *)
| Named of string (* a struct or union declared in the file *) | Named of string (* a struct or union declared in the file *)
(* A C enum: an i32 at run time, but its own type, so a keyword at a call
site has something to resolve against and a plain integer does not fit. *)
| Enum of string
| Slice of t (* [T] ptr+len, non-owning *) | Slice of t (* [T] ptr+len, non-owning *)
| Array of int64 * t (* [n T] inline, a value, copies *) | Array of int64 * t (* [n T] inline, a value, copies *)
| Map of t * t (* {K V} *) | Map of t * t (* {K V} *)
@ -67,7 +70,7 @@ let rec equal a b =
| Int x, Int y -> x = y | Int x, Int y -> x = y
| Float x, Float y -> x = y | Float x, Float y -> x = y
| Bool, Bool | String, String | Unit, Unit | Never, Never -> true | Bool, Bool | String, String | Unit, Unit | Never, Never -> true
| Named x, Named y -> String.equal x y | Named x, Named y | Enum x, Enum y -> String.equal x y
| Slice x, Slice y -> equal x y | Slice x, Slice y -> equal x y
| Array (n, x), Array (m, y) -> Int64.equal n m && equal x y | Array (n, x), Array (m, y) -> Int64.equal n m && equal x y
| Map (k, v), Map (k', v') -> equal k k' && equal v v' | Map (k, v), Map (k', v') -> equal k k' && equal v v'
@ -87,7 +90,7 @@ let rec to_string = function
| String -> "string" | String -> "string"
| Unit -> "Unit" | Unit -> "Unit"
| Never -> "Never" | Never -> "Never"
| Named n -> n | Named n | Enum n -> n
| Slice t -> "[" ^ to_string t ^ "]" | Slice t -> "[" ^ to_string t ^ "]"
| Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t) | Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t)
| Map (k, v) -> Printf.sprintf "{%s %s}" (to_string k) (to_string v) | Map (k, v) -> Printf.sprintf "{%s %s}" (to_string k) (to_string v)
@ -103,7 +106,7 @@ let is_numeric = function Int _ | Float _ -> true | _ -> false
(* Ordering and equality are defined on machine types and on nothing else at (* Ordering and equality are defined on machine types and on nothing else at
milestone 2 — strings, structs and slices have no built-in [=], because an milestone 2 — strings, structs and slices have no built-in [=], because an
unconstrained type supports only what every type supports (plan.org, Types). *) unconstrained type supports only what every type supports (plan.org, Types). *)
let is_comparable = is_numeric let is_comparable = function Enum _ -> true | t -> is_numeric t
(* [Never] is the type of an expression that does not produce a value: return, (* [Never] is the type of an expression that does not produce a value: return,
an early-returning `some`, exit. It fits anywhere, and that is the only an early-returning `some`, exit. It fits anywhere, and that is the only

122
sand-sim/sim.flan Normal file
View File

@ -0,0 +1,122 @@
;;;; The falling-sand simulation, with no raylib in it.
;;;;
;;;; It is a package of its own because milestone 4 asks for sand to be tested
;;;; twice — interactive at 120 fps, and headless over N frames with the grid
;;;; hashed (plan.org, Build sequence). The headless run is the one CI does on
;;;; wasm32, and a program that imports the raylib package links the raylib
;;;; shared library on *every* target, whatever its main does. So the headless
;;;; artifact cannot import raylib at all, and the only way to have both
;;;; without two copies of the simulation is for both to import this.
;;;;
;;;; The directory is the package (plan.org, Modules): sand.flan imports it as
;;;; sim/, test/programs/sand-headless.flan imports it as sim/ too.
(defconst screen-width 1400)
(defconst screen-height 1000)
(defconst cell-size 5)
;; f32: velocity is [f32], and there is no implicit widening.
(defconst gravity f32 0.05)
(defconst rows (/ screen-height cell-size))
(defconst cols (/ screen-width cell-size))
(defconst brush-size 10)
;; Packed 0xRRGGBBAA. A cell of 0 means empty, so no Option and no tag word.
(defconst colors [4 u32] [0xE6B800FF 0x3B6E8CFF 0xA83232FF 0xCC6B1FFF])
;; Flat, unboxed, statically sized. No headers, so these are exactly
;; rows*cols*4 bytes each — the same memory the Odin port has. Fixed arrays are
;; values, so `(set grid (zeroed))` overwrites in place rather than reallocating.
;; No initialiser means all-bytes-zero (plan.org, zero values), so these are
;; BSS and cost nothing to start. `(zeroed)` below is the explicit spelling for
;; re-zeroing later — a memset, not an allocation.
(defvar grid [rows [cols u32]])
(defvar velocity [rows [cols f32]])
;; An index into colors, not a colour.
(defvar current-color i32)
(defn clear-grid []
(set grid (zeroed))
(set velocity (zeroed)))
(defn empty-at? [row i32 col i32] bool
(= 0 (at grid row col)))
(defn next-color []
(set current-color (% (+ current-color 1) (len colors))))
;; Drop a brush-sized cloud of grains centred on [row col]. This is what the
;; mouse drives interactively and what the headless run calls directly — the
;; only difference between the two is where the centre comes from.
(defn paint-at [row i32 col i32]
(let [half (/ brush-size 2)]
(dotimes [x brush-size]
(dotimes [y brush-size]
(let [r (+ y (- row half))
c (+ x (- col half))]
(when (and (>= r 0) (< r (- rows 1))
(>= c 0) (< c (- cols 1))
(empty-at? r c)
(< (rand-f32) 0.5))
(set (at grid r c) (nth colors current-color))
(set (at velocity r c) 1.0)))))))
(defn move-grain [from-row i32 from-col i32
to-row i32 to-col i32
vel f32]
(set (at grid to-row to-col) (at grid from-row from-col))
(set (at grid from-row from-col) 0)
(set (at velocity to-row to-col) vel)
(set (at velocity from-row from-col) 0.0))
;; Move the grain at [row col] as far down as it can, sliding to a free
;; diagonal neighbour when the cell below is taken.
;;
;; Imperative `while` with early `return`, not loop/recur — see plan.org
;; "Loop story". The recur version read as a tail call but was a countdown
;; over a mutable scan position, which is what a while loop is.
(defn settle [row i32 col i32]
(let [vel (+ gravity (at velocity row col))
y (min (- rows 1) (+ row (i32 vel)))]
(while (> y row)
(when (empty-at? y col)
(move-grain row col y col vel)
(return))
(let [left? (and (> col 0) (empty-at? y (- col 1)))
right? (and (< col (- cols 1)) (empty-at? y (+ col 1)))]
(when (or left? right?)
(let [side (cond
(not left?) 1
(not right?) -1
:else (if (< (rand-f32) 0.5) 1 -1))]
(move-grain row col y (+ col side) vel)
(return))))
(set y (- y 1)))
;; Nowhere to fall: reset the accumulated velocity and stay put.
(set (at velocity row col) 0.0)))
;; One frame of physics. Bottom-up, so a grain settles at most once per frame.
(defn step []
(let [row (- rows 2)]
(while (>= row 0)
(dotimes [col cols]
(unless (empty-at? row col)
(settle row col)))
(set row (- row 1)))))
;; FNV-1a over the grid, so the headless run has one number to compare. It has
;; to be identical on native and wasm32, which is the whole reason rand-f32 is
;; a seeded PRNG written in Flan rather than libc's (plan.org, RNG is ours).
;; Named because a let binding takes no type annotation, and 0xcbf29ce484222325
;; does not fit the i32 an unannotated integer literal would default to.
(defconst fnv-offset u64 0xcbf29ce484222325)
(defconst fnv-prime u64 1099511628211)
(defn hash-grid [] u64
(let [h fnv-offset]
(dotimes [row rows]
(dotimes [col cols]
(let [c (at grid row col)]
(dotimes [b 4]
(set h (bit-xor h (u64 (bit-and (>> c (u32 (* b 8))) 255))))
(set h (* h fnv-prime))))))
h))

117
sand.flan
View File

@ -6,7 +6,10 @@
;;;; path to "the language runs something". ;;;; path to "the language runs something".
;;;; ;;;;
;;;; It is tested twice: headless (N frames, hash the grid — the version CI runs ;;;; It is tested twice: headless (N frames, hash the grid — the version CI runs
;;;; on native and wasm32) and interactive at 120 fps. ;;;; on native and wasm32) and interactive at 120 fps. This file is the
;;;; interactive half; the simulation itself lives in sand-sim/ so the headless
;;;; half can have it without linking raylib. See sand-sim/sim.flan for why that
;;;; split exists, and test/programs/sand-headless.flan for the other driver.
;;;; ;;;;
;;;; Note what it still deliberately does not use: no Vec, no Map, no generics, ;;;; Note what it still deliberately does not use: no Vec, no Map, no generics,
;;;; no user-written macros, no conditions, no allocator other than the stack ;;;; no user-written macros, no conditions, no allocator other than the stack
@ -21,86 +24,15 @@
;;;; lowercase in a TYPE position is a type variable; in a LENGTH position ;;;; lowercase in a TYPE position is a type variable; in a LENGTH position
;;;; it is an ordinary compile-time value, so [rows [cols u32]] is unambiguous ;;;; it is an ordinary compile-time value, so [rows [cols u32]] is unambiguous
(import rl "vendor:raylib") ; directory = package; declaration optional (import rl "vendor:raylib") ; directory = package; declaration optional
(import sim "sand-sim") ; no collection prefix: relative to this file
(defconst screen-width 1400)
(defconst screen-height 1000)
(defconst cell-size 5)
(defconst gravity 0.05)
(defconst rows (/ screen-height cell-size))
(defconst cols (/ screen-width cell-size))
(defconst brush-size 10)
;; Packed 0xRRGGBBAA. A cell of 0 means empty, so no Option and no tag word.
(defconst colors [4 u32] [0xE6B800FF 0x3B6E8CFF 0xA83232FF 0xCC6B1FFF])
;; Flat, unboxed, statically sized. No headers, so these are exactly
;; rows*cols*4 bytes each — the same memory the Odin port has. Fixed arrays are
;; values, so `(set grid (zeroed))` overwrites in place rather than reallocating.
;; No initialiser means all-bytes-zero (plan.org, zero values), so these are
;; BSS and cost nothing to start. `(zeroed)` below is the explicit spelling for
;; re-zeroing later — a memset, not an allocation.
(defvar grid [rows [cols u32]])
(defvar velocity [rows [cols f32]])
(defvar current-color u32)
(defn clear-grid []
(set grid (zeroed))
(set velocity (zeroed)))
(defn empty-at? [row i32 col i32] bool
(= 0 (at grid row col)))
;; Locals are assignable places (spec-memory.md); parameters are not. ;; Locals are assignable places (spec-memory.md); parameters are not.
(defn paint [] (defn paint []
(let [m (rl/get-mouse-position) (let [m (rl/get-mouse-position)
row (/ (i32 (.y m)) cell-size) row (/ (i32 (.y m)) sim/cell-size)
col (/ (i32 (.x m)) cell-size) col (/ (i32 (.x m)) sim/cell-size)]
half (/ brush-size 2)] (sim/paint-at row col)))
(dotimes [x brush-size]
(dotimes [y brush-size]
(let [r (+ y (- row half))
c (+ x (- col half))]
(when (and (>= r 0) (< r (- rows 1))
(>= c 0) (< c (- cols 1))
(empty-at? r c)
(< (rand-f32) 0.5))
(set (at grid r c) (nth colors current-color))
(set (at velocity r c) 1.0)))))))
(defn move-grain [from-row i32 from-col i32
to-row i32 to-col i32
vel f32]
(set (at grid to-row to-col) (at grid from-row from-col))
(set (at grid from-row from-col) 0)
(set (at velocity to-row to-col) vel)
(set (at velocity from-row from-col) 0.0))
;; Move the grain at [row col] as far down as it can, sliding to a free
;; diagonal neighbour when the cell below is taken.
;;
;; Imperative `while` with early `return`, not loop/recur — see plan.org
;; "Loop story". The recur version read as a tail call but was a countdown
;; over a mutable scan position, which is what a while loop is.
(defn settle [row i32 col i32]
(let [vel (+ gravity (at velocity row col))
y (min (- rows 1) (+ row (i32 vel)))]
(while (> y row)
(when (empty-at? y col)
(move-grain row col y col vel)
(return))
(let [left? (and (> col 0) (empty-at? y (- col 1)))
right? (and (< col (- cols 1)) (empty-at? y (+ col 1)))]
(when (or left? right?)
(let [side (cond
(not left?) 1
(not right?) -1
:else (if (< (rand-f32) 0.5) 1 -1))]
(move-grain row col y (+ col side) vel)
(return))))
(set y (- y 1)))
;; Nowhere to fall: reset the accumulated velocity and stay put.
(set (at velocity row col) 0.0)))
;; Every cross-function call in a dev build routes through an indirection cell, ;; Every cross-function call in a dev build routes through an indirection cell,
;; so redefining this from the REPL reaches the running loop on the next frame. ;; so redefining this from the REPL reaches the running loop on the next frame.
@ -113,33 +45,26 @@
;; because old code is never unloaded; changing its SIGNATURE is not, and the ;; because old code is never unloaded; changing its SIGNATURE is not, and the
;; reload rejects it. See plan.org "What redefinition cannot do". ;; reload rejects it. See plan.org "What redefinition cannot do".
(defn game-update [] (defn game-update []
(when (rl/key-pressed? :r) (clear-grid)) (when (rl/key-pressed? :r) (sim/clear-grid))
(when (rl/key-down? :space) (paint)) (when (rl/mouse-button-down? :left) (paint))
(when (rl/key-released? :space) (when (rl/mouse-button-released? :left) (sim/next-color))
(set current-color (% (+ current-color 1) (len colors)))) (sim/step))
;; Bottom-up, so a grain settles at most once per frame.
(let [row (- rows 2)]
(while (>= row 0)
(dotimes [col cols]
(unless (empty-at? row col)
(settle row col)))
(set row (- row 1)))))
(defn game-draw [] (defn game-draw []
(rl/clear-background rl/black) (rl/clear-background rl/black)
(dotimes [row rows] (dotimes [row sim/rows]
(dotimes [col cols] (dotimes [col sim/cols]
(let [c (at grid row col)] (let [c (at sim/grid row col)]
(unless (= 0 c) (unless (= 0 c)
(rl/draw-rectangle (i32 (* col cell-size)) (rl/draw-rectangle (i32 (* col sim/cell-size))
(i32 (* row cell-size)) (i32 (* row sim/cell-size))
cell-size cell-size sim/cell-size sim/cell-size
(rl/get-color c)))))) (rl/get-color c))))))
(rl/draw-fps 20 20)) (rl/draw-fps 20 20))
(defn main [] (defn main []
(rl/set-trace-log-level :warning) (rl/set-trace-log-level :warning)
(rl/init-window screen-width screen-height "SAND") (rl/init-window sim/screen-width sim/screen-height "SAND")
(defer (rl/close-window)) (defer (rl/close-window))
(rl/set-target-fps 120) (rl/set-target-fps 120)
;; Bare (defn main []) — argv and the i32 status are both optional. ;; Bare (defn main []) — argv and the i32 status are both optional.

4
test/dune
View File

@ -6,4 +6,8 @@
(deps (deps
(file %{workspace_root}/calc-me.flan) (file %{workspace_root}/calc-me.flan)
(file %{workspace_root}/sand.flan) (file %{workspace_root}/sand.flan)
; The sim package and the raylib bindings, because the headless sand case and
; the FFI case import them and an import reads the directory at build time.
(glob_files %{workspace_root}/sand-sim/*)
(glob_files %{workspace_root}/vendor/raylib/*)
(glob_files programs/*.flan))) (glob_files programs/*.flan)))

12
test/programs/raylib-ffi.flan Normal file
View File

@ -0,0 +1,12 @@
(import rl "vendor:raylib")
;; No window: GetColor and the enums are pure, so this exercises the whole
;; boundary — struct out-pointer, keyword->enum, string ptr+len — headlessly.
(defn main [] i32
(let [c (rl/get-color 0x11223344)]
(print-i64 (i64 (.r c))) (newline)
(print-i64 (i64 (.g c))) (newline)
(print-i64 (i64 (.b c))) (newline)
(print-i64 (i64 (.a c))) (newline)
(rl/set-trace-log-level :warning)
0))

27
test/programs/sand-headless.flan Normal file
View File

@ -0,0 +1,27 @@
;;;; sand.flan's other half: N frames, no window, hash the grid.
;;;;
;;;; This is the version CI runs on native *and* wasm32, which is why it does
;;;; not import the raylib package — a program that does links libraylib on
;;;; every target regardless of what its main does. The simulation itself is
;;;; shared with the interactive driver; only the input differs.
;;;;
;;;; The hash is a regression test only because the sequence is reproducible:
;;;; rand-f32 is a seeded PRNG written in Flan, so the same seed gives the same
;;;; grains in the same places on both targets (plan.org, RNG is ours).
(import sim "../../sand-sim")
(defconst frames 40)
(defn main [] i32
(rand-seed 20260910)
;; Four clouds, spread across the top, one per colour. Deterministic
;; positions: the mouse is what the interactive driver has and this does not.
(dotimes [i 4]
(sim/next-color)
(sim/paint-at 4 (* (+ i 1) (/ sim/cols 5))))
(dotimes [f frames]
(sim/step))
(print-i64 (i64 (sim/hash-grid)))
(newline)
0)

28
test/test_acceptance.ml
View File

@ -28,8 +28,12 @@ let compile ?(opt = "-O2") ?(checks = true) path =
Filename.concat scratch Filename.concat scratch
("flan-t-" ^ Filename.remove_extension (Filename.basename path)) ("flan-t-" ^ Filename.remove_extension (Filename.basename path))
in in
let p = Reader.read_file path |> Parse.program |> Check.program in (* Through [Load], so a program with an (import ...) is buildable here: it
ignore (Build.executable ~opts:{ Build.default with opt; checks } p ~out:exe); brings back the package's C shim and linker arguments as well. *)
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
ignore (Build.executable ~opts:{ Build.default with opt; checks }
~csrcs:l.Load.csrcs ~lflags:l.Load.lflags p ~out:exe);
exe exe
(* No Str, and the reader is hand-written for the same reason. *) (* No Str, and the reader is hand-written for the same reason. *)
@ -106,9 +110,29 @@ let () =
outputs "machine surface" "programs/machine.flan" machine_out; outputs "machine surface" "programs/machine.flan" machine_out;
outputs "unit main exits 0" "programs/unit-main.flan" "ok\n"; outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";
(* The raylib FFI, headless. GetColor and the enums need no window, so the
whole boundary is exercised without a display: a struct returned through
an out-pointer, a keyword resolved against an enum, and a Flan string
crossing as ptr+len. 0x11223344 comes back as four separate bytes, which
is the check that matters — a Color is not the little-endian reading of
the packed integer, so an identity would pass a weaker test. *)
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then
outputs "raylib ffi, headless" "programs/raylib-ffi.flan" "17\n34\n51\n68\n"
else
print_endline "acceptance: skipping the raylib FFI case (no libraylib)";
(* Again at -O0. Everything above runs through mem2reg, which launders a (* Again at -O0. Everything above runs through mem2reg, which launders a
sloppy alloca; -O0 tests the IR actually emitted, so a disagreement sloppy alloca; -O0 tests the IR actually emitted, so a disagreement
between the two points at undefined behaviour rather than a typo. *) between the two points at undefined behaviour rather than a typo. *)
(* sand.flan's simulation, headless. This is the milestone-4 acceptance
case: N frames from a seeded PRNG, one hash. It imports the sim package
and not raylib, deliberately — a program that imports raylib links
libraylib on every target, and this one is the version meant to run on
wasm32 too. The hash is reproducible only because rand-f32 is ours. *)
let sand_out = "2256461126764447066\n" in
outputs "sand, headless" "programs/sand-headless.flan" sand_out;
outputs ~opt:"-O0" "sand, headless, -O0" "programs/sand-headless.flan" sand_out;
outputs ~opt:"-O0" "value semantics, -O0" "programs/values.flan" values_out; outputs ~opt:"-O0" "value semantics, -O0" "programs/values.flan" values_out;
outputs ~opt:"-O0" "machine surface, -O0" "programs/machine.flan" machine_out; outputs ~opt:"-O0" "machine surface, -O0" "programs/machine.flan" machine_out;

42
test/test_flan.ml
View File

@ -530,15 +530,39 @@ let () =
~needle:"milestone 6"; ~needle:"milestone 6";
rejects_check "try is milestone 6" "(defn f [] i32 (try 1))" rejects_check "try is milestone 6" "(defn f [] i32 (try 1))"
~needle:"milestone 6"; ~needle:"milestone 6";
rejects_check "dotimes is milestone 4" (* dotimes and defer are implemented; what is still rejected is a defer that
"(defn f [] (dotimes [i 3] (g)))" ~needle:"milestone 4"; is not a top-level form, because it would run at function exit rather than
rejects_check "defer is milestone 4" "(defn f [] (defer (g)))" at the exit of the block it was written in. *)
~needle:"milestone 4"; rejects_check "defer must be top-level"
rejects_check "imports are milestone 4" "(import rl \"vendor:raylib\")" "(defn f [] (let [x 1] (defer (g))))" ~needle:"top-level";
~needle:"milestone 4"; (* An import is resolved by [Load] before the checker runs, so one that
rejects_check "keywords are milestone 4" reaches [Check] means a driver skipped that step. *)
"(defn g [x i32]) (defn f [] (g :space))" rejects_check "an unresolved import is a driver bug"
~needle:"milestone 4"; "(import rl \"vendor:raylib\")" ~needle:"not resolved";
(* Keywords resolve against an enum and against nothing else. *)
rejects_check "a keyword needs an enum"
"(defn g [x i32]) (defn f [] (g :space))" ~needle:"is expected here";
rejects_check "a keyword with no expectation"
"(defn f [] (print-i64 (i64 :space)))" ~needle:"no keyword type";
rejects_check "a keyword that is not a member"
"(defenum Key [space 32]) (defn g [k Key]) (defn f [] (g :spcae))"
~needle:"has no member :spcae";
accepts "a keyword that is a member"
"(defenum Key [space 32 r 82]) (defn g [k Key]) (defn f [] (g :r))";
(* A folded constant skips [check], so its range check has to be its own. *)
rejects_check "a folded constant is still range-checked"
"(defconst c u8 300) (defn f [] u8 c)" ~needle:"does not fit in u8";
(* An index converts from a narrower integer and never from a wider one. *)
accepts "a u32 index" "(defvar a [4 u32]) (defn f [] u32 (let [i 2] (at a (u32 i))))";
rejects_check "an i64 index"
"(defvar a [4 u32]) (defn f [] u32 (let [i 2] (at a (i64 i))))"
~needle:"is wider";
(* An aggregate cannot cross to C — the shim's job, in C, per target. *)
rejects_check "an extern may not take a struct"
"(defstruct V [x f32]) (declare f [v V] \"c_f\")" ~needle:"cannot cross to C";
rejects_check "an extern may not return a struct"
"(defstruct V [x f32]) (declare f [] V \"c_f\")" ~needle:"cannot cross to C";
rejects_check "fn values are milestone 5" "(defn f [] (fn [x] x))" rejects_check "fn values are milestone 5" "(defn f [] (fn [x] x))"
~needle:"milestone 5"; ~needle:"milestone 5";
rejects_check "type variables are milestone 5" "(defn f [x a])" rejects_check "type variables are milestone 5" "(defn f [x a])"

2
vendor/raylib/link vendored Normal file
View File

@ -0,0 +1,2 @@
-l:libraylib.so.550
-lm

105
vendor/raylib/raylib.flan vendored Normal file
View File

@ -0,0 +1,105 @@
;;;; raylib, declared for Flan. The directory is the package (plan.org,
;;;; Modules), and (import rl "vendor:raylib") qualifies all of it as rl/…
;;;;
;;;; Nothing here names a raylib symbol. Every `declare` names a wrapper in
;;;; shim.c, and that is the whole design decision: raylib passes Color by
;;;; value and returns Vector2 by value, and how a small aggregate is passed
;;;; differs between x86-64, arm64 and wasm32. Written in C, clang classifies
;;;; each one correctly per target for free; written in emit.ml it would be
;;;; three calling conventions to reimplement and then maintain forever. This
;;;; is "one narrow host ABI, implemented twice" (plan.org, Targets), and it
;;;; is why the checker rejects an aggregate in a `declare` signature at all.
;;;;
;;;; So each struct that crosses does it through a pointer, and the `-raw`
;;;; declaration is wrapped by an ordinary Flan function just below it. The
;;;; `-raw` names are visible as rl/…-raw because there is no visibility rule
;;;; yet; they are not meant to be called.
;; Layouts are C's — no object headers anywhere — so these are exactly
;; raylib's structs and nothing marshals.
(defstruct Vector2 [x f32 y f32])
(defstruct Color [r u8 g u8 b u8 a u8])
;; KeyboardKey, the subset sand.flan uses. A keyword at a call site resolves
;; against these members at compile time and a typo is an error there.
(defenum Key
[space 32 apostrophe 39 comma 44 minus 45 period 46 slash 47
zero 48 one 49 two 50 three 51 four 52
five 53 six 54 seven 55 eight 56 nine 57
a 65 b 66 c 67 d 68 e 69 f 70 g 71 h 72 i 73
j 74 k 75 l 76 m 77 n 78 o 79 p 80 q 81 r 82
s 83 t 84 u 85 v 86 w 87 x 88 y 89 z 90
escape 256 enter 257 tab 258 backspace 259
right 262 left 263 down 264 up 265])
(defenum MouseButton
[left 0 right 1 middle 2 side 3 extra 4 forward 5 back 6])
(defenum TraceLogLevel
[all 0 trace 1 debug 2 info 3 warning 4 error 5 fatal 6 none 7])
;; ── Window ──────────────────────────────────────────────────────────
(declare init-window [width i32 height i32 title string] "flan_rl_init_window")
(declare close-window [] "flan_rl_close_window")
(declare window-should-close? [] bool "flan_rl_window_should_close")
(declare set-target-fps [fps i32] "flan_rl_set_target_fps")
(declare set-trace-log-level [level TraceLogLevel] "flan_rl_set_trace_log_level")
;; ── Input ───────────────────────────────────────────────────────────
(declare key-pressed? [key Key] bool "flan_rl_is_key_pressed")
(declare key-down? [key Key] bool "flan_rl_is_key_down")
(declare key-released? [key Key] bool "flan_rl_is_key_released")
(declare mouse-button-pressed? [button MouseButton] bool
"flan_rl_is_mouse_button_pressed")
(declare mouse-button-down? [button MouseButton] bool
"flan_rl_is_mouse_button_down")
(declare mouse-button-released? [button MouseButton] bool
"flan_rl_is_mouse_button_released")
(declare get-mouse-position-raw [out (Ptr Vector2)] "flan_rl_get_mouse_position")
(defn get-mouse-position [] Vector2
(let [v (Vector2 {})]
(get-mouse-position-raw (addr v))
v))
;; ── Colours ─────────────────────────────────────────────────────────
;;
;; A Color is four bytes in RGBA order, so it is *not* the little-endian
;; reading of the packed 0xRRGGBBAA integer — that is why get-color is a real
;; call and not a reinterpretation.
(declare get-color-raw [hex u32 out (Ptr Color)] "flan_rl_get_color")
(defn get-color [hex u32] Color
(let [c (Color {})]
(get-color-raw hex (addr c))
c))
(defconst black (Color {:r 0 :g 0 :b 0 :a 255}))
(defconst white (Color {:r 255 :g 255 :b 255 :a 255}))
;; ── Drawing ─────────────────────────────────────────────────────────
(declare begin-drawing [] "flan_rl_begin_drawing")
(declare end-drawing [] "flan_rl_end_drawing")
(declare draw-fps [x i32 y i32] "flan_rl_draw_fps")
(declare clear-background-raw [color (Ptr Color)] "flan_rl_clear_background")
(defn clear-background [color Color]
;; The copy is not ceremony: a parameter is not an assignable place
;; (spec-memory.md), so there is no address to take without one.
(let [c color]
(clear-background-raw (addr c))))
(declare draw-rectangle-raw
[x i32 y i32 width i32 height i32 color (Ptr Color)]
"flan_rl_draw_rectangle")
(defn draw-rectangle [x i32 y i32 width i32 height i32 color Color]
(let [c color]
(draw-rectangle-raw x y width height (addr c))))

83
vendor/raylib/shim.c vendored Normal file
View File

@ -0,0 +1,83 @@
/* The C half of the raylib binding: one wrapper per `declare` in raylib.flan.
*
* The wrappers exist so that no aggregate is ever passed or returned across
* the Flan/C boundary. raylib takes Color by value and returns Vector2 by
* value, and a small aggregate is passed differently on x86-64 (<2 x float>,
* i32), on arm64, and on wasm32. Here, clang classifies each one correctly for
* whichever target the build is for; in the Flan backend it would be three
* conventions to reimplement. Everything below therefore trades in scalars and
* pointers only — see raylib.flan.
*
* raylib's own headers are not needed and not used: these prototypes are the
* declarations, so the build has no dependency on raylib-devel being
* installed, only on the shared library being linkable.
*/
#include <stdbool.h>
#include <stddef.h>
#include <string.h>
typedef struct { float x, y; } Vector2;
typedef struct { unsigned char r, g, b, a; } Color;
extern void InitWindow(int width, int height, const char *title);
extern void CloseWindow(void);
extern bool WindowShouldClose(void);
extern void SetTargetFPS(int fps);
extern void SetTraceLogLevel(int level);
extern bool IsKeyPressed(int key);
extern bool IsKeyDown(int key);
extern bool IsKeyReleased(int key);
extern bool IsMouseButtonPressed(int button);
extern bool IsMouseButtonDown(int button);
extern bool IsMouseButtonReleased(int button);
extern Vector2 GetMousePosition(void);
extern Color GetColor(unsigned int hex);
extern void BeginDrawing(void);
extern void EndDrawing(void);
extern void DrawFPS(int x, int y);
extern void ClearBackground(Color color);
extern void DrawRectangle(int x, int y, int width, int height, Color color);
/* A Flan string arrives as ptr+len and is not NUL-terminated, so a C API that
* wants a C string needs a copy. The window title is the only one, it is short
* by nature, and truncating is better than reading past the end. */
static const char *cstr(const char *p, long long n, char *buf, size_t cap) {
size_t k = (size_t)n < cap - 1 ? (size_t)n : cap - 1;
memcpy(buf, p, k);
buf[k] = '\0';
return buf;
}
void flan_rl_init_window(int width, int height, const char *title, long long n) {
char buf[256];
InitWindow(width, height, cstr(title, n, buf, sizeof buf));
}
void flan_rl_close_window(void) { CloseWindow(); }
bool flan_rl_window_should_close(void) { return WindowShouldClose(); }
void flan_rl_set_target_fps(int fps) { SetTargetFPS(fps); }
void flan_rl_set_trace_log_level(int l) { SetTraceLogLevel(l); }
bool flan_rl_is_key_pressed(int key) { return IsKeyPressed(key); }
bool flan_rl_is_key_down(int key) { return IsKeyDown(key); }
bool flan_rl_is_key_released(int key) { return IsKeyReleased(key); }
bool flan_rl_is_mouse_button_pressed(int b) { return IsMouseButtonPressed(b); }
bool flan_rl_is_mouse_button_down(int b) { return IsMouseButtonDown(b); }
bool flan_rl_is_mouse_button_released(int b) { return IsMouseButtonReleased(b); }
void flan_rl_get_mouse_position(Vector2 *out) { *out = GetMousePosition(); }
void flan_rl_get_color(unsigned int hex, Color *out) { *out = GetColor(hex); }
void flan_rl_begin_drawing(void) { BeginDrawing(); }
void flan_rl_end_drawing(void) { EndDrawing(); }
void flan_rl_draw_fps(int x, int y) { DrawFPS(x, y); }
void flan_rl_clear_background(const Color *color) { ClearBackground(*color); }
void flan_rl_draw_rectangle(int x, int y, int width, int height,
const Color *color) {
DrawRectangle(x, y, width, height, *color);
}