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

The structural printer reads only the case in hand

Browse Source 
print, the REPL inspector and the break buffer's locals all walk a concrete
type through render.ml, and a union fell through its Named arm to <Shape>.
It now recovers the case from the tag by a chain of comparisons -- the same
shape the enum arm already had, and for the same reason: the name is erased
before any backend sees it -- and reads the fields of that case only. Reading
the others would be reading a payload that is not there.

It prints (Shape.Dot {.x 1.5 .y -2.5}), which is what the source would write.

The union table has to reach the walk, so Render.ctx grew a field and its
three construction sites in session.ml and one in check.ml pass it. That is
the whole of the session.ml change.

test/programs/unions.flan is the program: a case with no fields, a case wider
than another, a case holding a string, a union in a struct, a union through a
call in both directions, ZII, reassignment, and printing. Its layout was
checked against clang's for the same declaration -- 32 bytes aligned 8 with
the payload at offset 8, and 40/8 for the struct holding it.
This commit is contained in:
Joseph Ferano 2026-09-12 16:53:26 +07:00
parent 675241e226
commit 03f7609201
4 changed files with 147 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
lib/check.ml
View File

@ -1121,7 +1121,8 @@ and var ctx loc ~want name =
(Tast.MakeCase (uname, c.Tast.vname, [])))
| Some (uname, c) ->
fail loc
"%s is a case of the union %s, and a union value names both — write %s.%s" name uname uname c.Tast.vname
"%s is a case of the union %s, and a union value names both — \
write %s.%s" name uname uname c.Tast.vname
| None ->
if Hashtbl.mem ctx.env.fns name then
unimplemented loc
@ -1479,12 +1480,14 @@ and check_struct ctx ~want loc name kvs =
misspelling. It can now, so it says what was meant. *)
| Some (uname, c) ->
fail loc
"%s is a case of the union %s, not a struct — a union value names both, as (%s.%s {.field value ...})"
"%s is a case of the union %s, not a struct — a union value names \
both, as (%s.%s {.field value ...})"
name uname uname c.Tast.vname
| None ->
if Hashtbl.mem ctx.env.unions name then
fail loc
"%s is a union, and a union value names the case as well as the type — write (%s.%s {.field value ...}) for one of %s"
"%s is a union, and a union value names the case as well as the \
type — write (%s.%s {.field value ...}) for one of %s"
name name (first_case_name ctx.env name) (case_list ctx.env name)
else fail loc "unknown struct %s" name)
| Some s ->
@ -3116,6 +3119,7 @@ and named_call ctx ~want loc name args =
let rc =
{ Render.structs =
Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.structs [];
unions = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.unions [];
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) ctx.env.enums [];
emit = emitter;
alloc = (fun ty -> fresh_slot ctx ty) }
@ -3219,7 +3223,8 @@ and named_call ctx ~want loc name args =
reaches for a constructor, and neither is one. *)
let uname, c = Hashtbl.find ctx.env.cases name in
fail loc
"%s is a case of the union %s — write (%s.%s {.field value ...}), or %s.%s on its own when it has no fields"
"%s is a case of the union %s — write (%s.%s {.field value ...}), \
or %s.%s on its own when it has no fields"
name uname uname c.Tast.vname uname c.Tast.vname
else if Hashtbl.mem ctx.env.structs name then
fail loc

57
lib/render.ml
View File

