Every defn in the tree states its return type, and Unit is written ()
The mechanical half, ahead of the parser change that needs it. tools/unit-return.py
fills the empty slot with () and rewrites Unit as () wherever a type is spelled --
(Fn [i32] Unit), (Map i32 Unit), a return type written out.
Deciding whether a defn already had a return type is the whole difficulty, and
the script does it the way parse.ml did: is_type_form is transcribed rather than
improved, because being identical to the parser it replaces is what makes the
sweep meaning-preserving. It is re-runnable, so the lanes that branched before
this can have the same pass at merge:
python3 tools/unit-return.py .
python3 tools/unit-return.py --in-strings test/test_flan.ml test/test_acceptance.ml \
test/test_session.ml emacs/test-flan-dev.el emacs/test-flan-mode.el
python3 tools/unit-return.py --raw-ml lib/prelude.ml
python3 tools/unit-return.py --in-html web/index.html
-v logs every defn it saw and what it decided, which is how a sweep of 440 sites
gets reviewed at all. Embedded modes pool a file's type declarations across all
its fragments, because a snippet split across concatenation -- decls ^ "(defn f
[s [u8]] Cursor ...)" -- cannot see the names the other half declared; pooled
names count only in bare-symbol position, for the same reason the prelude's do.
A fragment that cuts off mid-form is skipped rather than guessed at. Five sites
in test_flan.ml still needed a hand, and they are in this commit.
Two things ride along because the sweep needs them: parse.ml reads a lone () as
the return type of a function with no body, which was not a shape the old
optional slot could produce; and the map refusals name () rather than Unit, since
that is now the spelling a caller wrote.
This commit is contained in:
parent
385ecc5c48
commit
26c53e0a19
@ -27,10 +27,10 @@
|
|||||||
(at (.src c) (.pos c))
|
(at (.src c) (.pos c))
|
||||||
0)) ; 0 doubles as end-of-input
|
0)) ; 0 doubles as end-of-input
|
||||||
|
|
||||||
(defn advance [c (Ptr Cursor)]
|
(defn advance [c (Ptr Cursor)] ()
|
||||||
(set (.pos c) (+ (.pos c) 1))) ; field access auto-derefs one level
|
(set (.pos c) (+ (.pos c) 1))) ; field access auto-derefs one level
|
||||||
|
|
||||||
(defn skip-spaces [c (Ptr Cursor)]
|
(defn skip-spaces [c (Ptr Cursor)] ()
|
||||||
(while (= (peek c) \space)
|
(while (= (peek c) \space)
|
||||||
(advance c)))
|
(advance c)))
|
||||||
|
|
||||||
|
|||||||
@ -29,7 +29,7 @@
|
|||||||
(use-placeholder [] -1)
|
(use-placeholder [] -1)
|
||||||
(retry [] 7)))
|
(retry [] 7)))
|
||||||
|
|
||||||
(defn run-once []
|
(defn run-once [] ()
|
||||||
(print (fetch 1)) (println "")
|
(print (fetch 1)) (println "")
|
||||||
|
|
||||||
(handler-bind [(AssetMissing [c] (set seen (+ seen (i64 (.id c)))))]
|
(handler-bind [(AssetMissing [c] (set seen (+ seen (i64 (.id c)))))]
|
||||||
|
|||||||
@ -70,7 +70,7 @@
|
|||||||
;; the first argument — `(+ gravity …)' — instead of under `vel'.
|
;; the first argument — `(+ gravity …)' — instead of under `vel'.
|
||||||
(test-flan-mode--check
|
(test-flan-mode--check
|
||||||
"a let's bindings align name under name"
|
"a let's bindings align name under name"
|
||||||
"(defn settle [row i32 col i32]
|
"(defn settle [row i32 col i32] ()
|
||||||
(let [vel (+ gravity (at velocity row col))
|
(let [vel (+ gravity (at velocity row col))
|
||||||
y (min (- rows 1) (+ row (i32 vel)))]
|
y (min (- rows 1) (+ row (i32 vel)))]
|
||||||
(while (> y row)
|
(while (> y row)
|
||||||
@ -117,7 +117,7 @@
|
|||||||
|
|
||||||
(test-flan-mode--check
|
(test-flan-mode--check
|
||||||
"and a defn without one indents it the same"
|
"and a defn without one indents it the same"
|
||||||
"(defn show-trim [s string]
|
"(defn show-trim [s string] ()
|
||||||
(print s)
|
(print s)
|
||||||
(println \"\"))")
|
(println \"\"))")
|
||||||
|
|
||||||
@ -127,7 +127,7 @@
|
|||||||
"a wrapped parameter list aligns under the first parameter"
|
"a wrapped parameter list aligns under the first parameter"
|
||||||
"(defn move-grain [row i32 col i32
|
"(defn move-grain [row i32 col i32
|
||||||
to-row i32 to-col i32
|
to-row i32 to-col i32
|
||||||
vel f32]
|
vel f32] ()
|
||||||
(set moved true))")
|
(set moved true))")
|
||||||
|
|
||||||
;; `handler-bind' clauses: the vector is the special argument, and each clause
|
;; `handler-bind' clauses: the vector is the special argument, and each clause
|
||||||
|
|||||||
@ -17,7 +17,7 @@
|
|||||||
(defconst screen-width 800)
|
(defconst screen-width 800)
|
||||||
(defconst screen-height 450)
|
(defconst screen-height 450)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - basic window")
|
"raylib [core] example - basic window")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -35,7 +35,7 @@
|
|||||||
(defvar frame-circle rl/Vector2)
|
(defvar frame-circle rl/Vector2)
|
||||||
(defvar current-fps i32)
|
(defvar current-fps i32)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - delta time")
|
"raylib [core] example - delta time")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -90,7 +90,7 @@
|
|||||||
(defn axis-at [pad i32 index i32] f32
|
(defn axis-at [pad i32 index i32] f32
|
||||||
(rl/get-gamepad-axis-movement pad (rl/GamepadAxis index)))
|
(rl/get-gamepad-axis-movement pad (rl/GamepadAxis index)))
|
||||||
|
|
||||||
(defn draw-pad-background []
|
(defn draw-pad-background [] ()
|
||||||
(rl/draw-rectangle-rounded
|
(rl/draw-rectangle-rounded
|
||||||
(rl/Rectangle {.x 175.0 .y 110.0 .width 460.0 .height 220.0})
|
(rl/Rectangle {.x 175.0 .y 110.0 .width 460.0 .height 220.0})
|
||||||
0.3 16 rl/darkgray)
|
0.3 16 rl/darkgray)
|
||||||
@ -119,7 +119,7 @@
|
|||||||
(rl/Rectangle {.x 495.0 .y 98.0 .width 100.0 .height 10.0})
|
(rl/Rectangle {.x 495.0 .y 98.0 .width 100.0 .height 10.0})
|
||||||
0.5 16 rl/darkgray))
|
0.5 16 rl/darkgray))
|
||||||
|
|
||||||
(defn draw-pad-buttons []
|
(defn draw-pad-buttons [] ()
|
||||||
(when (rl/gamepad-button-down? gamepad :middle-left)
|
(when (rl/gamepad-button-down? gamepad :middle-left)
|
||||||
(rl/draw-circle 365 170 10.0 rl/red))
|
(rl/draw-circle 365 170 10.0 rl/red))
|
||||||
(when (rl/gamepad-button-down? gamepad :middle)
|
(when (rl/gamepad-button-down? gamepad :middle)
|
||||||
@ -153,13 +153,13 @@
|
|||||||
(rl/Rectangle {.x 495.0 .y 98.0 .width 100.0 .height 10.0})
|
(rl/Rectangle {.x 495.0 .y 98.0 .width 100.0 .height 10.0})
|
||||||
0.5 16 rl/red)))
|
0.5 16 rl/red)))
|
||||||
|
|
||||||
(defn draw-stick [cx i32 cy i32 ax f32 ay f32 thumb-down bool]
|
(defn draw-stick [cx i32 cy i32 ax f32 ay f32 thumb-down bool] ()
|
||||||
(rl/draw-circle cx cy 40.0 rl/black)
|
(rl/draw-circle cx cy 40.0 rl/black)
|
||||||
(rl/draw-circle cx cy 35.0 rl/lightgray)
|
(rl/draw-circle cx cy 35.0 rl/lightgray)
|
||||||
(rl/draw-circle (+ cx (i32 (* ax 20.0))) (+ cy (i32 (* ay 20.0))) 25.0
|
(rl/draw-circle (+ cx (i32 (* ax 20.0))) (+ cy (i32 (* ay 20.0))) 25.0
|
||||||
(if thumb-down rl/red rl/black)))
|
(if thumb-down rl/red rl/black)))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
;; Before init-window, and it has to be: raylib reads the flags while it is
|
;; Before init-window, and it has to be: raylib reads the flags while it is
|
||||||
;; creating the context, so the same call afterwards is accepted, logged, and
|
;; creating the context, so the same call afterwards is accepted, logged, and
|
||||||
;; has no effect on the window that already exists.
|
;; has no effect on the window that already exists.
|
||||||
|
|||||||
@ -147,7 +147,7 @@
|
|||||||
(= log-mode 1) (not (= g previous-gesture))
|
(= log-mode 1) (not (= g previous-gesture))
|
||||||
:else true))
|
:else true))
|
||||||
|
|
||||||
(defn push-log [g rl/Gesture]
|
(defn push-log [g rl/Gesture] ()
|
||||||
(set previous-gesture g)
|
(set previous-gesture g)
|
||||||
(set gesture-color (gesture-color-of g))
|
(set gesture-color (gesture-color-of g))
|
||||||
(when (<= gesture-log-index 0) (set gesture-log-index gesture-log-size))
|
(when (<= gesture-log-index 0) (set gesture-log-index gesture-log-size))
|
||||||
@ -162,11 +162,11 @@
|
|||||||
(defconst prot-y f32 315.0)
|
(defconst prot-y f32 315.0)
|
||||||
(defconst angle-length f32 90.0)
|
(defconst angle-length f32 90.0)
|
||||||
|
|
||||||
(defn swipe-box [gx i32 gy i32 which rl/Gesture]
|
(defn swipe-box [gx i32 gy i32 which rl/Gesture] ()
|
||||||
(rl/draw-rectangle gx gy 20 20
|
(rl/draw-rectangle gx gy 20 20
|
||||||
(if (= last-gesture which) rl/red rl/lightgray)))
|
(if (= last-gesture which) rl/red rl/lightgray)))
|
||||||
|
|
||||||
(defn draw-last-gesture [touch-count i32]
|
(defn draw-last-gesture [touch-count i32] ()
|
||||||
(rl/draw-text "Last gesture" (+ last-x 33) (- last-y 47) 20 rl/black)
|
(rl/draw-text "Last gesture" (+ last-x 33) (- last-y 47) 20 rl/black)
|
||||||
(rl/draw-text "Swipe Tap Pinch Touch" (+ last-x 17)
|
(rl/draw-text "Swipe Tap Pinch Touch" (+ last-x 17)
|
||||||
(- last-y 18) 10 rl/black)
|
(- last-y 18) 10 rl/black)
|
||||||
@ -213,7 +213,7 @@
|
|||||||
(rl/draw-circle (+ last-x 180) (+ (+ last-y 7) (* i 15)) 5.0
|
(rl/draw-circle (+ last-x 180) (+ (+ last-y 7) (* i 15)) 5.0
|
||||||
(if (<= touch-count i) rl/lightgray gesture-color))))
|
(if (<= touch-count i) rl/lightgray gesture-color))))
|
||||||
|
|
||||||
(defn draw-log []
|
(defn draw-log [] ()
|
||||||
(rl/draw-text "Log" 10 10 20 rl/black)
|
(rl/draw-text "Log" 10 10 20 rl/black)
|
||||||
;; Forward from the newest, wrapping — the inverted queue read the right way
|
;; Forward from the newest, wrapping — the inverted queue read the right way
|
||||||
;; round.
|
;; round.
|
||||||
@ -234,7 +234,7 @@
|
|||||||
(rl/draw-text "Hide" 115 10 10 rl/white)
|
(rl/draw-text "Hide" 115 10 10 rl/white)
|
||||||
(rl/draw-text "Hold" 115 20 10 rl/white)))
|
(rl/draw-text "Hold" 115 20 10 rl/white)))
|
||||||
|
|
||||||
(defn draw-protractor []
|
(defn draw-protractor [] ()
|
||||||
(rl/draw-text "Angle" (+ (i32 prot-x) 55) (+ (i32 prot-y) 76) 10 rl/black)
|
(rl/draw-text "Angle" (+ (i32 prot-x) 55) (+ (i32 prot-y) 76) 10 rl/black)
|
||||||
;; The C's TextFormat/TextFindIndex/TextSubtext dance to get two decimals,
|
;; The C's TextFormat/TextFindIndex/TextSubtext dance to get two decimals,
|
||||||
;; in one call. It rounds where the C truncated, so the last digit can
|
;; in one call. It rounds where the C truncated, so the last digit can
|
||||||
@ -272,7 +272,7 @@
|
|||||||
.y (+ (* angle-length (cos-f32 rad)) prot-y)})
|
.y (+ (* angle-length (cos-f32 rad)) prot-y)})
|
||||||
3.0 gesture-color))))
|
3.0 gesture-color))))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - input gestures testbed")
|
"raylib [core] example - input gestures testbed")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -52,7 +52,7 @@
|
|||||||
(= g :pinch-out) "GESTURE PINCH OUT"
|
(= g :pinch-out) "GESTURE PINCH OUT"
|
||||||
:else ""))
|
:else ""))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - input gestures")
|
"raylib [core] example - input gestures")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -21,7 +21,7 @@
|
|||||||
|
|
||||||
(defvar ball rl/Vector2)
|
(defvar ball rl/Vector2)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - input keys")
|
"raylib [core] example - input keys")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -27,7 +27,7 @@
|
|||||||
|
|
||||||
(defvar box-y i32)
|
(defvar box-y i32)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - input mouse wheel")
|
"raylib [core] example - input mouse wheel")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -19,7 +19,7 @@
|
|||||||
|
|
||||||
(defvar ball-color rl/Color)
|
(defvar ball-color rl/Color)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - input mouse")
|
"raylib [core] example - input mouse")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -31,7 +31,7 @@
|
|||||||
|
|
||||||
(defvar touch-positions [max-touch-points rl/Vector2])
|
(defvar touch-positions [max-touch-points rl/Vector2])
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - input multitouch")
|
"raylib [core] example - input multitouch")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -69,7 +69,7 @@
|
|||||||
|
|
||||||
(defvar player rl/Vector2)
|
(defvar player rl/Vector2)
|
||||||
|
|
||||||
(defn reset-player []
|
(defn reset-player [] ()
|
||||||
(set player (rl/Vector2 {.x (/ (f32 screen-width) 2.0)
|
(set player (rl/Vector2 {.x (/ (f32 screen-width) 2.0)
|
||||||
.y (/ (f32 screen-height) 2.0)})))
|
.y (/ (f32 screen-height) 2.0)})))
|
||||||
|
|
||||||
@ -91,7 +91,7 @@
|
|||||||
|
|
||||||
;; The C's switch on the pressed button. Nothing moves for button-none, which
|
;; The C's switch on the pressed button. Nothing moves for button-none, which
|
||||||
;; is the `default: break`.
|
;; is the `default: break`.
|
||||||
(defn move-player [button i32 dt f32]
|
(defn move-player [button i32 dt f32] ()
|
||||||
(let [step (* player-speed dt)]
|
(let [step (* player-speed dt)]
|
||||||
(cond
|
(cond
|
||||||
(= button button-up) (set (.y player) (- (.y player) step))
|
(= button button-up) (set (.y player) (- (.y player) step))
|
||||||
@ -149,7 +149,7 @@
|
|||||||
(rl/Color {.r 230 .g 41 .b 55 .a 255}) ; red, right
|
(rl/Color {.r 230 .g 41 .b 55 .a 255}) ; red, right
|
||||||
(rl/Color {.r 0 .g 228 .b 48 .a 255})]) ; green, down
|
(rl/Color {.r 0 .g 228 .b 48 .a 255})]) ; green, down
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/init-window screen-width screen-height
|
(rl/init-window screen-width screen-height
|
||||||
"raylib [core] example - input virtual controls")
|
"raylib [core] example - input virtual controls")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -326,17 +326,17 @@ let map_type loc (k : Types.t) (v : Types.t) =
|
|||||||
copying, and free would leak what they own. Owned entries arrive with \
|
copying, and free would leak what they own. Owned entries arrive with \
|
||||||
drop (step 5 in NEXT.md)"
|
drop (step 5 in NEXT.md)"
|
||||||
(Types.to_string k) (Types.to_string v);
|
(Types.to_string k) (Types.to_string v);
|
||||||
(* Unit has no bytes, so a slot for one is a slot of nothing: the cell
|
(* () has no bytes, so a slot for one is a slot of nothing: the cell
|
||||||
geometry divides the cache line by the element size and there is nothing
|
geometry divides the cache line by the element size and there is nothing
|
||||||
to divide by. It is also the natural spelling of a *set*, which is why
|
to divide by. It is also the natural spelling of a *set*, which is why
|
||||||
someone will write it, so it is refused by name rather than by a crash. *)
|
someone will write it, so it is refused by name rather than by a crash. *)
|
||||||
if Types.equal v Types.Unit then
|
if Types.equal v Types.Unit then
|
||||||
fail loc
|
fail loc
|
||||||
"a map value cannot be Unit — there is nothing to store. A set of keys \
|
"a map value cannot be () — there is nothing to store. A set of keys \
|
||||||
is not built yet; use (Map %s bool) and ignore the value"
|
is not built yet; use (Map %s bool) and ignore the value"
|
||||||
(Types.to_string k);
|
(Types.to_string k);
|
||||||
if Types.equal k Types.Unit then
|
if Types.equal k Types.Unit then
|
||||||
fail loc "a map key cannot be Unit — every key would be the same key";
|
fail loc "a map key cannot be () — every key would be the same key";
|
||||||
(* The key, as far as the type alone can say. A struct passes here and is
|
(* The key, as far as the type alone can say. A struct passes here and is
|
||||||
decided at the operation, by [key_pair], which walks its fields — the
|
decided at the operation, by [key_pair], which walks its fields — the
|
||||||
struct table is not necessarily complete while a type is being resolved,
|
struct table is not necessarily complete while a type is being resolved,
|
||||||
|
|||||||
@ -731,6 +731,10 @@ let rec decl types (f : Form.t) : Ast.decl =
|
|||||||
(* An omitted return type means Unit. A leading form that is a type
|
(* An omitted return type means Unit. A leading form that is a type
|
||||||
and is not the whole body is the return type. *)
|
and is not the whole body is the return type. *)
|
||||||
| [] -> None, []
|
| [] -> None, []
|
||||||
|
(* A lone [()] is the return type and an empty body, never a body of
|
||||||
|
one form: [()] is not an expression, so there is nothing for the
|
||||||
|
[more <> []] guard below to protect here. *)
|
||||||
|
| [ ({ v = List []; _ } as only) ] -> Some (texpr only), []
|
||||||
| first :: more when more <> [] && is_type_form types first ->
|
| first :: more when more <> [] && is_type_form types first ->
|
||||||
Some (texpr first), body_of more
|
Some (texpr first), body_of more
|
||||||
| _ -> None, body_of rest
|
| _ -> None, body_of rest
|
||||||
|
|||||||
@ -62,7 +62,7 @@ let source = {flan|
|
|||||||
;; behaviour a release build wants and gets for free.
|
;; behaviour a release build wants and gets for free.
|
||||||
(defstruct Pause [])
|
(defstruct Pause [])
|
||||||
|
|
||||||
(defn pause []
|
(defn pause [] ()
|
||||||
(restart-case (error (Pause {}))
|
(restart-case (error (Pause {}))
|
||||||
(continue [] (do))))
|
(continue [] (do))))
|
||||||
|
|
||||||
@ -72,7 +72,7 @@ let source = {flan|
|
|||||||
;; down to 32 bits by an xorshift and rotated by the state's top five bits.
|
;; down to 32 bits by an xorshift and rotated by the state's top five bits.
|
||||||
(defvar rand-state u64 6364136223846793005)
|
(defvar rand-state u64 6364136223846793005)
|
||||||
|
|
||||||
(defn rand-seed [seed u64]
|
(defn rand-seed [seed u64] ()
|
||||||
(set rand-state (+ (* seed 6364136223846793005) 1442695040888963407)))
|
(set rand-state (+ (* seed 6364136223846793005) 1442695040888963407)))
|
||||||
|
|
||||||
(defn rand-u32 [] u32
|
(defn rand-u32 [] u32
|
||||||
@ -111,12 +111,12 @@ let source = {flan|
|
|||||||
;; shape and the same argument — so the set is the same i32 and f32 the rest of
|
;; shape and the same argument — so the set is the same i32 and f32 the rest of
|
||||||
;; this family covers.
|
;; this family covers.
|
||||||
|
|
||||||
(defn swap-i32! [s [i32] i i32 j i32]
|
(defn swap-i32! [s [i32] i i32 j i32] ()
|
||||||
(let [t (at s i)]
|
(let [t (at s i)]
|
||||||
(set (at s i) (at s j))
|
(set (at s i) (at s j))
|
||||||
(set (at s j) t)))
|
(set (at s j) t)))
|
||||||
|
|
||||||
(defn reverse-i32! [s [i32]]
|
(defn reverse-i32! [s [i32]] ()
|
||||||
(let [i 0
|
(let [i 0
|
||||||
j (- (len s) 1)]
|
j (- (len s) 1)]
|
||||||
(while (< i j)
|
(while (< i j)
|
||||||
@ -128,7 +128,7 @@ let source = {flan|
|
|||||||
;; comparison function — quicksort would want a stack and mergesort a buffer,
|
;; comparison function — quicksort would want a stack and mergesort a buffer,
|
||||||
;; and neither exists. Ascending, and stable, though with no payload type to
|
;; and neither exists. Ascending, and stable, though with no payload type to
|
||||||
;; carry that is not yet observable.
|
;; carry that is not yet observable.
|
||||||
(defn sort-i32! [s [i32]]
|
(defn sort-i32! [s [i32]] ()
|
||||||
(let [i 1]
|
(let [i 1]
|
||||||
(while (< i (len s))
|
(while (< i (len s))
|
||||||
(let [j i]
|
(let [j i]
|
||||||
@ -190,12 +190,12 @@ let source = {flan|
|
|||||||
;; also the only fix, since there is no ordering of the reals that a NaN sits
|
;; also the only fix, since there is no ordering of the reals that a NaN sits
|
||||||
;; anywhere in.
|
;; anywhere in.
|
||||||
|
|
||||||
(defn swap-f32! [s [f32] i i32 j i32]
|
(defn swap-f32! [s [f32] i i32 j i32] ()
|
||||||
(let [t (at s i)]
|
(let [t (at s i)]
|
||||||
(set (at s i) (at s j))
|
(set (at s i) (at s j))
|
||||||
(set (at s j) t)))
|
(set (at s j) t)))
|
||||||
|
|
||||||
(defn reverse-f32! [s [f32]]
|
(defn reverse-f32! [s [f32]] ()
|
||||||
(let [i 0
|
(let [i 0
|
||||||
j (- (len s) 1)]
|
j (- (len s) 1)]
|
||||||
(while (< i j)
|
(while (< i j)
|
||||||
@ -203,7 +203,7 @@ let source = {flan|
|
|||||||
(set i (+ i 1))
|
(set i (+ i 1))
|
||||||
(set j (- j 1)))))
|
(set j (- j 1)))))
|
||||||
|
|
||||||
(defn sort-f32! [s [f32]]
|
(defn sort-f32! [s [f32]] ()
|
||||||
(let [i 1]
|
(let [i 1]
|
||||||
(while (< i (len s))
|
(while (< i (len s))
|
||||||
(let [j i]
|
(let [j i]
|
||||||
@ -268,11 +268,11 @@ let source = {flan|
|
|||||||
;; lifted into a function of its own and sees its parameters and the globals
|
;; lifted into a function of its own and sees its parameters and the globals
|
||||||
;; and nothing else.
|
;; and nothing else.
|
||||||
|
|
||||||
(defn map-i32! [s [i32] f (Fn [i32] i32)]
|
(defn map-i32! [s [i32] f (Fn [i32] i32)] ()
|
||||||
(dotimes [i (len s)]
|
(dotimes [i (len s)]
|
||||||
(set (at s i) (f (at s i)))))
|
(set (at s i) (f (at s i)))))
|
||||||
|
|
||||||
(defn map-f32! [s [f32] f (Fn [f32] f32)]
|
(defn map-f32! [s [f32] f (Fn [f32] f32)] ()
|
||||||
(dotimes [i (len s)]
|
(dotimes [i (len s)]
|
||||||
(set (at s i) (f (at s i)))))
|
(set (at s i) (f (at s i)))))
|
||||||
|
|
||||||
@ -317,7 +317,7 @@ let source = {flan|
|
|||||||
;; strict weak ordering — one answering true for both (a b) and (b a) — is the
|
;; strict weak ordering — one answering true for both (a b) and (b a) — is the
|
||||||
;; caller's mistake and shows up as an order, not as a loop: the inner while is
|
;; caller's mistake and shows up as an order, not as a loop: the inner while is
|
||||||
;; bounded by j reaching 0 whatever the comparison says.
|
;; bounded by j reaching 0 whatever the comparison says.
|
||||||
(defn sort-i32-by! [s [i32] before? (Fn [i32 i32] bool)]
|
(defn sort-i32-by! [s [i32] before? (Fn [i32 i32] bool)] ()
|
||||||
(let [i 1]
|
(let [i 1]
|
||||||
(while (< i (len s))
|
(while (< i (len s))
|
||||||
(let [j i]
|
(let [j i]
|
||||||
@ -327,7 +327,7 @@ let source = {flan|
|
|||||||
(set j (- j 1))))
|
(set j (- j 1))))
|
||||||
(set i (+ i 1)))))
|
(set i (+ i 1)))))
|
||||||
|
|
||||||
(defn sort-f32-by! [s [f32] before? (Fn [f32 f32] bool)]
|
(defn sort-f32-by! [s [f32] before? (Fn [f32 f32] bool)] ()
|
||||||
(let [i 1]
|
(let [i 1]
|
||||||
(while (< i (len s))
|
(while (< i (len s))
|
||||||
(let [j i]
|
(let [j i]
|
||||||
@ -996,7 +996,7 @@ let source = {flan|
|
|||||||
(return (< (at a i) (at b i)))))
|
(return (< (at a i) (at b i)))))
|
||||||
(< (len a) (len b))))
|
(< (len a) (len b))))
|
||||||
|
|
||||||
(defn swap-bytes! [s [[u8]] i i32 j i32]
|
(defn swap-bytes! [s [[u8]] i i32 j i32] ()
|
||||||
(let [t (at s i)]
|
(let [t (at s i)]
|
||||||
(set (at s i) (at s j))
|
(set (at s i) (at s j))
|
||||||
(set (at s j) t)))
|
(set (at s j) t)))
|
||||||
@ -1006,7 +1006,7 @@ let source = {flan|
|
|||||||
;; fields borrowed from one buffer without touching the buffer. Stable, and
|
;; fields borrowed from one buffer without touching the buffer. Stable, and
|
||||||
;; here that is observable — two equal fields are two distinct slices of
|
;; here that is observable — two equal fields are two distinct slices of
|
||||||
;; different parts of the input, and a caller can see which one came first.
|
;; different parts of the input, and a caller can see which one came first.
|
||||||
(defn sort-bytes! [s [[u8]]]
|
(defn sort-bytes! [s [[u8]]] ()
|
||||||
(let [i 1]
|
(let [i 1]
|
||||||
(while (< i (len s))
|
(while (< i (len s))
|
||||||
(let [j i]
|
(let [j i]
|
||||||
@ -1051,7 +1051,7 @@ let source = {flan|
|
|||||||
;; It takes a (Ptr (Vec u8)) and not a (Vec u8), and the difference is not
|
;; It takes a (Ptr (Vec u8)) and not a (Vec u8), and the difference is not
|
||||||
;; style: a Vec parameter *moves*, so (append! b s) taking one by value would
|
;; style: a Vec parameter *moves*, so (append! b s) taking one by value would
|
||||||
;; consume the caller's builder on the first call and refuse the second.
|
;; consume the caller's builder on the first call and refuse the second.
|
||||||
(defn append! [b (Ptr (Vec u8)) s [u8]]
|
(defn append! [b (Ptr (Vec u8)) s [u8]] ()
|
||||||
(dotimes [i (len s)]
|
(dotimes [i (len s)]
|
||||||
(push (deref b) (at s i))))
|
(push (deref b) (at s i))))
|
||||||
|
|
||||||
@ -1062,10 +1062,10 @@ let source = {flan|
|
|||||||
;; views of the same bytes — the second call overwrote the first. These copy
|
;; views of the same bytes — the second call overwrote the first. These copy
|
||||||
;; out of that buffer before returning, so the hazard ends at the call: a
|
;; out of that buffer before returning, so the hazard ends at the call: a
|
||||||
;; builder can hold as many numbers as it likes.
|
;; builder can hold as many numbers as it likes.
|
||||||
(defn append-i64! [b (Ptr (Vec u8)) n i64]
|
(defn append-i64! [b (Ptr (Vec u8)) n i64] ()
|
||||||
(append! b (i64->bytes n)))
|
(append! b (i64->bytes n)))
|
||||||
|
|
||||||
(defn append-f64! [b (Ptr (Vec u8)) x f64]
|
(defn append-f64! [b (Ptr (Vec u8)) x f64] ()
|
||||||
(append! b (f64->bytes x)))
|
(append! b (f64->bytes x)))
|
||||||
|
|
||||||
;; concat and join. Both take a slice of slices, which is the shape a caller
|
;; concat and join. Both take a slice of slices, which is the shape a caller
|
||||||
|
|||||||
56
sand.flan
56
sand.flan
@ -59,20 +59,20 @@
|
|||||||
;; An index into colors, not a colour.
|
;; An index into colors, not a colour.
|
||||||
(defvar current-color i32)
|
(defvar current-color i32)
|
||||||
|
|
||||||
(defn clear-grid []
|
(defn clear-grid [] ()
|
||||||
(set grid (zeroed))
|
(set grid (zeroed))
|
||||||
(set velocity (zeroed)))
|
(set velocity (zeroed)))
|
||||||
|
|
||||||
(defn empty-at? [row i32 col i32] bool
|
(defn empty-at? [row i32 col i32] bool
|
||||||
(= 0 (at grid row col)))
|
(= 0 (at grid row col)))
|
||||||
|
|
||||||
(defn next-color []
|
(defn next-color [] ()
|
||||||
(set current-color (% (+ current-color 1) (len colors))))
|
(set current-color (% (+ current-color 1) (len colors))))
|
||||||
|
|
||||||
;; Drop a brush-sized cloud of grains centred on [row col]. This is what the
|
;; 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
|
;; mouse drives interactively and what the headless run calls directly — the
|
||||||
;; only difference between the two is where the centre comes from.
|
;; only difference between the two is where the centre comes from.
|
||||||
(defn paint-at [row i32 col i32]
|
(defn paint-at [row i32 col i32] ()
|
||||||
(let [half (/ brush-size 2)]
|
(let [half (/ brush-size 2)]
|
||||||
(dotimes [x brush-size]
|
(dotimes [x brush-size]
|
||||||
(dotimes [y brush-size]
|
(dotimes [y brush-size]
|
||||||
@ -87,7 +87,7 @@
|
|||||||
|
|
||||||
(defn move-grain [from-row i32 from-col i32
|
(defn move-grain [from-row i32 from-col i32
|
||||||
to-row i32 to-col i32
|
to-row i32 to-col i32
|
||||||
vel f32]
|
vel f32] ()
|
||||||
(set (at grid to-row to-col) (at grid from-row from-col))
|
(set (at grid to-row to-col) (at grid from-row from-col))
|
||||||
(set (at grid from-row from-col) 0)
|
(set (at grid from-row from-col) 0)
|
||||||
(set (at velocity to-row to-col) vel)
|
(set (at velocity to-row to-col) vel)
|
||||||
@ -99,7 +99,7 @@
|
|||||||
;; Imperative `while` with early `return`, not loop/recur — see plan.org
|
;; 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
|
;; "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.
|
;; over a mutable scan position, which is what a while loop is.
|
||||||
(defn settle [row i32 col i32]
|
(defn settle [row i32 col i32] ()
|
||||||
(let [vel (+ gravity (at velocity row col))
|
(let [vel (+ gravity (at velocity row col))
|
||||||
some-point (rl/Vector2 {.x 15.0 .y 12})
|
some-point (rl/Vector2 {.x 15.0 .y 12})
|
||||||
y (min (- rows 1) (+ row (i32 vel)))]
|
y (min (- rows 1) (+ row (i32 vel)))]
|
||||||
@ -122,7 +122,7 @@
|
|||||||
(set (at velocity row col) 0.0)))
|
(set (at velocity row col) 0.0)))
|
||||||
|
|
||||||
;; One frame of physics. Bottom-up, so a grain settles at most once per frame.
|
;; One frame of physics. Bottom-up, so a grain settles at most once per frame.
|
||||||
(defn step []
|
(defn step [] ()
|
||||||
(let [row (- rows 2)]
|
(let [row (- rows 2)]
|
||||||
(while (>= row 0)
|
(while (>= row 0)
|
||||||
(dotimes [col cols]
|
(dotimes [col cols]
|
||||||
@ -193,7 +193,7 @@
|
|||||||
;; because ImageFlipHorizontal rewrites the buffer in place and the second
|
;; because ImageFlipHorizontal rewrites the buffer in place and the second
|
||||||
;; upload has to see the changed pixels — if the two badges look the same,
|
;; upload has to see the changed pixels — if the two badges look the same,
|
||||||
;; either the flip did nothing or the order here was swapped.
|
;; either the flip did nothing or the order here was swapped.
|
||||||
(defn load-brush []
|
(defn load-brush [] ()
|
||||||
(let [sheet (rl/load-image-from-memory ".png" brush-png)]
|
(let [sheet (rl/load-image-from-memory ".png" brush-png)]
|
||||||
(when (rl/image-valid? sheet)
|
(when (rl/image-valid? sheet)
|
||||||
(set brush (rl/load-texture-from-image sheet))
|
(set brush (rl/load-texture-from-image sheet))
|
||||||
@ -212,7 +212,7 @@
|
|||||||
;; needs a source rectangle; the three badges in the corner are the whole
|
;; needs a source rectangle; the three badges in the corner are the whole
|
||||||
;; sheet, at integer coordinates, at a Vector2 tinted with the current sand
|
;; sheet, at integer coordinates, at a Vector2 tinted with the current sand
|
||||||
;; colour, and scaled up — draw-texture, draw-texture-v and draw-texture-ex.
|
;; colour, and scaled up — draw-texture, draw-texture-v and draw-texture-ex.
|
||||||
(defn draw-brush []
|
(defn draw-brush [] ()
|
||||||
(when brush-ok
|
(when brush-ok
|
||||||
(let [m (rl/get-mouse-position)
|
(let [m (rl/get-mouse-position)
|
||||||
frame (f32 (if (rl/mouse-button-down? :left) 8.0 0.0))]
|
frame (f32 (if (rl/mouse-button-down? :left) 8.0 0.0))]
|
||||||
@ -256,14 +256,14 @@
|
|||||||
;; a run-time number, and no Flan type says what the buffer holds.
|
;; a run-time number, and no Flan type says what the buffer holds.
|
||||||
(defvar tone-pcm [8820 u8])
|
(defvar tone-pcm [8820 u8])
|
||||||
|
|
||||||
(defn write-sample [i i32 v i32]
|
(defn write-sample [i i32 v i32] ()
|
||||||
(set (at tone-pcm (* i 2)) (u8 (bit-and v 255)))
|
(set (at tone-pcm (* i 2)) (u8 (bit-and v 255)))
|
||||||
(set (at tone-pcm (+ (* i 2) 1)) (u8 (bit-and (>> v 8) 255))))
|
(set (at tone-pcm (+ (* i 2) 1)) (u8 (bit-and (>> v 8) 255))))
|
||||||
|
|
||||||
;; A square wave that decays to nothing over its length, which is the
|
;; A square wave that decays to nothing over its length, which is the
|
||||||
;; cheapest thing that sounds like a plink rather than a click. `period` is
|
;; cheapest thing that sounds like a plink rather than a click. `period` is
|
||||||
;; the half-period in frames, so a smaller one is a higher note.
|
;; the half-period in frames, so a smaller one is a higher note.
|
||||||
(defn build-tone [period i32]
|
(defn build-tone [period i32] ()
|
||||||
(dotimes [i tone-frames]
|
(dotimes [i tone-frames]
|
||||||
(let [amp (/ (* 9000 (- tone-frames i)) tone-frames)]
|
(let [amp (/ (* 9000 (- tone-frames i)) tone-frames)]
|
||||||
(write-sample i (if (= 0 (% (/ i period) 2)) amp (- 0 amp))))))
|
(write-sample i (if (= 0 (% (/ i period) 2)) amp (- 0 amp))))))
|
||||||
@ -275,7 +275,7 @@
|
|||||||
(defvar music-ok bool)
|
(defvar music-ok bool)
|
||||||
(defvar music-on bool)
|
(defvar music-on bool)
|
||||||
|
|
||||||
(defn start-audio []
|
(defn start-audio [] ()
|
||||||
(rl/init-audio-device)
|
(rl/init-audio-device)
|
||||||
(set audio-ok (rl/audio-device-ready?))
|
(set audio-ok (rl/audio-device-ready?))
|
||||||
(unless audio-ok
|
(unless audio-ok
|
||||||
@ -303,19 +303,19 @@
|
|||||||
(rl/set-music-pitch music 0.5)))))
|
(rl/set-music-pitch music 0.5)))))
|
||||||
(rl/set-master-volume 0.6))
|
(rl/set-master-volume 0.6))
|
||||||
|
|
||||||
(defn stop-audio []
|
(defn stop-audio [] ()
|
||||||
(when music-ok (rl/unload-music-stream music))
|
(when music-ok (rl/unload-music-stream music))
|
||||||
(when tone-ok (rl/unload-sound tone))
|
(when tone-ok (rl/unload-sound tone))
|
||||||
(rl/close-audio-device))
|
(rl/close-audio-device))
|
||||||
|
|
||||||
;; Every plink goes through here, so a silent build — no device, or a wave
|
;; Every plink goes through here, so a silent build — no device, or a wave
|
||||||
;; that would not load — is one branch and not a guard at every call site.
|
;; that would not load — is one branch and not a guard at every call site.
|
||||||
(defn plink [pitch f32]
|
(defn plink [pitch f32] ()
|
||||||
(when tone-ok
|
(when tone-ok
|
||||||
(rl/set-sound-pitch tone pitch)
|
(rl/set-sound-pitch tone pitch)
|
||||||
(rl/play-sound tone)))
|
(rl/play-sound tone)))
|
||||||
|
|
||||||
(defn toggle-music []
|
(defn toggle-music [] ()
|
||||||
(when music-ok
|
(when music-ok
|
||||||
(set music-on (not music-on))
|
(set music-on (not music-on))
|
||||||
(if music-on
|
(if music-on
|
||||||
@ -339,7 +339,7 @@
|
|||||||
(defvar scene rl/RenderTexture2D)
|
(defvar scene rl/RenderTexture2D)
|
||||||
(defvar scene-ok bool)
|
(defvar scene-ok bool)
|
||||||
|
|
||||||
(defn load-scene []
|
(defn load-scene [] ()
|
||||||
(set scene (rl/load-render-texture screen-width screen-height))
|
(set scene (rl/load-render-texture screen-width screen-height))
|
||||||
(set scene-ok (rl/render-texture-valid? scene))
|
(set scene-ok (rl/render-texture-valid? scene))
|
||||||
(unless scene-ok
|
(unless scene-ok
|
||||||
@ -357,7 +357,7 @@
|
|||||||
(defvar hud-font rl/Font)
|
(defvar hud-font rl/Font)
|
||||||
(defvar hud-font-ok bool)
|
(defvar hud-font-ok bool)
|
||||||
|
|
||||||
(defn load-hud-font []
|
(defn load-hud-font [] ()
|
||||||
(set hud-font (rl/get-font-default))
|
(set hud-font (rl/get-font-default))
|
||||||
(set hud-font-ok (rl/font-valid? hud-font)))
|
(set hud-font-ok (rl/font-valid? hud-font)))
|
||||||
|
|
||||||
@ -375,13 +375,13 @@
|
|||||||
|
|
||||||
;; A fresh (Camera2D {}) has a zoom of 0, which is singular: both conversions
|
;; A fresh (Camera2D {}) has a zoom of 0, which is singular: both conversions
|
||||||
;; hand back NaN and nothing draws. 1.0 is the identity.
|
;; hand back NaN and nothing draws. 1.0 is the identity.
|
||||||
(defn reset-view []
|
(defn reset-view [] ()
|
||||||
(set view (rl/Camera2D {.offset (rl/Vector2 {.x 0.0 .y 0.0})
|
(set view (rl/Camera2D {.offset (rl/Vector2 {.x 0.0 .y 0.0})
|
||||||
.target (rl/Vector2 {.x 0.0 .y 0.0})
|
.target (rl/Vector2 {.x 0.0 .y 0.0})
|
||||||
.rotation 0.0
|
.rotation 0.0
|
||||||
.zoom 1.0})))
|
.zoom 1.0})))
|
||||||
|
|
||||||
(defn set-view [target-x f32 target-y f32 zoom f32]
|
(defn set-view [target-x f32 target-y f32 zoom f32] ()
|
||||||
(set view (rl/Camera2D {.offset (.offset view)
|
(set view (rl/Camera2D {.offset (.offset view)
|
||||||
.target (rl/Vector2 {.x target-x .y target-y})
|
.target (rl/Vector2 {.x target-x .y target-y})
|
||||||
.rotation (.rotation view)
|
.rotation (.rotation view)
|
||||||
@ -391,7 +391,7 @@
|
|||||||
;; neither changes with the frame rate. That is the whole of what
|
;; neither changes with the frame rate. That is the whole of what
|
||||||
;; get-frame-time is for, and a loop that assumed it hit its target fps would
|
;; get-frame-time is for, and a loop that assumed it hit its target fps would
|
||||||
;; be a loop that moves differently on a slower machine.
|
;; be a loop that moves differently on a slower machine.
|
||||||
(defn move-view []
|
(defn move-view [] ()
|
||||||
(let [dt (rl/get-frame-time)
|
(let [dt (rl/get-frame-time)
|
||||||
pan (* (f32 600.0) dt)
|
pan (* (f32 600.0) dt)
|
||||||
tx (.x (.target view))
|
tx (.x (.target view))
|
||||||
@ -414,7 +414,7 @@
|
|||||||
;; The mouse is in screen pixels and the grid is in world cells, and with a
|
;; The mouse is in screen pixels and the grid is in world cells, and with a
|
||||||
;; camera in the way those stopped being the same thing — so this is the one
|
;; camera in the way those stopped being the same thing — so this is the one
|
||||||
;; place get-screen-to-world-2d is not a test case but a requirement.
|
;; place get-screen-to-world-2d is not a test case but a requirement.
|
||||||
(defn paint []
|
(defn paint [] ()
|
||||||
(let [m (rl/get-screen-to-world-2d (rl/get-mouse-position) view)
|
(let [m (rl/get-screen-to-world-2d (rl/get-mouse-position) view)
|
||||||
row (/ (i32 (.y m)) cell-size)
|
row (/ (i32 (.y m)) cell-size)
|
||||||
col (/ (i32 (.x m)) cell-size)]
|
col (/ (i32 (.x m)) cell-size)]
|
||||||
@ -430,7 +430,7 @@
|
|||||||
;; `settle` while `game-update` is mid-frame is safe
|
;; `settle` while `game-update` is mid-frame is safe
|
||||||
;; because old code is never unloaded; changing its SIGNATURE is not, and the
|
;; because old code is never unloaded; changing its SIGNATURE is not, and the
|
||||||
;; reload rejects it. See plan.org "What redefinition cannot do".
|
;; reload rejects it. See plan.org "What redefinition cannot do".
|
||||||
(defn game-update []
|
(defn game-update [] ()
|
||||||
(when (rl/key-pressed? :r) (clear-grid))
|
(when (rl/key-pressed? :r) (clear-grid))
|
||||||
(move-view)
|
(move-view)
|
||||||
;; key-released? and mouse-button-pressed? were bound and called by nothing
|
;; key-released? and mouse-button-pressed? were bound and called by nothing
|
||||||
@ -457,7 +457,7 @@
|
|||||||
(step))
|
(step))
|
||||||
|
|
||||||
|
|
||||||
(defn draw-grid []
|
(defn draw-grid [] ()
|
||||||
(dotimes [row rows]
|
(dotimes [row rows]
|
||||||
(dotimes [col cols]
|
(dotimes [col cols]
|
||||||
(let [c (at grid row col)]
|
(let [c (at grid row col)]
|
||||||
@ -471,7 +471,7 @@
|
|||||||
;; scales with the grid. That is the point: a shape binding that is subtly
|
;; scales with the grid. That is the point: a shape binding that is subtly
|
||||||
;; wrong is easiest to see when it is supposed to sit exactly on the cursor
|
;; wrong is easiest to see when it is supposed to sit exactly on the cursor
|
||||||
;; and does not.
|
;; and does not.
|
||||||
(defn draw-world-cursor []
|
(defn draw-world-cursor [] ()
|
||||||
(let [p (rl/get-screen-to-world-2d (rl/get-mouse-position) view)
|
(let [p (rl/get-screen-to-world-2d (rl/get-mouse-position) view)
|
||||||
tint (rl/get-color (at colors current-color))
|
tint (rl/get-color (at colors current-color))
|
||||||
x (.x p)
|
x (.x p)
|
||||||
@ -513,7 +513,7 @@
|
|||||||
;; so it is built to be *looked* at: every shape binding appears once, and each
|
;; so it is built to be *looked* at: every shape binding appears once, and each
|
||||||
;; one is asymmetric enough that a wrapper with its arguments crossed is
|
;; one is asymmetric enough that a wrapper with its arguments crossed is
|
||||||
;; visible rather than merely different.
|
;; visible rather than merely different.
|
||||||
(defn draw-hud []
|
(defn draw-hud [] ()
|
||||||
(let [title "SAND"
|
(let [title "SAND"
|
||||||
keys "arrows pan , . zoom 0 reset r clear space colour m music"
|
keys "arrows pan , . zoom 0 reset r clear space colour m music"
|
||||||
;; measure-text is what sizes the panel, so the box fits the string
|
;; measure-text is what sizes the panel, so the box fits the string
|
||||||
@ -619,7 +619,7 @@
|
|||||||
;; the marker. Every read-out below is asymmetric on purpose — the stick dot
|
;; the marker. Every read-out below is asymmetric on purpose — the stick dot
|
||||||
;; is offset by x and y separately, and the trigger bars are different lengths
|
;; is offset by x and y separately, and the trigger bars are different lengths
|
||||||
;; — so a crossed wrapper is visible rather than merely different.
|
;; — so a crossed wrapper is visible rather than merely different.
|
||||||
(defn draw-input-state []
|
(defn draw-input-state [] ()
|
||||||
(let [ox (f32 200.0)
|
(let [ox (f32 200.0)
|
||||||
oy (f32 90.0)
|
oy (f32 90.0)
|
||||||
r (f32 34.0)]
|
r (f32 34.0)]
|
||||||
@ -683,14 +683,14 @@
|
|||||||
.y (+ oy (* (.y q) (f32 200.0)))})
|
.y (+ oy (* (.y q) (f32 200.0)))})
|
||||||
(f32 4.0) rl/white))))))
|
(f32 4.0) rl/white))))))
|
||||||
|
|
||||||
(defn draw-world []
|
(defn draw-world [] ()
|
||||||
;; Everything between these two is in world space and moves with the camera.
|
;; Everything between these two is in world space and moves with the camera.
|
||||||
(rl/begin-mode-2d view)
|
(rl/begin-mode-2d view)
|
||||||
(draw-grid)
|
(draw-grid)
|
||||||
(draw-world-cursor)
|
(draw-world-cursor)
|
||||||
(rl/end-mode-2d))
|
(rl/end-mode-2d))
|
||||||
|
|
||||||
(defn game-draw []
|
(defn game-draw [] ()
|
||||||
;; The world goes into the render texture first, if there is one. Note the
|
;; The world goes into the render texture first, if there is one. Note the
|
||||||
;; clear inside the texture mode: the framebuffer keeps last frame's pixels
|
;; clear inside the texture mode: the framebuffer keeps last frame's pixels
|
||||||
;; otherwise, which looks like a trail and not like a bug.
|
;; otherwise, which looks like a trail and not like a bug.
|
||||||
@ -718,7 +718,7 @@
|
|||||||
(draw-input-state)
|
(draw-input-state)
|
||||||
(rl/draw-fps 20 20))
|
(rl/draw-fps 20 20))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(rl/set-trace-log-level :warning)
|
(rl/set-trace-log-level :warning)
|
||||||
(rl/init-window screen-width screen-height "SAND")
|
(rl/init-window screen-width screen-height "SAND")
|
||||||
(defer (rl/close-window))
|
(defer (rl/close-window))
|
||||||
|
|||||||
@ -77,7 +77,7 @@
|
|||||||
;; a copy and `set` would mutate the copy. `resolve` yields (Option (Ptr a))
|
;; a copy and `set` would mutate the copy. `resolve` yields (Option (Ptr a))
|
||||||
;; instead, and the pointer is visible in the binding's type. `deref` is the
|
;; instead, and the pointer is visible in the binding's type. `deref` is the
|
||||||
;; by-value counterpart. Both are overloaded on (Ptr a)/(Handle a).
|
;; by-value counterpart. Both are overloaded on (Ptr a)/(Handle a).
|
||||||
(defn damage [w (Ptr World) h (Handle Enemy) amount i32]
|
(defn damage [w (Ptr World) h (Handle Enemy) amount i32] ()
|
||||||
(match (resolve w h)
|
(match (resolve w h)
|
||||||
(Some e) (set (.hp e) (- (.hp e) amount)) ; e : (Ptr Enemy), field derefs
|
(Some e) (set (.hp e) (- (.hp e) amount)) ; e : (Ptr Enemy), field derefs
|
||||||
None (log "stale enemy handle")))
|
None (log "stale enemy handle")))
|
||||||
@ -134,7 +134,7 @@
|
|||||||
|
|
||||||
;; Intermediate frames say nothing about AssetMissing. Nothing to thread.
|
;; Intermediate frames say nothing about AssetMissing. Nothing to thread.
|
||||||
;; invoke-restart has type Never: it does not return to the handler.
|
;; invoke-restart has type Never: it does not return to the handler.
|
||||||
(defn load-level [path string] Level
|
(defn load-level [path string] () Level
|
||||||
(handler-bind [AssetMissing (fn [c]
|
(handler-bind [AssetMissing (fn [c]
|
||||||
(log "missing asset:" (.path c))
|
(log "missing asset:" (.path c))
|
||||||
(invoke-restart 'use-placeholder))]
|
(invoke-restart 'use-placeholder))]
|
||||||
@ -168,7 +168,7 @@
|
|||||||
;; `filter` allocates a (Vec Enemy) from the current allocator, which is why
|
;; `filter` allocates a (Vec Enemy) from the current allocator, which is why
|
||||||
;; this is wrapped: the frame arena is bulk-reset, so the Vec is never freed
|
;; this is wrapped: the frame arena is bulk-reset, so the Vec is never freed
|
||||||
;; individually. `each` borrows it as a slice.
|
;; individually. `each` borrows it as a slice.
|
||||||
(defn draw-frame [w (Ptr World) dt f32]
|
(defn draw-frame [w (Ptr World) dt f32] ()
|
||||||
(with-allocator context/temp
|
(with-allocator context/temp
|
||||||
(->> (as-slice (.enemies w))
|
(->> (as-slice (.enemies w))
|
||||||
(filter (fn [e] (on-screen? (.pos e))))
|
(filter (fn [e] (on-screen? (.pos e))))
|
||||||
@ -177,7 +177,7 @@
|
|||||||
|
|
||||||
;; ── defer for explicit resources ──────────────────────────────────────
|
;; ── defer for explicit resources ──────────────────────────────────────
|
||||||
;; defer DOES run when a restart transfer passes through this frame.
|
;; defer DOES run when a restart transfer passes through this frame.
|
||||||
(defn save-world [w (Ptr World) path string]
|
(defn save-world [w (Ptr World) path string] ()
|
||||||
(let [f (open path :write)]
|
(let [f (open path :write)]
|
||||||
(defer (close f))
|
(defer (close f))
|
||||||
(write-bytes f (serialize w))))
|
(write-bytes f (serialize w))))
|
||||||
@ -194,7 +194,7 @@
|
|||||||
;; An imperative loop, not (each (fn [p] (try ...))): `try` and `return` inside a
|
;; An imperative loop, not (each (fn [p] (try ...))): `try` and `return` inside a
|
||||||
;; `fn` exit the FN, so a callback would swallow the Err instead of propagating
|
;; `fn` exit the FN, so a callback would swallow the Err instead of propagating
|
||||||
;; it out of preload.
|
;; it out of preload.
|
||||||
(defn ^:async preload [paths [string]] (Result Unit)
|
(defn ^:async preload [paths [string]] (Result ())
|
||||||
(for [p paths]
|
(for [p paths]
|
||||||
(try (await (load-texture-async p))))
|
(try (await (load-texture-async p))))
|
||||||
(Ok unit))
|
(Ok unit))
|
||||||
|
|||||||
@ -7,13 +7,13 @@
|
|||||||
;;;; honest form is the concrete one, and the claim this file makes is only
|
;;;; honest form is the concrete one, and the claim this file makes is only
|
||||||
;;;; that the concrete ones are right.
|
;;;; that the concrete ones are right.
|
||||||
|
|
||||||
(defn show-f32 [s [f32]]
|
(defn show-f32 [s [f32]] ()
|
||||||
(dotimes [i (len s)]
|
(dotimes [i (len s)]
|
||||||
(print (at s i))
|
(print (at s i))
|
||||||
(print " "))
|
(print " "))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|
||||||
(defn show-fields [s [[u8]]]
|
(defn show-fields [s [[u8]]] ()
|
||||||
(dotimes [i (len s)]
|
(dotimes [i (len s)]
|
||||||
(print (string (at s i)))
|
(print (string (at s i)))
|
||||||
(print " "))
|
(print " "))
|
||||||
|
|||||||
@ -11,17 +11,17 @@
|
|||||||
;;;; for and a caller cannot tell from a real one: "", "abc", "1x", ".",
|
;;;; for and a caller cannot tell from a real one: "", "abc", "1x", ".",
|
||||||
;;;; "1e", " 1", "0x10" and "nan". Each must be None.
|
;;;; "1e", " 1", "0x10" and "nan". Each must be None.
|
||||||
|
|
||||||
(defn show-idx [o (Option i32)]
|
(defn show-idx [o (Option i32)] ()
|
||||||
(print (match o (Some i) i None -1))
|
(print (match o (Some i) i None -1))
|
||||||
(print " "))
|
(print " "))
|
||||||
|
|
||||||
(defn show-bool [b bool]
|
(defn show-bool [b bool] ()
|
||||||
(print (if b "t" "f")))
|
(print (if b "t" "f")))
|
||||||
|
|
||||||
;; Brackets around the result so an empty trim is visible as [] rather than
|
;; Brackets around the result so an empty trim is visible as [] rather than
|
||||||
;; as nothing at all — the all-whitespace case is otherwise indistinguishable
|
;; as nothing at all — the all-whitespace case is otherwise indistinguishable
|
||||||
;; from a trim that printed the wrong slice of length zero.
|
;; from a trim that printed the wrong slice of length zero.
|
||||||
(defn show-trim [s string]
|
(defn show-trim [s string] ()
|
||||||
(print "[")
|
(print "[")
|
||||||
(print (trim (bytes s)))
|
(print (trim (bytes s)))
|
||||||
(print "]"))
|
(print "]"))
|
||||||
|
|||||||
@ -11,7 +11,7 @@
|
|||||||
(defvar order i64)
|
(defvar order i64)
|
||||||
(defvar seen i64)
|
(defvar seen i64)
|
||||||
|
|
||||||
(defn note [n i64] (set order (+ (* order 10) n)))
|
(defn note [n i64] () (set order (+ (* order 10) n)))
|
||||||
|
|
||||||
;;; (1) An early return must run the defers registered above it, and (2) it
|
;;; (1) An early return must run the defers registered above it, and (2) it
|
||||||
;;; must run them innermost-first. A defer that (8) *calls* something is the
|
;;; must run them innermost-first. A defer that (8) *calls* something is the
|
||||||
|
|||||||
@ -12,7 +12,7 @@
|
|||||||
(defvar other i64)
|
(defvar other i64)
|
||||||
|
|
||||||
;;; Signals twice and keeps going both times — that is the whole of §1.
|
;;; Signals twice and keeps going both times — that is the whole of §1.
|
||||||
(defn load-all []
|
(defn load-all [] ()
|
||||||
(signal (AssetMissing {.id 1}))
|
(signal (AssetMissing {.id 1}))
|
||||||
(signal (AssetMissing {.id 2}))
|
(signal (AssetMissing {.id 2}))
|
||||||
(signal (Corrupt {.id 3})))
|
(signal (Corrupt {.id 3})))
|
||||||
|
|||||||
@ -11,7 +11,7 @@
|
|||||||
|
|
||||||
(defvar order i64)
|
(defvar order i64)
|
||||||
|
|
||||||
(defn note [n i32] (set order (+ (* order 10) (i64 n))))
|
(defn note [n i32] () (set order (+ (* order 10) (i64 n))))
|
||||||
|
|
||||||
;;; One defer in a let, with the acquisition it is paired with above it. This
|
;;; One defer in a let, with the acquisition it is paired with above it. This
|
||||||
;;; is the shape the relaxation exists for: acquire, defer the release beside
|
;;; is the shape the relaxation exists for: acquire, defer the release beside
|
||||||
@ -25,7 +25,7 @@
|
|||||||
;;; Two resources in one let. This is the case a flag granted once per block
|
;;; Two resources in one let. This is the case a flag granted once per block
|
||||||
;;; instead of once per form gets wrong: the first defer registers and the
|
;;; instead of once per form gets wrong: the first defer registers and the
|
||||||
;;; second is refused.
|
;;; second is refused.
|
||||||
(defn two []
|
(defn two [] ()
|
||||||
(let [a 1 b 2]
|
(let [a 1 b 2]
|
||||||
(defer (note a))
|
(defer (note a))
|
||||||
(defer (note b))
|
(defer (note b))
|
||||||
@ -33,7 +33,7 @@
|
|||||||
|
|
||||||
;;; A nested let still has the function's extent, so a defer in it registers
|
;;; A nested let still has the function's extent, so a defer in it registers
|
||||||
;;; too — and it registers *later* than the outer one, so it runs first.
|
;;; too — and it registers *later* than the outer one, so it runs first.
|
||||||
(defn nested []
|
(defn nested [] ()
|
||||||
(let [a 1]
|
(let [a 1]
|
||||||
(defer (note a))
|
(defer (note a))
|
||||||
(let [b 2]
|
(let [b 2]
|
||||||
@ -43,7 +43,7 @@
|
|||||||
;;; Registration order is one order across the boundary: a defer at the top
|
;;; Registration order is one order across the boundary: a defer at the top
|
||||||
;;; level and a defer inside a let interleave by where they are written, not by
|
;;; level and a defer inside a let interleave by where they are written, not by
|
||||||
;;; which construct they are in. Written 1, 2, 3; run 3, 2, 1.
|
;;; which construct they are in. Written 1, 2, 3; run 3, 2, 1.
|
||||||
(defn mixed []
|
(defn mixed [] ()
|
||||||
(defer (note 1))
|
(defer (note 1))
|
||||||
(let [x 2]
|
(let [x 2]
|
||||||
(defer (note x))
|
(defer (note x))
|
||||||
|
|||||||
@ -22,7 +22,7 @@
|
|||||||
(set calls (+ calls 1))
|
(set calls (+ calls 1))
|
||||||
(Point {.x 3 .y 4}))
|
(Point {.x 3 .y 4}))
|
||||||
|
|
||||||
(defn show2 [label string a i32 b i32]
|
(defn show2 [label string a i32 b i32] ()
|
||||||
(print label)
|
(print label)
|
||||||
(print " ")
|
(print " ")
|
||||||
(print a)
|
(print a)
|
||||||
|
|||||||
@ -37,7 +37,7 @@
|
|||||||
(= k edn/tok-list-close) ")"
|
(= k edn/tok-list-close) ")"
|
||||||
:else "?"))
|
:else "?"))
|
||||||
|
|
||||||
(defn dump [src string]
|
(defn dump [src string] ()
|
||||||
(let [b (bytes src)
|
(let [b (bytes src)
|
||||||
c (edn/cursor b)
|
c (edn/cursor b)
|
||||||
t (edn/next (addr c))]
|
t (edn/next (addr c))]
|
||||||
@ -55,7 +55,7 @@
|
|||||||
;; The refusals. Asserted on the *reason*, not on the fact of failing: a
|
;; The refusals. Asserted on the *reason*, not on the fact of failing: a
|
||||||
;; tokenizer that answered err-unexpected-byte for every one of these would
|
;; tokenizer that answered err-unexpected-byte for every one of these would
|
||||||
;; pass a test that only checked that it failed.
|
;; pass a test that only checked that it failed.
|
||||||
(defn refusal [src string]
|
(defn refusal [src string] ()
|
||||||
(let [b (bytes src)
|
(let [b (bytes src)
|
||||||
c (edn/cursor b)]
|
c (edn/cursor b)]
|
||||||
(while (and (edn/ok? (addr c))
|
(while (and (edn/ok? (addr c))
|
||||||
@ -118,7 +118,7 @@
|
|||||||
(return e)))))
|
(return e)))))
|
||||||
e))
|
e))
|
||||||
|
|
||||||
(defn show-enemy [src string]
|
(defn show-enemy [src string] ()
|
||||||
(let [b (bytes src)
|
(let [b (bytes src)
|
||||||
c (edn/cursor b)
|
c (edn/cursor b)
|
||||||
e (read-enemy (addr c))]
|
e (read-enemy (addr c))]
|
||||||
|
|||||||
@ -10,7 +10,7 @@
|
|||||||
|
|
||||||
;; The shape map/filter/reduce want: the function arrives as a parameter, is
|
;; The shape map/filter/reduce want: the function arrives as a parameter, is
|
||||||
;; called, and is never stored.
|
;; called, and is never stored.
|
||||||
(defn each! [xs [i32] f (Fn [i32] i32)] Unit
|
(defn each! [xs [i32] f (Fn [i32] i32)] ()
|
||||||
(dotimes [i (len xs)]
|
(dotimes [i (len xs)]
|
||||||
(set (at xs i) (f (at xs i)))))
|
(set (at xs i) (f (at xs i)))))
|
||||||
|
|
||||||
@ -23,7 +23,7 @@
|
|||||||
;; A comparator, which is the other half of what was blocked: a sort that is
|
;; A comparator, which is the other half of what was blocked: a sort that is
|
||||||
;; told the order rather than having it written in. Insertion sort, because the
|
;; told the order rather than having it written in. Insertion sort, because the
|
||||||
;; point here is the parameter and not the algorithm.
|
;; point here is the parameter and not the algorithm.
|
||||||
(defn sort-by! [xs [i32] before? (Fn [i32 i32] bool)] Unit
|
(defn sort-by! [xs [i32] before? (Fn [i32 i32] bool)] ()
|
||||||
(dotimes [i (len xs)]
|
(dotimes [i (len xs)]
|
||||||
(let [j i]
|
(let [j i]
|
||||||
(while (and (> j 0) (before? (at xs j) (at xs (- j 1))))
|
(while (and (> j 0) (before? (at xs j) (at xs (- j 1))))
|
||||||
@ -52,7 +52,7 @@
|
|||||||
;; A handler-bind and an fn literal in *one* function, which is the case that
|
;; A handler-bind and an fn literal in *one* function, which is the case that
|
||||||
;; would catch the two lifted-function name sequences sharing a counter: both
|
;; would catch the two lifted-function name sequences sharing a counter: both
|
||||||
;; are lifted out of [handles] and both are numbered within it.
|
;; are lifted out of [handles] and both are numbered within it.
|
||||||
(defn handles [] Unit
|
(defn handles [] ()
|
||||||
(handler-bind [(TooBig [c] (set seen (+ seen (.n c))))]
|
(handler-bind [(TooBig [c] (set seen (+ seen (.n c))))]
|
||||||
(let [xs [5 200 7 300]]
|
(let [xs [5 200 7 300]]
|
||||||
(println (fold (slice xs 0 4) checked))
|
(println (fold (slice xs 0 4) checked))
|
||||||
|
|||||||
@ -9,7 +9,7 @@
|
|||||||
;;;; sign, which belongs to the number and not to its integer part, because
|
;;;; sign, which belongs to the number and not to its integer part, because
|
||||||
;;;; -0.5 has an integer part of 0 and 0 carries no sign.
|
;;;; -0.5 has an integer part of 0 and 0 carries no sign.
|
||||||
|
|
||||||
(defn show [x f64 p i32]
|
(defn show [x f64 p i32] ()
|
||||||
(let [v (format-f64 x p)]
|
(let [v (format-f64 x p)]
|
||||||
(println (string (as-slice v)))
|
(println (string (as-slice v)))
|
||||||
(free v)))
|
(free v)))
|
||||||
|
|||||||
@ -9,7 +9,7 @@
|
|||||||
(defstruct P [x i32 y i32])
|
(defstruct P [x i32 y i32])
|
||||||
(defstruct Line [a P b P])
|
(defstruct Line [a P b P])
|
||||||
|
|
||||||
(defn bump [p (Ptr P)]
|
(defn bump [p (Ptr P)] ()
|
||||||
(set (.x p) (+ (.x p) 1)))
|
(set (.x p) (+ (.x p) 1)))
|
||||||
|
|
||||||
(defn sum-grid [] i32
|
(defn sum-grid [] i32
|
||||||
|
|||||||
@ -7,7 +7,7 @@
|
|||||||
;; membership test, all of them order-free. That is not a weakness of the test,
|
;; membership test, all of them order-free. That is not a weakness of the test,
|
||||||
;; it is the contract — a caller that wants an order sorts what it collected.
|
;; it is the contract — a caller that wants an order sorts what it collected.
|
||||||
|
|
||||||
(defn sum-and-count [] Unit
|
(defn sum-and-count [] ()
|
||||||
(let [m (map-new i32 i32)]
|
(let [m (map-new i32 i32)]
|
||||||
(put m 1 10)
|
(put m 1 10)
|
||||||
(put m 2 20)
|
(put m 2 20)
|
||||||
@ -29,7 +29,7 @@
|
|||||||
;; A map that never allocated has no block at all, and one that allocated and
|
;; A map that never allocated has no block at all, and one that allocated and
|
||||||
;; holds nothing has a block of nothing but zeroed hashes. Both walk zero
|
;; holds nothing has a block of nothing but zeroed hashes. Both walk zero
|
||||||
;; times, and they are different code paths to get there.
|
;; times, and they are different code paths to get there.
|
||||||
(defn the-empty-cases [] Unit
|
(defn the-empty-cases [] ()
|
||||||
(let [m (map-new i32 i32)
|
(let [m (map-new i32 i32)
|
||||||
cur (i64 0)
|
cur (i64 0)
|
||||||
k 0
|
k 0
|
||||||
@ -47,7 +47,7 @@
|
|||||||
|
|
||||||
;; A cursor left past the end keeps answering false rather than wrapping, so a
|
;; A cursor left past the end keeps answering false rather than wrapping, so a
|
||||||
;; second loop over a spent cursor is empty and not a repeat.
|
;; second loop over a spent cursor is empty and not a repeat.
|
||||||
(defn a-spent-cursor [] Unit
|
(defn a-spent-cursor [] ()
|
||||||
(let [m (map-new i32 i32)]
|
(let [m (map-new i32 i32)]
|
||||||
(put m 5 50)
|
(put m 5 50)
|
||||||
(put m 6 60)
|
(put m 6 60)
|
||||||
@ -64,7 +64,7 @@
|
|||||||
;; would catch the two runs being indexed with one geometry.
|
;; would catch the two runs being indexed with one geometry.
|
||||||
(defstruct Point [x i32 y i32])
|
(defstruct Point [x i32 y i32])
|
||||||
|
|
||||||
(defn wider-entries [] Unit
|
(defn wider-entries [] ()
|
||||||
(let [m (map-new string Point)]
|
(let [m (map-new string Point)]
|
||||||
(put m "a" (Point {.x 1 .y 2}))
|
(put m "a" (Point {.x 1 .y 2}))
|
||||||
(put m "bb" (Point {.x 3 .y 4}))
|
(put m "bb" (Point {.x 3 .y 4}))
|
||||||
@ -85,7 +85,7 @@
|
|||||||
;; Growth past the 75% threshold rehashes into a new block, so this walks a map
|
;; Growth past the 75% threshold rehashes into a new block, so this walks a map
|
||||||
;; whose layout is nothing like its insertion order and at a capacity several
|
;; whose layout is nothing like its insertion order and at a capacity several
|
||||||
;; doublings past the minimum.
|
;; doublings past the minimum.
|
||||||
(defn after-growth [] Unit
|
(defn after-growth [] ()
|
||||||
(let [m (map-new i64 i64)]
|
(let [m (map-new i64 i64)]
|
||||||
(dotimes [i 500]
|
(dotimes [i 500]
|
||||||
(put m (i64 i) (* (i64 i) 2)))
|
(put m (i64 i) (* (i64 i) 2)))
|
||||||
|
|||||||
@ -10,7 +10,7 @@
|
|||||||
;;;; past 2^24, where an f32 has no fractional bits and the guard, not the
|
;;;; past 2^24, where an f32 has no fractional bits and the guard, not the
|
||||||
;;;; cast, has to produce the answer.
|
;;;; cast, has to produce the answer.
|
||||||
|
|
||||||
(defn show [x f32]
|
(defn show [x f32] ()
|
||||||
(print x)
|
(print x)
|
||||||
(print " "))
|
(print " "))
|
||||||
|
|
||||||
|
|||||||
@ -13,7 +13,7 @@
|
|||||||
;;;; one copy per type. The proof that the macro is not one copy per type is
|
;;;; one copy per type. The proof that the macro is not one copy per type is
|
||||||
;;;; that the same three-word call below is made at i32, i64, u8 and f32.
|
;;;; that the same three-word call below is made at i32, i64, u8 and f32.
|
||||||
|
|
||||||
(defn show [x f32]
|
(defn show [x f32] ()
|
||||||
(print x)
|
(print x)
|
||||||
(print " "))
|
(print " "))
|
||||||
|
|
||||||
|
|||||||
@ -34,7 +34,7 @@
|
|||||||
(defstruct Long [s string])
|
(defstruct Long [s string])
|
||||||
(defvar long-one Long)
|
(defvar long-one Long)
|
||||||
|
|
||||||
(defn nothing [] )
|
(defn nothing [] () )
|
||||||
|
|
||||||
(defn find-it [s [i32] k i32] (Option i32)
|
(defn find-it [s [i32] k i32] (Option i32)
|
||||||
(dotimes [i (len s)]
|
(dotimes [i (len s)]
|
||||||
|
|||||||
@ -64,7 +64,7 @@
|
|||||||
;; different one.
|
;; different one.
|
||||||
(defvar pcm [16 u8])
|
(defvar pcm [16 u8])
|
||||||
|
|
||||||
(defn load-pcm []
|
(defn load-pcm [] ()
|
||||||
(set (at pcm 0) 0x00) (set (at pcm 1) 0x00) ; 0
|
(set (at pcm 0) 0x00) (set (at pcm 1) 0x00) ; 0
|
||||||
(set (at pcm 2) 0xE8) (set (at pcm 3) 0x03) ; 1000
|
(set (at pcm 2) 0xE8) (set (at pcm 3) 0x03) ; 1000
|
||||||
(set (at pcm 4) 0xD0) (set (at pcm 5) 0x07) ; 2000
|
(set (at pcm 4) 0xD0) (set (at pcm 5) 0x07) ; 2000
|
||||||
@ -76,7 +76,7 @@
|
|||||||
|
|
||||||
(defconst wav-path "/tmp/flan-raylib-audio.wav")
|
(defconst wav-path "/tmp/flan-raylib-audio.wav")
|
||||||
|
|
||||||
(defn show-wave [name string w rl/Wave]
|
(defn show-wave [name string w rl/Wave] ()
|
||||||
(print name)
|
(print name)
|
||||||
(print " ") (print (.frame-count w))
|
(print " ") (print (.frame-count w))
|
||||||
(print " ") (print (.sample-rate w))
|
(print " ") (print (.sample-rate w))
|
||||||
@ -84,7 +84,7 @@
|
|||||||
(print " ") (print (.channels w))
|
(print " ") (print (.channels w))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|
||||||
(defn show-bool [name string b bool]
|
(defn show-bool [name string b bool] ()
|
||||||
(print name) (print " ")
|
(print name) (print " ")
|
||||||
(println (if b "yes" "no")))
|
(println (if b "yes" "no")))
|
||||||
|
|
||||||
@ -121,7 +121,7 @@
|
|||||||
(rl/unload-wave one)
|
(rl/unload-wave one)
|
||||||
v)))
|
v)))
|
||||||
|
|
||||||
(defn show-frame [name string w rl/Wave i i32 want f32]
|
(defn show-frame [name string w rl/Wave i i32 want f32] ()
|
||||||
(show-bool name (near? (frame-at w i) want)))
|
(show-bool name (near? (frame-at w i) want)))
|
||||||
|
|
||||||
(defn main [] i32
|
(defn main [] i32
|
||||||
|
|||||||
@ -11,14 +11,14 @@
|
|||||||
;; survives it unchanged. Every case below is asymmetric — raylib does
|
;; survives it unchanged. Every case below is asymmetric — raylib does
|
||||||
;; something to the fields that depends on which is which.
|
;; something to the fields that depends on which is which.
|
||||||
|
|
||||||
(defn show-texture [t rl/Texture2D]
|
(defn show-texture [t rl/Texture2D] ()
|
||||||
(print (.id t)) (println "")
|
(print (.id t)) (println "")
|
||||||
(print (.width t)) (println "")
|
(print (.width t)) (println "")
|
||||||
(print (.height t)) (println "")
|
(print (.height t)) (println "")
|
||||||
(print (.mipmaps t)) (println "")
|
(print (.mipmaps t)) (println "")
|
||||||
(print (.format t)) (println ""))
|
(print (.format t)) (println ""))
|
||||||
|
|
||||||
(defn show-rect [r rl/Rectangle]
|
(defn show-rect [r rl/Rectangle] ()
|
||||||
(print (.x r)) (println "")
|
(print (.x r)) (println "")
|
||||||
(print (.y r)) (println "")
|
(print (.y r)) (println "")
|
||||||
(print (.width r)) (println "")
|
(print (.width r)) (println "")
|
||||||
@ -46,11 +46,11 @@
|
|||||||
;; ((140-100)/2)+8 = 28 and ((90-50)/2)+4 = 24. Swap offset and target in the
|
;; ((140-100)/2)+8 = 28 and ((90-50)/2)+4 = 24. Swap offset and target in the
|
||||||
;; defstruct and this reads (143,-16); swap rotation and zoom and the zoom
|
;; defstruct and this reads (143,-16); swap rotation and zoom and the zoom
|
||||||
;; becomes 0, the transform is singular, and both come back NaN.
|
;; becomes 0, the transform is singular, and both come back NaN.
|
||||||
(defn show-bool [name string b bool]
|
(defn show-bool [name string b bool] ()
|
||||||
(print name) (print " ")
|
(print name) (print " ")
|
||||||
(println (if b "yes" "no")))
|
(println (if b "yes" "no")))
|
||||||
|
|
||||||
(defn show-v [v rl/Vector2]
|
(defn show-v [v rl/Vector2] ()
|
||||||
(print (.x v)) (println "")
|
(print (.x v)) (println "")
|
||||||
(print (.y v)) (println ""))
|
(print (.y v)) (println ""))
|
||||||
|
|
||||||
@ -71,7 +71,7 @@
|
|||||||
(let [d (- a b)]
|
(let [d (- a b)]
|
||||||
(< (if (< d 0.0) (- 0.0 d) d) 0.0001)))
|
(< (if (< d 0.0) (- 0.0 d) d) 0.0001)))
|
||||||
|
|
||||||
(defn show-near [name string v rl/Vector2 x f32 y f32]
|
(defn show-near [name string v rl/Vector2 x f32 y f32] ()
|
||||||
(print name)
|
(print name)
|
||||||
(println (if (and (near? (.x v) x) (near? (.y v) y)) " ok" " bad")))
|
(println (if (and (near? (.x v) x) (near? (.y v) y)) " ok" " bad")))
|
||||||
|
|
||||||
|
|||||||
@ -67,7 +67,7 @@
|
|||||||
;; and glyph C answers with A's numbers.
|
;; and glyph C answers with A's numbers.
|
||||||
(defvar glyphs [3 rl/GlyphInfo])
|
(defvar glyphs [3 rl/GlyphInfo])
|
||||||
|
|
||||||
(defn build-glyphs []
|
(defn build-glyphs [] ()
|
||||||
(set (at glyph-recs 0) (rl/Rectangle {.x 0.0 .y 0.0 .width 5.0 .height 10.0}))
|
(set (at glyph-recs 0) (rl/Rectangle {.x 0.0 .y 0.0 .width 5.0 .height 10.0}))
|
||||||
(set (at glyph-recs 1) (rl/Rectangle {.x 5.0 .y 0.0 .width 7.0 .height 10.0}))
|
(set (at glyph-recs 1) (rl/Rectangle {.x 5.0 .y 0.0 .width 7.0 .height 10.0}))
|
||||||
(set (at glyph-recs 2) (rl/Rectangle {.x 12.0 .y 0.0 .width 9.0 .height 10.0}))
|
(set (at glyph-recs 2) (rl/Rectangle {.x 12.0 .y 0.0 .width 9.0 .height 10.0}))
|
||||||
@ -80,20 +80,20 @@
|
|||||||
(set (at glyphs 2) (rl/GlyphInfo {.value 67 .offset-x 3 .offset-y 0
|
(set (at glyphs 2) (rl/GlyphInfo {.value 67 .offset-x 3 .offset-y 0
|
||||||
.advance-x 0 .image (rl/Image {})})))
|
.advance-x 0 .image (rl/Image {})})))
|
||||||
|
|
||||||
(defn show-bool [name string b bool]
|
(defn show-bool [name string b bool] ()
|
||||||
(print name) (print " ")
|
(print name) (print " ")
|
||||||
(println (if b "yes" "no")))
|
(println (if b "yes" "no")))
|
||||||
|
|
||||||
(defn show-i [name string v i32]
|
(defn show-i [name string v i32] ()
|
||||||
(print name) (print " ") (print v) (println ""))
|
(print name) (print " ") (print v) (println ""))
|
||||||
|
|
||||||
(defn show-v [name string v rl/Vector2]
|
(defn show-v [name string v rl/Vector2] ()
|
||||||
(print name)
|
(print name)
|
||||||
(print " ") (print (.x v))
|
(print " ") (print (.x v))
|
||||||
(print " ") (print (.y v))
|
(print " ") (print (.y v))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|
||||||
(defn show-rect [name string r rl/Rectangle]
|
(defn show-rect [name string r rl/Rectangle] ()
|
||||||
(print name)
|
(print name)
|
||||||
(print " ") (print (.x r))
|
(print " ") (print (.x r))
|
||||||
(print " ") (print (.y r))
|
(print " ") (print (.y r))
|
||||||
|
|||||||
@ -34,7 +34,7 @@
|
|||||||
;; write identical bytes, so sharing one path between runs is harmless.
|
;; write identical bytes, so sharing one path between runs is harmless.
|
||||||
(defconst png-path "/tmp/flan-raylib-image.png")
|
(defconst png-path "/tmp/flan-raylib-image.png")
|
||||||
|
|
||||||
(defn show-image [name string i rl/Image]
|
(defn show-image [name string i rl/Image] ()
|
||||||
(print name)
|
(print name)
|
||||||
(print " ") (print (.width i))
|
(print " ") (print (.width i))
|
||||||
(print " ") (print (.height i))
|
(print " ") (print (.height i))
|
||||||
@ -42,7 +42,7 @@
|
|||||||
(print " ") (print (.format i))
|
(print " ") (print (.format i))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|
||||||
(defn show-color [name string c rl/Color]
|
(defn show-color [name string c rl/Color] ()
|
||||||
(print name)
|
(print name)
|
||||||
(print " ") (print (.r c))
|
(print " ") (print (.r c))
|
||||||
(print " ") (print (.g c))
|
(print " ") (print (.g c))
|
||||||
@ -50,13 +50,13 @@
|
|||||||
(print " ") (print (.a c))
|
(print " ") (print (.a c))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|
||||||
(defn show-bool [name string b bool]
|
(defn show-bool [name string b bool] ()
|
||||||
(print name) (print " ")
|
(print name) (print " ")
|
||||||
(println (if b "yes" "no")))
|
(println (if b "yes" "no")))
|
||||||
|
|
||||||
;; Every pixel read names its coordinates in the label, so a failure says
|
;; Every pixel read names its coordinates in the label, so a failure says
|
||||||
;; which one moved rather than only that something did.
|
;; which one moved rather than only that something did.
|
||||||
(defn show-pixel [name string i rl/Image x i32 y i32]
|
(defn show-pixel [name string i rl/Image x i32 y i32] ()
|
||||||
(show-color name (rl/get-image-color i x y)))
|
(show-color name (rl/get-image-color i x y)))
|
||||||
|
|
||||||
(defn main [] i32
|
(defn main [] i32
|
||||||
|
|||||||
@ -15,13 +15,13 @@
|
|||||||
(defvar ys [5 i32])
|
(defvar ys [5 i32])
|
||||||
(defvar zs [8 i32])
|
(defvar zs [8 i32])
|
||||||
|
|
||||||
(defn show [s [i32]]
|
(defn show [s [i32]] ()
|
||||||
(dotimes [i (len s)]
|
(dotimes [i (len s)]
|
||||||
(when (> i 0) (print " "))
|
(when (> i 0) (print " "))
|
||||||
(print (at s i)))
|
(print (at s i)))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|
||||||
(defn load-xs []
|
(defn load-xs [] ()
|
||||||
(set (at xs 0) 5)
|
(set (at xs 0) 5)
|
||||||
(set (at xs 1) -3)
|
(set (at xs 1) -3)
|
||||||
(set (at xs 2) 5)
|
(set (at xs 2) 5)
|
||||||
|
|||||||
@ -20,7 +20,7 @@
|
|||||||
;; which shares stdout's buffer with puts, so the interleaving is stable.
|
;; which shares stdout's buffer with puts, so the interleaving is stable.
|
||||||
(declare-c c-puts [s string] i32 "puts")
|
(declare-c c-puts [s string] i32 "puts")
|
||||||
|
|
||||||
(defn shows [s string]
|
(defn shows [s string] ()
|
||||||
(print "[")
|
(print "[")
|
||||||
(print s)
|
(print s)
|
||||||
(print "] ")
|
(print "] ")
|
||||||
|
|||||||
@ -11,7 +11,7 @@
|
|||||||
;;; A (Vec u8) printed as text, without the caller writing the two-step every
|
;;; A (Vec u8) printed as text, without the caller writing the two-step every
|
||||||
;;; time. as-slice borrows -- it copies ptr+len and never the elements -- so v
|
;;; time. as-slice borrows -- it copies ptr+len and never the elements -- so v
|
||||||
;;; is still the owner afterwards and is still free-able.
|
;;; is still the owner afterwards and is still free-able.
|
||||||
(defn show [v (Ptr (Vec u8))]
|
(defn show [v (Ptr (Vec u8))] ()
|
||||||
(println (string (as-slice (deref v)))))
|
(println (string (as-slice (deref v)))))
|
||||||
|
|
||||||
(defn main [] i32
|
(defn main [] i32
|
||||||
|
|||||||
@ -6,7 +6,7 @@
|
|||||||
;;;; end, and for parse-i64 every shape strtoll answers 0 for — "", "abc",
|
;;;; end, and for parse-i64 every shape strtoll answers 0 for — "", "abc",
|
||||||
;;;; "12x", "-" — each of which a caller could not tell from a real 0.
|
;;;; "12x", "-" — each of which a caller could not tell from a real 0.
|
||||||
|
|
||||||
(defn show-bool [b bool]
|
(defn show-bool [b bool] ()
|
||||||
(print (if b "t" "f")))
|
(print (if b "t" "f")))
|
||||||
|
|
||||||
(defn main [] i32
|
(defn main [] i32
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
;;;; The short entry point: both the parameter and the i32 status are optional,
|
;;;; The short entry point: both the parameter and the i32 status are optional,
|
||||||
;;;; and an omitted return type means Unit, so the process exits 0.
|
;;;; and an omitted return type means Unit, so the process exits 0.
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(println "ok"))
|
(println "ok"))
|
||||||
|
|||||||
@ -50,17 +50,17 @@
|
|||||||
|
|
||||||
;; code/width/ok, so a wrong answer names which of the three it got wrong
|
;; code/width/ok, so a wrong answer names which of the three it got wrong
|
||||||
;; rather than just failing.
|
;; rather than just failing.
|
||||||
(defn show-dec [s [u8]]
|
(defn show-dec [s [u8]] ()
|
||||||
(let [r (decode-rune s)]
|
(let [r (decode-rune s)]
|
||||||
(print (.code r)) (print "/")
|
(print (.code r)) (print "/")
|
||||||
(print (.width r)) (print "/")
|
(print (.width r)) (print "/")
|
||||||
(print (if (.ok r) "t" "f"))
|
(print (if (.ok r) "t" "f"))
|
||||||
(print " ")))
|
(print " ")))
|
||||||
|
|
||||||
(defn show-bool [b bool]
|
(defn show-bool [b bool] ()
|
||||||
(print (if b "t" "f")))
|
(print (if b "t" "f")))
|
||||||
|
|
||||||
(defn show-opt [o (Option i32)]
|
(defn show-opt [o (Option i32)] ()
|
||||||
(print (match o (Some v) v None -1))
|
(print (match o (Some v) v None -1))
|
||||||
(print " "))
|
(print " "))
|
||||||
|
|
||||||
@ -74,11 +74,11 @@
|
|||||||
(let [r (decode-rune (slice scratch 0 w))]
|
(let [r (decode-rune (slice scratch 0 w))]
|
||||||
(if (and (.ok r) (= (.width r) w)) (.code r) -1))))
|
(if (and (.ok r) (= (.width r) w)) (.code r) -1))))
|
||||||
|
|
||||||
(defn show-i32 [x i32]
|
(defn show-i32 [x i32] ()
|
||||||
(print x)
|
(print x)
|
||||||
(print " "))
|
(print " "))
|
||||||
|
|
||||||
(defn show-split [s [u8] sep u8]
|
(defn show-split [s [u8] sep u8] ()
|
||||||
(let [it (split-on-byte s sep)
|
(let [it (split-on-byte s sep)
|
||||||
going true]
|
going true]
|
||||||
(while going
|
(while going
|
||||||
|
|||||||
@ -382,7 +382,7 @@ let () =
|
|||||||
"a quoted restart name and then its arguments";
|
"a quoted restart name and then its arguments";
|
||||||
(* A clause parameter is a binding, so it needs something to hold. *)
|
(* A clause parameter is a binding, so it needs something to hold. *)
|
||||||
refuses_src "a restart parameter that is not a value"
|
refuses_src "a restart parameter that is not a value"
|
||||||
"(defn main [] i32 (restart-case 0 (use-value [v Unit] 1)))"
|
"(defn main [] i32 (restart-case 0 (use-value [v ()] 1)))"
|
||||||
"which is not a value";
|
"which is not a value";
|
||||||
(* And so does an argument: a [println] is Unit, and there would be nothing
|
(* And so does an argument: a [println] is Unit, and there would be nothing
|
||||||
to store into the clause's buffer. *)
|
to store into the clause's buffer. *)
|
||||||
@ -1669,7 +1669,7 @@ ERR@7 unexpected token: not the kind the caller was reading
|
|||||||
"(declare-c name [] string \"Name\")"
|
"(declare-c name [] string \"Name\")"
|
||||||
"a string only crosses as a parameter";
|
"a string only crosses as a parameter";
|
||||||
shim_refuses "declare-c: a callback"
|
shim_refuses "declare-c: a callback"
|
||||||
"(declare-c each [f (Fn [i32] Unit)] \"Each\")"
|
"(declare-c each [f (Fn [i32] ())] \"Each\")"
|
||||||
"a C callback is not implemented";
|
"a C callback is not implemented";
|
||||||
shim_refuses "declare-c: an unknown type"
|
shim_refuses "declare-c: an unknown type"
|
||||||
"(declare-c f [x Nope] \"F\")"
|
"(declare-c f [x Nope] \"F\")"
|
||||||
@ -1679,7 +1679,7 @@ ERR@7 unexpected token: not the kind the caller was reading
|
|||||||
"field xs of S is a slice";
|
"field xs of S is a slice";
|
||||||
shim_refuses "declare-c: the generated name is already taken"
|
shim_refuses "declare-c: the generated name is already taken"
|
||||||
(v2
|
(v2
|
||||||
^ "(defn mid-c [a (Ptr Vector2) out (Ptr Vector2)])\n\
|
^ "(defn mid-c [a (Ptr Vector2) out (Ptr Vector2)] ())\n\
|
||||||
(declare-c mid [a Vector2] Vector2 \"Mid\")")
|
(declare-c mid [a Vector2] Vector2 \"Mid\")")
|
||||||
"needs the name mid-c for the declaration it generates";
|
"needs the name mid-c for the declaration it generates";
|
||||||
shim_refuses "declare-c: two Flan names for one C function"
|
shim_refuses "declare-c: two Flan names for one C function"
|
||||||
@ -1724,19 +1724,19 @@ ERR@7 unexpected token: not the kind the caller was reading
|
|||||||
copied into every exit path cannot. A [let] inside either one inherits
|
copied into every exit path cannot. A [let] inside either one inherits
|
||||||
the refusal, not the permission: its extent is the loop's or the arm's. *)
|
the refusal, not the permission: its extent is the loop's or the arm's. *)
|
||||||
refuses_src "defer in a loop body"
|
refuses_src "defer in a loop body"
|
||||||
"(defn g [] 0)\n(defn f [] (while true (defer (g))))"
|
"(defn g [] () 0)\n(defn f [] () (while true (defer (g))))"
|
||||||
"not allowed inside a loop body";
|
"not allowed inside a loop body";
|
||||||
refuses_src "defer in a dotimes body"
|
refuses_src "defer in a dotimes body"
|
||||||
"(defn g [] 0)\n(defn f [] (dotimes [i 3] (defer (g))))"
|
"(defn g [] () 0)\n(defn f [] () (dotimes [i 3] (defer (g))))"
|
||||||
"not allowed inside a loop body";
|
"not allowed inside a loop body";
|
||||||
refuses_src "defer in a branch"
|
refuses_src "defer in a branch"
|
||||||
"(defn g [] 0)\n(defn f [] (if true (defer (g)) 0))"
|
"(defn g [] () 0)\n(defn f [] () (if true (defer (g)) 0))"
|
||||||
"not allowed inside a branch";
|
"not allowed inside a branch";
|
||||||
refuses_src "defer in a let inside a loop"
|
refuses_src "defer in a let inside a loop"
|
||||||
"(defn g [] 0)\n(defn f [] (while true (let [x 1] (defer (g)))))"
|
"(defn g [] () 0)\n(defn f [] () (while true (let [x 1] (defer (g)))))"
|
||||||
"not allowed inside a loop body";
|
"not allowed inside a loop body";
|
||||||
refuses_src "defer in a let inside a branch"
|
refuses_src "defer in a let inside a branch"
|
||||||
"(defn g [] 0)\n(defn f [] (if true (let [x 1] (defer (g))) 0))"
|
"(defn g [] () 0)\n(defn f [] () (if true (let [x 1] (defer (g))) 0))"
|
||||||
"not allowed inside a branch";
|
"not allowed inside a branch";
|
||||||
|
|
||||||
(* ── (Map K V), spec-memory.md step 4 ──────────────────────────
|
(* ── (Map K V), spec-memory.md step 4 ──────────────────────────
|
||||||
@ -1798,13 +1798,13 @@ ERR@7 unexpected token: not the kind the caller was reading
|
|||||||
Unit as a value is refused rather than dividing a cache line by zero,
|
Unit as a value is refused rather than dividing a cache line by zero,
|
||||||
and it is named because it is the natural spelling of a set. *)
|
and it is named because it is the natural spelling of a set. *)
|
||||||
refuses_src "a float is not a map key"
|
refuses_src "a float is not a map key"
|
||||||
"(defn f [m (Map f32 i32)] 0)" "is not a map key";
|
"(defn f [m (Map f32 i32)] () 0)" "is not a map key";
|
||||||
refuses_src "a Ptr is not a map key"
|
refuses_src "a Ptr is not a map key"
|
||||||
"(defn f [m (Map (Ptr i32) i32)] 0)" "hash an address";
|
"(defn f [m (Map (Ptr i32) i32)] () 0)" "hash an address";
|
||||||
refuses_src "a map value may not own storage"
|
refuses_src "a map value may not own storage"
|
||||||
"(defn f [m (Map i32 (Vec i32))] 0)" "holds a move-only value";
|
"(defn f [m (Map i32 (Vec i32))] () 0)" "holds a move-only value";
|
||||||
refuses_src "a map value may not be Unit"
|
refuses_src "a map value may not be ()"
|
||||||
"(defn f [m (Map i32 Unit)] 0)" "cannot be Unit";
|
"(defn f [m (Map i32 ())] () 0)" "cannot be ()";
|
||||||
refuses_src "map-new with nothing to say what it maps"
|
refuses_src "map-new with nothing to say what it maps"
|
||||||
"(defn main [] i32 (let [m (map-new)] (free m)) 0)"
|
"(defn main [] i32 (let [m (map-new)] (free m)) 0)"
|
||||||
"nothing here says what (map-new) maps";
|
"nothing here says what (map-new) maps";
|
||||||
@ -1967,16 +1967,16 @@ ERR@7 unexpected token: not the kind the caller was reading
|
|||||||
unions through each other. (Ptr T) breaks the cycle and is exercised in
|
unions through each other. (Ptr T) breaks the cycle and is exercised in
|
||||||
the program above -- it is the shape a Form has. *)
|
the program above -- it is the shape a Form has. *)
|
||||||
refuses_src "a union that contains itself by value"
|
refuses_src "a union that contains itself by value"
|
||||||
"(defunion T [Leaf (Node [l T r T])])\n(defn f [t T] 0)"
|
"(defunion T [Leaf (Node [l T r T])])\n(defn f [t T] () 0)"
|
||||||
"T contains itself by value";
|
"T contains itself by value";
|
||||||
refuses_src "two unions that contain each other by value"
|
refuses_src "two unions that contain each other by value"
|
||||||
"(defunion A [(X [b B])])\n(defunion B [(Y [a A])])\n(defn f [a A] 0)"
|
"(defunion A [(X [b B])])\n(defunion B [(Y [a A])])\n(defn f [a A] () 0)"
|
||||||
"contains itself by value";
|
"contains itself by value";
|
||||||
refuses_src "a union with no cases"
|
refuses_src "a union with no cases"
|
||||||
"(defunion U [])\n(defn f [u U] 0)"
|
"(defunion U [])\n(defn f [u U] () 0)"
|
||||||
"declares no cases";
|
"declares no cases";
|
||||||
refuses_src "a union case that owns a Vec"
|
refuses_src "a union case that owns a Vec"
|
||||||
"(defunion U [(A [v (Vec i32)])])\n(defn f [u U] 0)"
|
"(defunion U [(A [v (Vec i32)])])\n(defn f [u U] () 0)"
|
||||||
"which is move-only";
|
"which is move-only";
|
||||||
(* At the operation, not at the type: a struct key is decided by walking
|
(* At the operation, not at the type: a struct key is decided by walking
|
||||||
its fields and the struct table is not necessarily complete while a
|
its fields and the struct table is not necessarily complete while a
|
||||||
@ -1984,7 +1984,7 @@ ERR@7 unexpected token: not the kind the caller was reading
|
|||||||
pair is emitted. A union reaches the same place. *)
|
pair is emitted. A union reaches the same place. *)
|
||||||
refuses_src "a union is not a map key"
|
refuses_src "a union is not a map key"
|
||||||
"(defunion U [A B])\n\
|
"(defunion U [A B])\n\
|
||||||
(defn f [m (Map U i32) k U] (put m k 1))"
|
(defn f [m (Map U i32) k U] () (put m k 1))"
|
||||||
"the payload past the case in hand is indeterminate";
|
"the payload past the case in hand is indeterminate";
|
||||||
(* A global cannot hold a case, because writing one at link time means
|
(* A global cannot hold a case, because writing one at link time means
|
||||||
serialising the fields into the payload blob and a string field is a
|
serialising the fields into the payload blob and a string field is a
|
||||||
|
|||||||
@ -178,8 +178,8 @@ let () =
|
|||||||
reads "two discards" "(f #_#_a b c)" "(f c)";
|
reads "two discards" "(f #_#_a b c)" "(f c)";
|
||||||
reads "three discards" "(f #_#_#_a b c d)" "(f d)";
|
reads "three discards" "(f #_#_#_a b c d)" "(f d)";
|
||||||
(* Every position a form can appear in. *)
|
(* Every position a form can appear in. *)
|
||||||
reads "discard at top level" "#_(defn a [] 1) (defn b [] 2)" "(defn b [] 2)";
|
reads "discard at top level" "#_(defn a [] () 1) (defn b [] () 2)" "(defn b [] () 2)";
|
||||||
reads "discard a whole file" "#_(defn a [] 1)" "";
|
reads "discard a whole file" "#_(defn a [] () 1)" "";
|
||||||
reads "discard before quote" "(f #_a 'b)" "(f (quote b))";
|
reads "discard before quote" "(f #_a 'b)" "(f (quote b))";
|
||||||
reads "discard of a quote" "(f #_'a b)" "(f b)";
|
reads "discard of a quote" "(f #_'a b)" "(f b)";
|
||||||
(* Nested, which the recursive read gives for free. *)
|
(* Nested, which the recursive read gives for free. *)
|
||||||
@ -368,7 +368,7 @@ let () =
|
|||||||
|
|
||||||
(* ── Types: brackets mean different things by position ─────────── *)
|
(* ── Types: brackets mean different things by position ─────────── *)
|
||||||
let ty src =
|
let ty src =
|
||||||
match parse_decl (Printf.sprintf "(defn f [x %s])" src) with
|
match parse_decl (Printf.sprintf "(defn f [x %s] ())" src) with
|
||||||
| { d = Defn { params = [ { fty; _ } ]; _ }; _ } -> fty.t
|
| { d = Defn { params = [ { fty; _ } ]; _ }; _ } -> fty.t
|
||||||
| _ -> failwith "bad type test"
|
| _ -> failwith "bad type test"
|
||||||
in
|
in
|
||||||
@ -389,10 +389,14 @@ let () =
|
|||||||
(match (parse_decl "(defn f [x i32] bool x)").d with
|
(match (parse_decl "(defn f [x i32] bool x)").d with
|
||||||
| Defn { ret = Some _; params = [ _ ]; fbody = [ _ ]; _ } -> ()
|
| Defn { ret = Some _; params = [ _ ]; fbody = [ _ ]; _ } -> ()
|
||||||
| _ -> check "defn with return type" false);
|
| _ -> check "defn with return type" false);
|
||||||
(* An omitted return type means Unit — the body must not be eaten as a type *)
|
(* () is the unit return type, and the body is what follows it. *)
|
||||||
(match (parse_decl "(defn f [x i32] (g x))").d with
|
(match (parse_decl "(defn f [x i32] () (g x))").d with
|
||||||
| Defn { ret = None; fbody = [ _ ]; _ } -> ()
|
| Defn { ret = Some { t = Tname "Unit"; _ }; fbody = [ _ ]; _ } -> ()
|
||||||
| _ -> check "defn without return type" false);
|
| _ -> check "defn returning ()" false);
|
||||||
|
(* A lone () is the return type and an empty body, not a body of one form. *)
|
||||||
|
(match (parse_decl "(defn f [x i32] ())").d with
|
||||||
|
| Defn { ret = Some { t = Tname "Unit"; _ }; fbody = []; _ } -> ()
|
||||||
|
| _ -> check "defn returning () with no body" false);
|
||||||
(match (parse_decl "(defvar grid [4 u32])").d with
|
(match (parse_decl "(defvar grid [4 u32])").d with
|
||||||
| Defvar ("grid", Some _, Zeroed) -> ()
|
| Defvar ("grid", Some _, Zeroed) -> ()
|
||||||
| _ -> check "defvar is ZII" false);
|
| _ -> check "defvar is ZII" false);
|
||||||
@ -429,7 +433,7 @@ let () =
|
|||||||
~needle:"defmacro is (defmacro name [param ...] body ...)";
|
~needle:"defmacro is (defmacro name [param ...] body ...)";
|
||||||
parse_rejects "defmacro with a non-name param" "(defmacro m [1] x)"
|
parse_rejects "defmacro with a non-name param" "(defmacro m [1] x)"
|
||||||
~needle:"expected a name";
|
~needle:"expected a name";
|
||||||
parse_rejects "defmacro in expression position" "(defn f [] (defmacro m [] 1))"
|
parse_rejects "defmacro in expression position" "(defn f [] () (defmacro m [] 1))"
|
||||||
~needle:"top-level declaration";
|
~needle:"top-level declaration";
|
||||||
|
|
||||||
(* Quasiquote is a desugaring over Form, and it has already run by the time
|
(* Quasiquote is a desugaring over Form, and it has already run by the time
|
||||||
@ -463,9 +467,9 @@ let () =
|
|||||||
~needle:"quasiquote inside a quasiquote";
|
~needle:"quasiquote inside a quasiquote";
|
||||||
(* Not a missing feature — an unquote outside a quasiquote is a mistake, and
|
(* Not a missing feature — an unquote outside a quasiquote is a mistake, and
|
||||||
the reader cannot catch it because it does not track where it is. *)
|
the reader cannot catch it because it does not track where it is. *)
|
||||||
parse_rejects "unquote outside a quasiquote" "(defn f [] ~x)"
|
parse_rejects "unquote outside a quasiquote" "(defn f [] () ~x)"
|
||||||
~needle:"means nothing outside a quasiquote";
|
~needle:"means nothing outside a quasiquote";
|
||||||
parse_rejects "splice where a splice makes no sense" "(defn f [] (+ 1 ~@xs))"
|
parse_rejects "splice where a splice makes no sense" "(defn f [] () (+ 1 ~@xs))"
|
||||||
~needle:"splices only into a list or a vector";
|
~needle:"splices only into a list or a vector";
|
||||||
(* A splice with no bracket around it. The quasiquote is real here, so this
|
(* A splice with no bracket around it. The quasiquote is real here, so this
|
||||||
one is the desugaring's refusal and not the parser's. *)
|
one is the desugaring's refusal and not the parser's. *)
|
||||||
@ -477,17 +481,17 @@ let () =
|
|||||||
parse_rejects "odd field pairs" "(defstruct S [a])";
|
parse_rejects "odd field pairs" "(defstruct S [a])";
|
||||||
parse_rejects "cond without body" "(cond a)";
|
parse_rejects "cond without body" "(cond a)";
|
||||||
parse_rejects "unknown top form" "(nope x)";
|
parse_rejects "unknown top form" "(nope x)";
|
||||||
parse_rejects "break takes only a label" "(defn f [] (break 1))"
|
parse_rejects "break takes only a label" "(defn f [] () (break 1))"
|
||||||
~needle:"break is (break) or (break :label)";
|
~needle:"break is (break) or (break :label)";
|
||||||
parse_rejects "continue takes only a label" "(defn f [] (continue x))"
|
parse_rejects "continue takes only a label" "(defn f [] () (continue x))"
|
||||||
~needle:"continue is (continue) or (continue :label)";
|
~needle:"continue is (continue) or (continue :label)";
|
||||||
parse_rejects "a labelled while still needs a test" "(defn f [] (while :o))"
|
parse_rejects "a labelled while still needs a test" "(defn f [] () (while :o))"
|
||||||
~needle:"(while :label test body ...)";
|
~needle:"(while :label test body ...)";
|
||||||
parse_rejects "array with no type" "(defn f [] (array 4))"
|
parse_rejects "array with no type" "(defn f [] () (array 4))"
|
||||||
~needle:"array is (array COUNT TYPE)";
|
~needle:"array is (array COUNT TYPE)";
|
||||||
parse_rejects "array given a value, not a type" "(defn f [] (array 4 5))"
|
parse_rejects "array given a value, not a type" "(defn f [] () (array 4 5))"
|
||||||
~needle:"expected a type";
|
~needle:"expected a type";
|
||||||
parse_rejects "array with a non-constant count" "(defn f [] (array (+ 1 1) f32))"
|
parse_rejects "array with a non-constant count" "(defn f [] () (array (+ 1 1) f32))"
|
||||||
~needle:"an array length is an integer or a constant's name";
|
~needle:"an array length is an integer or a constant's name";
|
||||||
|
|
||||||
(* ── The corpus parses ─────────────────────────────────────────── *)
|
(* ── The corpus parses ─────────────────────────────────────────── *)
|
||||||
@ -664,11 +668,11 @@ let () =
|
|||||||
rejects_check "bare None has no type" "(defconst x None)"
|
rejects_check "bare None has no type" "(defconst x None)"
|
||||||
~needle:"what None is an Option of";
|
~needle:"what None is an Option of";
|
||||||
accepts "param types the literal"
|
accepts "param types the literal"
|
||||||
"(defn g [x u8]) (defn f [] (g 3))";
|
"(defn g [x u8] ()) (defn f [] () (g 3))";
|
||||||
rejects_check "wrong argument type"
|
rejects_check "wrong argument type"
|
||||||
"(defn g [x u8]) (defn f [] (g 0.5))" ~needle:"expected u8";
|
"(defn g [x u8] ()) (defn f [] () (g 0.5))" ~needle:"expected u8";
|
||||||
rejects_check "wrong arity"
|
rejects_check "wrong arity"
|
||||||
"(defn g [x u8]) (defn f [] (g 1 2))" ~needle:"takes 1 argument";
|
"(defn g [x u8] ()) (defn f [] () (g 1 2))" ~needle:"takes 1 argument";
|
||||||
rejects_check "wrong return type"
|
rejects_check "wrong return type"
|
||||||
"(defn f [] bool 1)" ~needle:"expected bool";
|
"(defn f [] bool 1)" ~needle:"expected bool";
|
||||||
rejects_check "if branches disagree"
|
rejects_check "if branches disagree"
|
||||||
@ -678,18 +682,18 @@ let () =
|
|||||||
(* A lowercase name is a type variable (plan.org, Types), so a mistyped
|
(* A lowercase name is a type variable (plan.org, Types), so a mistyped
|
||||||
primitive would otherwise be reported as unimplemented generics and send
|
primitive would otherwise be reported as unimplemented generics and send
|
||||||
you to plan.org instead of to the character you mistyped. *)
|
you to plan.org instead of to the character you mistyped. *)
|
||||||
rejects_check "a mistyped primitive" "(defn f [x f65])"
|
rejects_check "a mistyped primitive" "(defn f [x f65] ())"
|
||||||
~needle:"did you mean f64?";
|
~needle:"did you mean f64?";
|
||||||
rejects_check "a transposed primitive" "(defn f [x stirng])"
|
rejects_check "a transposed primitive" "(defn f [x stirng] ())"
|
||||||
~needle:"did you mean string?";
|
~needle:"did you mean string?";
|
||||||
rejects_check "a mistyped struct"
|
rejects_check "a mistyped struct"
|
||||||
"(defstruct Cursor [x i32]) (defn f [c Curser])"
|
"(defstruct Cursor [x i32]) (defn f [c Curser] ())"
|
||||||
~needle:"did you mean Cursor?";
|
~needle:"did you mean Cursor?";
|
||||||
(* Nothing close: the type-variable rule still applies, and still names the
|
(* Nothing close: the type-variable rule still applies, and still names the
|
||||||
milestone. *)
|
milestone. *)
|
||||||
rejects_check "a real type variable" "(defn f [x t])"
|
rejects_check "a real type variable" "(defn f [x t] ())"
|
||||||
~needle:"milestone 5";
|
~needle:"milestone 5";
|
||||||
rejects_check "an unknown concrete type" "(defn f [x Widget])"
|
rejects_check "an unknown concrete type" "(defn f [x Widget] ())"
|
||||||
~needle:"unknown type Widget";
|
~needle:"unknown type Widget";
|
||||||
|
|
||||||
(* ── Static bounds ─────────────────────────────────────────────── *)
|
(* ── Static bounds ─────────────────────────────────────────────── *)
|
||||||
@ -746,7 +750,7 @@ let () =
|
|||||||
accepts "field through a pointer auto-derefs"
|
accepts "field through a pointer auto-derefs"
|
||||||
(cursor ^ "(defn f [c (Ptr Cursor)] i32 (.pos c))");
|
(cursor ^ "(defn f [c (Ptr Cursor)] i32 (.pos c))");
|
||||||
accepts "set through a pointer"
|
accepts "set through a pointer"
|
||||||
(cursor ^ "(defn f [c (Ptr Cursor)] (set (.pos c) 1))");
|
(cursor ^ "(defn f [c (Ptr Cursor)] () (set (.pos c) 1))");
|
||||||
rejects_check "field of a non-struct"
|
rejects_check "field of a non-struct"
|
||||||
"(defn f [x i32] i32 (.pos x))" ~needle:"is not a struct";
|
"(defn f [x i32] i32 (.pos x))" ~needle:"is not a struct";
|
||||||
|
|
||||||
@ -754,14 +758,14 @@ let () =
|
|||||||
accepts "a local is assignable"
|
accepts "a local is assignable"
|
||||||
"(defn f [] i32 (let [x 1] (set x 2) x))";
|
"(defn f [] i32 (let [x 1] (set x 2) x))";
|
||||||
rejects_check "a parameter is not assignable"
|
rejects_check "a parameter is not assignable"
|
||||||
"(defn f [x i32] (set x 2))" ~needle:"parameters are not assignable";
|
"(defn f [x i32] () (set x 2))" ~needle:"parameters are not assignable";
|
||||||
rejects_check "a constant is not assignable"
|
rejects_check "a constant is not assignable"
|
||||||
"(defconst k 1) (defn f [] (set k 2))" ~needle:"is a constant";
|
"(defconst k 1) (defn f [] () (set k 2))" ~needle:"is a constant";
|
||||||
accepts "addr of a local gives a pointer"
|
accepts "addr of a local gives a pointer"
|
||||||
(cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \
|
(cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \
|
||||||
(defn f [s [u8]] i32 (let [c (Cursor {.src s})] (g (addr c))))");
|
(defn f [s [u8]] i32 (let [c (Cursor {.src s})] (g (addr c))))");
|
||||||
rejects_check "addr of a non-place"
|
rejects_check "addr of a non-place"
|
||||||
"(defn f [] (addr (+ 1 2)))" ~needle:"addr takes the address of a place";
|
"(defn f [] () (addr (+ 1 2)))" ~needle:"addr takes the address of a place";
|
||||||
|
|
||||||
(* ── Option, some, match ───────────────────────────────────────── *)
|
(* ── Option, some, match ───────────────────────────────────────── *)
|
||||||
accepts "some unwraps in an Option-returning function"
|
accepts "some unwraps in an Option-returning function"
|
||||||
@ -787,11 +791,11 @@ let () =
|
|||||||
rejects_check "unknown name" "(defn f [] i32 nope)" ~needle:"unknown name";
|
rejects_check "unknown name" "(defn f [] i32 nope)" ~needle:"unknown name";
|
||||||
rejects_check "unknown function" "(defn f [] i32 (nope 1))"
|
rejects_check "unknown function" "(defn f [] i32 (nope 1))"
|
||||||
~needle:"unknown function";
|
~needle:"unknown function";
|
||||||
rejects_check "defined twice" "(defn f []) (defn f [])"
|
rejects_check "defined twice" "(defn f [] ()) (defn f [] ())"
|
||||||
~needle:"defined twice";
|
~needle:"defined twice";
|
||||||
accepts "main with no parameters and no return" "(defn main [])";
|
accepts "main with no parameters and no return" "(defn main [] ())";
|
||||||
accepts "main with argv and a status" "(defn main [args [string]] i32 0)";
|
accepts "main with argv and a status" "(defn main [args [string]] i32 0)";
|
||||||
rejects_check "main with a wrong parameter" "(defn main [n i32])"
|
rejects_check "main with a wrong parameter" "(defn main [n i32] ())"
|
||||||
~needle:"main takes no parameters";
|
~needle:"main takes no parameters";
|
||||||
rejects_check "main returning the wrong type" "(defn main [] bool true)"
|
rejects_check "main returning the wrong type" "(defn main [] bool true)"
|
||||||
~needle:"main returns i32";
|
~needle:"main returns i32";
|
||||||
@ -802,14 +806,14 @@ let () =
|
|||||||
(* (Vec T) is built. What is still refused is the arity: one element type,
|
(* (Vec T) is built. What is still refused is the arity: one element type,
|
||||||
and a near-miss there would otherwise resolve to a type variable and come
|
and a near-miss there would otherwise resolve to a type variable and come
|
||||||
back as generics. *)
|
back as generics. *)
|
||||||
rejects_check "Vec takes one type" "(defn f [x (Vec i32 i32)])"
|
rejects_check "Vec takes one type" "(defn f [x (Vec i32 i32)] ())"
|
||||||
~needle:"exactly one type";
|
~needle:"exactly one type";
|
||||||
(* {K V} resolves now — it is the Map type spelling, and the only one, since
|
(* {K V} resolves now — it is the Map type spelling, and the only one, since
|
||||||
a bare map form in expression position is a struct literal's field list.
|
a bare map form in expression position is a struct literal's field list.
|
||||||
What is still refused is the arity, for the same reason Vec's is: a
|
What is still refused is the arity, for the same reason Vec's is: a
|
||||||
near-miss would otherwise resolve to a type variable and come back as
|
near-miss would otherwise resolve to a type variable and come back as
|
||||||
generics. *)
|
generics. *)
|
||||||
rejects_check "Map takes two types" "(defn f [x (Map i32)])"
|
rejects_check "Map takes two types" "(defn f [x (Map i32)] ())"
|
||||||
~needle:"exactly two types";
|
~needle:"exactly two types";
|
||||||
rejects_check "Result is milestone 6" "(defn f [] (Result i32 i32) None)"
|
rejects_check "Result is milestone 6" "(defn f [] (Result i32 i32) None)"
|
||||||
~needle:"milestone 6";
|
~needle:"milestone 6";
|
||||||
@ -823,10 +827,10 @@ let () =
|
|||||||
rather than once per iteration, and a branch cannot say "maybe
|
rather than once per iteration, and a branch cannot say "maybe
|
||||||
registered". *)
|
registered". *)
|
||||||
rejects_check "defer is refused in a loop body"
|
rejects_check "defer is refused in a loop body"
|
||||||
"(defn g [] 0) (defn f [] (while true (defer (g))))"
|
"(defn g [] () 0) (defn f [] () (while true (defer (g))))"
|
||||||
~needle:"a loop body";
|
~needle:"a loop body";
|
||||||
rejects_check "defer is refused in a branch"
|
rejects_check "defer is refused in a branch"
|
||||||
"(defn g [] 0) (defn f [] (if true (defer (g)) 0))"
|
"(defn g [] () 0) (defn f [] () (if true (defer (g)) 0))"
|
||||||
~needle:"a branch";
|
~needle:"a branch";
|
||||||
(* break and continue. The interesting half is the *relative* rule: a jump
|
(* break and continue. The interesting half is the *relative* rule: a jump
|
||||||
may not cross a construct that has work to do on the way out, and the
|
may not cross a construct that has work to do on the way out, and the
|
||||||
@ -834,34 +838,34 @@ let () =
|
|||||||
[return] still carries, and the accepting cases below are the ones a
|
[return] still carries, and the accepting cases below are the ones a
|
||||||
blanket rule would have got wrong. *)
|
blanket rule would have got wrong. *)
|
||||||
accepts "break leaves the innermost loop"
|
accepts "break leaves the innermost loop"
|
||||||
"(defn f [] (while true (break)))";
|
"(defn f [] () (while true (break)))";
|
||||||
accepts "a labelled break leaves the named loop"
|
accepts "a labelled break leaves the named loop"
|
||||||
"(defn f [] (while :o true (while true (break :o))))";
|
"(defn f [] () (while :o true (while true (break :o))))";
|
||||||
accepts "continue in a dotimes"
|
accepts "continue in a dotimes"
|
||||||
"(defn f [] (dotimes [i 3] (continue)))";
|
"(defn f [] () (dotimes [i 3] (continue)))";
|
||||||
rejects_check "break outside a loop"
|
rejects_check "break outside a loop"
|
||||||
"(defn f [] (break))" ~needle:"only allowed inside a loop";
|
"(defn f [] () (break))" ~needle:"only allowed inside a loop";
|
||||||
rejects_check "continue outside a loop"
|
rejects_check "continue outside a loop"
|
||||||
"(defn f [] (continue))" ~needle:"only allowed inside a loop";
|
"(defn f [] () (continue))" ~needle:"only allowed inside a loop";
|
||||||
rejects_check "a label naming no enclosing loop"
|
rejects_check "a label naming no enclosing loop"
|
||||||
"(defn f [] (while true (break :nope)))" ~needle:"no loop named :nope";
|
"(defn f [] () (while true (break :nope)))" ~needle:"no loop named :nope";
|
||||||
(* The rule the blanket one could not express, both ways round. A loop
|
(* The rule the blanket one could not express, both ways round. A loop
|
||||||
wholly inside a restart-case body keeps its local break; a break that
|
wholly inside a restart-case body keeps its local break; a break that
|
||||||
would *leave* the restart-case is refused, and says so. *)
|
would *leave* the restart-case is refused, and says so. *)
|
||||||
accepts "a loop inside a restart-case may break out of itself"
|
accepts "a loop inside a restart-case may break out of itself"
|
||||||
"(defn f [] (restart-case (while true (break)) (go [] (println \"\"))))";
|
"(defn f [] () (restart-case (while true (break)) (go [] (println \"\"))))";
|
||||||
rejects_check "break may not leave a restart-case"
|
rejects_check "break may not leave a restart-case"
|
||||||
"(defn f [] (while true (restart-case (break) (go [] (println \"\")))))"
|
"(defn f [] () (while true (restart-case (break) (go [] (println \"\")))))"
|
||||||
~needle:"a restart-case";
|
~needle:"a restart-case";
|
||||||
(* A clause is a barrier for the same reason the body is: it runs after a
|
(* A clause is a barrier for the same reason the body is: it runs after a
|
||||||
transfer landed, with the form's frames still to be popped. *)
|
transfer landed, with the form's frames still to be popped. *)
|
||||||
rejects_check "break may not leave a restart-case from a clause"
|
rejects_check "break may not leave a restart-case from a clause"
|
||||||
"(defn f [] (while true (restart-case (println \"\") (go [] (break)))))"
|
"(defn f [] () (while true (restart-case (println \"\") (go [] (break)))))"
|
||||||
~needle:"a restart-case";
|
~needle:"a restart-case";
|
||||||
accepts "a loop inside a handler-bind may break out of itself"
|
accepts "a loop inside a handler-bind may break out of itself"
|
||||||
"(defstruct C [n i32]) (defn f [] (handler-bind [(C [c] 0)] (while true (break))))";
|
"(defstruct C [n i32]) (defn f [] () (handler-bind [(C [c] 0)] (while true (break))))";
|
||||||
rejects_check "break may not leave a handler-bind"
|
rejects_check "break may not leave a handler-bind"
|
||||||
"(defstruct C [n i32]) (defn f [] (while true (handler-bind [(C [c] 0)] (break))))"
|
"(defstruct C [n i32]) (defn f [] () (while true (handler-bind [(C [c] 0)] (break))))"
|
||||||
~needle:"a handler-bind";
|
~needle:"a handler-bind";
|
||||||
(* An import is resolved by [Load] before the checker runs, so one that
|
(* An import is resolved by [Load] before the checker runs, so one that
|
||||||
reaches [Check] means a driver skipped that step. *)
|
reaches [Check] means a driver skipped that step. *)
|
||||||
@ -869,14 +873,14 @@ let () =
|
|||||||
"(import rl \"vendor:raylib\")" ~needle:"not resolved";
|
"(import rl \"vendor:raylib\")" ~needle:"not resolved";
|
||||||
(* Keywords resolve against an enum and against nothing else. *)
|
(* Keywords resolve against an enum and against nothing else. *)
|
||||||
rejects_check "a keyword needs an enum"
|
rejects_check "a keyword needs an enum"
|
||||||
"(defn g [x i32]) (defn f [] (g :space))" ~needle:"is expected here";
|
"(defn g [x i32] ()) (defn f [] () (g :space))" ~needle:"is expected here";
|
||||||
rejects_check "a keyword with no expectation"
|
rejects_check "a keyword with no expectation"
|
||||||
"(defn f [] (print (i64 :space)))" ~needle:"no keyword type";
|
"(defn f [] () (print (i64 :space)))" ~needle:"no keyword type";
|
||||||
rejects_check "a keyword that is not a member"
|
rejects_check "a keyword that is not a member"
|
||||||
"(defenum Key [space 32]) (defn g [k Key]) (defn f [] (g :spcae))"
|
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [] () (g :spcae))"
|
||||||
~needle:"has no member :spcae";
|
~needle:"has no member :spcae";
|
||||||
accepts "a keyword that is a member"
|
accepts "a keyword that is a member"
|
||||||
"(defenum Key [space 32 r 82]) (defn g [k Key]) (defn f [] (g :r))";
|
"(defenum Key [space 32 r 82]) (defn g [k Key] ()) (defn f [] () (g :r))";
|
||||||
(* Converting an enum, explicitly, in both directions. The point of the
|
(* Converting an enum, explicitly, in both directions. The point of the
|
||||||
conversion is that it is written at the site: a bare integer still does
|
conversion is that it is written at the site: a bare integer still does
|
||||||
not fit an enum parameter, so the checked property — a typo is an error
|
not fit an enum parameter, so the checked property — a typo is an error
|
||||||
@ -886,11 +890,11 @@ let () =
|
|||||||
accepts "an enum converts to a float, through its i32"
|
accepts "an enum converts to a float, through its i32"
|
||||||
"(defenum Key [space 32]) (defn f [k Key] f32 (f32 k))";
|
"(defenum Key [space 32]) (defn f [k Key] f32 (f32 k))";
|
||||||
accepts "an integer converts to an enum"
|
accepts "an integer converts to an enum"
|
||||||
"(defenum Key [space 32]) (defn g [k Key]) (defn f [i i32] (g (Key i)))";
|
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [i i32] () (g (Key i)))";
|
||||||
accepts "a value that is no declared member converts"
|
accepts "a value that is no declared member converts"
|
||||||
"(defenum Key [space 32]) (defn g [k Key]) (defn f [] (g (Key 999)))";
|
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [] () (g (Key 999)))";
|
||||||
rejects_check "an integer still does not fit an enum on its own"
|
rejects_check "an integer still does not fit an enum on its own"
|
||||||
"(defenum Key [space 32]) (defn g [k Key]) (defn f [i i32] (g i))"
|
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [i i32] () (g i))"
|
||||||
~needle:"expected Key";
|
~needle:"expected Key";
|
||||||
rejects_check "an enum does not convert to another enum"
|
rejects_check "an enum does not convert to another enum"
|
||||||
"(defenum A [x 1]) (defenum B [y 1]) (defn f [a A] B (B a))"
|
"(defenum A [x 1]) (defenum B [y 1]) (defn f [a A] B (B a))"
|
||||||
@ -905,8 +909,8 @@ let () =
|
|||||||
accepts "an enum is a return type"
|
accepts "an enum is a return type"
|
||||||
"(defenum Key [space 32]) (defn f [i i32] Key (Key i))";
|
"(defenum Key [space 32]) (defn f [i i32] Key (Key i))";
|
||||||
accepts "an enum conversion at the head of a body is not a return type"
|
accepts "an enum conversion at the head of a body is not a return type"
|
||||||
"(defenum Key [space 32]) (defn g [k Key]) \
|
"(defenum Key [space 32]) (defn g [k Key] ()) \
|
||||||
(defn f [] (Key 1) (g :space))";
|
(defn f [] () (Key 1) (g :space))";
|
||||||
rejects_check "an enum conversion takes one argument"
|
rejects_check "an enum conversion takes one argument"
|
||||||
"(defenum Key [space 32]) (defn f [] Key (Key 1 2))"
|
"(defenum Key [space 32]) (defn f [] Key (Key 1 2))"
|
||||||
~needle:"1 argument";
|
~needle:"1 argument";
|
||||||
@ -952,8 +956,8 @@ let () =
|
|||||||
An fn takes its parameter types from the position it is written in, and a
|
An fn takes its parameter types from the position it is written in, and a
|
||||||
defn's body that just answers one says nothing about them. *)
|
defn's body that just answers one says nothing about them. *)
|
||||||
rejects_check "an fn with nothing to say what it takes"
|
rejects_check "an fn with nothing to say what it takes"
|
||||||
"(defn f [] (fn [x] x))" ~needle:"nothing here says what this fn";
|
"(defn f [] () (fn [x] x))" ~needle:"nothing here says what this fn";
|
||||||
rejects_check "type variables are milestone 5" "(defn f [x a])"
|
rejects_check "type variables are milestone 5" "(defn f [x a] ())"
|
||||||
~needle:"milestone 5";
|
~needle:"milestone 5";
|
||||||
(* The other half: a name in value position now *works*, and the arity is
|
(* The other half: a name in value position now *works*, and the arity is
|
||||||
checked against the function it names. *)
|
checked against the function it names. *)
|
||||||
@ -998,13 +1002,13 @@ let () =
|
|||||||
|
|
||||||
accepts "handler-bind over a struct condition"
|
accepts "handler-bind over a struct condition"
|
||||||
"(defstruct C [id i32]) (defvar n i64)\n\
|
"(defstruct C [id i32]) (defvar n i64)\n\
|
||||||
(defn f [] (handler-bind [(C [c] (set n 1))] (signal (C {.id 2}))))";
|
(defn f [] () (handler-bind [(C [c] (set n 1))] (signal (C {.id 2}))))";
|
||||||
(* Matching is by type and there is no hierarchy, so a condition has to be a
|
(* Matching is by type and there is no hierarchy, so a condition has to be a
|
||||||
struct — an integer would have nothing to match against. *)
|
struct — an integer would have nothing to match against. *)
|
||||||
rejects_check "signalling a non-struct"
|
rejects_check "signalling a non-struct"
|
||||||
"(defn f [] (signal 1))" ~needle:"a condition is a struct";
|
"(defn f [] () (signal 1))" ~needle:"a condition is a struct";
|
||||||
rejects_check "erroring with a non-struct"
|
rejects_check "erroring with a non-struct"
|
||||||
"(defn f [] (error 1))" ~needle:"a condition is a struct";
|
"(defn f [] () (error 1))" ~needle:"a condition is a struct";
|
||||||
(* §2: error is Never, so it unifies with anything — including the position
|
(* §2: error is Never, so it unifies with anything — including the position
|
||||||
where a value of some other type was expected. That is what makes it
|
where a value of some other type was expected. That is what makes it
|
||||||
usable as a restart-case body's fall-through. *)
|
usable as a restart-case body's fall-through. *)
|
||||||
@ -1021,7 +1025,7 @@ let () =
|
|||||||
rather than as an unknown name. *)
|
rather than as an unknown name. *)
|
||||||
rejects_check "a handler capturing a local"
|
rejects_check "a handler capturing a local"
|
||||||
"(defstruct C [id i32])\n\
|
"(defstruct C [id i32])\n\
|
||||||
(defn f [] (let [n 0] (handler-bind [(C [c] (set n 1))] (signal (C {.id 2})))))"
|
(defn f [] () (let [n 0] (handler-bind [(C [c] (set n 1))] (signal (C {.id 2})))))"
|
||||||
~needle:"a handler cannot see n";
|
~needle:"a handler cannot see n";
|
||||||
(* The frames are popped on the way out of the body, so an early exit would
|
(* The frames are popped on the way out of the body, so an early exit would
|
||||||
leave them on the stack pointing into a function that has gone. *)
|
leave them on the stack pointing into a function that has gone. *)
|
||||||
@ -1033,7 +1037,7 @@ let () =
|
|||||||
into a lookup and no place form for one. Refused with that reason rather
|
into a lookup and no place form for one. Refused with that reason rather
|
||||||
than as a milestone that will never arrive. *)
|
than as a milestone that will never arrive. *)
|
||||||
rejects_check "a map entry as a place"
|
rejects_check "a map entry as a place"
|
||||||
"(defn f [] (set (get m 1) 2))"
|
"(defn f [] () (set (get m 1) 2))"
|
||||||
~needle:"a map is written with (put m k v)";
|
~needle:"a map is written with (put m k v)";
|
||||||
|
|
||||||
(* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *)
|
(* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *)
|
||||||
@ -1068,15 +1072,15 @@ let () =
|
|||||||
accepts "a restart with parameters"
|
accepts "a restart with parameters"
|
||||||
"(defn f [] i32 (restart-case 1 (skip [n i32] n)))";
|
"(defn f [] i32 (restart-case 1 (skip [n i32] n)))";
|
||||||
accepts "invoke-restart with arguments"
|
accepts "invoke-restart with arguments"
|
||||||
"(defn f [] (invoke-restart 'skip 1))";
|
"(defn f [] () (invoke-restart 'skip 1))";
|
||||||
rejects_check "a restart parameter outside its clause"
|
rejects_check "a restart parameter outside its clause"
|
||||||
"(defn f [] i32 (+ (restart-case 1 (skip [n i32] n)) n))"
|
"(defn f [] i32 (+ (restart-case 1 (skip [n i32] n)) n))"
|
||||||
~needle:"unknown name n";
|
~needle:"unknown name n";
|
||||||
rejects_check "a restart argument that is not a value"
|
rejects_check "a restart argument that is not a value"
|
||||||
"(defn f [] (invoke-restart 'skip (println \"\")))"
|
"(defn f [] () (invoke-restart 'skip (println \"\")))"
|
||||||
~needle:"a restart argument must be a value";
|
~needle:"a restart argument must be a value";
|
||||||
rejects_check "invoke-restart on an unquoted name"
|
rejects_check "invoke-restart on an unquoted name"
|
||||||
"(defn f [] (invoke-restart skip))"
|
"(defn f [] () (invoke-restart skip))"
|
||||||
~needle:"a quoted restart name and then its arguments";
|
~needle:"a quoted restart name and then its arguments";
|
||||||
(* §5 runs the defers on the way out, so a defer is already the cleanup path
|
(* §5 runs the defers on the way out, so a defer is already the cleanup path
|
||||||
a transfer uses. One that starts its own transfer has no answer. *)
|
a transfer uses. One that starts its own transfer has no answer. *)
|
||||||
@ -1090,9 +1094,9 @@ let () =
|
|||||||
(fun (name, src) ->
|
(fun (name, src) ->
|
||||||
rejects_check (name ^ " is still unimplemented") src
|
rejects_check (name ^ " is still unimplemented") src
|
||||||
~needle:"not implemented yet")
|
~needle:"not implemented yet")
|
||||||
[ "handler-case", "(defn f [] (handler-case 1))";
|
[ "handler-case", "(defn f [] () (handler-case 1))";
|
||||||
"find-restart", "(defn f [] (find-restart 'skip))";
|
"find-restart", "(defn f [] () (find-restart 'skip))";
|
||||||
"compute-restarts", "(defn f [] (compute-restarts))" ];
|
"compute-restarts", "(defn f [] () (compute-restarts))" ];
|
||||||
|
|
||||||
(* ── Destructuring ─────────────────────────────────────────────── *)
|
(* ── Destructuring ─────────────────────────────────────────────── *)
|
||||||
|
|
||||||
@ -1224,7 +1228,7 @@ let () =
|
|||||||
[ "a defn parameter", pt ^ "(defn f [{:keys [x]} Point] i32 x)";
|
[ "a defn parameter", pt ^ "(defn f [{:keys [x]} Point] i32 x)";
|
||||||
"a defstruct field", "(defstruct S [[a b] i32])";
|
"a defstruct field", "(defstruct S [[a b] i32])";
|
||||||
"an fn parameter", "(defn f [] i32 (let [g (fn [[a b]] a)] 0))";
|
"an fn parameter", "(defn f [] i32 (let [g (fn [[a b]] a)] 0))";
|
||||||
"a dotimes counter", "(defn f [] (dotimes [[a b] 3] 0))";
|
"a dotimes counter", "(defn f [] () (dotimes [[a b] 3] 0))";
|
||||||
"a declare parameter", pt ^ "(declare g [{:keys [x]} Point] \"G\")" ];
|
"a declare parameter", pt ^ "(declare g [{:keys [x]} Point] \"G\")" ];
|
||||||
|
|
||||||
(* ── match over an enum ────────────────────────────────────────── *)
|
(* ── match over an enum ────────────────────────────────────────── *)
|
||||||
@ -1548,9 +1552,9 @@ let () =
|
|||||||
let chain =
|
let chain =
|
||||||
synth
|
synth
|
||||||
"(defmacro m [args] `(do))\n\
|
"(defmacro m [args] `(do))\n\
|
||||||
(defn a [] Unit (m))\n\
|
(defn a [] () (m))\n\
|
||||||
(defn b [] Unit (a))\n\
|
(defn b [] () (a))\n\
|
||||||
(defn c [] Unit (do))\n"
|
(defn c [] () (do))\n"
|
||||||
in
|
in
|
||||||
check "the reduction is transitive"
|
check "the reduction is transitive"
|
||||||
(names_of (Macro.reduce chain) = [ "m"; "c" ]);
|
(names_of (Macro.reduce chain) = [ "m"; "c" ]);
|
||||||
|
|||||||
@ -218,7 +218,7 @@ let () =
|
|||||||
"not a package" — and the failure is the silent one above: the form
|
"not a package" — and the failure is the silent one above: the form
|
||||||
splices as a bare [step] and the running program keeps the one it had. *)
|
splices as a bare [step] and the running program keeps the one it had. *)
|
||||||
let t2, _ = Session.create ~file:"programs/sand-headless.flan" () in
|
let t2, _ = Session.create ~file:"programs/sand-headless.flan" () in
|
||||||
(match Session.eval ~origin:"../sand.flan" t2 "(defn step [] Unit (do))" with
|
(match Session.eval ~origin:"../sand.flan" t2 "(defn step [] () (do))" with
|
||||||
| c ->
|
| c ->
|
||||||
if c.Session.fns <> [ "sand/step" ] then
|
if c.Session.fns <> [ "sand/step" ] then
|
||||||
fail "a form from a single-file package reported %s, wanted sand/step"
|
fail "a form from a single-file package reported %s, wanted sand/step"
|
||||||
@ -226,7 +226,7 @@ let () =
|
|||||||
| exception Loc.Error (_, m) -> fail "redefining sand/step: %s" m);
|
| exception Loc.Error (_, m) -> fail "redefining sand/step: %s" m);
|
||||||
|
|
||||||
(* And a file that is not a package keeps its names as written. *)
|
(* And a file that is not a package keeps its names as written. *)
|
||||||
(match Session.eval ~origin:"../sand.flan" t "(defn game-draw [] Unit (do))" with
|
(match Session.eval ~origin:"../sand.flan" t "(defn game-draw [] () (do))" with
|
||||||
| c ->
|
| c ->
|
||||||
if c.Session.fns <> [ "game-draw" ] then
|
if c.Session.fns <> [ "game-draw" ] then
|
||||||
fail "a form from the program's own file reported %s"
|
fail "a form from the program's own file reported %s"
|
||||||
|
|||||||
536
tools/unit-return.py
Executable file
536
tools/unit-return.py
Executable file
@ -0,0 +1,536 @@
|
|||||||
|
#!/usr/bin/env python3
|
||||||
|
"""Give every `defn` an explicit return type, and rewrite `Unit` as `()`.
|
||||||
|
|
||||||
|
`(defn f [x i32] body)` becomes `(defn f [x i32] () body)`, and a return type
|
||||||
|
already written as `Unit` -- or a `Unit` anywhere else a type is spelled, as in
|
||||||
|
`(Fn [i32] Unit)` -- becomes `()`.
|
||||||
|
|
||||||
|
Two rules, one pass, because both are the same change: the slot after the
|
||||||
|
parameters is now unconditionally a type, so a function that returns nothing
|
||||||
|
has to say so, and the thing it says is `()`.
|
||||||
|
|
||||||
|
Deciding whether a `defn` already has a return type is the whole difficulty,
|
||||||
|
and this script does it the way `lib/parse.ml` did before the slot became
|
||||||
|
mandatory: a form in that position is the return type when it is a *type form*
|
||||||
|
and it is not the entire body. `is_type_form` below is a transcription of the
|
||||||
|
one in parse.ml, deliberately faithful rather than improved -- being identical
|
||||||
|
to the parser it is replacing is what makes the sweep meaning-preserving. The
|
||||||
|
type names it needs come from the file's own declarations, from the prelude's
|
||||||
|
(read out of lib/prelude.ml), and from the builtin list.
|
||||||
|
|
||||||
|
Re-runnable: a `defn` whose slot is already filled is left alone, and `()` is
|
||||||
|
itself a type form, so converting a converted file is a no-op. Parallel
|
||||||
|
branches that wrote Flan in the old spelling want this pass at merge.
|
||||||
|
|
||||||
|
tools/unit-return.py <file-or-dir>... # rewrite .flan in place
|
||||||
|
tools/unit-return.py --check <file-or-dir>... # report, change nothing
|
||||||
|
tools/unit-return.py --in-strings <file.ml>... # Flan inside "..." literals
|
||||||
|
tools/unit-return.py --raw-ml lib/prelude.ml # Flan in a {flan|...|flan} block
|
||||||
|
tools/unit-return.py --in-html web/index.html # Flan in <pre><code> blocks
|
||||||
|
|
||||||
|
A directory is walked for `.flan` files only. Anything else is named on the
|
||||||
|
command line with the mode that says how its Flan is embedded, because a blind
|
||||||
|
scan of an OCaml or HTML file would read its punctuation as Flan.
|
||||||
|
|
||||||
|
`-v` logs every `defn` seen and what was decided about it, which is the only
|
||||||
|
practical way to review a sweep this size.
|
||||||
|
|
||||||
|
**Read the diff of every non-`.flan` file.** A snippet split across OCaml
|
||||||
|
string concatenation -- `decls ^ "(defn f [s [u8]] Cursor ...)"` -- is scanned
|
||||||
|
one literal at a time, and the names the other literal declared would be
|
||||||
|
invisible. The embedded modes work around it by pooling every fragment's type
|
||||||
|
declarations across the whole file, and counting a pooled name only as a bare
|
||||||
|
symbol, exactly as the prelude's types count: as a list head it would eat
|
||||||
|
`(Some 1)` and `(Rune {.code 65})` as return types, which is the misparse this
|
||||||
|
change exists to remove. That is sound because no user type takes arguments --
|
||||||
|
only the builtin constructors do, and they are known already -- but it is a
|
||||||
|
pool and not the real scope, so read the diff.
|
||||||
|
"""
|
||||||
|
|
||||||
|
import sys, os, re
|
||||||
|
|
||||||
|
DELIM = set('()[]{}";`~ \t\n\r,')
|
||||||
|
OPENERS = {'(': ')', '[': ']', '{': '}'}
|
||||||
|
CLOSERS = {')', ']', '}'}
|
||||||
|
|
||||||
|
# lib/parse.ml, [primitives] and [builtin_types]. Present in [types] under
|
||||||
|
# their plain names, so they count as type forms in every position.
|
||||||
|
BUILTINS = {
|
||||||
|
"i8", "i16", "i32", "i64", "u8", "u16", "u32", "u64",
|
||||||
|
"f32", "f64", "bool", "string", "Unit", "Never",
|
||||||
|
"Ptr", "Option", "Result", "Vec", "Map", "Handle", "Fn",
|
||||||
|
}
|
||||||
|
|
||||||
|
NUMERIC = re.compile(r'^[-+]?[0-9]')
|
||||||
|
|
||||||
|
|
||||||
|
class Atom:
|
||||||
|
def __init__(self, start, end, text):
|
||||||
|
self.start, self.end, self.text = start, end, text
|
||||||
|
self.tok = start # never moves; `start` may slide onto a quote sigil
|
||||||
|
self.items = []
|
||||||
|
|
||||||
|
@property
|
||||||
|
def open_char(self):
|
||||||
|
return None
|
||||||
|
|
||||||
|
def sym(self):
|
||||||
|
"""The symbol name, or None if this atom is not one.
|
||||||
|
|
||||||
|
A string, a keyword, a character literal and a number are all atoms and
|
||||||
|
none of them is a symbol -- parse.ml's [is_type_form] answers false for
|
||||||
|
every one of them, through its catch-all arm.
|
||||||
|
"""
|
||||||
|
t = self.text
|
||||||
|
if not t or t[0] in '":\\' or NUMERIC.match(t):
|
||||||
|
return None
|
||||||
|
return t
|
||||||
|
|
||||||
|
|
||||||
|
class Seq:
|
||||||
|
def __init__(self, open_char, start):
|
||||||
|
self.open_char, self.start = open_char, start
|
||||||
|
self.end = start
|
||||||
|
self.items = []
|
||||||
|
self.closed = False
|
||||||
|
|
||||||
|
def sym(self):
|
||||||
|
return None
|
||||||
|
|
||||||
|
|
||||||
|
def lex_forms(src, i, end, stop=None):
|
||||||
|
"""Read forms from src[i:end]. Returns (items, next_index, closed).
|
||||||
|
|
||||||
|
`closed` is False when the text ran out before the enclosing delimiter did,
|
||||||
|
which is how a fragment that holds only part of a form is recognised --
|
||||||
|
`"(defn step [] i64\\n"`, one line of a snippet built by concatenation.
|
||||||
|
|
||||||
|
The lexing rules mirror lib/reader.ml. A quote/quasiquote/unquote prefix is
|
||||||
|
folded into the form it applies to, so a quoted value stays one element.
|
||||||
|
"""
|
||||||
|
items = []
|
||||||
|
n = end
|
||||||
|
pending_prefix = None
|
||||||
|
|
||||||
|
def push(node):
|
||||||
|
nonlocal pending_prefix
|
||||||
|
if pending_prefix is not None:
|
||||||
|
node.start = pending_prefix
|
||||||
|
pending_prefix = None
|
||||||
|
items.append(node)
|
||||||
|
|
||||||
|
while i < n:
|
||||||
|
c = src[i]
|
||||||
|
if c in ' \t\n\r,':
|
||||||
|
i += 1
|
||||||
|
elif c == ';': # line comment
|
||||||
|
while i < n and src[i] != '\n':
|
||||||
|
i += 1
|
||||||
|
elif c == '"': # string literal
|
||||||
|
j = i + 1
|
||||||
|
while j < n and src[j] != '"':
|
||||||
|
j += 2 if src[j] == '\\' else 1
|
||||||
|
j = min(j + 1, n)
|
||||||
|
push(Atom(i, j, src[i:j]))
|
||||||
|
i = j
|
||||||
|
elif c == '\\': # character literal
|
||||||
|
j = i + 1
|
||||||
|
if j < n:
|
||||||
|
j += 1
|
||||||
|
while j < n and src[j] not in DELIM:
|
||||||
|
j += 1
|
||||||
|
push(Atom(i, j, src[i:j]))
|
||||||
|
i = j
|
||||||
|
elif c in "'`~": # quote sugar
|
||||||
|
if pending_prefix is None:
|
||||||
|
pending_prefix = i
|
||||||
|
i += 2 if (c == '~' and i + 1 < n and src[i + 1] == '@') else 1
|
||||||
|
elif c in OPENERS:
|
||||||
|
node = Seq(c, i)
|
||||||
|
node.items, i, node.closed = lex_forms(src, i + 1, n, OPENERS[c])
|
||||||
|
node.end = i
|
||||||
|
push(node)
|
||||||
|
elif c in CLOSERS:
|
||||||
|
return items, i + 1, True
|
||||||
|
else: # symbol or keyword
|
||||||
|
j = i
|
||||||
|
while j < n and src[j] not in DELIM:
|
||||||
|
j += 1
|
||||||
|
if j == i:
|
||||||
|
j = i + 1
|
||||||
|
push(Atom(i, j, src[i:j]))
|
||||||
|
i = j
|
||||||
|
return items, n, False
|
||||||
|
|
||||||
|
|
||||||
|
def head(node):
|
||||||
|
"""The head symbol of a `(...)` form, or None."""
|
||||||
|
if getattr(node, 'open_char', None) != '(' or not node.items:
|
||||||
|
return None
|
||||||
|
return node.items[0].sym()
|
||||||
|
|
||||||
|
|
||||||
|
# ── the type sets, as lib/parse.ml collects them ──────────────────────
|
||||||
|
|
||||||
|
class Types:
|
||||||
|
"""What `is_type_form` consults.
|
||||||
|
|
||||||
|
Three sets, kept apart exactly as parse.ml keeps them, because which
|
||||||
|
positions a name counts in depends on where it came from:
|
||||||
|
|
||||||
|
`names` -- builtins and the file's own defstruct/defunion/defalias. Count
|
||||||
|
as a bare symbol *and* as a list head, since `(Option f64)` is a type.
|
||||||
|
|
||||||
|
`enums`, `prelude` -- enum names and the prelude's types. Count only as a
|
||||||
|
bare symbol. As a list head they would eat `(Key 1)` and `(Rune {.code 65})`
|
||||||
|
-- a conversion and a constructor -- as return types, which is the silent
|
||||||
|
misparse this whole change exists to remove.
|
||||||
|
|
||||||
|
`aliases` -- import aliases, for `rl/Vector2`.
|
||||||
|
"""
|
||||||
|
def __init__(self, prelude_names, prelude_enums):
|
||||||
|
self.names = set(BUILTINS)
|
||||||
|
self.enums = set(prelude_enums)
|
||||||
|
self.prelude = set(prelude_names)
|
||||||
|
self.aliases = set()
|
||||||
|
|
||||||
|
def scan(self, forms):
|
||||||
|
"""Add what a program's top-level declarations introduce."""
|
||||||
|
for f in forms:
|
||||||
|
h = head(f)
|
||||||
|
if h in ('defstruct', 'defunion', 'defalias') and len(f.items) == 3:
|
||||||
|
n = f.items[1].sym()
|
||||||
|
if n:
|
||||||
|
self.names.add(n)
|
||||||
|
elif h == 'defenum' and len(f.items) == 3:
|
||||||
|
n = f.items[1].sym()
|
||||||
|
if n:
|
||||||
|
self.enums.add(n)
|
||||||
|
elif h == 'import' and len(f.items) == 3:
|
||||||
|
a = f.items[1].sym()
|
||||||
|
if a:
|
||||||
|
self.aliases.add(a)
|
||||||
|
|
||||||
|
def copy(self):
|
||||||
|
t = Types(self.prelude, self.enums)
|
||||||
|
t.names = set(self.names)
|
||||||
|
t.aliases = set(self.aliases)
|
||||||
|
return t
|
||||||
|
|
||||||
|
def qualified(self, s):
|
||||||
|
i = s.find('/')
|
||||||
|
if i < 0:
|
||||||
|
return False
|
||||||
|
alias, name = s[:i], s[i + 1:]
|
||||||
|
return alias in self.aliases and name[:1].isupper()
|
||||||
|
|
||||||
|
def is_type_form(self, f):
|
||||||
|
oc = getattr(f, 'open_char', None)
|
||||||
|
if oc == '(' and not f.items:
|
||||||
|
return True # () is unit
|
||||||
|
if oc in ('[', '{'):
|
||||||
|
return True # [T], [n T] and {K V} are only types
|
||||||
|
if oc == '(':
|
||||||
|
h = head(f)
|
||||||
|
return bool(h) and (h in self.names or self.qualified(h))
|
||||||
|
s = f.sym()
|
||||||
|
if s is None:
|
||||||
|
return False
|
||||||
|
return s in self.names or s in self.enums or s in self.prelude \
|
||||||
|
or self.qualified(s)
|
||||||
|
|
||||||
|
|
||||||
|
def prelude_type_names(root):
|
||||||
|
"""The prelude's type names, from its {flan|...|flan} block.
|
||||||
|
|
||||||
|
parse.ml's [prelude_types] does the same walk over the same text; reading
|
||||||
|
the file keeps the two from drifting apart by hand.
|
||||||
|
"""
|
||||||
|
path = os.path.join(root, 'lib', 'prelude.ml')
|
||||||
|
try:
|
||||||
|
with open(path, encoding='utf-8') as fh:
|
||||||
|
src = fh.read()
|
||||||
|
except OSError:
|
||||||
|
return set(), set()
|
||||||
|
body = flan_block(src)
|
||||||
|
if body is None:
|
||||||
|
return set(), set()
|
||||||
|
forms, _, _ = lex_forms(body, 0, len(body))
|
||||||
|
names, enums = set(), set()
|
||||||
|
for f in forms:
|
||||||
|
h = head(f)
|
||||||
|
if len(f.items) != 3:
|
||||||
|
continue
|
||||||
|
n = f.items[1].sym()
|
||||||
|
if not n:
|
||||||
|
continue
|
||||||
|
if h in ('defstruct', 'defunion', 'defalias'):
|
||||||
|
names.add(n)
|
||||||
|
elif h == 'defenum':
|
||||||
|
enums.add(n)
|
||||||
|
return names, enums
|
||||||
|
|
||||||
|
|
||||||
|
def flan_block(src):
|
||||||
|
i = src.find('{flan|')
|
||||||
|
j = src.rfind('|flan}')
|
||||||
|
if i < 0 or j < i:
|
||||||
|
return None
|
||||||
|
return src[i + len('{flan|'):j]
|
||||||
|
|
||||||
|
|
||||||
|
# ── the rewrite ───────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
def plan(src, types, label, log, base_line=1):
|
||||||
|
"""Edits for one program's worth of Flan. Returns [(start, end, text)]."""
|
||||||
|
forms, _, _ = lex_forms(src, 0, len(src))
|
||||||
|
types = types.copy()
|
||||||
|
types.scan(forms)
|
||||||
|
edits = []
|
||||||
|
|
||||||
|
def line_of(off):
|
||||||
|
return base_line + src.count('\n', 0, off)
|
||||||
|
|
||||||
|
def walk(node, nested):
|
||||||
|
if getattr(node, 'open_char', None) is None:
|
||||||
|
# Only inside a form. Every type position is -- (Fn [i32] Unit),
|
||||||
|
# [Unit], the slot after a defn's parameters -- and a bare top-level
|
||||||
|
# `Unit` is not Flan at all. The guard is what keeps this pass off
|
||||||
|
# an OCaml literal that happens to spell the word, as the checker's
|
||||||
|
# own pattern `Tname "Unit"` does.
|
||||||
|
if nested and node.sym() == 'Unit':
|
||||||
|
edits.append((node.tok, node.end, '()'))
|
||||||
|
return
|
||||||
|
if head(node) == 'defn':
|
||||||
|
decide(node)
|
||||||
|
for it in node.items:
|
||||||
|
walk(it, True)
|
||||||
|
|
||||||
|
def decide(node):
|
||||||
|
items = node.items
|
||||||
|
# (defn name [params] ...). Anything else -- a metadata sigil, a
|
||||||
|
# malformed form -- is left alone and reported, because guessing at a
|
||||||
|
# shape the parser does not accept is how a sweep corrupts a file.
|
||||||
|
if not node.closed:
|
||||||
|
log.append("%s:%d: skipped, the form is cut off here -- a fragment "
|
||||||
|
"of a snippet built by concatenation"
|
||||||
|
% (label, line_of(node.start)))
|
||||||
|
return
|
||||||
|
if len(items) < 3 or getattr(items[2], 'open_char', None) != '[':
|
||||||
|
log.append("%s:%d: skipped, not (defn name [params] ...)"
|
||||||
|
% (label, line_of(node.start)))
|
||||||
|
return
|
||||||
|
name = items[1].sym() or '?'
|
||||||
|
rest = items[3:]
|
||||||
|
# parse.ml's guard: a single remaining form is the body, not the
|
||||||
|
# return type -- [(defn f [] i32)] was a function returning Unit whose
|
||||||
|
# body is the name [i32]. The exception is a lone [()], which is what
|
||||||
|
# this script itself writes for a function with no body, and which was
|
||||||
|
# never a legal body form. Without it a second run would fill the slot
|
||||||
|
# again, and a re-runnable sweep is the point.
|
||||||
|
lone_unit = len(rest) == 1 and getattr(rest[0], 'open_char', None) == '(' \
|
||||||
|
and not rest[0].items
|
||||||
|
if rest and (len(rest) >= 2 or lone_unit) and types.is_type_form(rest[0]):
|
||||||
|
log.append("%s:%d: %s kept %s"
|
||||||
|
% (label, line_of(node.start), name,
|
||||||
|
src[rest[0].start:rest[0].end].replace('\n', ' ')))
|
||||||
|
return
|
||||||
|
edits.append((items[2].end, items[2].end, ' ()'))
|
||||||
|
log.append("%s:%d: %s filled ()" % (label, line_of(node.start), name))
|
||||||
|
|
||||||
|
for f in forms:
|
||||||
|
walk(f, False)
|
||||||
|
return edits
|
||||||
|
|
||||||
|
|
||||||
|
def apply(src, edits):
|
||||||
|
if not edits:
|
||||||
|
return src, 0
|
||||||
|
out = []
|
||||||
|
last = 0
|
||||||
|
for start, end, text in sorted(edits):
|
||||||
|
out.append(src[last:start])
|
||||||
|
out.append(text)
|
||||||
|
last = end
|
||||||
|
out.append(src[last:])
|
||||||
|
return ''.join(out), len(edits)
|
||||||
|
|
||||||
|
|
||||||
|
def mask_ocaml_escapes(body):
|
||||||
|
"""Blank out OCaml escapes so the Flan lexer cannot trip on them.
|
||||||
|
|
||||||
|
Length-preserving, so offsets into the masked text index the original. A
|
||||||
|
`\\"` must not end a Flan string, and the `\\n\\` line continuations the
|
||||||
|
tests wrap their snippets with must not read as Flan character literals.
|
||||||
|
|
||||||
|
An escaped newline becomes a real one rather than a blank: a `;` comment
|
||||||
|
runs to end of line, so flattening `\\n` to spaces would let one comment
|
||||||
|
swallow the rest of the snippet.
|
||||||
|
"""
|
||||||
|
chars = list(body)
|
||||||
|
i = 0
|
||||||
|
while i < len(chars) - 1:
|
||||||
|
if chars[i] == '\\':
|
||||||
|
c = chars[i + 1]
|
||||||
|
chars[i] = ' '
|
||||||
|
chars[i + 1] = c if c in '\n\t' else ('\n' if c == 'n' else ' ')
|
||||||
|
i += 2
|
||||||
|
else:
|
||||||
|
i += 1
|
||||||
|
return ''.join(chars)
|
||||||
|
|
||||||
|
|
||||||
|
def pool(types, fragments):
|
||||||
|
"""Fold every fragment's declarations into the bare-symbol-only sets.
|
||||||
|
|
||||||
|
One file's Flan is written in pieces -- concatenated OCaml literals, one
|
||||||
|
<pre> per section -- and a piece does not see the piece that declared its
|
||||||
|
types. Pooling gives it back. See the module docstring for why pooled names
|
||||||
|
count only in bare-symbol position.
|
||||||
|
"""
|
||||||
|
for body in fragments:
|
||||||
|
forms, _, _ = lex_forms(body, 0, len(body))
|
||||||
|
seen = types.copy()
|
||||||
|
seen.names = set()
|
||||||
|
seen.enums = set()
|
||||||
|
seen.scan(forms)
|
||||||
|
types.prelude |= seen.names
|
||||||
|
types.enums |= seen.enums
|
||||||
|
types.aliases |= seen.aliases
|
||||||
|
return types
|
||||||
|
|
||||||
|
|
||||||
|
def convert_flan(src, types, label, log):
|
||||||
|
return apply(src, plan(src, types, label, log))
|
||||||
|
|
||||||
|
|
||||||
|
def ocaml_literals(src):
|
||||||
|
"""(offset, masked body) for every OCaml string literal in `src`."""
|
||||||
|
out = []
|
||||||
|
i, n = 0, len(src)
|
||||||
|
while i < n:
|
||||||
|
c = src[i]
|
||||||
|
if c == '"':
|
||||||
|
j = i + 1
|
||||||
|
while j < n and src[j] != '"':
|
||||||
|
j += 2 if src[j] == '\\' else 1
|
||||||
|
out.append((i + 1, mask_ocaml_escapes(src[i + 1:j])))
|
||||||
|
i = j + 1
|
||||||
|
elif c == '(' and i + 1 < n and src[i + 1] == '*': # OCaml comment
|
||||||
|
i += 2
|
||||||
|
else:
|
||||||
|
i += 1
|
||||||
|
return out
|
||||||
|
|
||||||
|
|
||||||
|
def convert_in_strings(src, types, label, log):
|
||||||
|
"""Flan inside ordinary OCaml `"..."` literals, as the tests write it."""
|
||||||
|
lits = ocaml_literals(src)
|
||||||
|
pool(types, [body for _, body in lits])
|
||||||
|
edits = []
|
||||||
|
for off, body in lits:
|
||||||
|
base = src.count('\n', 0, off) + 1
|
||||||
|
for s, e, t in plan(body, types, label, log, base):
|
||||||
|
edits.append((off + s, off + e, t))
|
||||||
|
return apply(src, edits)
|
||||||
|
|
||||||
|
|
||||||
|
def convert_raw_ml(src, types, label, log):
|
||||||
|
"""A whole {flan|...|flan} block, as lib/prelude.ml writes it."""
|
||||||
|
i = src.find('{flan|')
|
||||||
|
j = src.rfind('|flan}')
|
||||||
|
if i < 0 or j < i:
|
||||||
|
return src, 0
|
||||||
|
off = i + len('{flan|')
|
||||||
|
body = src[off:j]
|
||||||
|
base = src.count('\n', 0, off) + 1
|
||||||
|
edits = [(off + s, off + e, t) for s, e, t in plan(body, types, label, log, base)]
|
||||||
|
return apply(src, edits)
|
||||||
|
|
||||||
|
|
||||||
|
CODE = re.compile(r'<pre><code>(.*?)</code></pre>', re.S)
|
||||||
|
|
||||||
|
|
||||||
|
def convert_in_html(src, types, label, log):
|
||||||
|
"""Flan in <pre><code> blocks. HTML entities are left escaped: `<` lexes
|
||||||
|
as an ordinary atom and nothing this pass writes needs escaping."""
|
||||||
|
edits = []
|
||||||
|
pool(types, [m.group(1) for m in CODE.finditer(src)])
|
||||||
|
for m in CODE.finditer(src):
|
||||||
|
off = m.start(1)
|
||||||
|
base = src.count('\n', 0, off) + 1
|
||||||
|
for s, e, t in plan(m.group(1), types, label, log, base):
|
||||||
|
edits.append((off + s, off + e, t))
|
||||||
|
return apply(src, edits)
|
||||||
|
|
||||||
|
|
||||||
|
MODES = {
|
||||||
|
'--in-strings': convert_in_strings,
|
||||||
|
'--raw-ml': convert_raw_ml,
|
||||||
|
'--in-html': convert_in_html,
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
def walk_paths(paths):
|
||||||
|
for p in paths:
|
||||||
|
if os.path.isdir(p):
|
||||||
|
for root, dirs, files in os.walk(p):
|
||||||
|
# vendor/ is not third-party: edn, raylib and agent are this
|
||||||
|
# repo's own packages, written in Flan, and they convert too.
|
||||||
|
dirs[:] = [d for d in dirs
|
||||||
|
if d not in ('_build', '.git', 'node_modules')]
|
||||||
|
for f in sorted(files):
|
||||||
|
if f.endswith('.flan'):
|
||||||
|
yield os.path.join(root, f)
|
||||||
|
else:
|
||||||
|
yield p
|
||||||
|
|
||||||
|
|
||||||
|
def main(argv):
|
||||||
|
check = '--check' in argv
|
||||||
|
verbose = '-v' in argv or '--verbose' in argv
|
||||||
|
modes = [m for m in MODES if m in argv]
|
||||||
|
if len(modes) > 1:
|
||||||
|
sys.stderr.write("pick one of %s\n" % ', '.join(MODES))
|
||||||
|
return 2
|
||||||
|
mode = modes[0] if modes else None
|
||||||
|
paths = [a for a in argv[1:] if not a.startswith('-')] or ['.']
|
||||||
|
|
||||||
|
root = os.path.dirname(os.path.dirname(os.path.abspath(__file__)))
|
||||||
|
pnames, penums = prelude_type_names(root)
|
||||||
|
if not pnames:
|
||||||
|
sys.stderr.write("warning: no prelude types found under %s -- a "
|
||||||
|
"prelude type in return position may be mis-read\n" % root)
|
||||||
|
|
||||||
|
total_files = total_edits = 0
|
||||||
|
log = []
|
||||||
|
for path in walk_paths(paths):
|
||||||
|
if not path.endswith('.flan') and mode is None:
|
||||||
|
sys.stderr.write(
|
||||||
|
"%s: say how the Flan is embedded -- --in-strings for OCaml "
|
||||||
|
"string literals, --raw-ml for a {flan|...|flan} block, "
|
||||||
|
"--in-html for <pre><code> blocks. A blind scan would read the "
|
||||||
|
"host language's punctuation as Flan.\n" % path)
|
||||||
|
return 2
|
||||||
|
with open(path, encoding='utf-8') as fh:
|
||||||
|
src = fh.read()
|
||||||
|
types = Types(pnames, penums)
|
||||||
|
fn = MODES[mode] if mode else convert_flan
|
||||||
|
new, n = fn(src, types, path, log)
|
||||||
|
if n:
|
||||||
|
total_files += 1
|
||||||
|
total_edits += n
|
||||||
|
print("%s: %d" % (path, n))
|
||||||
|
if not check:
|
||||||
|
with open(path, 'w', encoding='utf-8') as fh:
|
||||||
|
fh.write(new)
|
||||||
|
if verbose:
|
||||||
|
for line in log:
|
||||||
|
print(" " + line)
|
||||||
|
verb = "would make" if check else "made"
|
||||||
|
print("%s %d edits across %d files" % (verb, total_edits, total_files))
|
||||||
|
return 1 if (check and total_edits) else 0
|
||||||
|
|
||||||
|
|
||||||
|
if __name__ == '__main__':
|
||||||
|
sys.exit(main(sys.argv))
|
||||||
4
vendor/edn/edn.flan
vendored
4
vendor/edn/edn.flan
vendored
@ -197,7 +197,7 @@
|
|||||||
;;
|
;;
|
||||||
;; The first failure wins: a later one would overwrite the offset that
|
;; The first failure wins: a later one would overwrite the offset that
|
||||||
;; explains the file, with an offset that is merely downstream of it.
|
;; explains the file, with an offset that is merely downstream of it.
|
||||||
(defn fail [c (Ptr Cursor) code i32 pos i32]
|
(defn fail [c (Ptr Cursor) code i32 pos i32] ()
|
||||||
(when (= (.err c) err-none)
|
(when (= (.err c) err-none)
|
||||||
(set (.err c) code)
|
(set (.err c) code)
|
||||||
(set (.err-pos c) pos)))
|
(set (.err-pos c) pos)))
|
||||||
@ -256,7 +256,7 @@
|
|||||||
;; Whitespace, commas, and `;` comments, which run to the newline or to the end
|
;; Whitespace, commas, and `;` comments, which run to the newline or to the end
|
||||||
;; of input — a comment on the last line of a file with no trailing newline is
|
;; of input — a comment on the last line of a file with no trailing newline is
|
||||||
;; the case that decides whether the loop tests the length before the byte.
|
;; the case that decides whether the loop tests the length before the byte.
|
||||||
(defn skip-trivia [c (Ptr Cursor)]
|
(defn skip-trivia [c (Ptr Cursor)] ()
|
||||||
(while (not (at-end? c))
|
(while (not (at-end? c))
|
||||||
(let [b (at (.src c) (.pos c))]
|
(let [b (at (.src c) (.pos c))]
|
||||||
(cond
|
(cond
|
||||||
|
|||||||
@ -7,7 +7,7 @@
|
|||||||
;; No initialiser means all-bytes-zero, so this is BSS and costs nothing.
|
;; No initialiser means all-bytes-zero, so this is BSS and costs nothing.
|
||||||
(defvar grid [rows [cols i32]])
|
(defvar grid [rows [cols i32]])
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(set (at grid 1 2) 7)
|
(set (at grid 1 2) 7)
|
||||||
(print (at grid 1 2)) (println "") ; 7
|
(print (at grid 1 2)) (println "") ; 7
|
||||||
(print (len palette)) (println "") ; 4
|
(print (len palette)) (println "") ; 4
|
||||||
|
|||||||
@ -7,6 +7,6 @@
|
|||||||
(use-placeholder [] -1)
|
(use-placeholder [] -1)
|
||||||
(retry [] 7)))
|
(retry [] 7)))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (load 1))
|
(print (load 1))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|||||||
@ -3,7 +3,7 @@
|
|||||||
;; (at xs 7) with a literal index does not reach the backend at all: check.ml
|
;; (at xs 7) with a literal index does not reach the backend at all: check.ml
|
||||||
;; rejects it. This one goes through a local, so it is the runtime check that
|
;; rejects it. This one goes through a local, so it is the runtime check that
|
||||||
;; catches it — the same message, and the program stops where it happened.
|
;; catches it — the same message, and the program stops where it happened.
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [i 7]
|
(let [i 7]
|
||||||
(println "before")
|
(println "before")
|
||||||
(print (at xs i))
|
(print (at xs i))
|
||||||
|
|||||||
@ -9,7 +9,7 @@
|
|||||||
(use-placeholder [] -1)
|
(use-placeholder [] -1)
|
||||||
(retry [] 7)))
|
(retry [] 7)))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(agent/start "/tmp/flan-breakdemo.sock")
|
(agent/start "/tmp/flan-breakdemo.sock")
|
||||||
(print (load 1))
|
(print (load 1))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|||||||
@ -2,11 +2,11 @@
|
|||||||
|
|
||||||
(defvar seen i64)
|
(defvar seen i64)
|
||||||
|
|
||||||
(defn load-all []
|
(defn load-all [] ()
|
||||||
(signal (AssetMissing {.id 1})) ; Unit — the caller carries on
|
(signal (AssetMissing {.id 1})) ; Unit — the caller carries on
|
||||||
(signal (AssetMissing {.id 2})))
|
(signal (AssetMissing {.id 2})))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(load-all) ; no handler: a no-op
|
(load-all) ; no handler: a no-op
|
||||||
(print seen) (println "") ; 0
|
(print seen) (println "") ; 0
|
||||||
|
|
||||||
|
|||||||
@ -6,7 +6,7 @@
|
|||||||
(= n 0) "zero"
|
(= n 0) "zero"
|
||||||
:else "positive"))
|
:else "positive"))
|
||||||
|
|
||||||
(defn countdown [n i32]
|
(defn countdown [n i32] ()
|
||||||
(let [i n]
|
(let [i n]
|
||||||
(while (> i 0)
|
(while (> i 0)
|
||||||
(print i)
|
(print i)
|
||||||
@ -20,7 +20,7 @@
|
|||||||
(return (Some (at s i)))))
|
(return (Some (at s i)))))
|
||||||
None)
|
None)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(println (classify -3))
|
(println (classify -3))
|
||||||
(countdown 4)
|
(countdown 4)
|
||||||
(unless false
|
(unless false
|
||||||
|
|||||||
@ -6,6 +6,6 @@
|
|||||||
(println "body")
|
(println "body")
|
||||||
n)
|
n)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (work 3))
|
(print (work 3))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|||||||
@ -7,7 +7,7 @@
|
|||||||
(= k :escape) "escape"
|
(= k :escape) "escape"
|
||||||
:else "an arrow"))
|
:else "an arrow"))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
;; :space resolves against the parameter's enum at compile time.
|
;; :space resolves against the parameter's enum at compile time.
|
||||||
;; A typo is an error here, not a wrong number later.
|
;; A typo is an error here, not a wrong number later.
|
||||||
(println (key-name :space))
|
(println (key-name :space))
|
||||||
|
|||||||
@ -2,5 +2,5 @@
|
|||||||
;; no aggregate crosses, so no wrapper is generated.
|
;; no aggregate crosses, so no wrapper is generated.
|
||||||
(declare cos-f64 [x f64] f64 "cos")
|
(declare cos-f64 [x f64] f64 "cos")
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (cos-f64 0.0)) (println ""))
|
(print (cos-f64 0.0)) (println ""))
|
||||||
|
|||||||
@ -5,7 +5,7 @@
|
|||||||
(defconst cols 4)
|
(defconst cols 4)
|
||||||
(defvar grid [rows [cols u32]]) ; BSS, rows*cols*4 bytes
|
(defvar grid [rows [cols u32]]) ; BSS, rows*cols*4 bytes
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print cell-size) (println "")
|
(print cell-size) (println "")
|
||||||
(print gravity) (println "")
|
(print gravity) (println "")
|
||||||
(print current-color) (println "")
|
(print current-color) (println "")
|
||||||
|
|||||||
@ -1,2 +1,2 @@
|
|||||||
(defn main []
|
(defn main [] ()
|
||||||
(println "hello from flan"))
|
(println "hello from flan"))
|
||||||
|
|||||||
@ -4,7 +4,7 @@
|
|||||||
(defn doubled-first [s [i32]] (Option i32)
|
(defn doubled-first [s [i32]] (Option i32)
|
||||||
(Some (* 2 (some (index-of-i32 s 15)))))
|
(Some (* 2 (some (index-of-i32 s 15)))))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(match (doubled-first (slice nums 0 4))
|
(match (doubled-first (slice nums 0 4))
|
||||||
(Some i) (do (print i) (println "")) ; 4
|
(Some i) (do (print i) (println "")) ; 4
|
||||||
None (println "not found"))
|
None (println "not found"))
|
||||||
|
|||||||
@ -2,7 +2,7 @@
|
|||||||
;; arrives qualified by the alias this import chose.
|
;; arrives qualified by the alias this import chose.
|
||||||
(import g "geom")
|
(import g "geom")
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [v (g/add (g/V2 {.x 3.0 .y 0.0})
|
(let [v (g/add (g/V2 {.x 3.0 .y 0.0})
|
||||||
(g/V2 {.x 0.0 .y 4.0}))]
|
(g/V2 {.x 0.0 .y 4.0}))]
|
||||||
(print (g/length v))
|
(print (g/length v))
|
||||||
|
|||||||
@ -5,7 +5,7 @@
|
|||||||
(defvar room [room-size i32])
|
(defvar room [room-size i32])
|
||||||
|
|
||||||
;; `set` takes a fixed list of forms, not an extensible setf.
|
;; `set` takes a fixed list of forms, not an extensible setf.
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [e (Enemy {.hp 10 .name "slime"})
|
(let [e (Enemy {.hp 10 .name "slime"})
|
||||||
p (addr e)]
|
p (addr e)]
|
||||||
(set spawned (+ spawned 1)) ; a local or a defvar
|
(set spawned (+ spawned 1)) ; a local or a defvar
|
||||||
|
|||||||
@ -4,7 +4,7 @@
|
|||||||
(defn look-up [k Key] (Option i32)
|
(defn look-up [k Key] (Option i32)
|
||||||
(if (= k :space) (Some 32) None))
|
(if (= k :space) (Some 32) None))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(println 42) ; an i32, uncast
|
(println 42) ; an i32, uncast
|
||||||
(println 1.5)
|
(println 1.5)
|
||||||
(println (Enemy {.hp 3 .name "wisp" .key :left}))
|
(println (Enemy {.hp 3 .name "wisp" .key :left}))
|
||||||
|
|||||||
@ -15,7 +15,7 @@
|
|||||||
(use-placeholder [] -1)
|
(use-placeholder [] -1)
|
||||||
(retry [] 7)))
|
(retry [] 7)))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (fetch 1)) (println "") ; 101 — nothing handled it
|
(print (fetch 1)) (println "") ; 101 — nothing handled it
|
||||||
|
|
||||||
(handler-bind [(AssetMissing [c] (invoke-restart 'use-placeholder))]
|
(handler-bind [(AssetMissing [c] (invoke-restart 'use-placeholder))]
|
||||||
|
|||||||
@ -2,6 +2,6 @@
|
|||||||
|
|
||||||
(declare-c get-mouse-position [] Vector2 "GetMousePosition")
|
(declare-c get-mouse-position [] Vector2 "GetMousePosition")
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (.x (get-mouse-position)))
|
(print (.x (get-mouse-position)))
|
||||||
(println ""))
|
(println ""))
|
||||||
|
|||||||
@ -7,10 +7,10 @@
|
|||||||
(at (.src c) (.pos c))
|
(at (.src c) (.pos c))
|
||||||
0))
|
0))
|
||||||
|
|
||||||
(defn advance [c (Ptr Cursor)]
|
(defn advance [c (Ptr Cursor)] ()
|
||||||
(set (.pos c) (+ (.pos c) 1))) ; field access derefs one level
|
(set (.pos c) (+ (.pos c) 1))) ; field access derefs one level
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [c (Cursor {.src (bytes "hi")})] ; pos omitted, so pos is 0
|
(let [c (Cursor {.src (bytes "hi")})] ; pos omitted, so pos is 0
|
||||||
(print (peek (addr c))) (println "")
|
(print (peek (addr c))) (println "")
|
||||||
(advance (addr c))
|
(advance (addr c))
|
||||||
|
|||||||
@ -337,7 +337,7 @@ produced. <code>run</code> builds to a temporary file and execs it.</p>
|
|||||||
|
|
||||||
<p>The smallest program:</p>
|
<p>The smallest program:</p>
|
||||||
|
|
||||||
<pre><code>(defn main []
|
<pre><code>(defn main [] ()
|
||||||
(println "hello from flan"))</code></pre>
|
(println "hello from flan"))</code></pre>
|
||||||
|
|
||||||
<p>The entry point is <code>(defn main [args [string]] i32)</code>. Both the parameter
|
<p>The entry point is <code>(defn main [args [string]] i32)</code>. Both the parameter
|
||||||
@ -380,7 +380,7 @@ heap is involved.</p>
|
|||||||
(defvar room [room-size i32])
|
(defvar room [room-size i32])
|
||||||
|
|
||||||
;; `set` takes a fixed list of forms, not an extensible setf.
|
;; `set` takes a fixed list of forms, not an extensible setf.
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [e (Enemy {.hp 10 .name "slime"})
|
(let [e (Enemy {.hp 10 .name "slime"})
|
||||||
p (addr e)]
|
p (addr e)]
|
||||||
(set spawned (+ spawned 1)) ; a local or a defvar
|
(set spawned (+ spawned 1)) ; a local or a defvar
|
||||||
@ -411,7 +411,7 @@ wisp
|
|||||||
;; (at xs 7) with a literal index does not reach the backend at all: check.ml
|
;; (at xs 7) with a literal index does not reach the backend at all: check.ml
|
||||||
;; rejects it. This one goes through a local, so it is the runtime check that
|
;; rejects it. This one goes through a local, so it is the runtime check that
|
||||||
;; catches it — the same message, and the program stops where it happened.
|
;; catches it — the same message, and the program stops where it happened.
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [i 7]
|
(let [i 7]
|
||||||
(println "before")
|
(println "before")
|
||||||
(print (at xs i))
|
(print (at xs i))
|
||||||
@ -502,10 +502,10 @@ its fields, and omitted fields are zeroed.</p>
|
|||||||
(at (.src c) (.pos c))
|
(at (.src c) (.pos c))
|
||||||
0))
|
0))
|
||||||
|
|
||||||
(defn advance [c (Ptr Cursor)]
|
(defn advance [c (Ptr Cursor)] ()
|
||||||
(set (.pos c) (+ (.pos c) 1))) ; field access derefs one level
|
(set (.pos c) (+ (.pos c) 1))) ; field access derefs one level
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [c (Cursor {.src (bytes "hi")})] ; pos omitted, so pos is 0
|
(let [c (Cursor {.src (bytes "hi")})] ; pos omitted, so pos is 0
|
||||||
(print (peek (addr c))) (println "")
|
(print (peek (addr c))) (println "")
|
||||||
(advance (addr c))
|
(advance (addr c))
|
||||||
@ -534,7 +534,7 @@ typo is an error there rather than a wrong number later.</p>
|
|||||||
(= k :escape) "escape"
|
(= k :escape) "escape"
|
||||||
:else "an arrow"))
|
:else "an arrow"))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
;; :space resolves against the parameter's enum at compile time.
|
;; :space resolves against the parameter's enum at compile time.
|
||||||
;; A typo is an error here, not a wrong number later.
|
;; A typo is an error here, not a wrong number later.
|
||||||
(println (key-name :space))
|
(println (key-name :space))
|
||||||
@ -567,7 +567,7 @@ functions need no forward declaration. Globals come in two kinds:</p>
|
|||||||
(defconst cols 4)
|
(defconst cols 4)
|
||||||
(defvar grid [rows [cols u32]]) ; BSS, rows*cols*4 bytes
|
(defvar grid [rows [cols u32]]) ; BSS, rows*cols*4 bytes
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print cell-size) (println "")
|
(print cell-size) (println "")
|
||||||
(print gravity) (println "")
|
(print gravity) (println "")
|
||||||
(print current-color) (println "")
|
(print current-color) (println "")
|
||||||
@ -601,7 +601,7 @@ whose type matters is named at the top level rather than written inline.</p>
|
|||||||
(= n 0) "zero"
|
(= n 0) "zero"
|
||||||
:else "positive"))
|
:else "positive"))
|
||||||
|
|
||||||
(defn countdown [n i32]
|
(defn countdown [n i32] ()
|
||||||
(let [i n]
|
(let [i n]
|
||||||
(while (> i 0)
|
(while (> i 0)
|
||||||
(print i)
|
(print i)
|
||||||
@ -615,7 +615,7 @@ whose type matters is named at the top level rather than written inline.</p>
|
|||||||
(return (Some (at s i)))))
|
(return (Some (at s i)))))
|
||||||
None)
|
None)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(println (classify -3))
|
(println (classify -3))
|
||||||
(countdown 4)
|
(countdown 4)
|
||||||
(unless false
|
(unless false
|
||||||
@ -655,7 +655,7 @@ on nothing else today. <code>some</code> unwraps <code>Some</code> and early-ret
|
|||||||
(defn doubled-first [s [i32]] (Option i32)
|
(defn doubled-first [s [i32]] (Option i32)
|
||||||
(Some (* 2 (some (index-of-i32 s 15)))))
|
(Some (* 2 (some (index-of-i32 s 15)))))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(match (doubled-first (slice nums 0 4))
|
(match (doubled-first (slice nums 0 4))
|
||||||
(Some i) (do (print i) (println "")) ; 4
|
(Some i) (do (print i) (println "")) ; 4
|
||||||
None (println "not found"))
|
None (println "not found"))
|
||||||
@ -680,7 +680,7 @@ has not executed yet and must not fire.</p>
|
|||||||
(println "body")
|
(println "body")
|
||||||
n)
|
n)
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (work 3))
|
(print (work 3))
|
||||||
(println ""))</code></pre>
|
(println ""))</code></pre>
|
||||||
|
|
||||||
@ -711,7 +711,7 @@ It is a place: <code>(set (at grid r c) v)</code> and <code>(addr (at grid r c))
|
|||||||
;; No initialiser means all-bytes-zero, so this is BSS and costs nothing.
|
;; No initialiser means all-bytes-zero, so this is BSS and costs nothing.
|
||||||
(defvar grid [rows [cols i32]])
|
(defvar grid [rows [cols i32]])
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(set (at grid 1 2) 7)
|
(set (at grid 1 2) 7)
|
||||||
(print (at grid 1 2)) (println "") ; 7
|
(print (at grid 1 2)) (println "") ; 7
|
||||||
(print (len palette)) (println "") ; 4
|
(print (len palette)) (println "") ; 4
|
||||||
@ -750,7 +750,7 @@ user-supplied printer to choose between.</p>
|
|||||||
(defn look-up [k Key] (Option i32)
|
(defn look-up [k Key] (Option i32)
|
||||||
(if (= k :space) (Some 32) None))
|
(if (= k :space) (Some 32) None))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(println 42) ; an i32, uncast
|
(println 42) ; an i32, uncast
|
||||||
(println 1.5)
|
(println 1.5)
|
||||||
(println (Enemy {.hp 3 .name "wisp" .key :left}))
|
(println (Enemy {.hp 3 .name "wisp" .key :left}))
|
||||||
@ -859,7 +859,7 @@ and no ceremony.</p>
|
|||||||
;; arrives qualified by the alias this import chose.
|
;; arrives qualified by the alias this import chose.
|
||||||
(import g "geom")
|
(import g "geom")
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(let [v (g/add (g/V2 {.x 3.0 .y 0.0})
|
(let [v (g/add (g/V2 {.x 3.0 .y 0.0})
|
||||||
(g/V2 {.x 0.0 .y 4.0}))]
|
(g/V2 {.x 0.0 .y 4.0}))]
|
||||||
(print (g/length v))
|
(print (g/length v))
|
||||||
@ -933,11 +933,11 @@ normally leaves the signaller to carry on — the accumulation case:</p>
|
|||||||
|
|
||||||
(defvar seen i64)
|
(defvar seen i64)
|
||||||
|
|
||||||
(defn load-all []
|
(defn load-all [] ()
|
||||||
(signal (AssetMissing {.id 1})) ; Unit — the caller carries on
|
(signal (AssetMissing {.id 1})) ; Unit — the caller carries on
|
||||||
(signal (AssetMissing {.id 2})))
|
(signal (AssetMissing {.id 2})))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(load-all) ; no handler: a no-op
|
(load-all) ; no handler: a no-op
|
||||||
(print seen) (println "") ; 0
|
(print seen) (println "") ; 0
|
||||||
|
|
||||||
@ -971,7 +971,7 @@ first, before the clause body starts.</p>
|
|||||||
(use-placeholder [] -1)
|
(use-placeholder [] -1)
|
||||||
(retry [] 7)))
|
(retry [] 7)))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (fetch 1)) (println "") ; 101 — nothing handled it
|
(print (fetch 1)) (println "") ; 101 — nothing handled it
|
||||||
|
|
||||||
(handler-bind [(AssetMissing [c] (invoke-restart 'use-placeholder))]
|
(handler-bind [(AssetMissing [c] (invoke-restart 'use-placeholder))]
|
||||||
@ -1060,7 +1060,7 @@ and an exit status of 134:</p>
|
|||||||
(use-placeholder [] -1)
|
(use-placeholder [] -1)
|
||||||
(retry [] 7)))
|
(retry [] 7)))
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (load 1))
|
(print (load 1))
|
||||||
(println ""))</code></pre>
|
(println ""))</code></pre>
|
||||||
|
|
||||||
@ -1083,7 +1083,7 @@ is generated; a Flan string crosses as ptr+len, exactly as it is stored.</p>
|
|||||||
|
|
||||||
<pre><code>(declare cos-f64 [x f64] f64 "cos")
|
<pre><code>(declare cos-f64 [x f64] f64 "cos")
|
||||||
|
|
||||||
(defn main []
|
(defn main [] ()
|
||||||
(print (cos-f64 0.0)) (println ""))</code></pre>
|
(print (cos-f64 0.0)) (println ""))</code></pre>
|
||||||
|
|
||||||
<pre><code class="sh">1</code></pre>
|
<pre><code class="sh">1</code></pre>
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user