M2 item 6: defclass, generic functions, and multimethods on the dyn side
This commit is contained in:
commit
dc39631db7
245
FIX.org
245
FIX.org
@ -185,8 +185,9 @@ against 985ms on LLVM.
|
||||
* Landed on dev-loop
|
||||
|
||||
Items 1, 2, 3 and 5 are merged and green (dune test --force, 232 elisp checks,
|
||||
0 failures). Items 4 (drop) and 7 (defdata) are still being written. Item 6 is
|
||||
held.
|
||||
0 failures). Items 4 (drop) and 7 (defdata) are still being written. Item 6 —
|
||||
classes and generic functions — is no longer held: it landed, and the M2 queue
|
||||
above records it under item 6 with its commits.
|
||||
|
||||
** Re-run is merged, and does not work under --x86
|
||||
Park and re-run live in the merged entry point's main(), and --x86 refuses the
|
||||
@ -519,7 +520,10 @@ rename. typed-flan branch freezes the static language pre-dyn.
|
||||
5. Typed = and != grow strings: bytewise, length + same-pointer fast paths,
|
||||
both backends, one survey program. Ordering stays refused. — LANDED, daed039
|
||||
6. defclass = named dyn map + shape tag; CLOS class dispatch AND
|
||||
Clojure-style arbitrary dispatch functions. After 1.
|
||||
Clojure-style arbitrary dispatch functions. After 1. — LANDED, 8d2bf2a
|
||||
(the feature), 5af990e (the daemon proof and an x86 descriptor fix it
|
||||
turned up) and 6c6024e. Written up below, "Classes and generic
|
||||
functions, 2026-09-20".
|
||||
7. dyn if: truthiness (nil/false are false, all else true). Typed stays
|
||||
strict bool. — LANDED, 264765a
|
||||
|
||||
@ -1359,3 +1363,238 @@ test/programs/defvar-dyn.flan is both readings in one program, pinned in
|
||||
acceptance at the default, -O0 and --x86; and dev-rerun.flan grew a
|
||||
[(defvar tally 0)] whose line is 4 after three re-runs, which is the claim
|
||||
that the new spelling goes through the old guard.
|
||||
* Classes and generic functions, 2026-09-20 — M2 queue item 6
|
||||
The recorded decision was "defclass = named dyn map + shape tag; CLOS class
|
||||
dispatch AND Clojure-style arbitrary dispatch functions", and it is built as
|
||||
written. The two dispatch styles are one mechanism and not two: a class
|
||||
dispatcher is the shape tag of the first argument used as the dispatch
|
||||
function, so a method written for the class ~point~ and one written for the
|
||||
value ~:point~ are the same branch — which is also why the two spellings are
|
||||
refused as duplicates of each other.
|
||||
|
||||
** The surface, as landed
|
||||
#+begin_src lisp
|
||||
(defclass point [x y]) ; a class: named slots, no types
|
||||
(point 3 4) ; the constructor — the class's own name
|
||||
(class-of p) ; :point, and nil for anything else
|
||||
(get p :x) (put p :x 10) ; the slots are map keys; nothing new
|
||||
|
||||
(defgeneric area [self] dyn) ; CLOS: dispatch on the class
|
||||
(defmethod area point [p] (* (get p :x) (get p :y)))
|
||||
|
||||
(defmulti describe [x] dyn (get x :kind)) ; Clojure: the body is the dispatch
|
||||
(defmethod describe :square [s] (get s :side))
|
||||
(defmethod describe :else [s] "something else")
|
||||
#+end_src
|
||||
|
||||
- *A slot is a key.* An instance is a dyn map, so ~get~, ~put~, ~has-key?~
|
||||
and ~len~ are how one is read and written, and no operation was added for
|
||||
any of it. ~(len p)~ is the slot count.
|
||||
- *The constructor is positional*, one argument per slot in the order they
|
||||
were written, and it is an ordinary ~defn~ — so its arity refusal, its cell
|
||||
in a dev build and its behaviour under redefinition are the ones every
|
||||
function already has. The named-slot spelling is deferred; see below.
|
||||
- *A method has no return slot.* The generic states the return type once, for
|
||||
every method written for it, which is also what makes the parse
|
||||
unambiguous: the vector is always the third form.
|
||||
- *Every parameter of a generic and of a method is dyn*, written or not, and
|
||||
a slot that is not a bare name is refused. That keeps these forms off the
|
||||
undecided-pairing path a ~defn~'s vector is on: a vector that may hold only
|
||||
names can be read by the parser, where a ~defn~'s cannot be read until
|
||||
every type name is known.
|
||||
- *A dispatch value is a literal* — a class's name, a keyword, a string, an
|
||||
integer, ~true~, ~false~, or ~:else~ for the arm everything falls through
|
||||
to. ~:else~ and not Clojure's ~:default~, because ~match~ already spells
|
||||
"none of the above" that way and two words for it would be one too many.
|
||||
~:else~ is the last arm whatever order it was written in.
|
||||
- *A miss signals.* ~(defstruct NoMethod [generic string value dyn])~ in the
|
||||
prelude, signalled with ~error~, carrying the name written at the generic
|
||||
and the value the dispatch actually produced. A condition and not a trap,
|
||||
because a miss is something a program can be written to answer;
|
||||
~handler-case~ around the call is the shape, and a ~:else~ method is the
|
||||
other answer. No restart is established at the miss, which is
|
||||
BoundsError's decision taken for BoundsError's reason. ~value~ is the first
|
||||
~dyn~ field in any condition here; the per-type descriptor an item-2 struct
|
||||
carries is what the collector reaches it by.
|
||||
|
||||
** The shape tag: a header field, not a reserved key
|
||||
This queue item's own note said "named dyn map + shape tag", and the obvious
|
||||
reading was a reserved entry in the map. It is a field in the object's header
|
||||
instead — an interned ~kw_entry *~ in the map arm of ~flan_obj~'s union — and
|
||||
the departure is deliberate.
|
||||
|
||||
An entry would be counted by ~len~, walked by both renderers, and compared by
|
||||
~dyn_equal~'s key loop. Every instance would answer a length one larger than
|
||||
its slot count, print a key nobody wrote, and be one ~put~ away from having
|
||||
its own class changed. A header field cannot be reached by ~get~ or ~put~ at
|
||||
all, so the question of a user key colliding with it does not arise rather
|
||||
than being answered by picking an unlikely spelling.
|
||||
|
||||
It cost nothing. The view arm of that union is 24 bytes, so the map arm
|
||||
growing from 16 to 24 does not grow the union, and ~sizeof(flan_obj)~ is 48
|
||||
before and after — checked, not assumed. It needs no marking either: an
|
||||
interned keyword entry is immortal by construction and is not a collector
|
||||
object, which ~mark_value~ states by following ~BOX_OBJ~ and nothing else.
|
||||
|
||||
The tag is read in exactly four places in flan_dyn.c: ~class-of~ answers it;
|
||||
~dyn_equal~ compares it, so two instances of one class compare by their slots
|
||||
and an instance is never equal to a plain map with the same entries
|
||||
(Clojure's answer for a record beside a map); and *both* renderers write it —
|
||||
~render~, which is what ~print~ goes through, and ~say_render~, the 96-byte
|
||||
sentence a trap prints, so a dyn trap naming an instance says which class it
|
||||
was. The spelling is ~#point{ :x 1 :y 2}~, Clojure's own for a record.
|
||||
|
||||
The tag is built from the class's *qualified* name, and the qualifier is the
|
||||
**importer's alias** rather than anything the defining package chose — the
|
||||
same class imported as ~a~ and as ~zz~ tags its instances ~:a/point~ and
|
||||
~:zz/point~. That falls straight out of [Load]'s rename, and it is right for
|
||||
the dispatch, which resolves the class name through the same rename and
|
||||
therefore agrees with it. What it is *not* safe for is a hand-written
|
||||
dispatch value: ~(defmethod g :a/point ...)~ is a keyword and nobody
|
||||
qualifies it, so it is coupled to one import's alias and silently answers for
|
||||
nothing under another. Write the class's name, ~(defmethod g point ...)~,
|
||||
which is renamed with everything else. Two packages' own ~point~ classes are
|
||||
two classes either way, which was the property wanted.
|
||||
|
||||
** How it is built: a pass, not a macro
|
||||
None of the four forms reaches the checker. ~lib/classes.ml~ rewrites the
|
||||
whole declaration list at the top of ~Check.build_program~, exactly where
|
||||
~Shim.expand~ rewrites a ~declare-c~: a class becomes its constructor, a
|
||||
generic becomes one function whose body binds the dispatch value and compares
|
||||
it down a chain, and a method becomes a branch of that chain.
|
||||
|
||||
A macro sees one form and this needs the whole list, because a method may be
|
||||
written above its generic, below it, or arrive at a reload an hour later.
|
||||
Running over the flat list is also what makes the dev loop work: a reload
|
||||
rebuilds every dispatch from the session's whole set of declarations.
|
||||
|
||||
*The method bodies are inlined rather than lifted into functions of their
|
||||
own*, and that is the load-bearing choice. A generic is then exactly one
|
||||
top-level name, so adding a method to a running program is the ordinary
|
||||
redefinition of one function, through the cell the call site already goes
|
||||
through. ~session.ml~ names the generic alongside the method's own
|
||||
declaration name for that reason — without it a ~C-c C-c~ on a ~defmethod~
|
||||
would install something no call site reads. A method still declares a name of
|
||||
its own, ~area@:circle~, which is what makes re-evaluating one a replacement
|
||||
and evaluating a new one an append; no function is emitted under it. Proved
|
||||
end to end against a real daemon (~test_dev.ml~, "a method added to a running
|
||||
program"), not only at the session's report.
|
||||
|
||||
A method's own parameter names are bound from the generic's *in parallel*,
|
||||
through temporaries in the unspellable ~[~]~ namespace. A [let] binds in
|
||||
sequence, so the pairwise spelling reads a name it has just bound: a method
|
||||
[[b a]] under a generic [[a b]] would be handed its first argument twice and
|
||||
the second would be unreachable. Both the swap and the one-step shift are
|
||||
pinned in the survey program, where the values are what is wrong rather than
|
||||
the types.
|
||||
|
||||
The cost, recorded rather than hidden: *a method is not separately callable
|
||||
and is not a frame of its own*. A break loop under a method shows the
|
||||
generic. And the generic's own parameter names stay in scope inside a method
|
||||
that renamed them, so a body reaching for ~self~ where it declared ~p~
|
||||
silently resolves instead of being refused — small, and closing it would mean
|
||||
giving the dispatcher unspellable parameter names, which is what the
|
||||
inspector reads.
|
||||
|
||||
** Deferred, each with the reason
|
||||
- *Inheritance.* plan.org's own rule is that method specificity and ambiguity
|
||||
rules are required before inheritance or multiple dispatch is enabled, and
|
||||
with single dispatch on literal values there is no specificity question at
|
||||
all: two methods either answer for the same value, which is refused, or for
|
||||
different ones. A hierarchy would create the question, and the author never
|
||||
asked for one.
|
||||
- *Multi-argument dispatch.* plan.org names it as the later extension, for
|
||||
~(collide Player Enemy)~. It wants the specificity rules above.
|
||||
- *~:before~, ~:after~, ~:around~ and ~call-next-method~.* They only mean
|
||||
something once methods can be ordered by anything but equality, which is
|
||||
the same gate inheritance is behind.
|
||||
- *Named-slot construction*, ~(point {:x 1})~ with an omitted slot meaning
|
||||
nil — the dyn twin of ~(Cursor {.src s})~ with its omitted-is-zeroed rule.
|
||||
Positional is what a generated ~defn~ gives for free, arity included; the
|
||||
named form is a checker special case and was not worth one at v1.
|
||||
- *Unknown-slot checking at ~(get p :z)~.* The one compile-time win a
|
||||
declared slot set makes possible (docs/SPIKE-DUPLICITY.md §8 names it), and
|
||||
it needs the checker to know the class of an expression — class-typed
|
||||
tracking on the dyn side, which dyn deliberately does not have. A class
|
||||
adds a tag and a dispatch, not a static slot discipline.
|
||||
- *Computed dispatch values.* Clojure registers a method under any value
|
||||
because registration there is a run-time call; here it is compile-time, and
|
||||
the method's declaration name is built from the value.
|
||||
- *~nil~ and floats as dispatch values.* ~:else~ covers the nil case, which
|
||||
is the common one (~class-of~ answers nil for anything that is not an
|
||||
instance); a float compared for equality is a trap waiting to be sprung.
|
||||
- *Class redefinition and migration* — plan.org's ~redefine-class~ /
|
||||
~migrate-instances~. A heterogeneous map has no layout to be stale, so
|
||||
nothing breaks today when a class gains a slot: old instances simply lack
|
||||
it. Enumerating live instances is the part that is missing, and it is the
|
||||
pool's question rather than this lane's.
|
||||
- *The JS backend.* It refuses dyn wholesale, so none of this compiles there.
|
||||
Same parking as the string-equality hole above.
|
||||
|
||||
** Two things found on the way, neither about classes
|
||||
- *The x86 backend's redefinition module never emitted the per-type dyn
|
||||
descriptors.* ~Emit.redefinition~ has always emitted them, by going through
|
||||
~finish~; the x86 twin ended at the rodata section and stopped. Nothing had
|
||||
reached it, because a redefined body had to construct a struct holding a
|
||||
dyn to need one, and until ~NoMethod~ there was no such struct a
|
||||
compiler-written body could build. It is not a bad read at run time — a
|
||||
descriptor label is local, so ~ld~ refuses the module with an undefined
|
||||
symbol. Fixed with one line beside the same call in the executable path.
|
||||
|
||||
Emitting them turned up the second half: ~descriptors_asm~ wrote them into
|
||||
~.rodata~, and a descriptor holds the address of its own offset table. A
|
||||
relocation in a read-only section is a ~DT_TEXTREL~ — ld warns about it in
|
||||
a PIE and refuses it in a shared object — so the section is now
|
||||
~.data.rel.ro~, which exists for exactly this and is what both the
|
||||
executable and the reload module use. Verified with ~readelf -d~ on a
|
||||
reload module from each backend: no ~TEXTREL~, descriptors in
|
||||
~.data.rel.ro~.
|
||||
|
||||
*Still unexercised, and for the next sweep rather than this lane:* marking
|
||||
THROUGH a descriptor that an x86 reload module emitted. What is proved is
|
||||
that the module links and runs; what is not is a collection happening while
|
||||
a live instance of a dyn-holding struct sits in a frame of a body that
|
||||
module delivered. The LLVM path has been exercised since item 2; this one
|
||||
has existed for a day.
|
||||
- *A dyn value answered by ~eval-expr~ never reaches the reply's ~:value~.*
|
||||
It renders to the program's own stdout, which arrives on a *later* reply's
|
||||
~:output~ — the dyn-global rows already read one that way and say so, and
|
||||
~(+ 2 3)~ answering "5" beside ~(area (point 3 4))~ answering "" is the
|
||||
whole of the difference. Left standing: where a dyn expression's value
|
||||
should surface is a question about the editor protocol, not about this
|
||||
lane. The dev test works around it by comparing inside the expression, so
|
||||
what crosses the wire is a typed 1.
|
||||
|
||||
** What was run
|
||||
~dune test --root .~ green (exit 0, no FAIL lines) after each commit, and
|
||||
again on the rebase onto the defvar-dyn lane — whose ~load.ml~ arms are the
|
||||
~defvar~ one and whose ~ast.ml~ arm is the ~Ambiguous~ initialiser, disjoint
|
||||
from the four class arms beside them; both sets were read against each other
|
||||
by hand rather than trusted to the auto-merge. Three acceptance rows for
|
||||
~test/programs/dyn-class.flan~ — default, ~-O0~ and ~--x86~ — and a three-way
|
||||
diff of the program's real output across the same three, captured by hand
|
||||
before the rows were written and again after the rebase. It is in
|
||||
~test_sanitize.ml~'s list; per the sweep policy the sweep itself was not run.
|
||||
|
||||
** Found while running it: ~dune test~ exits 1 at random, and has since before
|
||||
this lane
|
||||
~test_dev.ml~'s ~trap_park~ rows are racy, and when they lose the race the
|
||||
whole test binary dies with ~Fatal error: exception Flan.Wire.Closed~ — exit
|
||||
1 with no FAIL line anywhere, which is the worst shape a failure can have
|
||||
given that the sweep policy says a lane is judged on the exit status.
|
||||
|
||||
The mechanism: ~trap_park~ polls with ~ask~, which is a bare ~Wire.send~ /
|
||||
~Wire.recv~ pair with nothing around it, and the program it is polling has
|
||||
just aborted at the break loop. If the daemon exits between the send and the
|
||||
recv, ~Wire.recv~ raises ~Closed~, nothing catches it, and every row after it
|
||||
— in this lane's case the new class daemon among them — never runs. Both
|
||||
observed failures landed at the same row, ~dev-trap-null-alloc~.
|
||||
|
||||
*It is not this lane's.* Measured on a detached worktree at dev-loop's tip
|
||||
(c4e0725) with nothing of this lane in it: 2 of 5 runs exit 1 with the same
|
||||
exception at the same row, against 2 of 5 on this branch. The rates match
|
||||
because the code is the same.
|
||||
|
||||
Not fixed here, deliberately: the fix is to catch ~Closed~ in that poll and
|
||||
read it as the program having ended, which is a claim about what those rows
|
||||
mean and belongs to whoever owns them. Flagged rather than patched.
|
||||
|
||||
@ -92,6 +92,15 @@ let summarise (d : Flan.Ast.decl) =
|
||||
Printf.sprintf "declare-c %s (%d params) = %s" fn.name
|
||||
(List.length fn.params) csym
|
||||
| Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms)
|
||||
| Defclass (n, slots) ->
|
||||
Printf.sprintf "defclass %s (%d slots)" n (List.length slots)
|
||||
| Defgeneric fn ->
|
||||
Printf.sprintf "defgeneric %s (%d params)" fn.name (List.length fn.params)
|
||||
| Defmulti fn ->
|
||||
Printf.sprintf "defmulti %s (%d params)" fn.name (List.length fn.params)
|
||||
| Defmethod m ->
|
||||
Printf.sprintf "defmethod %s %s (%d body forms)" m.mgen
|
||||
(dispatch_text m.mkey) (List.length m.mfn.fbody)
|
||||
| Defn fn ->
|
||||
Printf.sprintf "defn %s (%d params, %s return, %d body forms)"
|
||||
fn.name (List.length fn.params)
|
||||
|
||||
94
lib/ast.ml
94
lib/ast.ml
@ -69,7 +69,13 @@ and expr_kind =
|
||||
(* {:a 1 :b s} — a dyn map literal. Braces whose first form is not a
|
||||
[.field] symbol are this; the struct spelling keeps the dot. Keys are
|
||||
ordinary expressions, keywords being the common case. *)
|
||||
| MapLit of (expr * expr) list
|
||||
(* The [string option] is a shape tag, and the parser never writes one: a
|
||||
tagged map is what a (defclass ...) constructor builds, and
|
||||
[Classes.expand] is the only thing that writes that constructor. The tag
|
||||
is the class's name; the instance carries it in its object header, not as
|
||||
an entry, so a tagged literal and an untagged one with the same pairs
|
||||
differ in exactly one word and in nothing a [get] can see. *)
|
||||
| MapLit of string option * (expr * expr) list
|
||||
| Arr of expr list (* [0xE6B800FF ...] — a fixed array value *)
|
||||
(* (array 4 rl/Vector2) — a zeroed fixed array, given its count and its
|
||||
element type. [n T] is the ordinary *type* syntax and already works
|
||||
@ -208,6 +214,52 @@ and decl_kind =
|
||||
(* value is optional: ZII. `uninit` opts out and is recorded as Uninit. *)
|
||||
| Defvar of string * texpr option * init
|
||||
| Defconst of string * texpr option * expr
|
||||
(* ── The dyn side's classes and generic functions ──────────────────
|
||||
None of these four reaches [Check]. [Classes.expand] turns the whole set
|
||||
into ordinary [Defn]s before pass one collects anything, the way [Shim]
|
||||
already turns a [DeclareC] into a [Declare] plus a [Defn]: a class is a
|
||||
constructor, and a generic function is one function whose body is a
|
||||
dispatch over the methods written for it.
|
||||
|
||||
They are declarations here rather than a macro because the expansion
|
||||
needs the *whole* declaration list in hand — a method may be written
|
||||
anywhere in the file, or arrive at a reload long after the generic did,
|
||||
and a macro sees one form. *)
|
||||
|
||||
(* (defclass point [x y]) — the slot names, in constructor order. *)
|
||||
| Defclass of string * (string * Loc.t) list
|
||||
(* (defgeneric area [self] dyn) — CLOS's class dispatch: the dispatch value
|
||||
is the shape tag of the first argument. The parameter vector and the
|
||||
return slot are a [defn]'s, and there is no body. *)
|
||||
| Defgeneric of fn
|
||||
(* (defmulti describe [x] dyn (get x :kind)) — Clojure's: the body IS the
|
||||
dispatch function, computing the value the methods are keyed by. Exactly
|
||||
a [defn]'s shape, which is what it is. *)
|
||||
| Defmulti of fn
|
||||
(* (defmethod area point [p] body ...) — one method of a generic. [mgen] is
|
||||
the generic's name, [mkey] the dispatch value it answers for, and [mfn]
|
||||
carries the parameter vector and the body. There is no return slot: the
|
||||
generic states the return type once, for all of its methods. *)
|
||||
| Defmethod of methd
|
||||
|
||||
(* A dispatch value, written at a [defmethod]. Only literals: the value is
|
||||
compared at run time and the *name* the method is declared under is built
|
||||
from it at compile time, so it has to be something both passes can read. *)
|
||||
and dispatch =
|
||||
(* [point] — a class's name, standing for the keyword its instances carry.
|
||||
Refused unless a [defclass] of that name is in scope, which is the one
|
||||
compile-time check a shape tag makes possible. *)
|
||||
| Dclass of string
|
||||
| Dkw of string (* :circle *)
|
||||
| Dstr of string (* "circle" *)
|
||||
| Dint of int64
|
||||
| Dbool of bool
|
||||
(* [:else] — the method that answers when no other does. The spelling is
|
||||
[match]'s, not Clojure's [:default], because this language already has
|
||||
one word for "none of the above" and two would be one too many. *)
|
||||
| Delse
|
||||
|
||||
and methd = { mgen : string; mkey : dispatch; mfn : fn; mkloc : Loc.t }
|
||||
|
||||
and variant = { vname : string; vfields : field list; vloc : Loc.t }
|
||||
|
||||
@ -225,11 +277,37 @@ and init = Zeroed | Uninit | Init of expr | Ambiguous of expr
|
||||
one top-level namespace, so this is both the set [Load] renames on an import
|
||||
and the set [Check] refuses to see twice — one definition, so the two cannot
|
||||
drift apart. *)
|
||||
(* How a dispatch value reads back, in a message and in the name below. The
|
||||
keyword keeps its colon and the string its quotes, so that a method written
|
||||
for :circle and one written for "circle" — two different values — do not
|
||||
read as the same thing in a duplicate-method refusal. *)
|
||||
let dispatch_text = function
|
||||
| Dclass n -> n
|
||||
| Dkw k -> ":" ^ k
|
||||
| Dstr s -> "\"" ^ s ^ "\""
|
||||
| Dint i -> Int64.to_string i
|
||||
| Dbool b -> if b then "true" else "false"
|
||||
| Delse -> ":else"
|
||||
|
||||
(* The top-level name a [defmethod] declares. No function is ever emitted
|
||||
under it — a method's body is inlined into its generic's dispatch, so the
|
||||
only function the pass writes is the generic itself — but a declaration
|
||||
still needs a name of its own, for the reason every declaration does: a
|
||||
session replaces a declaration it has already seen by name, and appends one
|
||||
it has not. Redefining a method has to replace, and adding one has to
|
||||
append, and the pair (generic, dispatch value) is what tells those two
|
||||
apart. The [@] is what keeps the name out of a program's reach: no symbol a
|
||||
reader accepts contains one. *)
|
||||
let method_name (m : methd) = m.mgen ^ "@" ^ dispatch_text m.mkey
|
||||
|
||||
let declared_name (d : decl) =
|
||||
match d.d with
|
||||
| Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _)
|
||||
| Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) -> Some n
|
||||
| Declare (fn, _) | DeclareC (fn, _) | Defn fn -> Some fn.name
|
||||
| Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _)
|
||||
| Defclass (n, _) -> Some n
|
||||
| Declare (fn, _) | DeclareC (fn, _) | Defn fn
|
||||
| Defgeneric fn | Defmulti fn -> Some fn.name
|
||||
| Defmethod m -> Some (method_name m)
|
||||
| Package _ | Import _ -> None
|
||||
|
||||
(* ── Instrumenting a form with (pause) ─────────────────────────────── *)
|
||||
@ -279,7 +357,7 @@ let map_children f (e : expr) : expr =
|
||||
| Call (fn, args) -> Call (ex fn, List.map ex args)
|
||||
| Match (s, arms) -> Match (ex s, List.map arm arms)
|
||||
| Struct (n, fs) -> Struct (n, List.map (fun (n, v) -> (n, ex v)) fs)
|
||||
| MapLit kvs -> MapLit (List.map (fun (k, v) -> (ex k, ex v)) kvs)
|
||||
| MapLit (tag, kvs) -> MapLit (tag, List.map (fun (k, v) -> (ex k, ex v)) kvs)
|
||||
| Arr es -> Arr (List.map ex es)
|
||||
| Fn (ps, es) -> Fn (ps, List.map ex es)
|
||||
| Dotimes (l, n, c, es) -> Dotimes (l, n, ex c, List.map ex es)
|
||||
@ -331,6 +409,14 @@ let mark_pause ~line ~col (ds : decl list) : decl list option =
|
||||
hit := true;
|
||||
{ d with d = Defn { f with fbody = pause_call d.dloc :: f.fbody } }
|
||||
| Defn f -> { d with d = Defn { f with fbody = body f.fbody } }
|
||||
(* A method's body and a defmulti's dispatch body are code someone wrote
|
||||
and can stop inside, so both are walked. Marking the whole declaration
|
||||
— the [at d.dloc] case above — is deliberately not offered for either:
|
||||
a method is not a function of its own by the time it runs, so there is
|
||||
no entry to stop at, only the forms inside it. *)
|
||||
| Defmethod m ->
|
||||
{ d with d = Defmethod { m with mfn = { m.mfn with fbody = body m.mfn.fbody } } }
|
||||
| Defmulti f -> { d with d = Defmulti { f with fbody = body f.fbody } }
|
||||
| Defvar (n, t, Init e) -> { d with d = Defvar (n, t, Init (walk e)) }
|
||||
(* The value reading of an undecided [defvar] is walked too: if it is the
|
||||
one that wins it is an initialiser like any other, and if the type
|
||||
|
||||
66
lib/check.ml
66
lib/check.ml
@ -2417,7 +2417,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
|
||||
like any other dyn value would. The literal lowers to a fresh slot — a
|
||||
rooted one, because a slot of type dyn is what [dyn_roots] counts — so
|
||||
the map stays reachable across the allocations its own entries make. *)
|
||||
| Ast.MapLit kvs ->
|
||||
| Ast.MapLit (tag, kvs) ->
|
||||
let m = fresh_slot ctx Types.Dyn in
|
||||
let mval = mk loc Types.Dyn (Tast.Local m) in
|
||||
let sets =
|
||||
@ -2428,10 +2428,19 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr =
|
||||
check ctx ~want:Types.Dyn v ])
|
||||
kvs
|
||||
in
|
||||
(* A shape tag, if this is the literal a class's constructor was written
|
||||
from. It is the class's name interned as a keyword, and it goes into
|
||||
the object's header rather than into the entries — so everything below
|
||||
this line, the rooting included, is the untagged case unchanged. *)
|
||||
let empty =
|
||||
match tag with
|
||||
| None -> rt loc Types.Dyn "flan_dyn_map_new" []
|
||||
| Some cls ->
|
||||
rt loc Types.Dyn "flan_dyn_map_new_class"
|
||||
[ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ] ]
|
||||
in
|
||||
expect ctx loc ~want
|
||||
(mk loc Types.Dyn
|
||||
(Tast.Let ([ (m, rt loc Types.Dyn "flan_dyn_map_new" []) ],
|
||||
sets @ [ mval ])))
|
||||
(mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ])))
|
||||
| Ast.Quote _ ->
|
||||
unimplemented loc "a quoted symbol (restart names)" 6
|
||||
| Ast.Var name -> var ctx loc ~want name
|
||||
@ -5439,6 +5448,25 @@ and named_call ctx ~want loc name args =
|
||||
(Types.to_string other))
|
||||
| _ -> assert false)
|
||||
|
||||
(* (class-of v) -> the class's name as a keyword, or nil. It is the dyn
|
||||
side's one question about shape, and the dispatch a (defgeneric ...)
|
||||
compiles to is this call and a comparison — so what a class dispatcher
|
||||
is, exactly, is the shape tag of the first argument as the dispatch
|
||||
function, which is what makes the CLOS half and the Clojure half one
|
||||
mechanism rather than two.
|
||||
|
||||
Anything that is not an instance answers nil rather than trapping: an
|
||||
ordinary map, a number, nil itself. Asking is not a claim, and the
|
||||
question is askable of every value — the same line [get] takes about an
|
||||
absent key. *)
|
||||
| "class-of" ->
|
||||
arity loc name 1 args;
|
||||
(match args with
|
||||
| [ v ] ->
|
||||
expect ctx loc ~want
|
||||
(rt loc Types.Dyn "flan_dyn_class_of" [ check ctx ~want:Types.Dyn v ])
|
||||
| _ -> assert false)
|
||||
|
||||
(* (map-remove m k) -> (Option V): the value that was there, or None when
|
||||
the key was not. The same answer [get] gives, for the same reason — a key
|
||||
that is not in the map is an answer and not a failure — and the value
|
||||
@ -6779,6 +6807,12 @@ let builtins : (string * string * string) list =
|
||||
wants, where get would hand back an Option to match on. Over a dyn map \
|
||||
it is the question that stays askable when nil might also be stored \
|
||||
under the key.");
|
||||
("class-of", "class-of [dyn] dyn",
|
||||
"The class's name as a keyword for a value built by a defclass \
|
||||
constructor, and nil for everything else — an ordinary map included. \
|
||||
It is what a defgeneric dispatches on, so a class dispatcher is this \
|
||||
call over the first argument and a defmulti whose body is (class-of x) \
|
||||
is the same generic function written the other way.");
|
||||
("keyword", "keyword [string|[u8]] dyn",
|
||||
"The interned dyn keyword named by the bytes, for a name that only \
|
||||
exists at run time — a reader building :texture-path out of a token's \
|
||||
@ -7229,7 +7263,21 @@ let collect env (decls : Ast.decl list) =
|
||||
Hashtbl.replace env.globals n (ty, false)
|
||||
| Ast.Defconst (n, Some t, _) ->
|
||||
Hashtbl.replace env.globals n (resolve env t, true)
|
||||
| Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped)
|
||||
| Ast.Defconst (n, None, v) -> untyped := (n, v) :: !untyped
|
||||
(* [Classes.expand] ran at the top of [build_program] and left none of
|
||||
these behind, the way [Shim.expand] leaves no [declare-c] behind. A
|
||||
driver that assembled a declaration list and skipped that pass would
|
||||
otherwise get a missing name from wherever the constructor was
|
||||
called, with nothing pointing here. *)
|
||||
| Ast.Defclass (n, _) | Ast.Defgeneric { Ast.name = n; _ }
|
||||
| Ast.Defmulti { Ast.name = n; _ } ->
|
||||
fail loc
|
||||
"internal: %s reached the checker unexpanded — Classes.expand did \
|
||||
not run over this declaration list" n
|
||||
| Ast.Defmethod m ->
|
||||
fail loc
|
||||
"internal: a method of %s reached the checker unexpanded — \
|
||||
Classes.expand did not run over this declaration list" m.Ast.mgen)
|
||||
decls;
|
||||
(* Also to a fixpoint, and for the same reason: one untyped constant may be
|
||||
defined in terms of another declared after it. A constant that still does
|
||||
@ -8421,6 +8469,11 @@ let build_program ~keep_going (decls : Ast.decl list) : Tast.program * env =
|
||||
flattening comes back to be compiled into the build. Nothing below this
|
||||
line knows the form exists. *)
|
||||
let decls, cshim = Shim.expand decls in
|
||||
(* And on the same line: every class and generic function becomes the
|
||||
[defn]s it stands for. It runs over the whole list because a method may
|
||||
be written anywhere in it, which is also what makes a reload rebuild
|
||||
every dispatch from the session's declarations — see lib/classes.ml. *)
|
||||
let decls = Classes.expand decls in
|
||||
(* Pass one, and it stops at the first thing it refuses. That is not
|
||||
laziness: every name, type and signature in the file comes from here, so a
|
||||
declaration this pass could not make sense of leaves a hole that pass two
|
||||
@ -8791,6 +8844,9 @@ let memory_class (sym : string) (args : Tast.expr list) =
|
||||
gc "allocates: a dyn vector is an object on the collector's heap"
|
||||
| "flan_dyn_map_new" ->
|
||||
gc "allocates: a dyn map is an object on the collector's heap"
|
||||
| "flan_dyn_map_new_class" ->
|
||||
gc "allocates: a class instance is a dyn map on the collector's heap, \
|
||||
with the class's name in its header"
|
||||
| "flan_dyn_view_vec" | "flan_dyn_view_flat" ->
|
||||
gc "allocates: a typed container crossing into dyn takes a view record \
|
||||
on the collector's heap — the elements are not copied, the record is"
|
||||
|
||||
351
lib/classes.ml
Normal file
351
lib/classes.ml
Normal file
@ -0,0 +1,351 @@
|
||||
(** The dyn side's classes and generic functions, turned into ordinary
|
||||
declarations.
|
||||
|
||||
[(defclass point [x y])] is a constructor. [(defgeneric area [self] dyn)]
|
||||
and [(defmulti describe [x] dyn (get x :kind))] are each one function whose
|
||||
body is a dispatch, and [(defmethod area point [p] ...)] is a branch of
|
||||
one. Nothing below this pass knows any of the four forms exists: what it
|
||||
writes is [defn]s, and they are checked, emitted, rooted, redefined and
|
||||
inspected as any other function is.
|
||||
|
||||
**Why a pass and not a macro.** A macro sees one form. This needs the
|
||||
whole declaration list, because a method may be written anywhere — above
|
||||
its generic, below it, or at a reload an hour later — and the generic's
|
||||
body is not decidable until every method is in hand. The pass runs at the
|
||||
top of [Check.build_program], over the flat list an import has already
|
||||
been folded into, so a reload rebuilds every dispatch from the session's
|
||||
whole set of declarations and a method added to a running program is the
|
||||
ordinary redefinition of the one function that dispatches. [Shim.expand]
|
||||
is the precedent, form for form.
|
||||
|
||||
**Why the method bodies are inlined rather than lifted into functions of
|
||||
their own.** A generic is then exactly one top-level name, which is what
|
||||
makes adding a method at a reload work: the session installs the bodies
|
||||
the evaluated form declared, one name each, and a new method has to reach
|
||||
a call site that was compiled before it existed. One function means one
|
||||
cell to replace. The cost is that a method is not separately callable and
|
||||
does not appear as a frame of its own, which is recorded in FIX.org.
|
||||
|
||||
**What it does not do.** There is no inheritance, no multi-argument
|
||||
dispatch, and no :before/:after/:around — see FIX.org, 2026-09-20, for
|
||||
which of those were deferred and why. A method's dispatch value is a
|
||||
literal, so the specificity question CLOS answers with a class precedence
|
||||
list does not arise here: two methods either answer for the same value,
|
||||
which is refused, or for different ones. *)
|
||||
|
||||
let dyn_at loc : Ast.texpr = { Ast.t = Ast.Tname "dyn"; tloc = loc }
|
||||
|
||||
let ex loc (e : Ast.expr_kind) : Ast.expr = { Ast.e; loc }
|
||||
|
||||
(* The name the dispatch value is bound to inside a generic's body. [~] is a
|
||||
delimiter in the reader, so no symbol anyone can write is this one and no
|
||||
method body can shadow it or be shadowed by it. *)
|
||||
let dispatch_slot = "~dispatch"
|
||||
|
||||
(* The condition a generic signals when no method answers. Its struct is in
|
||||
the prelude; this is the only place that builds one. *)
|
||||
let no_method = "NoMethod"
|
||||
|
||||
(* ── Collecting ────────────────────────────────────────────────────── *)
|
||||
|
||||
type generic = {
|
||||
gkind : [ `Class | `Multi ];
|
||||
gfn : Ast.fn;
|
||||
gloc : Loc.t;
|
||||
(* In source order, which is dispatch order: the first method whose value
|
||||
matches answers, and since duplicates are refused the order is not
|
||||
observable except for [:else], which is moved to the end regardless. *)
|
||||
mutable gms : Ast.methd list;
|
||||
}
|
||||
|
||||
let collect (decls : Ast.decl list) =
|
||||
let classes : (string, Loc.t) Hashtbl.t = Hashtbl.create 8 in
|
||||
let generics : (string, generic) Hashtbl.t = Hashtbl.create 8 in
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defclass (n, slots) ->
|
||||
(* Two slots of one name would write one entry and read one value,
|
||||
and the constructor would take two arguments for it. The duplicate
|
||||
parameter that falls out of it is refused by the checker anyway;
|
||||
this says which declaration it came from. *)
|
||||
let seen = Hashtbl.create 8 in
|
||||
List.iter
|
||||
(fun (s, sloc) ->
|
||||
if Hashtbl.mem seen s then
|
||||
Loc.failk "check/duplicate-slot" sloc
|
||||
"%s names the slot %s twice. A slot is a key in the \
|
||||
instance's map, so the second would replace the first and \
|
||||
the constructor would take an argument that goes nowhere"
|
||||
n s;
|
||||
Hashtbl.replace seen s ())
|
||||
slots;
|
||||
Hashtbl.replace classes n d.Ast.dloc
|
||||
| Ast.Defgeneric fn ->
|
||||
Hashtbl.replace generics fn.Ast.name
|
||||
{ gkind = `Class; gfn = fn; gloc = d.Ast.dloc; gms = [] }
|
||||
| Ast.Defmulti fn ->
|
||||
Hashtbl.replace generics fn.Ast.name
|
||||
{ gkind = `Multi; gfn = fn; gloc = d.Ast.dloc; gms = [] }
|
||||
| _ -> ())
|
||||
decls;
|
||||
(* Methods second, so a method may be written above the generic it extends
|
||||
— which it has to be able to be, since a reload appends. *)
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defmethod m ->
|
||||
let g =
|
||||
match Hashtbl.find_opt generics m.Ast.mgen with
|
||||
| Some g -> g
|
||||
| None ->
|
||||
Loc.failk "check/unknown-generic" d.Ast.dloc
|
||||
"no defgeneric or defmulti names %s, so there is nothing for \
|
||||
this method to be a method of. A generic function is \
|
||||
declared once, with its parameters and its return type, and \
|
||||
the methods are written against it"
|
||||
m.Ast.mgen
|
||||
in
|
||||
(match m.Ast.mkey with
|
||||
| Ast.Dclass c when not (Hashtbl.mem classes c) ->
|
||||
Loc.failk "check/unknown-class" m.Ast.mkloc
|
||||
"no defclass names %s. A bare name in a method's dispatch slot \
|
||||
is a class, and stands for the shape tag its instances carry; \
|
||||
a dispatch value that is not a class is written as itself — a \
|
||||
keyword, a string, an integer"
|
||||
c
|
||||
| _ -> ());
|
||||
let n = List.length m.Ast.mfn.Ast.params
|
||||
and want = List.length g.gfn.Ast.params in
|
||||
if n <> want then
|
||||
Loc.failk "check/method-arity" d.Ast.dloc
|
||||
"%s takes %d argument%s and this method of it takes %d. Every \
|
||||
method of a generic function has the generic's own parameter \
|
||||
list: one call site reaches all of them, and it can only pass \
|
||||
one number of arguments"
|
||||
m.Ast.mgen want (if want = 1 then "" else "s") n;
|
||||
(* A class's name and its keyword are one dispatch value — a class
|
||||
stands for the keyword its instances carry, which is the whole of
|
||||
how the two dispatch styles share a mechanism — so [point] and
|
||||
[:point] have to be compared as one or the second method is
|
||||
accepted and is dead code. *)
|
||||
let norm = function Ast.Dclass c -> Ast.Dkw c | k -> k in
|
||||
List.iter
|
||||
(fun (prev : Ast.methd) ->
|
||||
if norm prev.Ast.mkey = norm m.Ast.mkey then
|
||||
Loc.failk "check/duplicate-method" d.Ast.dloc
|
||||
"%s already has a method for %s. Two methods for one \
|
||||
dispatch value is an ambiguity nothing resolves — there \
|
||||
is no specificity rule here, because a dispatch value is \
|
||||
a value and not a type"
|
||||
m.Ast.mgen (Ast.dispatch_text m.Ast.mkey))
|
||||
g.gms;
|
||||
g.gms <- g.gms @ [ m ]
|
||||
| _ -> ())
|
||||
decls;
|
||||
(classes, generics)
|
||||
|
||||
(* ── Writing the declarations ──────────────────────────────────────── *)
|
||||
|
||||
(* [(defclass point [x y])] becomes
|
||||
|
||||
(defn point [x dyn y dyn] dyn #point{:x x :y y})
|
||||
|
||||
— the constructor, positional, one argument per slot in the order the
|
||||
slots were written. The slots are keys in an ordinary dyn map, so [get],
|
||||
[put] and [has-key?] are how one is read and written and no new operation
|
||||
is needed for any of it. What the class adds is the tag on the map, which
|
||||
is what [class-of] answers and what a generic dispatches on.
|
||||
|
||||
Named-slot construction — the dyn twin of [(Cursor {.src s})], with an
|
||||
omitted slot meaning nil — is deferred, and so is refusing an unknown slot
|
||||
at [(get p :z)]. Both are recorded in FIX.org. *)
|
||||
let constructor n slots loc : Ast.decl =
|
||||
let params =
|
||||
List.map
|
||||
(fun (s, sloc) -> { Ast.fname = s; fty = dyn_at sloc; floc = sloc })
|
||||
slots
|
||||
in
|
||||
let pairs =
|
||||
List.map (fun (s, sloc) -> (ex sloc (Ast.Kw s), ex sloc (Ast.Var s))) slots
|
||||
in
|
||||
{ Ast.d =
|
||||
Ast.Defn
|
||||
{ Ast.name = n; params; praw = None; ret = Some (dyn_at loc);
|
||||
fwhere = []; fbody = [ ex loc (Ast.MapLit (Some n, pairs)) ];
|
||||
nloc = loc };
|
||||
dloc = loc }
|
||||
|
||||
(* The dispatch value a method answers for, as an expression to compare
|
||||
against. A class's name stands for the keyword its instances carry, which
|
||||
is the whole of how the CLOS half and the Clojure half share one
|
||||
mechanism: [(defgeneric area [self] dyn)] is [(defmulti area [self] dyn
|
||||
(class-of self))], and a method written for the class [point] is a method
|
||||
written for the value [:point]. *)
|
||||
let key_expr loc (k : Ast.dispatch) : Ast.expr =
|
||||
match k with
|
||||
| Ast.Dclass c -> ex loc (Ast.Kw c)
|
||||
| Ast.Dkw k -> ex loc (Ast.Kw k)
|
||||
| Ast.Dstr s -> ex loc (Ast.Str s)
|
||||
| Ast.Dint i -> ex loc (Ast.Int i)
|
||||
| Ast.Dbool b -> ex loc (Ast.Var (if b then "true" else "false"))
|
||||
| Ast.Delse -> assert false (* never compared: it is the else arm *)
|
||||
|
||||
(* A method's body, with the method's own parameter names bound to the
|
||||
generic's. The names are the method's to choose — [(defmethod area point [p]
|
||||
...)] under [(defgeneric area [self] dyn)] — and a method whose names
|
||||
already agree with the generic's binds nothing, so the common case adds no
|
||||
[let] at all.
|
||||
|
||||
**The rebinding is parallel, and it has to be.** A [let] here binds in
|
||||
sequence: each binding is in scope for the next one's value. So the
|
||||
pairwise spelling — [(let [b a a b] ...)] for a generic [[a b]] and a
|
||||
method [[b a]] — reads the [b] it has just bound and hands the method its
|
||||
first argument twice, with the second unreachable. That is a swap, and a
|
||||
swap is exactly what a method renaming its parameters is most likely to be
|
||||
doing; the non-swap case [[b c]] is the same bug one step shorter, since
|
||||
[b] reads the binding above it rather than the parameter. Both are what
|
||||
[rotatef] and Clojure's destructuring do in parallel, and neither language
|
||||
would read a name it was in the middle of rebinding.
|
||||
|
||||
So every argument is copied into a temp first and every method name is
|
||||
bound from a temp, never from a parameter. [~] is a delimiter in the
|
||||
reader, so the temps cannot collide with a method's names whatever they
|
||||
are, and one uniform shape is written rather than only the pairs that
|
||||
actually collide — a rule that fires only on the tangled case is a rule
|
||||
nobody exercises. *)
|
||||
let method_body (g : generic) (m : Ast.methd) : Ast.expr =
|
||||
let loc = m.Ast.mfn.Ast.nloc in
|
||||
let pairs = List.combine m.Ast.mfn.Ast.params g.gfn.Ast.params in
|
||||
if
|
||||
List.for_all
|
||||
(fun ((mp : Ast.field), (gp : Ast.field)) ->
|
||||
String.equal mp.Ast.fname gp.Ast.fname)
|
||||
pairs
|
||||
then ex loc (Ast.Do m.Ast.mfn.Ast.fbody)
|
||||
else begin
|
||||
let tmp i = Printf.sprintf "~arg%d" i in
|
||||
let hold =
|
||||
List.mapi
|
||||
(fun i ((_ : Ast.field), (gp : Ast.field)) ->
|
||||
{ Ast.bname = tmp i; bty = None;
|
||||
bval = ex gp.Ast.floc (Ast.Var gp.Ast.fname);
|
||||
bloc = gp.Ast.floc })
|
||||
pairs
|
||||
in
|
||||
let rename =
|
||||
List.mapi
|
||||
(fun i ((mp : Ast.field), (_ : Ast.field)) ->
|
||||
{ Ast.bname = mp.Ast.fname; bty = None;
|
||||
bval = ex mp.Ast.floc (Ast.Var (tmp i));
|
||||
bloc = mp.Ast.floc })
|
||||
pairs
|
||||
in
|
||||
ex loc (Ast.Let (hold @ rename, m.Ast.mfn.Ast.fbody))
|
||||
end
|
||||
|
||||
(* What a generic answers when no method does. Common Lisp signals here and
|
||||
so does this: it is a condition with a handler-case around it, not a trap,
|
||||
because a dispatch that missed is a thing a program can be written to
|
||||
answer — a default, a log line, a fallback object — and a trap would take
|
||||
that away. [error] rather than [signal] because there is no value to carry
|
||||
on with if nothing handles it.
|
||||
|
||||
No restart is established at the miss. That is BoundsError's and
|
||||
ArithError's decision, taken here for their reason: a restart frame is
|
||||
allocated by the form that offers it, and the ones that matter — a frame
|
||||
loop's [continue] — are already on the stack and reachable from a handler
|
||||
without this form pushing anything. *)
|
||||
let miss loc gname : Ast.expr =
|
||||
ex loc
|
||||
(Ast.Signal
|
||||
(Ast.Serror,
|
||||
ex loc
|
||||
(Ast.Struct
|
||||
(no_method,
|
||||
[ ("generic", ex loc (Ast.Str gname));
|
||||
("value", ex loc (Ast.Var dispatch_slot)) ]))))
|
||||
|
||||
let dispatcher (g : generic) : Ast.decl =
|
||||
let loc = g.gloc in
|
||||
let gname = g.gfn.Ast.name in
|
||||
(* The value the methods are keyed by. A defgeneric computes it — the shape
|
||||
tag of the first argument — and a defmulti's own body is it. *)
|
||||
let value =
|
||||
match g.gkind with
|
||||
| `Multi -> ex loc (Ast.Do g.gfn.Ast.fbody)
|
||||
| `Class ->
|
||||
(match g.gfn.Ast.params with
|
||||
| p :: _ ->
|
||||
ex loc
|
||||
(Ast.Call (ex loc (Ast.Var "class-of"),
|
||||
[ ex p.Ast.floc (Ast.Var p.Ast.fname) ]))
|
||||
| [] ->
|
||||
Loc.failk "check/method-arity" loc
|
||||
"%s takes no arguments, and a defgeneric dispatches on the class \
|
||||
of its first one. Write a defmulti, whose body says what to \
|
||||
dispatch on"
|
||||
gname)
|
||||
in
|
||||
(* [:else] last whatever order it was written in, because it is the arm
|
||||
everything else falls through to and not a value to compare against. *)
|
||||
let fallback, cases =
|
||||
List.partition (fun (m : Ast.methd) -> m.Ast.mkey = Ast.Delse) g.gms
|
||||
in
|
||||
let last =
|
||||
match fallback with
|
||||
| m :: _ -> method_body g m
|
||||
| [] -> miss loc gname
|
||||
in
|
||||
let chain =
|
||||
List.fold_right
|
||||
(fun (m : Ast.methd) rest ->
|
||||
let kloc = m.Ast.mkloc in
|
||||
ex kloc
|
||||
(Ast.If
|
||||
(ex kloc
|
||||
(Ast.Call (ex kloc (Ast.Var "="),
|
||||
[ ex kloc (Ast.Var dispatch_slot);
|
||||
key_expr kloc m.Ast.mkey ])),
|
||||
method_body g m, Some rest)))
|
||||
cases last
|
||||
in
|
||||
{ Ast.d =
|
||||
Ast.Defn
|
||||
{ g.gfn with
|
||||
Ast.fbody =
|
||||
[ ex loc
|
||||
(Ast.Let ([ { Ast.bname = dispatch_slot; bty = None;
|
||||
bval = value; bloc = loc } ],
|
||||
[ chain ])) ] };
|
||||
dloc = loc }
|
||||
|
||||
(** Every [defclass], [defgeneric], [defmulti] and [defmethod] in the list,
|
||||
replaced by the [defn]s they stand for. Everything else is untouched and
|
||||
keeps its position: a constructor is written where its class was and a
|
||||
dispatch where its generic was, so declaration order — which is emission
|
||||
order for globals — does not move. *)
|
||||
let expand (decls : Ast.decl list) : Ast.decl list =
|
||||
let has =
|
||||
List.exists
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defclass _ | Ast.Defgeneric _ | Ast.Defmulti _
|
||||
| Ast.Defmethod _ -> true
|
||||
| _ -> false)
|
||||
decls
|
||||
in
|
||||
if not has then decls
|
||||
else begin
|
||||
let _classes, generics = collect decls in
|
||||
List.filter_map
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defclass (n, slots) -> Some (constructor n slots d.Ast.dloc)
|
||||
| Ast.Defgeneric fn | Ast.Defmulti fn ->
|
||||
Some (dispatcher (Hashtbl.find generics fn.Ast.name))
|
||||
(* Gone: its body is inside its generic's dispatch. *)
|
||||
| Ast.Defmethod _ -> None
|
||||
| _ -> Some d)
|
||||
decls
|
||||
end
|
||||
12
lib/emit.ml
12
lib/emit.ml
@ -3619,6 +3619,8 @@ declare i64 @flan_dyn_from_bool(i32)
|
||||
declare i64 @flan_dyn_from_bytes(ptr, i64)
|
||||
declare i64 @flan_dyn_vec_new()
|
||||
declare i64 @flan_dyn_map_new()
|
||||
declare i64 @flan_dyn_map_new_class(i64)
|
||||
declare i64 @flan_dyn_class_of(i64)
|
||||
declare i64 @flan_dyn_kw(ptr, i64)
|
||||
declare i64 @flan_dyn_map_get(i64, i64)
|
||||
declare void @flan_dyn_map_set(i64, i64, i64)
|
||||
@ -4034,7 +4036,15 @@ let descriptors_asm m =
|
||||
"\n# The per-type dyn descriptors — runtime/flan_dyn.h's flan_desc: the\n\
|
||||
# size of one instance, how many dyn words it holds, and where they are.\n\
|
||||
# Read by the collector through flan_dyn_root_push_desc and by nothing\n\
|
||||
# else; no value points at one.\n\t.section\t.rodata\n";
|
||||
# else; no value points at one.\n\
|
||||
#\n\
|
||||
# .data.rel.ro and not .rodata, because a descriptor holds the address\n\
|
||||
# of its own offset table. That is a relocation, and a relocation in a\n\
|
||||
# read-only section is one the dynamic linker can only apply by making\n\
|
||||
# the section writable — a DT_TEXTREL, which ld warns about in a PIE\n\
|
||||
# and refuses outright in a shared object. .data.rel.ro is the section\n\
|
||||
# for exactly this: relocated at load and read-only from then on.\n\
|
||||
\t.section\t.data.rel.ro,\"aw\",@progbits\n";
|
||||
List.iter
|
||||
(fun (_, (sym, offs, size)) ->
|
||||
Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym);
|
||||
|
||||
69
lib/load.ml
69
lib/load.ml
@ -267,8 +267,11 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
|
||||
Ast.Struct (name n, List.map (fun (k, v) -> (k, go v)) kvs)
|
||||
(* A dyn map literal has no name of its own to qualify; its keys and
|
||||
values are ordinary expressions and are walked like anything else. *)
|
||||
| Ast.MapLit kvs ->
|
||||
Ast.MapLit (List.map (fun (k, v) -> (go k, go v)) kvs)
|
||||
| Ast.MapLit (tag, kvs) ->
|
||||
(* The tag is a class's name and is already qualified: the only thing
|
||||
that writes one is [Classes.expand], which runs over the flat list
|
||||
after every import has been folded into it. *)
|
||||
Ast.MapLit (tag, List.map (fun (k, v) -> (go k, go v)) kvs)
|
||||
| Ast.Arr items -> Ast.Arr (gos items)
|
||||
| Ast.ArrayOf t -> Ast.ArrayOf (rename_texpr owned alias t)
|
||||
| Ast.Fn (ps, body) ->
|
||||
@ -358,6 +361,18 @@ let rename_pitem owned alias (p : Ast.pitem) : Ast.pitem =
|
||||
| Ast.Pname _ -> p
|
||||
| Ast.Ptype t -> Ast.Ptype (rename_texpr owned alias t)
|
||||
|
||||
(* A generic function's or a method's signature and body. Its parameters are
|
||||
all [dyn] and were written out by the parser, so unlike a [defn]'s there is
|
||||
no undecided vector to qualify and the names the body may shadow are simply
|
||||
the parameter names. The declared name is qualified by the caller, which
|
||||
for a method is not [fn.name] at all. *)
|
||||
let qualify_dyn_fn owned alias (fn : Ast.fn) : Ast.fn =
|
||||
let bound = List.map (fun (p : Ast.field) -> p.Ast.fname) fn.Ast.params in
|
||||
{ fn with
|
||||
Ast.name = qualify alias fn.Ast.name;
|
||||
ret = Option.map (rename_texpr owned alias) fn.Ast.ret;
|
||||
fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody }
|
||||
|
||||
let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
|
||||
let loc = d.Ast.dloc in
|
||||
let k =
|
||||
@ -432,6 +447,41 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
|
||||
params; praw;
|
||||
ret = Option.map (rename_texpr owned alias) fn.Ast.ret;
|
||||
fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody }
|
||||
(* ── The class forms ──────────────────────────────────────────────
|
||||
[Classes.expand] has not run — it runs over the whole flat list, after
|
||||
every import has been folded into it — so these arrive here as written
|
||||
and the rename is the ordinary one: the declared name, plus whatever
|
||||
inside them is a name of this package.
|
||||
|
||||
A class's slots are not renamed. They are keywords in the map the
|
||||
constructor builds, and a keyword belongs to nobody — the same line the
|
||||
[MapLit] arm above takes about a map literal's keys. The *class's* name
|
||||
is qualified, so [pkg/point] is what an instance's shape tag reads and
|
||||
two packages' [point] classes are two classes. *)
|
||||
| Ast.Defclass (n, slots) -> Ast.Defclass (qualify alias n, slots)
|
||||
(* A generic's parameters are dyn and were written out by the parser, so
|
||||
there is no unpaired vector here and [bound] is exactly the parameter
|
||||
names. *)
|
||||
| Ast.Defgeneric fn -> Ast.Defgeneric (qualify_dyn_fn owned alias fn)
|
||||
| Ast.Defmulti fn -> Ast.Defmulti (qualify_dyn_fn owned alias fn)
|
||||
(* Both halves of the head are names this package owns or does not: the
|
||||
generic being extended, and — when the dispatch value is a class — the
|
||||
class being dispatched on. A method written in one package for another
|
||||
package's generic therefore keeps working, because [owned] answers no
|
||||
for that name and the alias-qualified spelling the source wrote is left
|
||||
alone by [rename_expr]'s rule. *)
|
||||
| Ast.Defmethod m ->
|
||||
let mkey =
|
||||
match m.Ast.mkey with
|
||||
| Ast.Dclass c when List.mem c owned -> Ast.Dclass (qualify alias c)
|
||||
| k -> k
|
||||
in
|
||||
let mgen = if List.mem m.Ast.mgen owned then qualify alias m.Ast.mgen
|
||||
else m.Ast.mgen in
|
||||
let mfn = qualify_dyn_fn owned alias m.Ast.mfn in
|
||||
Ast.Defmethod
|
||||
{ m with Ast.mgen; mkey;
|
||||
mfn = { mfn with Ast.name = mgen ^ "@" ^ Ast.dispatch_text mkey } }
|
||||
| Ast.Package _ -> Ast.Package alias
|
||||
(* A package's own imports were resolved before this ran and are not in
|
||||
the list it is given, so one arriving here is a bug in [import] rather
|
||||
@ -681,7 +731,7 @@ let rec expr_uses acc (e : Ast.expr) =
|
||||
| Ast.Struct (n, kvs) ->
|
||||
acc := (n, e.Ast.loc) :: !acc;
|
||||
List.iter (fun (_, v) -> go v) kvs
|
||||
| Ast.MapLit kvs -> List.iter (fun (k, v) -> go k; go v) kvs
|
||||
| Ast.MapLit (_, kvs) -> List.iter (fun (k, v) -> go k; go v) kvs
|
||||
| Ast.Arr items -> gos items
|
||||
| Ast.ArrayOf t -> texpr_uses acc t
|
||||
| Ast.Fn (_, body) -> gos body
|
||||
@ -755,6 +805,19 @@ let decl_uses acc (d : Ast.decl) =
|
||||
| Ast.Zeroed | Ast.Uninit -> ())
|
||||
| Ast.Defconst (_, t, v) ->
|
||||
Option.iter (texpr_uses acc) t; expr_uses acc v
|
||||
(* A class's slots are keywords and name nothing. Its constructor's body is
|
||||
written by [Classes.expand], long after this, out of the slots alone. *)
|
||||
| Ast.Defclass _ -> ()
|
||||
| Ast.Defgeneric f | Ast.Defmulti f -> fn f
|
||||
(* The generic is a use — a method in one package extending another's has to
|
||||
pull that package in — and so is the class in the dispatch slot, for the
|
||||
same reason a type in a signature is. *)
|
||||
| Ast.Defmethod m ->
|
||||
acc := (m.Ast.mgen, d.Ast.dloc) :: !acc;
|
||||
(match m.Ast.mkey with
|
||||
| Ast.Dclass c -> acc := (c, m.Ast.mkloc) :: !acc
|
||||
| _ -> ());
|
||||
fn m.Ast.mfn
|
||||
|
||||
let uses (ds : Ast.decl list) =
|
||||
let acc = ref [] in
|
||||
|
||||
121
lib/parse.ml
121
lib/parse.ml
@ -140,6 +140,52 @@ and pitems (items : Form.t list) : Ast.pitem list =
|
||||
| _ -> Ast.Ptype (texpr it))
|
||||
items
|
||||
|
||||
(* A generic's or a method's parameter vector. Every slot is a bare name and
|
||||
every parameter is [dyn], so the types are written out here rather than
|
||||
left for [Check.pair_params] to decide: the pairing exists because a
|
||||
[defn]'s vector is ambiguous until every type name is known, and this one
|
||||
never is. A parameter named after a type is therefore fine here, where in a
|
||||
[defn] it would be refused. *)
|
||||
and dyn_params which (items : Form.t list) : Ast.field list =
|
||||
List.map
|
||||
(fun (it : Form.t) ->
|
||||
match it.v with
|
||||
| Sym s ->
|
||||
{ Ast.fname = s;
|
||||
fty = { Ast.t = Ast.Tname "dyn"; tloc = it.loc };
|
||||
floc = it.loc }
|
||||
| _ ->
|
||||
fail it
|
||||
"a %s's parameter is a bare name, and found %s. Every parameter of \
|
||||
a generic function is dyn — there is no type to write, and a \
|
||||
method that wanted one could not be reached by a dispatch that \
|
||||
does not know types either"
|
||||
which (Form.to_string it))
|
||||
items
|
||||
|
||||
(* A [defmethod]'s dispatch value. Literals only: the value is compared
|
||||
against what the dispatch answered at run time, and the method is declared
|
||||
under a name built from it at compile time, so it has to be something both
|
||||
passes can read off the source. A computed one — Clojure allows any value a
|
||||
method is registered under, because registration there is a run-time call —
|
||||
is not available and the message says so. *)
|
||||
and dispatch (f : Form.t) : Ast.dispatch =
|
||||
match f.v with
|
||||
| Kw "else" -> Ast.Delse
|
||||
| Sym "true" -> Ast.Dbool true
|
||||
| Sym "false" -> Ast.Dbool false
|
||||
| Sym s -> Ast.Dclass s
|
||||
| Kw k -> Ast.Dkw k
|
||||
| Str s -> Ast.Dstr s
|
||||
| Int i -> Ast.Dint i
|
||||
| _ ->
|
||||
fail f
|
||||
"a method's dispatch value is a class's name, a keyword, a string, an \
|
||||
integer, true, false, or :else for the one that answers when no other \
|
||||
does — and found %s. It is matched at compile time as well as at run \
|
||||
time, so it is written out rather than computed"
|
||||
(Form.to_string f)
|
||||
|
||||
(* ── The constraint map at the head of a defn body ──────────────────────
|
||||
[(defn sort [s [$t]] () {:where (ordered? $t)} body ...)]. Clojure's
|
||||
[{:pre [...] :post [...]}] is the precedent and the reason it is a map
|
||||
@ -274,7 +320,7 @@ let rec expr (f : Form.t) : Ast.expr =
|
||||
| Map ({ v = Sym s; _ } :: _)
|
||||
when String.length s > 1 && s.[0] = '.' ->
|
||||
fail f "a bare map is not an expression; write (Type {.field v})"
|
||||
| Map items -> mk (Ast.MapLit (map_pairs f items))
|
||||
| Map items -> mk (Ast.MapLit (None, map_pairs f items))
|
||||
| List [] -> fail f "() is not an expression"
|
||||
| List (head :: args) -> form f mk head args
|
||||
|
||||
@ -567,7 +613,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
|
||||
output rather than a dependency. Building a declaration as a value is what
|
||||
a macro is for. *)
|
||||
| Sym ("defmacro" | "defn" | "defvar" | "defconst" | "defstruct" | "defdata"
|
||||
| "defunion"
|
||||
| "defunion" | "defclass" | "defgeneric" | "defmulti" | "defmethod"
|
||||
| "defenum" | "defalias" | "import" as name) ->
|
||||
fail f
|
||||
"%s is a top-level declaration, not an expression. A quasiquoted one is \
|
||||
@ -1215,6 +1261,77 @@ let rec decl (f : Form.t) : Ast.decl =
|
||||
"defn is (defn name [param Type ...] ReturnType body ...). The return \
|
||||
type is not optional; a function that returns nothing writes ()")
|
||||
|
||||
(* ── The dyn side's classes and generic functions ──────────────────
|
||||
Four forms, all of them shorthand: nothing below [Classes.expand] knows
|
||||
they exist, and what it writes in their place is ordinary [defn]s. The
|
||||
parsing here is only the shape check — which slots are present, and what
|
||||
kind of thing is in each — because everything that needs the other
|
||||
declarations to answer (is that a class? is there a generic by that
|
||||
name? has this dispatch value a method already?) is the expansion's.
|
||||
|
||||
Every parameter of a generic and of a method is [dyn], written or not,
|
||||
so a parameter vector here takes bare names and nothing else. That is
|
||||
what keeps these off [defn]'s undecided-pairing path: a [defn]'s vector
|
||||
cannot be read until every type name is known, and one that may hold
|
||||
only names can be read here. *)
|
||||
| List ({ v = Sym "defclass"; _ } :: args) ->
|
||||
(match args with
|
||||
| [ n; { v = Vec slots; _ } ] ->
|
||||
mk (Ast.Defclass
|
||||
(sym n,
|
||||
List.map
|
||||
(fun (s : Form.t) ->
|
||||
match s.v with
|
||||
| Sym name -> (name, s.loc)
|
||||
| _ ->
|
||||
fail s
|
||||
"a class slot is a name. Its value is dyn and there is \
|
||||
no type to write: an instance is a dyn map with a \
|
||||
shape tag on it, and (get p :%s) is how a slot is read"
|
||||
(Form.to_string s))
|
||||
slots))
|
||||
| _ -> fail f "defclass is (defclass Name [slot ...])")
|
||||
|
||||
| List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) ->
|
||||
let generic = String.equal which "defgeneric" in
|
||||
let usage =
|
||||
if generic then
|
||||
"defgeneric is (defgeneric name [param ...] ReturnType). It has no \
|
||||
body: its dispatch value is the class of its first argument, which \
|
||||
is what makes it the class-dispatching half of the pair. Write \
|
||||
defmulti for a dispatch value of your own"
|
||||
else
|
||||
"defmulti is (defmulti name [param ...] ReturnType body ...), and the \
|
||||
body is the dispatch: it answers the value the methods are keyed by"
|
||||
in
|
||||
(match args with
|
||||
| n :: { v = Vec ps; _ } :: ret :: body
|
||||
when if generic then body = [] else body <> [] ->
|
||||
mk ((if generic then (fun fn -> Ast.Defgeneric fn)
|
||||
else fun fn -> Ast.Defmulti fn)
|
||||
{ Ast.name = sym n; params = dyn_params which ps; praw = None;
|
||||
ret = Some (texpr ret); fwhere = []; fbody = body_of body;
|
||||
nloc = n.loc })
|
||||
| _ -> fail f "%s" usage)
|
||||
|
||||
| List ({ v = Sym "defmethod"; _ } :: args) ->
|
||||
(match args with
|
||||
| n :: key :: { v = Vec ps; _ } :: body when body <> [] ->
|
||||
let gen = sym n and k = dispatch key in
|
||||
mk (Ast.Defmethod
|
||||
{ Ast.mgen = gen; mkey = k; mkloc = key.loc;
|
||||
(* The name is the declaration's, not a symbol anything emits:
|
||||
no function is ever written under it. *)
|
||||
mfn = { Ast.name = gen ^ "@" ^ Ast.dispatch_text k;
|
||||
params = dyn_params "defmethod" ps; praw = None;
|
||||
ret = None; fwhere = []; fbody = body_of body;
|
||||
nloc = n.loc } })
|
||||
| _ ->
|
||||
fail f
|
||||
"defmethod is (defmethod generic dispatch [param ...] body ...). \
|
||||
There is no return type: the generic states it once, for every \
|
||||
method written for it")
|
||||
|
||||
| List ({ v = Sym ("declare" | "declare-c" as which); _ } :: args) ->
|
||||
(* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is
|
||||
last and is always written: a foreign name is not derivable from a Flan
|
||||
|
||||
@ -148,6 +148,28 @@ let source = {flan|
|
||||
;; pushed here.
|
||||
(defstruct ArithError [op i32 lhs i64 rhs i64])
|
||||
|
||||
;; What a generic function signals when no method answers. `generic` is the
|
||||
;; name written at the defgeneric or defmulti, and `value` is what the
|
||||
;; dispatch actually produced -- the class of the first argument for a
|
||||
;; defgeneric, whatever the body answered for a defmulti. A miss is nil for
|
||||
;; the common case of a value that is not an instance at all.
|
||||
;;
|
||||
;; A condition and not a trap, and that is the decision rather than the
|
||||
;; obvious default: Common Lisp signals here, and a dispatch that missed is
|
||||
;; something a program can be written to answer -- a default object, a log
|
||||
;; line, a fallback -- which a trap would take away. `handler-case` around
|
||||
;; the call is the shape, and a method written for `:else` is the other
|
||||
;; answer, in the generic rather than at the call.
|
||||
;;
|
||||
;; `value` is dyn, which is the one field type no other condition here has.
|
||||
;; It is the honest one: a dispatch value is whatever the dispatch answered
|
||||
;; and there is no narrower type it has. The collector reaches it through the
|
||||
;; per-type descriptor a struct with a dyn field carries.
|
||||
;;
|
||||
;; No restart is established at the miss, which is BoundsError's decision
|
||||
;; taken for BoundsError's reason -- see the note above it.
|
||||
(defstruct NoMethod [generic string value dyn])
|
||||
|
||||
;; A breakpoint. (pause) stops the program where it stands and hands it to the
|
||||
;; break loop, with the whole stack under it readable — C-c C-b lists the
|
||||
;; frames, TAB opens one, and taking `continue` resumes at the call.
|
||||
|
||||
@ -586,7 +586,21 @@ let eval ?(origin = "<eval>") ?pause t src : change =
|
||||
fail loc "nothing to pause at line %d, column %d of the form sent"
|
||||
line col)
|
||||
in
|
||||
let names = List.filter_map Ast.declared_name incoming in
|
||||
(* A method declares a name of its own — that is what makes evaluating one
|
||||
twice a replacement and evaluating a new one an append, through the same
|
||||
kept/added logic every other declaration goes through. But no function is
|
||||
emitted under that name: a method's body is inlined into its generic's
|
||||
dispatch by [Classes.expand], so the body that has to be installed is the
|
||||
*generic's*. Naming it here is what makes [C-c C-c] on a defmethod reach
|
||||
a call site compiled before the method existed, which is the whole of why
|
||||
this feature is usable in the loop the project exists for. *)
|
||||
let names =
|
||||
List.filter_map Ast.declared_name incoming
|
||||
@ List.filter_map
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None)
|
||||
incoming
|
||||
in
|
||||
let replacement n =
|
||||
List.find_opt
|
||||
(fun (d : Ast.decl) -> Ast.declared_name d = Some n)
|
||||
|
||||
11
lib/x86.ml
11
lib/x86.ml
@ -4922,6 +4922,17 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
|
||||
\t.size\tflan_reload_transient, 1\n\
|
||||
flan_reload_transient:\n\t.byte\t1\n"
|
||||
| _ -> ());
|
||||
(* The per-type dyn descriptors this module's own bodies asked for, exactly
|
||||
as [program] emits them. They were missing here, and the hole only became
|
||||
reachable when a redefined body first constructed a struct holding a dyn:
|
||||
[desc_of] mints a local label and the body references it, so a module
|
||||
that never wrote the label out is one [ld] refuses with an undefined
|
||||
symbol rather than one that loads and reads garbage. The labels are local
|
||||
in both backends — [desc_of] says so, and this is the other half of that
|
||||
sentence — so emitting the same type's descriptor here and in the host is
|
||||
not a duplicate symbol. [Emit.redefinition] has always emitted them, by
|
||||
going through [finish]. *)
|
||||
Buffer.add_string out (Emit.descriptors_asm md);
|
||||
Buffer.add_string out "\n\t.section\t.rodata\n";
|
||||
Buffer.add_buffer out rodata;
|
||||
Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n";
|
||||
|
||||
@ -220,6 +220,11 @@ typedef struct flan_dyn_alloc_hdr {
|
||||
uint64_t epoch;
|
||||
} flan_dyn_alloc_hdr;
|
||||
|
||||
/* A keyword's interned entry, declared here because a map's shape tag is one.
|
||||
* The definition, the table and the argument for interning are further down,
|
||||
* under "Keywords". */
|
||||
struct kw_entry;
|
||||
|
||||
typedef struct flan_obj {
|
||||
struct flan_obj *next; /* every object ever allocated, newest first */
|
||||
uint8_t kind;
|
||||
@ -228,7 +233,26 @@ typedef struct flan_obj {
|
||||
of a map */
|
||||
union {
|
||||
int64_t i; /* OBJ_INT */
|
||||
struct { flan_dyn *items; int64_t cap; } v; /* OBJ_VEC and OBJ_MAP —
|
||||
struct { flan_dyn *items; int64_t cap;
|
||||
/* OBJ_MAP only, and NULL for every map that is not a defclass
|
||||
instance: the shape tag. It is the interned entry of the
|
||||
class's name — :point for (defclass point [x y]) — so the
|
||||
identity compare that makes keyword equality cheap is also
|
||||
what makes a class check cheap, and the tag needs no marking
|
||||
because an interned entry is immortal and is not a GC object
|
||||
(see [mark_value], which follows BOX_OBJ and nothing else).
|
||||
|
||||
It lives in the header rather than in a reserved entry of the
|
||||
map itself, which is the one place this departs from the
|
||||
queue's note: an entry would be counted by [len], walked by
|
||||
[render], and compared by [dyn_equal]'s key loop, so every
|
||||
instance would answer a length one larger than its slot count
|
||||
and print a key nobody wrote. A field cannot be reached by
|
||||
[get] or [put] at all, so no user key can collide with it.
|
||||
|
||||
A vec leaves it NULL. The arm is shared, so the field exists
|
||||
for both kinds; nothing reads it for an OBJ_VEC. */
|
||||
struct kw_entry *klass; } v; /* OBJ_VEC and OBJ_MAP —
|
||||
a map shares the vec's arm on purpose: its entries are the same malloc
|
||||
block of dyn words, interleaved key then value, with [len] counting
|
||||
entries and [cap] counting entries too. Sharing the arm is what lets the
|
||||
@ -555,6 +579,13 @@ static void render(flan_dyn v, int depth, int nested) {
|
||||
case FLAN_DYN_TAG_MAP: {
|
||||
flan_obj *o = dyn_obj(v);
|
||||
int64_t i;
|
||||
/* A class instance prints its shape tag in front, Clojure's own spelling
|
||||
* for a record: #point{ :x 1 :y 2}. The tag is not an entry, so it is
|
||||
* written here or it is not written at all. */
|
||||
if (o->u.v.klass != NULL) {
|
||||
emit("#");
|
||||
emit_n(kw_bytes(o->u.v.klass), o->u.v.klass->len);
|
||||
}
|
||||
emit("{");
|
||||
for (i = 0; i < o->len; i++) {
|
||||
emit(" ");
|
||||
@ -651,6 +682,19 @@ static void say_render(sayer *s, flan_dyn v, int depth) {
|
||||
flan_obj *o = dyn_obj(v);
|
||||
int64_t i;
|
||||
if (depth >= 2) { say_puts(s, "{...}"); return; }
|
||||
/* The same tag [render] writes, so a trap sentence naming an instance
|
||||
* says which class it was. Truncated with the rest when the buffer is
|
||||
* short: [say] is a 96-byte sentence, not a printer. */
|
||||
if (o->u.v.klass != NULL && s->n < s->cap - 8) {
|
||||
int64_t j;
|
||||
say_puts(s, "#");
|
||||
for (j = 0; j < o->u.v.klass->len && s->n < s->cap - 8; j++) {
|
||||
char c[2];
|
||||
c[0] = (char)kw_bytes(o->u.v.klass)[j];
|
||||
c[1] = '\0';
|
||||
say_puts(s, c);
|
||||
}
|
||||
}
|
||||
say_puts(s, "{");
|
||||
for (i = 0; i < o->len && s->n < s->cap - 8; i++) {
|
||||
say_puts(s, " ");
|
||||
@ -1015,6 +1059,9 @@ flan_dyn flan_dyn_vec_new(void) {
|
||||
o->len = 0;
|
||||
o->u.v.items = NULL;
|
||||
o->u.v.cap = 0;
|
||||
/* Shared arm, and nothing reads this for a vec; written anyway so that the
|
||||
field's value is never whatever [gc_alloc] happened to leave. */
|
||||
o->u.v.klass = NULL;
|
||||
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
||||
}
|
||||
|
||||
@ -1023,9 +1070,37 @@ flan_dyn flan_dyn_map_new(void) {
|
||||
o->len = 0;
|
||||
o->u.v.items = NULL;
|
||||
o->u.v.cap = 0;
|
||||
o->u.v.klass = NULL;
|
||||
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
||||
}
|
||||
|
||||
/* The same map with a shape tag on it: what a (defclass ...) constructor
|
||||
* calls. [k] is a keyword and anything else traps by name — the compiler
|
||||
* hands it the class's own name and nothing else can reach this. */
|
||||
flan_dyn flan_dyn_map_new_class(flan_dyn k) {
|
||||
flan_obj *o;
|
||||
if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD)
|
||||
trap1(TYPE_TRAP, "class instance", "a class tag is a keyword", k);
|
||||
o = gc_alloc(OBJ_MAP, 0);
|
||||
o->len = 0;
|
||||
o->u.v.items = NULL;
|
||||
o->u.v.cap = 0;
|
||||
o->u.v.klass = dyn_kw(k);
|
||||
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
||||
}
|
||||
|
||||
/* The shape tag, as a value: the class's name as a keyword, or nil. Never
|
||||
* traps. Absence is an answer here for the reason it is one in [map_get] —
|
||||
* asking what class a value is, is a question every value can be asked, and
|
||||
* an ordinary map, a number and nil all truthfully answer "none". */
|
||||
flan_dyn flan_dyn_class_of(flan_dyn v) {
|
||||
flan_obj *o;
|
||||
if (flan_dyn_tag(v) != FLAN_DYN_TAG_MAP) return flan_dyn_nil();
|
||||
o = dyn_obj(v);
|
||||
if (o->u.v.klass == NULL) return flan_dyn_nil();
|
||||
return dyn_make(BOX_KW, (uint64_t)(uintptr_t)o->u.v.klass);
|
||||
}
|
||||
|
||||
/* ── Keywords ──────────────────────────────────────────────────────────
|
||||
*
|
||||
* One global table, append-only, never freed: a keyword is a *name*, the set
|
||||
@ -1483,6 +1558,12 @@ static int dyn_equal(flan_dyn a, flan_dyn b, int depth) {
|
||||
int64_t i, j;
|
||||
if (x == y) return 1;
|
||||
if (depth >= EQ_DEPTH) return 0;
|
||||
/* The shape tag is part of the value. Two instances of one class compare
|
||||
* by their entries as any two maps do; an instance and a plain map with
|
||||
* the same entries do not, which is Clojure's answer for a record beside
|
||||
* a map and is the only answer a tag can have if it means anything. An
|
||||
* identity compare, because both sides are interned entries. */
|
||||
if (x->u.v.klass != y->u.v.klass) return 0;
|
||||
if (x->len != y->len) return 0;
|
||||
for (i = 0; i < x->len; i++) {
|
||||
flan_dyn k = x->u.v.items[i * 2];
|
||||
|
||||
@ -76,6 +76,24 @@ flan_dyn flan_dyn_from_bytes(const uint8_t *p, int64_t n);
|
||||
flan_dyn flan_dyn_vec_new(void);
|
||||
flan_dyn flan_dyn_map_new(void);
|
||||
|
||||
/* A map carrying a shape tag: what a (defclass point [x y]) constructor
|
||||
* builds. [k] is the class's name as a keyword and anything else traps.
|
||||
*
|
||||
* The tag lives in the object's header and not in an entry of the map, so it
|
||||
* is invisible to [get], [set], [contains] and [len] — an instance's length
|
||||
* is its slot count and no key a program can write collides with it. What can
|
||||
* see it is [flan_dyn_class_of], [flan_dyn_eq] (two values of different
|
||||
* classes are unequal, and an instance is never equal to a plain map) and
|
||||
* [flan_dyn_print] (an instance renders as #point{ :x 1 :y 2}).
|
||||
*
|
||||
* The tag is not traced and does not have to be: an interned keyword entry is
|
||||
* immortal and is not a collector object. */
|
||||
flan_dyn flan_dyn_map_new_class(flan_dyn k);
|
||||
|
||||
/* The class's name as a keyword, or nil for anything that is not an instance
|
||||
* — an ordinary map included. Never traps. */
|
||||
flan_dyn flan_dyn_class_of(flan_dyn v);
|
||||
|
||||
/* A keyword: :foo as a run-time value. Interned — the runtime keeps one entry
|
||||
* per distinct name forever, so two keywords with the same bytes are the same
|
||||
* word and equality is an identity compare, never a memcmp. The entries are
|
||||
|
||||
26
test/programs/dev-class.flan
Normal file
26
test/programs/dev-class.flan
Normal file
@ -0,0 +1,26 @@
|
||||
;;;; A class and a generic function, for the dev loop rather than for output.
|
||||
;;;;
|
||||
;;;; What a session does with this is the question the feature is judged on:
|
||||
;;;; adding a method to a running program has to reach the call sites that
|
||||
;;;; were compiled before the method existed. It does, and the reason is that
|
||||
;;;; a generic is one function — the methods are branches of its body, not
|
||||
;;;; functions of their own — so a new method is the ordinary redefinition of
|
||||
;;;; one name, through the cell the call already goes through.
|
||||
;;;;
|
||||
;;;; It keeps running rather than returning, for dev-repl.flan's reason: an
|
||||
;;;; expression typed at the editor is a thunk the agent runs at a frame
|
||||
;;;; boundary, and a parked program has none.
|
||||
(import agent "vendor:agent")
|
||||
|
||||
(defclass point [x y])
|
||||
(defclass circle [r])
|
||||
|
||||
(defgeneric area [self] dyn)
|
||||
|
||||
(defmethod area point [p] (* (get p :x) (get p :y)))
|
||||
|
||||
(defn main [] i32
|
||||
(agent/start "/tmp/flan-dev-class-fallback.sock")
|
||||
(dotimes [i 4000]
|
||||
(agent/wait 5))
|
||||
0)
|
||||
137
test/programs/dyn-class.flan
Normal file
137
test/programs/dyn-class.flan
Normal file
@ -0,0 +1,137 @@
|
||||
;;;; Classes and generic functions, the dyn side's two dispatch styles.
|
||||
;;;;
|
||||
;;;; A defclass is a named dyn map with a shape tag. The constructor is the
|
||||
;;;; class's own name, positional over the slots; the slots are ordinary map
|
||||
;;;; keys, so get and put are how one is read and written and nothing new was
|
||||
;;;; needed for either. What the class adds is the tag, which lives in the
|
||||
;;;; object's header and not in the entries: (len p) is the slot count, no key
|
||||
;;;; a program can write collides with it, and it shows up in exactly three
|
||||
;;;; places -- class-of, equality, and the printed form #point{ :x 1 :y 2}.
|
||||
;;;;
|
||||
;;;; The two dispatch styles are one mechanism. A defgeneric dispatches on the
|
||||
;;;; class of its first argument, which is Common Lisp's; a defmulti's body IS
|
||||
;;;; the dispatch, which is Clojure's. A class dispatcher is the shape tag of
|
||||
;;;; the first argument as the dispatch function, so the second spells the
|
||||
;;;; first, and a method is a branch either way.
|
||||
|
||||
(defclass point [x y])
|
||||
(defclass circle [r])
|
||||
|
||||
;; CLOS's half: dispatch on the class of the first argument. The generic
|
||||
;; declares the parameters and the return type once; a method states neither.
|
||||
(defgeneric area [self] dyn)
|
||||
|
||||
(defmethod area point [p] (* (get p :x) (get p :y)))
|
||||
;; A method may name its parameter whatever it likes -- the generic's name is
|
||||
;; bound to it on the way in.
|
||||
(defmethod area circle [c] (* 3 (* (get c :r) (get c :r))))
|
||||
|
||||
;; Clojure's half: the dispatch is a body, over the same parameter list every
|
||||
;; method has, answering the value the methods are keyed by.
|
||||
(defmulti describe [thing] dyn (get thing :kind))
|
||||
|
||||
(defmethod describe :square [s] (get s :side))
|
||||
(defmethod describe "round" [s] "a round thing, keyed by a string")
|
||||
(defmethod describe 7 [s] "the one keyed by a number")
|
||||
;; The method that answers when no other does. It is :else, which is the word
|
||||
;; match already uses, and it is the last arm whatever order it is written in.
|
||||
(defmethod describe :else [s] "something else")
|
||||
|
||||
;; A generic with no :else: a miss signals, and the program answers it.
|
||||
(defgeneric name-of [self] dyn)
|
||||
(defmethod name-of point [p] "a point")
|
||||
|
||||
;; A method's parameter names are its own, and the rebinding that gives it
|
||||
;; them is parallel. [reorder] names them in the generic's order reversed, which
|
||||
;; a sequential binding would get wrong in the worst possible way -- it would
|
||||
;; read the name it had just bound and hand the method its first argument
|
||||
;; twice. [shift] is the same bug one step shorter: [b] there is the
|
||||
;; generic's second parameter and must not become the first.
|
||||
(defmulti reorder [a b] dyn (class-of a))
|
||||
(defmethod reorder point [b a] [b a])
|
||||
(defmulti shift [a b] dyn (class-of a))
|
||||
(defmethod shift point [b c] [b c])
|
||||
|
||||
(defn main [] i32
|
||||
(let [p (point 3 4)
|
||||
c (circle 2)]
|
||||
;; The instance is a map, and prints as one with its tag in front.
|
||||
(println p)
|
||||
(println (len p))
|
||||
(println (get p :x))
|
||||
(put p :x 10)
|
||||
(println (get p :x))
|
||||
(println (has-key? p :x))
|
||||
(println (has-key? p :nothing))
|
||||
(println (get p :nothing))
|
||||
|
||||
;; The shape tag, as a value. Every value can be asked; only an instance
|
||||
;; answers with a name.
|
||||
(println (class-of p))
|
||||
(println (class-of c))
|
||||
(println (class-of {:x 3 :y 4}))
|
||||
(println (class-of 1))
|
||||
(println (class-of nil))
|
||||
|
||||
;; Equality takes the tag into account: two instances of one class compare
|
||||
;; by their slots, an instance and a plain map with the same entries do
|
||||
;; not, and two classes with the same slots are two classes.
|
||||
(println (= (point 1 2) (point 1 2)))
|
||||
(println (= (point 1 2) (point 1 3)))
|
||||
(println (= (point 1 2) {:x 1 :y 2}))
|
||||
(println (= (circle 2) (circle 2)))
|
||||
|
||||
;; Class dispatch. Same call site, two classes, two methods.
|
||||
(println (area p))
|
||||
(println (area c))
|
||||
|
||||
;; Arbitrary dispatch, over three kinds of dispatch value and the
|
||||
;; fallback. The dispatch runs on every call, so the value is whatever
|
||||
;; the map holds at the time.
|
||||
(println (describe {:kind :square :side 5}))
|
||||
(println (describe {:kind "round"}))
|
||||
(println (describe {:kind 7}))
|
||||
(println (describe {:kind :hexagon}))
|
||||
;; An empty map on its own is the zero-field struct literal, so it is
|
||||
;; bound first -- the dispatch answers nil for a map with no :kind, and
|
||||
;; nil finds no method either.
|
||||
(let [empty {:no :kind}]
|
||||
(println (describe empty)))
|
||||
|
||||
;; An instance is an ordinary dyn value: it goes in a vec, keys a map,
|
||||
;; and is collected like anything else.
|
||||
(let [v [p c]]
|
||||
(println (len v))
|
||||
(println (class-of (at v 1))))
|
||||
|
||||
;; The renamed parameters, in the generic's own order: the first element
|
||||
;; of each answer is the first argument. A sequential rebinding would
|
||||
;; print the point twice in the first and lose the 99 in the second.
|
||||
(println (reorder p 99))
|
||||
(println (shift p 99))
|
||||
|
||||
;; The miss. No method and no :else, so the generic signals NoMethod, and
|
||||
;; handler-case answers the whole form with a value -- the condition
|
||||
;; carries the generic's name and the dispatch value that found nothing.
|
||||
(println (name-of p))
|
||||
(println
|
||||
(handler-case (name-of c)
|
||||
[(NoMethod [e] (.generic e))]))
|
||||
;; The condition carries the dispatch value that found nothing, which for
|
||||
;; a defgeneric over a value that is no instance at all is nil.
|
||||
(println
|
||||
(handler-case (name-of 42)
|
||||
[(NoMethod [e] (.value e))])))
|
||||
|
||||
;; Instances under the collector: enough of them to pass the 1 MiB floor
|
||||
;; many times over, with one live instance in a rooted global. A marker that
|
||||
;; lost an instance's slots would free something live and the sum would come
|
||||
;; out wrong -- the tag itself is an interned keyword and immortal, which is
|
||||
;; why it needs no tracing.
|
||||
(let [total (point 0 0)]
|
||||
(dotimes [i 50000]
|
||||
(let [q (point i "forty-seven bytes of text to fatten each row")]
|
||||
(put total :x (+ (get total :x) (len q)))))
|
||||
(println (get total :x))
|
||||
(println (class-of total)))
|
||||
0)
|
||||
@ -3575,6 +3575,41 @@ level "1"
|
||||
"programs/dyn-map.flan" dyn_map_out;
|
||||
outputs ~x86:true "dyn: maps and keywords, --x86"
|
||||
"programs/dyn-map.flan" dyn_map_out;
|
||||
(* ── Classes and generic functions, M2 item 6 ────────────────────
|
||||
The dyn side's two dispatch styles over one mechanism, at all three
|
||||
rows because dispatch is a chain of dyn comparisons and the shape tag
|
||||
is a word in an object header — two things the backends could differ
|
||||
about and do not. Captured from the running program. The first line
|
||||
pins the tagged rendering (#point in front of the map the renderer
|
||||
already wrote, with its space-per-element convention unchanged) and
|
||||
the 2 after it pins the other half of the decision: the tag is not an
|
||||
entry, so an instance's length is its slot count. The three nils in
|
||||
the middle are class-of over a plain map, a number and nil — asking
|
||||
is not a claim. The 40 and the 12 are class dispatch over two
|
||||
classes at one call site; the four lines under them are arbitrary
|
||||
dispatch over a keyword, a string, a number and the :else fallback.
|
||||
The two bracketed lines are a method whose parameter names are the
|
||||
generic's reversed and one whose names are shifted along: both answer
|
||||
first-argument-first, which is what says the rebinding is parallel —
|
||||
a sequential one prints the point twice in the first and loses the 99
|
||||
in the second.
|
||||
name-of, then nil, are a dispatch miss answered by handler-case: the
|
||||
generic's name out of the condition, then the dispatch value that
|
||||
found nothing. The 100000 at the end is 50000 instances allocated
|
||||
against one live instance, well past the collector's 1 MiB floor. *)
|
||||
let dyn_class_out =
|
||||
"#point{ :x 3 :y 4}\n2\n3\n10\ntrue\nfalse\nnil\n:point\n\
|
||||
:circle\nnil\nnil\nnil\ntrue\nfalse\nfalse\ntrue\n40\n12\n5\n\
|
||||
a round thing, keyed by a string\nthe one keyed by a number\n\
|
||||
something else\nsomething else\n2\n:circle\n\
|
||||
[ #point{ :x 10 :y 4} 99]\n[ #point{ :x 10 :y 4} 99]\n\
|
||||
a point\nname-of\nnil\n100000\n:point\n"
|
||||
in
|
||||
outputs "dyn: classes and dispatch" "programs/dyn-class.flan" dyn_class_out;
|
||||
outputs ~opt:"-O0" "dyn: classes and dispatch, -O0"
|
||||
"programs/dyn-class.flan" dyn_class_out;
|
||||
outputs ~x86:true "dyn: classes and dispatch, --x86"
|
||||
"programs/dyn-class.flan" dyn_class_out;
|
||||
(* ── Per-type descriptors, M2 item 2 ─────────────────────────────
|
||||
The first program anywhere with a dyn field in a struct, which was a
|
||||
refusal until the descriptors landed. It matters at all three rows
|
||||
|
||||
@ -4899,6 +4899,91 @@ let () =
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ gsock; gout ];
|
||||
|
||||
(* ── A method added to a running program ───────────────────────
|
||||
The one claim classes rest on, made end to end rather than at the
|
||||
session's report: a generic function compiled with one method gets a
|
||||
second one delivered into the live process, and the call that goes
|
||||
through its cell answers with the new method's body. The session test
|
||||
pins which name is installed; this pins that installing it works.
|
||||
|
||||
Its own daemon over [programs/dev-class.flan], which keeps running so
|
||||
that an expression has a frame boundary to be run at. *)
|
||||
let csock = tmp "class.sock" and cout = tmp "class.out" in
|
||||
(try Sys.remove csock with Sys_error _ -> ());
|
||||
let cfd = Unix.openfile cout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let cpid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-class.flan"; "-s"; csock |]
|
||||
Unix.stdin cfd Unix.stderr
|
||||
in
|
||||
Unix.close cfd;
|
||||
if not (listening ~pid:cpid csock) then begin
|
||||
fail "the class daemon %s (%S)" !listen_why
|
||||
(In_channel.with_open_bin cout In_channel.input_all);
|
||||
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = connect csock in
|
||||
let said r = Option.value ~default:"" (Wire.string_field r "message") in
|
||||
let value r = Option.value ~default:"" (Wire.string_field r "value") in
|
||||
let ask code =
|
||||
request c
|
||||
(Printf.sprintf
|
||||
"(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")"
|
||||
code)
|
||||
in
|
||||
(* Every answer is compared inside the expression rather than read out
|
||||
of it. A generic answers a dyn, and a dyn value is rendered to the
|
||||
program's own stdout rather than into the reply's :value — it does
|
||||
reach a later reply's :output, which is how the dyn-global rows
|
||||
below read one, but the flush is the next reply's and not this one's.
|
||||
Asking the running program whether the answer is 12 puts a typed
|
||||
value in :value and takes the timing out of the test.
|
||||
|
||||
The first ask is retried: the agent's thread is let go only after the
|
||||
socket is bound, so an early ask is a race with the startup and not a
|
||||
result. *)
|
||||
let answered = ref "" in
|
||||
let asked () =
|
||||
let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in
|
||||
status r = "ok" && (answered := value r; true)
|
||||
in
|
||||
if not (await asked) then
|
||||
fail "the class daemon never reached a frame boundary"
|
||||
else begin
|
||||
if !answered <> "1" then
|
||||
fail "the method the program was built with answered %S" !answered;
|
||||
(* A circle has no method yet, so the dispatch misses and the generic
|
||||
signals NoMethod — the answer a program handles, spelled here as
|
||||
the thing that makes the next step's success mean something. *)
|
||||
let r =
|
||||
request c
|
||||
"(:op \"eval\" :code \"(defmethod area circle [q] (* 3 (* (get q \
|
||||
:r) (get q :r))))\" :file \"programs/dev-class.flan\")"
|
||||
in
|
||||
if status r <> "ok" then fail "delivering a new method: %s" (said r)
|
||||
else begin
|
||||
(* The call site in the generic's own cell now reaches a branch that
|
||||
did not exist when the process started. *)
|
||||
let r = ask "(if (= (area (circle 2)) 12) 1 0)" in
|
||||
if status r <> "ok" then
|
||||
fail "calling a generic after a method was added: %s" (said r)
|
||||
else if value r <> "1" then
|
||||
fail "the added method did not answer 12 (%S)" (value r);
|
||||
(* And the method that was already there still answers, which is
|
||||
what says the generic was extended rather than replaced. *)
|
||||
let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in
|
||||
if value r <> "1" then
|
||||
fail "the original method stopped answering (%S)" (value r)
|
||||
end
|
||||
end;
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] cpid) with Unix.Unix_error _ -> ())
|
||||
end;
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ csock; cout ];
|
||||
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||
[ sock; out; bsock; bout ];
|
||||
Test_support.report ~label:"dev" ()
|
||||
|
||||
@ -1732,6 +1732,144 @@ let () =
|
||||
main_at "a wrong main parameter points at main" "(defn main [n i32] ())";
|
||||
main_at "a wrong main return type points at main" "(defn main [] bool true)";
|
||||
|
||||
(* ── Classes and generic functions — M2 item 6 ─────────────────── *)
|
||||
(* A class is a constructor and a shape tag. The constructor is the class's
|
||||
own name, positional over the slots, and everything that reads or writes
|
||||
an instance is the dyn map operation that was already there. *)
|
||||
accepts "a class and its constructor"
|
||||
"(defclass point [x y])\n\
|
||||
(defn main [] i32 (let [p (point 1 2)] (if (= (get p :x) 1) 0 1)))";
|
||||
accepts "a class with no slots"
|
||||
"(defclass marker [])\n(defn main [] i32 (let [m (marker)] 0))";
|
||||
accepts "class-of answers nil for anything that is not an instance"
|
||||
"(defn main [] i32 (if (= (class-of 1) nil) 0 1))";
|
||||
(* The constructor is an ordinary function, so its arity is the ordinary
|
||||
arity check and a wrong one names the class. *)
|
||||
rejects_check "a constructor takes one argument per slot"
|
||||
"(defclass point [x y])\n(defn main [] i32 (let [p (point 1)] 0))"
|
||||
~needle:"point";
|
||||
(* A slot vector holds names and nothing else. [(defclass point [x i64])]
|
||||
is therefore two slots, one of them unfortunately named — the parser
|
||||
cannot tell a type's name from a slot's and does not have to, since a
|
||||
slot has no type to write. What it can tell is a form that is not a name
|
||||
at all. *)
|
||||
rejects_check "a slot is a name, not a type expression"
|
||||
"(defclass point [x (Ptr i64)])\n(defn main [] i32 0)"
|
||||
~needle:"a class slot is a name";
|
||||
rejects_check "a class does not name a slot twice"
|
||||
"(defclass point [x x])\n(defn main [] i32 0)"
|
||||
~needle:"names the slot x twice";
|
||||
|
||||
(* Both halves of the dispatch, and the fact that they are one mechanism:
|
||||
a defgeneric is a defmulti whose dispatch is (class-of first-argument),
|
||||
so a method written for a class is a method written for its keyword. *)
|
||||
accepts "class dispatch"
|
||||
"(defclass point [x y])\n\
|
||||
(defgeneric area [self] dyn)\n\
|
||||
(defmethod area point [p] (* (get p :x) (get p :y)))\n\
|
||||
(defn main [] i32 (if (= (area (point 2 3)) 6) 0 1))";
|
||||
accepts "arbitrary dispatch, with a fallback"
|
||||
"(defmulti describe [x] dyn (get x :kind))\n\
|
||||
(defmethod describe :square [s] 1)\n\
|
||||
(defmethod describe :else [s] 2)\n\
|
||||
(defn main [] i32 (if (= (describe {:kind :round}) 2) 0 1))";
|
||||
accepts "a method may name its parameters whatever it likes"
|
||||
"(defclass point [x y])\n\
|
||||
(defgeneric area [self] dyn)\n\
|
||||
(defmethod area point [whatever] (get whatever :x))\n\
|
||||
(defn main [] i32 0)";
|
||||
(* The rebinding that gives a method its own parameter names is parallel.
|
||||
A [let] binds in sequence, so the pairwise spelling reads a name it has
|
||||
just bound: these two type-check either way and the values are what is
|
||||
wrong, which is why dyn-class.flan is where they are really pinned. What
|
||||
is pinned here is that both shapes are legal at all. *)
|
||||
accepts "a method may reverse its generic's parameter names"
|
||||
"(defmulti g [a b] () (class-of a))\n\
|
||||
(defmethod g :else [b a] (println b) (println a))\n\
|
||||
(defn main [] i32 0)";
|
||||
accepts "a method may shift its generic's parameter names along"
|
||||
"(defmulti g [a b] () (class-of a))\n\
|
||||
(defmethod g :else [b c] (println b) (println c))\n\
|
||||
(defn main [] i32 0)";
|
||||
accepts "a method may be written above its generic"
|
||||
"(defclass point [x y])\n\
|
||||
(defmethod area point [p] (get p :x))\n\
|
||||
(defgeneric area [self] dyn)\n\
|
||||
(defn main [] i32 0)";
|
||||
(* A generic with no methods at all is legal and always misses; that is a
|
||||
run-time answer (the NoMethod condition), not a compile-time refusal. *)
|
||||
accepts "a generic with no methods"
|
||||
"(defgeneric area [self] dyn)\n(defn main [] i32 0)";
|
||||
|
||||
rejects_check "a method needs a generic"
|
||||
"(defclass point [x y])\n(defmethod area point [p] 1)\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"no defgeneric or defmulti names area";
|
||||
rejects_check "a method dispatching on an unknown class"
|
||||
"(defgeneric area [self] dyn)\n(defmethod area square [p] 1)\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"no defclass names square";
|
||||
rejects_check "two methods for one dispatch value"
|
||||
"(defclass point [x y])\n\
|
||||
(defgeneric area [self] dyn)\n\
|
||||
(defmethod area point [p] 1)\n\
|
||||
(defmethod area point [p] 2)\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"already has a method for point";
|
||||
(* A class's name and its keyword are one value: a class stands for the
|
||||
keyword its instances carry, so these two methods are the same method
|
||||
written twice and the second would be dead code. *)
|
||||
rejects_check "a class and its keyword are one dispatch value"
|
||||
"(defclass point [x y])\n\
|
||||
(defgeneric area [self] dyn)\n\
|
||||
(defmethod area point [p] 1)\n\
|
||||
(defmethod area :point [p] 2)\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"already has a method for :point";
|
||||
rejects_check "two :else methods for one generic"
|
||||
"(defmulti d [x] dyn x)\n\
|
||||
(defmethod d :else [x] 1)\n\
|
||||
(defmethod d :else [x] 2)\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"already has a method for :else";
|
||||
rejects_check "a method's arity is its generic's"
|
||||
"(defclass point [x y])\n\
|
||||
(defgeneric area [self] dyn)\n\
|
||||
(defmethod area point [p q] 1)\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"and this method of it takes 2";
|
||||
rejects_check "a generic's parameter is a bare name"
|
||||
"(defgeneric area [self (Ptr i64)] dyn)\n(defn main [] i32 0)"
|
||||
~needle:"parameter is a bare name";
|
||||
rejects_check "a defgeneric has no body"
|
||||
"(defgeneric area [self] dyn (class-of self))\n(defn main [] i32 0)"
|
||||
~needle:"It has no body";
|
||||
rejects_check "a defmulti has one"
|
||||
"(defmulti describe [x] dyn)\n(defn main [] i32 0)"
|
||||
~needle:"the body is the dispatch";
|
||||
rejects_check "a defgeneric needs something to dispatch on"
|
||||
"(defgeneric area [] dyn)\n(defn main [] i32 0)"
|
||||
~needle:"dispatches on the class of its first";
|
||||
rejects_check "a dispatch value is written out, not computed"
|
||||
"(defmulti d [x] dyn x)\n(defmethod d (f 1) [x] 1)\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"is written out rather than computed";
|
||||
(* A method has no return slot: the generic states the type once, for all
|
||||
of them. What that means for anyone writing the defn spelling by habit
|
||||
is that the slot they would have written is read as the first form of
|
||||
the body, and a lone type name there is an unknown name. *)
|
||||
rejects_check "a method has no return slot"
|
||||
"(defclass point [x y])\n\
|
||||
(defgeneric area [self] dyn)\n\
|
||||
(defmethod area point [p] dyn (get p :x))\n\
|
||||
(defn main [] i32 0)"
|
||||
~needle:"dyn";
|
||||
(* A class and a function are one namespace, as a defn and a defvar are:
|
||||
the constructor is a defn, so the collision is the ordinary one. *)
|
||||
rejects_check "a class collides with a function of the same name"
|
||||
"(defclass point [x y])\n(defn point [] i32 0)\n(defn main [] i32 0)"
|
||||
~needle:"point";
|
||||
|
||||
(* ── Unconstrained operators, and everything past milestone 2 ──── *)
|
||||
(* M2 queue item 5: typed = and != grow strings, bytewise. Ordering does
|
||||
not — there is no collation the language has picked, so < stays
|
||||
|
||||
@ -195,6 +195,14 @@ let corpus =
|
||||
amount of reading the offsets can. *)
|
||||
"programs/dyn-struct.flan", [];
|
||||
"programs/dyn-map.flan", [];
|
||||
(* Classes, M2 queue item 6. A class instance is a map with one more word
|
||||
in its header, so what this adds over [dyn-map] is that word: it is
|
||||
written by a constructor, read by class-of, compared by equality and
|
||||
printed by both renderers, and it is the one field in an object that
|
||||
the marker deliberately does not trace — an interned keyword entry is
|
||||
immortal and is not a collector object. If that reasoning is wrong,
|
||||
50000 instances past the one-megabyte floor is where ASan says so. *)
|
||||
"programs/dyn-class.flan", [];
|
||||
(* nil <-> None at (Option T), M2 queue item 4: an Option's tag is read
|
||||
with a raw [Field] the surface language never writes (check.ml's
|
||||
[box_option]/[unbox_option], the same access Render's structural
|
||||
|
||||
@ -303,6 +303,53 @@ let () =
|
||||
| _ -> ()
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "a name added earlier was forgotten: %s" m);
|
||||
|
||||
(* ── A method added to a running program ────────────────────────
|
||||
The dev loop is what classes were built for, so this is the case that
|
||||
decides whether the feature is usable at all. A generic function is one
|
||||
top-level name whose body dispatches, and a method is a branch of it —
|
||||
so adding a method has to install the *generic's* body, not a function
|
||||
of the method's own, and it has to do it through the cell the call site
|
||||
already goes through. If it reported only the method's own declaration
|
||||
name, [report]'s compiled call to [area] would go on running the body it
|
||||
was built with and the new method would be invisible. *)
|
||||
let t, _ = Session.create ~file:"programs/dev-class.flan" () in
|
||||
let c = Session.eval t "(defmethod area circle [c] (* 3 (* (get c :r) (get c :r))))" in
|
||||
if not c.Session.installs then
|
||||
fail "adding a method had nothing to install";
|
||||
if not (List.mem "area" c.Session.fns) then
|
||||
fail "adding a method installed %s, not the generic's body"
|
||||
(String.concat " " c.Session.fns);
|
||||
(* Redefining one is the same path, and the declaration is replaced rather
|
||||
than appended: a second (defmethod area circle ...) is not a duplicate
|
||||
method, it is this one again. *)
|
||||
let c = Session.eval t "(defmethod area circle [c] 0)" in
|
||||
if not (List.mem "area" c.Session.fns) then
|
||||
fail "redefining a method installed %s" (String.concat " " c.Session.fns);
|
||||
(* And it stays in the session: the class the method dispatches on, the
|
||||
generic it extends, and the method itself are all still there for the
|
||||
next form to check against. *)
|
||||
(match Session.eval t "(defmethod area point [p] (+ (get p :x) (get p :y)))" with
|
||||
| _ -> ()
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a method added earlier left the session broken: %s" m);
|
||||
(* A method for a class that is not there is refused, and refusing leaves
|
||||
the session exactly as it was — the same rule every other refusal here
|
||||
follows. *)
|
||||
(match Session.eval t "(defmethod area square [s] 1)" with
|
||||
| _ -> fail "a method dispatching on an unknown class was accepted"
|
||||
| exception Loc.Error _ -> ());
|
||||
(* A whole new class and a method for it, in one form — the shape of
|
||||
actually growing a program in the loop. The constructor is a name the
|
||||
process was never built with, so it goes through the registry the way
|
||||
any added function does, and the generic is redefined around it. *)
|
||||
let c =
|
||||
Session.eval t
|
||||
"(do (defclass square [s]) (defmethod area square [q] (* (get q :s) (get q :s))))"
|
||||
in
|
||||
if not (List.mem "square" c.Session.fns && List.mem "area" c.Session.fns) then
|
||||
fail "adding a class and a method installed %s"
|
||||
(String.concat " " c.Session.fns);
|
||||
|
||||
(* A file with imports, re-evaluated whole — the C-c C-k case. The session
|
||||
keeps the *expanded* declarations, so the package's names are replaced in
|
||||
place rather than appended a second time and rejected as duplicates. *)
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user