@ -35,6 +35,10 @@ type emitter = {
type ctx = {
structs : Tast.structure list;
(* The declared unions. [Types.Named] covers a struct and a union alike, so
which list the name is in is what says which this is — the same
arrangement the checker and the emitter use. *)
unions : Tast.union list;
enums : (string * (string * int64) list) list;
emit : emitter;
(* A slot in the *caller's* frame. Only the slice arm needs one, and it needs
@ -132,6 +136,59 @@ let rec render c depth (e : Tast.expr) : Tast.expr list =
(Tast.If (is_some,
do_ ((lit "(some " :: render c (depth + 1) some) @ [ lit ")" ]),
lit "none")) ]
(* A union, printed as the source would write it: the case is recovered
from the tag by a chain of comparisons, exactly as an enum's member name
is, and only the case in hand has its fields read. Reading the others
would be reading a payload that is not there. *)
| Types.Named n
when List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname n)
c.unions ->
let u =
List.find (fun (u : Tast.union) -> String.equal u.Tast.uname n) c.unions
in
let tag = { Tast.e = Tast.Field (e, 0); ty = Types.Int Types.I32; loc } in
let one i (v : Tast.variant) otherwise =
let is =
{ Tast.e =
Tast.Prim (Tast.Eq,
[ tag; { Tast.e = Tast.Int (Int64.of_int i, Types.I32);
ty = Types.Int Types.I32; loc } ]);
ty = Types.Bool; loc }
in
let full = n ^ "." ^ v.Tast.vname in
let body =
if v.Tast.vfields = [] then lit full
else
let shown = List.filteri (fun i _ -> i < max_span) v.Tast.vfields in
let parts =
List.concat
(List.mapi
(fun i (f : Tast.field) ->
let fv =
{ Tast.e = Tast.CaseField (e, v.Tast.vname, i);
ty = f.Tast.fty; loc }
in
(if i = 0 then [] else [ lit " " ])
@ [ lit ("." ^ f.Tast.fname ^ " ") ]
@ render c (depth + 1) fv)
shown)
in
do_ ((lit ("(" ^ full ^ " {") :: parts)
@ (if List.length v.Tast.vfields > max_span then [ lit " ..." ]
else [])
@ [ lit "})" ])
in
unit_ (Tast.If (is, body, otherwise))
in
(* The fallback is a tag no case names, which only a scribbled-over union
could hold. Showing the number is more use than showing a case it is
not. *)
let base =
do_ [ lit ("<" ^ n ^ " tag ");
c.emit.ei64 (cast (Types.Int Types.I64) tag); lit ">" ]
in
[ List.fold_left (fun acc x -> x acc) base
(List.rev (List.mapi one u.Tast.cases)) ]
| Types.Named n ->
(match
List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n)

3
lib/session.ml
View File

@ -463,6 +463,7 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
emit = dev_emitter;
alloc = (fun ty ->
@ -582,6 +583,7 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
let extra = ref [] and nslots = ref 0 in
let c =
{ Render.structs = t.program.Tast.structs;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
emit = dev_emitter;
alloc = (fun ty ->
@ -651,6 +653,7 @@ let eval_expr ?(origin = "<eval>") t src : change =
let extra = ref [] and nslots = ref (Array.length base) in
let c =
{ Render.structs = t.program.Tast.structs;
unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
emit = dev_emitter;
alloc = (fun ty ->

78
test/programs/unions.flan Normal file
View File

@ -0,0 +1,78 @@
;;;; Union values: declaring one, making one, matching one, printing one.
;;;;
;;;; The layout claim is the load-bearing one, so it is asserted rather than
;;;; described: a union is a tag and room for the largest case, aligned to the
;;;; widest member of any case, which is C's struct { int tag; union {...}; }.
;;;; That is what the macro expander will need to agree with byte for byte, so
;;;; `Shape` here is deliberately the shape a Form has: a case with no fields,
;;;; a case whose members are wider than another's, and a case holding a
;;;; string -- the three things a payload blob has to hold without disturbing
;;;; the alignment of any of them.
(defunion Shape
[Empty
(Dot [x f64 y f64])
(Rect [w i32 h i32])
(Tag [name string n u8])])
;; A union crosses a call boundary in both directions, as a parameter and as a
;; return type -- a value that cannot do that is not a value.
(defn area [s Shape] f64
(match s
(Rect w h) (* (f64 w) (f64 h))
(Dot _x _y) 0.0
_ -1.0))
(defn widen [n i32] Shape (Shape.Rect {.w n .h (* n 2)}))
;; A union as a struct field, which is the path that makes its size and
;; alignment visible to something other than a slot.
(defstruct Cell [id i32 s Shape])
(defn describe [s Shape] string
(match s
Empty "empty"
(Dot x y) (if (= x y) "dot on the diagonal" "dot")
(Rect w h) (if (= w h) "square" "rect")
(Tag name n) name))
(defn main [] i32
;; A case with no fields is a whole value and is written as a name.
(println (describe Shape.Empty))
(println (describe (Shape.Dot {.x 2.0 .y 2.0})))
(println (describe (Shape.Dot {.x 1.0 .y 2.0})))
(println (describe (Shape.Rect {.w 3 .h 3})))
(println (describe (Shape.Tag {.name "tagged" .n 7})))
;; ZII: omitted fields are zeroed, exactly as in a struct literal.
(println (describe (Shape.Rect {.w 0})))
;; Returned from a call, then matched.
(print (i64 (area (widen 4)))) (println "")
(print (i64 (area (Shape.Dot {.x 9.0 .y 9.0})))) (println "")
(print (i64 (area Shape.Empty))) (println "")
;; Through a struct field, and copied: assigning a Cell copies the union's
;; bytes, so the copy's payload must be the original's.
(let [c (Cell {.id 1 .s (Shape.Tag {.name "in a cell" .n 3})})
d c]
(println (describe (.s d)))
;; A zeroed union is the first declared case -- Empty -- which is what
;; makes case order part of the contract.
(let [z (Cell {.id 2})]
(println (describe (.s z)))))
;; A local assigned a second case: the tag moves and the payload is rewritten.
(let [v Shape.Empty]
(set v (Shape.Rect {.w 5 .h 6}))
(print (i64 (area v))) (println "")
(set v (Shape.Tag {.name "reassigned" .n 1}))
(println (describe v)))
;; The structural printer, which reads only the case in hand: the other
;; cases' fields are not there to read.
(print Shape.Empty) (println "")
(print (Shape.Dot {.x 1.5 .y -2.5})) (println "")
(print (Shape.Tag {.name "printed" .n 9})) (println "")
(print (Cell {.id 7 .s (Shape.Rect {.w 1 .h 2})})) (println "")
0)