diff --git a/lib/check.ml b/lib/check.ml index 26dfd43..6e5be45 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -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 diff --git a/lib/render.ml b/lib/render.ml index 7de13dd..0333943 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -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) diff --git a/lib/session.ml b/lib/session.ml index 2658130..52618e9 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -463,6 +463,7 @@ let render_locals ?(origin = "") 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 = "") 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 = "") 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 -> diff --git a/test/programs/unions.flan b/test/programs/unions.flan new file mode 100644 index 0000000..e7ec041 --- /dev/null +++ b/test/programs/unions.flan @@ -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)