diff --git a/NEXT.md b/NEXT.md index 0bfd181..3192c70 100644 --- a/NEXT.md +++ b/NEXT.md @@ -1,11 +1,12 @@ # Where this is -Milestones 2 and 3 of `plan.org` were merged: the interpreter was dropped -(open decision #7, settled — see below) and the compiled path is the only -backend. **calc-me.flan compiles and runs.** +Milestone 4 is done: **sand.flan builds, links raylib and runs**, and its +simulation has a headless acceptance case that runs on the `dune test` path at +`-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 | @@ -15,46 +16,184 @@ reader ✅ → parse ✅ → check ✅ → emit ✅ → clang ✅ | `lib/reader.ml` | hand-written S-expression reader, no menhir/ocamllex | | `lib/ast.ml` | AST: `texpr`, `expr`, `place`, `pattern`, `decl` | | `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/tast.ml` | the typed IR the backend consumes | | `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/build.ml` | `.ll` + the shim → clang → executable | -| `runtime/flan_rt.c` | the whole host ABI: argv, stdout, exit, 4 conversions | +| `lib/build.ml` | `.ll` + the shim + the packages' C → clang → executable | +| `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` | | `test/test_flan.ml` | reader, parser and checker | -| `test/test_acceptance.ml` | 20 expression/result pairs + 3 whole programs + the traps | -| `test/programs/*.flan` | the milestone-2 surface calc-me does not reach | +| `test/test_acceptance.ml` | expression/result pairs + whole programs + the traps | ``` $ flan run calc-me.flan "1 + 2 * (3 - 0.5) / 2" 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` -*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 -`(import rl ...)`, which is milestone 4 — as it should. +## What milestone 4 added + +**`dotimes`** desugars in `check.ml` to a `Let` plus a `While` — no new IR node. +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 -Open decision #7 is settled: **the compiled path is the only backend.** The two -arguments for a permanent interpreter had both already expired in `plan.org` — -the instrumentation step debugger that wanted it is cut, and compiled -redefinition measured at ~16ms, which is perceptually instant for expression -eval too. CCL and SBCL both do full interactive development without leaning on -an interpreter; what makes a live image work is a fast compiler callable at -runtime. - -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. +Open decision #7 is settled: **the compiled path is the only backend.** Both +arguments for a permanent interpreter had expired — the instrumentation step +debugger that wanted it is cut, and compiled redefinition measured at ~16ms, +perceptually instant for expression eval too. Milestone 3 did not need an +oracle either: the acceptance table is hand-written, so the table *is* the +oracle. Consequences already applied: milestone 2's "interpreted calls per +second" criterion is dropped, and the host ABI moved onto the critical path. ## 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 f32 f64 float double bool i1 +an enum i32 [T] and string { ptr, i64 } ptr+len, non-owning [n T] [n x T] inline, a value (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 `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. - `addr` of a local is then just the alloca, and `mem2reg` removes the ones - nobody addressed. `test/programs/values.flan` pins this down: mutate the - original, the copy is unchanged. + requires. `addr` of a local is then just the alloca, and `mem2reg` removes + the ones nobody addressed. `test/programs/values.flan` pins this down. - **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 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 -`ret`, never platform unwinding, so wasm32 needs no exception proposal. +Non-local exit is lowered explicitly: `return`, `some` and a failed bounds +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 -to a `noreturn cold` call and then `unreachable` — the same explicit shape as -`return` and `some`, so wasm32 needs nothing extra for it either. The message -carries the source location, because `Tast.expr` keeps a `Loc.t` and a language -that threads locations through the whole frontend should not trap anonymously: - -``` -$ flan run test/programs/bounds.flan 2 -test/programs/bounds.flan:25:29: slice [2 1) is out of bounds for length 5 (exit 134) -``` - -Three check sites, and the third is the one with the trap in it: - -- **`at` on `[n T]`** — the bound is static, so LLVM folds the check away for a - literal index. A literal that is *out* of bounds never reaches emit at all: - `check.ml` rejects it, along with a negative literal index (wrong whatever - the target) and a literal `slice` range that runs backwards. Only literals — - a `defconst` is a global in the typed IR, not a folded constant, so - `(at a k)` stays a runtime trap. A slice bound may sit one past the end and - an index may not, which is the one place the two rules differ. -- **`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`. +- **An index converts from a narrower integer and never from a wider one.** + `(nth colors current-color)` with a `u32` index works — anything above 2³¹ + truncates to a negative `i32` and the unsigned bounds check rejects it. An + `i64` index is refused with the reason: 2³²+5 truncates to 5 and would read + 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 + accepted as a `u64` too, because the reader records 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. +- **A folded constant skips `check`.** `(defconst rows (/ h c))` is emitted + 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 + is therefore its own call to `in_range`; there is a regression test. +- A `let` binding takes no type annotation, which is why `sand-sim` names its + FNV constants instead of writing them inline. +- `(defn f [] f65 0.0)` still says *unknown name* rather than *did you mean + f64*: with a single body form the parser cannot tell a return type from the + first expression. Only the parameter position and `(Option …)` are + unambiguous. ## Where build time goes @@ -167,83 +254,51 @@ Verified by reading `flan emit` output rather than by trusting the tests: | 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 `flan_rt.c` | 40ms — recompiled every build, and it never changes | +| `clang` on `flan_rt.c` | 40ms — recompiled every build, never changes | | link | 20ms | -Two cheap wins take it to ~60ms: cache `flan_rt.o`, and skip the clang driver -for the `.ll` (`llc` + link directly). This reproduces plan.org's own -measurement — the driver is the cost, not codegen — and it is a subset of the -dev path's machinery, so doing it now is not wasted work. +sand.flan additionally recompiles `shim.c` every build. Two cheap wins take the +base to ~60ms: cache `flan_rt.o` (and the packages' `.o`), and skip the clang +driver for the `.ll` (`llc` + link directly). Both are a subset of the dev +path's machinery, so doing them now is not wasted work. -**There is still no REPL.** Nothing in `lib/` or `bin/` does redefinition, -`dlopen`, or nREPL; `build.ml`'s docstring describes the dev path and says -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. +**There is still no REPL.** Nothing does redefinition, `dlopen`, or nREPL. +`build` is the only way to run code. ## Next -Recommended order — start with milestone 4; wasm32 needs a system install only -you can authorize, and the REPL is worth more once there is a frame loop for it -to not stutter. - -1. **Milestone 4 — sand.flan.** `dotimes`, `defer`, and typed raylib FFI with - keyword→enum coercion. Fixed 2-D arrays are done. `flan check sand.flan` - already fails on `(import rl ...)`, as it should. FFI is the part most likely - to expose layout bugs the calc-me surface cannot reach. -2. **wasm32.** The backend is there (`llc` lists `wasm32`) and - `Build.opts.target` already plumbs `--target`, but there is **no wasi - sysroot on this machine** — `clang --target=wasm32-wasi` cannot find - `stdio.h`. Install `wasi-sdk`/`wasi-libc` (`dnf search wasi` for the Fedora - package name), then run the same acceptance table on both targets in CI. - That is milestone 3's real remaining work. The bounds work above was written - to survive the port — no unwinding, and `exit(134)` rather than `abort()`, - so the same trap assertion should hold on wasm32 — but that is intent, not a - tested result: nothing here has ever been built for wasm32. - WASI is the syscall interface wasm has to import to get stdout, argv and - exit at all; `flan_rt.c` calls libc (`fwrite`, `snprintf`, `strtod`, - `malloc`), so it needs `wasi-libc`. The alternative is a second freestanding - 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. +1. **wasm32.** The user installed `wasi-libc-devel` and `wasi-libc-static`; the + sysroot is `/usr/wasm32-wasi` and `wasm-ld` is present. `clang + --target=wasm32-wasi --sysroot=/usr/wasm32-wasi` gets past the headers and + then **fails to link**: it wants + `lib/clang/20/lib/wasm32-unknown-wasi/libclang_rt.builtins.a`, which no + Fedora package provides (`dnf provides '*libclang_rt.builtins*wasm*'` finds + nothing). It has to come from a wasi-sdk release, dropped into clang's + resource directory. After that: teach `build.ml` `--sysroot`, and run the + acceptance table — `sand-headless.flan` included, which is exactly why it + does not import raylib — on both targets in CI. + Note plan.org has the *web* build linking raylib via emscripten, which + brings its own sysroot: wasi-sdk is right for the headless table, not + necessarily for the eventual game build. +2. **The dev path / REPL.** `llc` + `ld -shared` + `dlopen` ≈ 16ms, a compiler + daemon plus an in-game reload agent (plan.org, Dev architecture). There is + now a frame loop for it to not stutter, which was the reason to do it after + milestone 4. +3. **Loose ends from milestone 4**, none of them blocking: block-scoped + `defer`; package visibility, so `rl/get-color-raw` is not callable; a + package importing a package; imported unions. ## Watch for 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 explicitly and rejected if unsupported.** `check.ml` rejects `Vec`, `Map`, -`Result`/`try`, union values, closures, `dotimes`, `defer`, keywords at call -sites, imports, generics and function values *by name*, each with the milestone -it belongs to. The tests assert on the reason, not just on the failure. +`Result`/`try`, union values, closures, quoted symbols, generics and function +values *by name*, each with the milestone it belongs to; `load.ml` rejects the +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 diff --git a/bin/main.ml b/bin/main.ml index a181df8..a24fbcb 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -17,12 +17,24 @@ let summarise (d : Flan.Ast.decl) = | Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs) | Defvar (n, _, _) -> Printf.sprintf "defvar %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 -> Printf.sprintf "defn %s (%d params, %s return, %d body forms)" fn.name (List.length fn.params) (match fn.ret with None -> "Unit" | Some _ -> "explicit") (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 decision, not the optimisation level (NEXT.md, Bounds checks). *) let no_checks_flag = "--no-bounds-checks" @@ -48,11 +60,7 @@ let () = List.iter (fun path -> with_errors path (fun () -> - let p = - Flan.Reader.read_file path - |> Flan.Parse.program - |> Flan.Check.program - in + let p = checked path in List.iter (fun (g : Flan.Tast.global) -> Printf.printf "%s %s %s\n" @@ -73,11 +81,7 @@ let () = List.iter (fun path -> with_errors path (fun () -> - Flan.Reader.read_file path - |> Flan.Parse.program - |> Flan.Check.program - |> Flan.Emit.program ~checks - |> print_string)) + checked path |> Flan.Emit.program ~checks |> print_string)) files | _ :: "build" :: path :: rest -> let checks = not (List.mem no_checks_flag rest) in @@ -91,22 +95,19 @@ let () = exit 2 in with_errors path (fun () -> - Flan.Reader.read_file path - |> Flan.Parse.program - |> Flan.Check.program - |> fun p -> - ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks } p ~out)) + let l = load path in + let p = Flan.Check.program l.decls in + ignore (Flan.Build.executable ~opts:{ Flan.Build.default with checks } + ~csrcs:l.csrcs ~lflags:l.lflags p ~out)) | _ :: "run" :: path :: args -> with_errors path (fun () -> let exe = Filename.concat (Filename.get_temp_dir_name ()) (Printf.sprintf "flan-run-%d" (Unix.getpid ())) in - Flan.Reader.read_file path - |> Flan.Parse.program - |> Flan.Check.program - |> fun p -> - ignore (Flan.Build.executable p ~out:exe); + let l = load path in + let p = Flan.Check.program l.decls in + ignore (Flan.Build.executable ~csrcs:l.csrcs ~lflags:l.lflags p ~out:exe); let code = Sys.command (String.concat " " (List.map Filename.quote (exe :: args))) in diff --git a/lib/ast.ml b/lib/ast.ml index cc9cf5c..58b9a65 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -94,6 +94,13 @@ and decl_kind = | Defstruct of string * field list | Defunion of string * variant list | 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. *) | Defvar of string * texpr option * init | Defconst of string * texpr option * expr diff --git a/lib/build.ml b/lib/build.ml index f88245e..368b8ff 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -38,7 +38,11 @@ type opts = { checks. Dropping them is a release decision, not an optimisation one. *) 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 ll = Filename.concat dir (Filename.basename out ^ ".ll") in let rt = Filename.concat dir "flan_rt.c" in @@ -48,7 +52,10 @@ let executable ?(opts = default) (p : Tast.program) ~out = String.concat " " ([ Filename.quote clang; opts.opt; "-Wno-override-module" ] @ (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 let code = Sys.command cmd in if code <> 0 then diff --git a/lib/check.ml b/lib/check.ml index f397518..b554602 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -47,6 +47,12 @@ type env = { aliases : (string, Ast.texpr) Hashtbl.t; consts : (string, int64) Hashtbl.t; (* compile-time array lengths *) 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; globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *) } @@ -57,6 +63,8 @@ let new_env () = { aliases = Hashtbl.create 16; consts = Hashtbl.create 16; locs = Hashtbl.create 16; + enums = Hashtbl.create 8; + externs = Hashtbl.create 32; fns = Hashtbl.create 32; globals = Hashtbl.create 16; } @@ -71,6 +79,10 @@ type ctx = { frame — nothing else records it, since the IR refers to slots by index. *) mutable slot_tys : Types.t list; 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 = @@ -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.structs [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.unions [] + @ Hashtbl.fold (fun k _ acc -> k :: acc) env.enums [] in 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) | _ when Hashtbl.mem env.structs n || Hashtbl.mem env.unions 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 below would otherwise report [f65] as unimplemented generics and send 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 mk loc (Types.Float k) (Tast.Float (x, k)) | Ast.Str s -> expect loc ~want (mk loc Types.String (Tast.Str s)) - | Ast.Kw _ -> - unimplemented loc "a keyword at a call site (keyword->enum coercion)" 4 + | Ast.Kw k -> + (* 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 _ -> unimplemented loc "a quoted symbol (restart names)" 6 | Ast.Var name -> var ctx loc ~want name @@ -267,7 +300,12 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = None | Some v -> Some (check ctx ~want:ctx.ret v) 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) -> let p, pty = check_place ctx loc p 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)) | Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6 | Ast.Fn _ -> unimplemented loc "fn values" 5 - | Ast.Dotimes _ -> unimplemented loc "dotimes" 4 - | Ast.Defer _ -> unimplemented loc "defer" 4 + | Ast.Dotimes (name, count, body) -> check_dotimes ctx ~want loc name count body + | 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 = match want with @@ -325,9 +370,18 @@ and in_range loc k n = bits = 64 || (Int64.compare n (Int64.neg (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 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 if ok then n 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 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 = let c = check ctx ~want:Types.Bool c in match e with @@ -585,6 +665,32 @@ and static_index loc (ty : Types.t) ~past_end what k = and literal (e : Tast.expr) = 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. *) and indexed ctx (target : Tast.expr) (idx : Ast.expr list) = 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) 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 | Some k -> static_index loc ty ~past_end:false "index" k | None -> ()); @@ -648,6 +754,45 @@ and named_call ctx ~want loc name args = | "not" -> arity loc name 1 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 ────────────────────────────────────────────────── *) | "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 own below. *) 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 (fun (d : Ast.decl) -> let loc = d.Ast.dloc in match d.Ast.d with | 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, _) -> - unimplemented loc - (Printf.sprintf "the cross-package import (import %s ...)" alias) 4 + fail loc "internal: the import of %s was not resolved before checking" + 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.Defstruct (n, fs) -> 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 run without swallowing it. *) 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 let pending = ref (List.rev !untyped) in let rec settle () = @@ -973,7 +1162,7 @@ let check_finite env = let check_fn env (fn : Ast.fn) : Tast.fn = 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 (fun (p : Ast.field) ty -> 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, in which case whatever it evaluates to is discarded. *) 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 - | [ last ] -> [ check ctx ?want last ] - | x :: rest -> check ctx x :: go rest + | [ last ] -> + (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 in go body 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; slots = Array.of_list (List.rev ctx.slot_tys); ret; body; floc = fn.Ast.nloc } 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 | Ast.Defvar (n, _, init) -> 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 } | Ast.Defconst (n, _, v) -> let ty, _ = Hashtbl.find env.globals n in - Some { Tast.gname = n; gty = ty; ginit = check (ctx ()) ~want:ty v; - gconst = true } + (* [collect] already folded the integer constants, because an array length + 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 (* 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 [] |> List.sort (fun a b -> String.compare (name a) (name b)) 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; unions = values (fun (u : Tast.union) -> u.Tast.uname) env.unions; - globals; fns } + globals; externs; fns } diff --git a/lib/emit.ml b/lib/emit.ml index eedaa39..b7cd29d 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -64,6 +64,8 @@ let rec ll (t : Types.t) = | Types.String | Types.Slice _ -> "%slice" | Types.Unit | Types.Never -> "{}" | 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.Ptr _ -> "ptr" | Types.Option e -> Printf.sprintf "{ i8, %s }" (ll e) @@ -80,6 +82,9 @@ type m = { strs : Buffer.t; (* string literal constants *) structs : (string, Tast.structure) 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 *) mutable nstr : int; } @@ -232,7 +237,10 @@ let rec value f (e : Tast.expr) : string = load f (addr f e) e.Tast.ty | Tast.Addr p -> fst (place f p) | 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.Let (bs, body) -> 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); 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 = let cv = value f c in 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 | t' -> failwith ("comparison on " ^ Types.to_string 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 ] -> let a = value f x in let t = fresh f in @@ -678,6 +723,9 @@ let emit_fn m (fn : Tast.fn) = fn.Tast.params; let last = ref "zeroinitializer" in 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; let 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 = { out = Buffer.create 8192; strs = Buffer.create 512; structs = Hashtbl.create 16; globals = Hashtbl.create 16; + externs = Hashtbl.create 32; checks; nstr = 0; } in List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s) p.Tast.structs; List.iter (fun (g : Tast.global) -> Hashtbl.replace m.globals g.Tast.gname g.Tast.gty) p.Tast.globals; + List.iter (fun (e : Tast.extern) -> Hashtbl.replace m.externs e.Tast.ename e.Tast.esym) + p.Tast.externs; List.iter (fun (s : Tast.structure) -> 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)))) p.Tast.structs; 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_fn m) p.Tast.fns; (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with diff --git a/lib/load.ml b/lib/load.ml new file mode 100644 index 0000000..07bc885 --- /dev/null +++ b/lib/load.ml @@ -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 diff --git a/lib/parse.ml b/lib/parse.ml index 64ac475..7a75edf 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -349,6 +349,37 @@ let rec decl types (f : Form.t) : Ast.decl = fbody = body; nloc = n.loc }) | _ -> 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) -> (match args with | [ n; t ] -> mk (Ast.Defvar (sym n, Some (texpr t), Ast.Zeroed)) diff --git a/lib/prelude.ml b/lib/prelude.ml index 37d4ddb..cb427e8 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -29,6 +29,28 @@ let source = {flan| (defn newline [] (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 — ;; there is nothing to dispatch on yet. (defn print-line [s string] diff --git a/lib/tast.ml b/lib/tast.ml index 9c15231..ae8d065 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -19,6 +19,9 @@ type prim = | Add | Sub | Mul | Div | Rem | Eq | Ne | Lt | Le | Gt | Ge | 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 *) | Len | At | Slice (* 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 } +(* 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 = { structs : structure list; unions : union list; globals : global list; (* in declaration order *) + externs : extern list; fns : fn list; } diff --git a/lib/types.ml b/lib/types.ml index 1f52dc9..ef1ef27 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -23,6 +23,9 @@ type t = | Unit (* the zero-sized type, not C's void *) | Never (* return, exit, error: no value at all *) | 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 *) | Array of int64 * t (* [n T] inline, a value, copies *) | Map of t * t (* {K V} *) @@ -67,7 +70,7 @@ let rec equal a b = | Int x, Int y -> x = y | Float x, Float y -> x = y | 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 | 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' @@ -87,7 +90,7 @@ let rec to_string = function | String -> "string" | Unit -> "Unit" | Never -> "Never" - | Named n -> n + | Named n | Enum n -> n | Slice t -> "[" ^ 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) @@ -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 milestone 2 — strings, structs and slices have no built-in [=], because an 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, an early-returning `some`, exit. It fits anywhere, and that is the only diff --git a/sand-sim/sim.flan b/sand-sim/sim.flan new file mode 100644 index 0000000..cc66c8f --- /dev/null +++ b/sand-sim/sim.flan @@ -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)) diff --git a/sand.flan b/sand.flan index 4b81efd..4f09a59 100644 --- a/sand.flan +++ b/sand.flan @@ -6,7 +6,10 @@ ;;;; path to "the language runs something". ;;;; ;;;; 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, ;;;; 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 ;;;; it is an ordinary compile-time value, so [rows [cols u32]] is unambiguous -(import rl "vendor:raylib") ; directory = package; declaration optional - -(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))) +(import rl "vendor:raylib") ; directory = package; declaration optional +(import sim "sand-sim") ; no collection prefix: relative to this file ;; Locals are assignable places (spec-memory.md); parameters are not. (defn paint [] - (let [m (rl/get-mouse-position) - row (/ (i32 (.y m)) cell-size) - col (/ (i32 (.x m)) cell-size) - 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))) + (let [m (rl/get-mouse-position) + row (/ (i32 (.y m)) sim/cell-size) + col (/ (i32 (.x m)) sim/cell-size)] + (sim/paint-at row col))) ;; 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. @@ -113,33 +45,26 @@ ;; because old code is never unloaded; changing its SIGNATURE is not, and the ;; reload rejects it. See plan.org "What redefinition cannot do". (defn game-update [] - (when (rl/key-pressed? :r) (clear-grid)) - (when (rl/key-down? :space) (paint)) - (when (rl/key-released? :space) - (set current-color (% (+ current-color 1) (len colors)))) - ;; 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))))) + (when (rl/key-pressed? :r) (sim/clear-grid)) + (when (rl/mouse-button-down? :left) (paint)) + (when (rl/mouse-button-released? :left) (sim/next-color)) + (sim/step)) (defn game-draw [] (rl/clear-background rl/black) - (dotimes [row rows] - (dotimes [col cols] - (let [c (at grid row col)] + (dotimes [row sim/rows] + (dotimes [col sim/cols] + (let [c (at sim/grid row col)] (unless (= 0 c) - (rl/draw-rectangle (i32 (* col cell-size)) - (i32 (* row cell-size)) - cell-size cell-size + (rl/draw-rectangle (i32 (* col sim/cell-size)) + (i32 (* row sim/cell-size)) + sim/cell-size sim/cell-size (rl/get-color c)))))) (rl/draw-fps 20 20)) (defn main [] (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)) (rl/set-target-fps 120) ;; Bare (defn main []) — argv and the i32 status are both optional. diff --git a/test/dune b/test/dune index 3a57741..69c59b4 100644 --- a/test/dune +++ b/test/dune @@ -6,4 +6,8 @@ (deps (file %{workspace_root}/calc-me.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))) diff --git a/test/programs/raylib-ffi.flan b/test/programs/raylib-ffi.flan new file mode 100644 index 0000000..ad0b719 --- /dev/null +++ b/test/programs/raylib-ffi.flan @@ -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)) diff --git a/test/programs/sand-headless.flan b/test/programs/sand-headless.flan new file mode 100644 index 0000000..3135093 --- /dev/null +++ b/test/programs/sand-headless.flan @@ -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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 15327d2..0e70878 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -28,8 +28,12 @@ let compile ?(opt = "-O2") ?(checks = true) path = Filename.concat scratch ("flan-t-" ^ Filename.remove_extension (Filename.basename path)) in - let p = Reader.read_file path |> Parse.program |> Check.program in - ignore (Build.executable ~opts:{ Build.default with opt; checks } p ~out:exe); + (* Through [Load], so a program with an (import ...) is buildable here: it + 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 (* 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 "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 sloppy alloca; -O0 tests the IR actually emitted, so a disagreement 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" "machine surface, -O0" "programs/machine.flan" machine_out; diff --git a/test/test_flan.ml b/test/test_flan.ml index a5dff4d..e4a377c 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -530,15 +530,39 @@ let () = ~needle:"milestone 6"; rejects_check "try is milestone 6" "(defn f [] i32 (try 1))" ~needle:"milestone 6"; - rejects_check "dotimes is milestone 4" - "(defn f [] (dotimes [i 3] (g)))" ~needle:"milestone 4"; - rejects_check "defer is milestone 4" "(defn f [] (defer (g)))" - ~needle:"milestone 4"; - rejects_check "imports are milestone 4" "(import rl \"vendor:raylib\")" - ~needle:"milestone 4"; - rejects_check "keywords are milestone 4" - "(defn g [x i32]) (defn f [] (g :space))" - ~needle:"milestone 4"; + (* dotimes and defer are implemented; what is still rejected is a defer that + is not a top-level form, because it would run at function exit rather than + at the exit of the block it was written in. *) + rejects_check "defer must be top-level" + "(defn f [] (let [x 1] (defer (g))))" ~needle:"top-level"; + (* An import is resolved by [Load] before the checker runs, so one that + reaches [Check] means a driver skipped that step. *) + rejects_check "an unresolved import is a driver bug" + "(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))" ~needle:"milestone 5"; rejects_check "type variables are milestone 5" "(defn f [x a])" diff --git a/vendor/raylib/link b/vendor/raylib/link new file mode 100644 index 0000000..21fde4d --- /dev/null +++ b/vendor/raylib/link @@ -0,0 +1,2 @@ +-l:libraylib.so.550 +-lm diff --git a/vendor/raylib/raylib.flan b/vendor/raylib/raylib.flan new file mode 100644 index 0000000..0d6194d --- /dev/null +++ b/vendor/raylib/raylib.flan @@ -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)))) diff --git a/vendor/raylib/shim.c b/vendor/raylib/shim.c new file mode 100644 index 0000000..11db1a6 --- /dev/null +++ b/vendor/raylib/shim.c @@ -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 +#include +#include + +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); +}