Fully propagating variance for struct/cstruct/union/ctype.

I think newtype requires this also.

src/compiler/flx_bind/flx_bind_expression.ml

@@ -1791,7 +1791,7 @@ print_endline ("`EXPR_variant_subtype_match_coercion");
       begin match ut with
       | BTYP_inst (_,i,ts',_) ->
         begin match hfind "lookup" state.sym_table i with
-        | { Flx_sym.id=id; symdef=SYMDEF_union ls } ->
+        | { Flx_sym.id=id; symdef=SYMDEF_union (ls,_) } ->
           let vidx =
             let rec scan = function
             | [] -> None
@@ -1950,7 +1950,7 @@ print_endline ("match ho ctor, binding expr = " ^ string_of_expr e);
       begin match ut with
       | BTYP_inst (_,i,ts',_) ->
         begin match hfind "lookup" state.sym_table i with
-        | { Flx_sym.id=id; symdef=SYMDEF_union ls } ->
+        | { Flx_sym.id=id; symdef=SYMDEF_union (ls,_) } ->
           let _,vs,_  = find_split_vs state.sym_table bsym_table i in
 (*
         print_endline ( "OK got union type " ^ id ^ "<"^si i ^ "> vs= " ^ catmap "," (fun (id,j,_)-> id^"<"^si j^">") vs 

src/compiler/flx_bind/flx_bind_record_proj.ml

@@ -22,8 +22,8 @@ let handle_field_name state bsym_table build_env env rs be bt cal_apply bind_typ
   match Flx_lookup_state.hfind "Flx_bind_record_proj:handle_field_name" state.sym_table i with
 
   (* STRUCT *)
-  | { Flx_sym.id=id; sr=sra; symdef=SYMDEF_struct ls }
-  | { Flx_sym.id=id; sr=sra; symdef=SYMDEF_cstruct (ls,_) } ->
+  | { Flx_sym.id=id; sr=sra; symdef=SYMDEF_struct (ls,_) }
+  | { Flx_sym.id=id; sr=sra; symdef=SYMDEF_cstruct (ls,_,_) } ->
     let _,vs,_ = Flx_generic.find_split_vs state.sym_table bsym_table i in
     let cidx,ct =
       let rec scan i = function

src/compiler/flx_bind/flx_bind_symbol.ml

@@ -754,7 +754,7 @@ print_endline ("Flx_bbind: Adding type of index " ^ si symbol_index ^ " to cache
       prec,
       `Callback (ts_c,client_data_pos)))
 
-  | SYMDEF_union (cs) ->
+  | SYMDEF_union (cs,variance) ->
     if state.print_flag then
       print_endline ("//Binding union " ^ si symbol_index ^ " --> " ^ sym.Flx_sym.id);
     let ut = btyp_inst ( `Nominal,
@@ -767,20 +767,20 @@ print_endline ("Flx_bbind: Adding type of index " ^ si symbol_index ^ " to cache
       n, v, evs, bt d, bt c, gadt
     ) cs 
     in
-    add_bsym None (bbdcl_union (bvs, cs'))
+    add_bsym None (bbdcl_union (bvs, cs',variance))
 
-  | SYMDEF_struct cs ->
+  | SYMDEF_struct (cs,variance) ->
     if state.print_flag then 
       print_endline ("//Binding struct " ^ si symbol_index ^ " --> " ^ sym.Flx_sym.id);
     let cs' = List.map (fun (n,t) -> n, bt t) cs in
-    add_bsym None (bbdcl_struct (bvs, cs'))
+    add_bsym None (bbdcl_struct (bvs, cs',variance))
 
-  | SYMDEF_cstruct (cs,reqs) ->
+  | SYMDEF_cstruct (cs,reqs,variance) ->
     if state.print_flag then 
       print_endline ("//Binding cstruct " ^ si symbol_index ^ " --> " ^ sym.Flx_sym.id);
     let cs' = List.map (fun (n,t) -> n, bt t) cs in
     let breqs = bind_reqs reqs in 
-    add_bsym None (bbdcl_cstruct (bvs, cs', breqs))
+    add_bsym None (bbdcl_cstruct (bvs, cs', breqs,variance))
 
   | SYMDEF_instance qn ->
     (*
@@ -814,12 +814,12 @@ print_endline (" &&&&&& SYMDEF_instance calling BBIND_SYMBOL");
   | SYMDEF_inherit _ -> ()
   | SYMDEF_inherit_fun _ -> ()
 
-  | SYMDEF_abs (quals,ct,reqs)->
+  | SYMDEF_abs (quals,ct,reqs,variance)->
     if state.print_flag then
       print_endline ("//Binding abstract primitive type " ^ si symbol_index ^ " ->  " ^ sym.Flx_sym.id);
     let reqs = bind_reqs reqs in
     let bquals = bind_quals quals in
-    add_bsym None (bbdcl_external_type (bvs, bquals, ct, reqs))
+    add_bsym None (bbdcl_external_type (bvs, bquals, ct, reqs,variance))
 
   | SYMDEF_newtype t ->
     let t = bt t in

src/compiler/flx_bind/flx_btype_of_bsym.ml

@@ -57,10 +57,10 @@ let btype_of_bsym state bsym_table sr bt bid bsym =
   | BBDCL_external_fun (_,_,params,return_type,_,_,_) ->
       btyp_function (btyp_tuple params, return_type)
   | BBDCL_external_code _ -> assert false
-  | BBDCL_union (_,ls) ->
+  | BBDCL_union (_,ls,variance) ->
       btyp_variant (List.map (fun (n,_,evs,d,c,gadt) -> n,d) ls)
-  | BBDCL_struct (_,ls)
-  | BBDCL_cstruct (_,ls,_) ->
+  | BBDCL_struct (_,ls,variance)
+  | BBDCL_cstruct (_,ls,_,variance) ->
 (*
 print_endline "Type of struct, considered as constructor function";
 *)

src/compiler/flx_bind/flx_cal_apply.ml

@@ -98,8 +98,8 @@ print_endline ("cal_apply', AFTER NORMALISE, fn = " ^ sbt bsym_table t1 ^ " arg=
       begin match get_data state.sym_table index with
       { Flx_sym.id=id; symdef=entry } ->
         begin match entry with
-        | SYMDEF_cstruct (cs,_) -> t1, `None
-        | SYMDEF_struct (cs) -> t1, `None
+        | SYMDEF_cstruct (cs,_,_) -> t1, `None
+        | SYMDEF_struct (cs,_) -> t1, `None
         | _ ->
           clierrx "[flx_bind/flx_lookup.ml:2193: E112] " sr
           (

src/compiler/flx_bind/flx_coerce.ml

@@ -148,7 +148,7 @@ print_endline ("Trying to coerce value of type " ^ si i ^ " to linear type " ^ F
 *)
       begin match hfind "lookup" state.sym_table i with
       | { Flx_sym.id="int";
-          symdef=SYMDEF_abs (_, Flx_code_spec.Str_template "int", _) }  ->
+          symdef=SYMDEF_abs (_, Flx_code_spec.Str_template "int", _,_) }  ->
         begin match e' with
         | BEXPR_literal {Flx_literal.felix_type="int"; internal_value=big} ->
 (*
@@ -189,7 +189,7 @@ print_endline ("Coercion from int expression result is " ^ sbe bsym_table r);
       let n = Flx_btype.sizeof_linear_type bsym_table  t in
       begin match hfind "lookup" state.sym_table i with
       | { Flx_sym.id="int";
-          symdef=SYMDEF_abs (_, Flx_code_spec.Str_template "int", _) }  ->
+          symdef=SYMDEF_abs (_, Flx_code_spec.Str_template "int", _,_) }  ->
         Flx_bexpr.bexpr_coerce (x',inttype)
 
       | _ ->

src/compiler/flx_bind/flx_decoder.ml

@@ -27,7 +27,7 @@ print_endline("Bound type " ^ Flx_print.sbt bsym_table but);
 *)
         let bbdcl = Flx_bsym.bbdcl bsym in
         begin (* 8*)match bbdcl with
-        | Flx_bbdcl.BBDCL_union (ubvs, flds)  -> 
+        | Flx_bbdcl.BBDCL_union (ubvs, flds,variance)  -> 
           let uname = Flx_bsym.id bsym in
 (*
 print_endline ("Generating union decoder chip _decoder_" ^ uname); 

src/compiler/flx_bind/flx_encoder.ml

@@ -30,7 +30,7 @@ print_endline("Bound type " ^ Flx_print.sbt bsym_table but);
 *)
         let bbdcl = Flx_bsym.bbdcl bsym in
         begin (* 8*)match bbdcl with
-        | Flx_bbdcl.BBDCL_union (ubvs, flds)  -> 
+        | Flx_bbdcl.BBDCL_union (ubvs, flds,_)  -> 
           let uname = Flx_bsym.id bsym in
 (*
 print_endline ("Generating union encoder chip _encoder_" ^ uname); 

src/compiler/flx_bind/flx_inner_type_of_index.ml

@@ -190,8 +190,8 @@ print_endline ("** FINISH **** Calculating Function type for function " ^ sym.Fl
       clierrx "[flx_bind/flx_lookup.ml:2048: E108] " sym.Flx_sym.sr ("Union " ^ sym.Flx_sym.id ^ " doesn't have a type")
 
   (* struct as function *)
-  | SYMDEF_cstruct (ls,_)
-  | SYMDEF_struct ls ->
+  | SYMDEF_cstruct (ls,_,_)
+  | SYMDEF_struct (ls,_) ->
       let _,vs,_  = find_split_vs state.sym_table bsym_table index in
       let ts = List.map
         (fun (s,i,_) -> `TYP_name (sym.Flx_sym.sr,s,[]))

src/compiler/flx_bind/flx_lookup.ml

@@ -849,8 +849,8 @@ and lookup_name_with_sig
        print_endline ("Found nominal type "^si j ^" in bound symbol table");
 *)
        begin match Flx_bsym.bbdcl bsym with
-       | BBDCL_struct (vs,fields) 
-       | BBDCL_cstruct (vs, fields,_) ->
+       | BBDCL_struct (vs,fields,variance) 
+       | BBDCL_cstruct (vs, fields,_,variance) ->
          begin match
             Flx_list.list_assoc_index_with_assoc fields name
          with
@@ -873,8 +873,8 @@ and lookup_name_with_sig
 *)
        begin try
          match hfind "lookup" state.sym_table j with
-         | { Flx_sym.symdef=SYMDEF_struct fields; vs=vs } 
-         | { Flx_sym.symdef=SYMDEF_cstruct (fields,_); vs=vs } ->
+         | { Flx_sym.symdef=SYMDEF_struct (fields,variance); vs=vs } 
+         | { Flx_sym.symdef=SYMDEF_cstruct (fields,_,variance); vs=vs } ->
            begin match
               Flx_list.list_assoc_index_with_assoc fields name
            with
@@ -899,8 +899,8 @@ and lookup_name_with_sig
        print_endline ("Found nominal type "^si j ^" in bound symbol table");
 *)
        begin match Flx_bsym.bbdcl bsym with
-       | BBDCL_struct (vs,fields) 
-       | BBDCL_cstruct (vs, fields,_) ->
+       | BBDCL_struct (vs,fields,variance) 
+       | BBDCL_cstruct (vs, fields,_,variance) ->
          begin match
             Flx_list.list_assoc_index_with_assoc fields name
          with
@@ -923,8 +923,8 @@ and lookup_name_with_sig
 *)
        begin try
          match hfind "lookup" state.sym_table j with
-         | { Flx_sym.symdef=SYMDEF_struct fields; vs=vs } 
-         | { Flx_sym.symdef=SYMDEF_cstruct (fields,_); vs=vs } ->
+         | { Flx_sym.symdef=SYMDEF_struct (fields,variance); vs=vs } 
+         | { Flx_sym.symdef=SYMDEF_cstruct (fields,_,variance); vs=vs } ->
            begin match
               Flx_list.list_assoc_index_with_assoc fields name
            with

src/compiler/flx_bind/flx_remap.ml

@@ -79,7 +79,7 @@ let remap_bbdcl offset bbdcl =
       bbdcl_instance_type (remap_bvs vs, remap_btype ty)
 
 
-  | BBDCL_external_type (vs, quals, code, reqs) ->
+  | BBDCL_external_type (vs, quals, code, reqs,variance) ->
       let vs = remap_bvs vs in
       let quals =
         List.map begin function
@@ -88,7 +88,7 @@ let remap_bbdcl offset bbdcl =
         end quals
       in
       let reqs = remap_breqs reqs in
-      bbdcl_external_type (vs, quals, code, reqs)
+      bbdcl_external_type (vs, quals, code, reqs,variance)
 
   | BBDCL_external_const (props, vs, ty, code, reqs) ->
       let vs = remap_bvs vs in
@@ -113,21 +113,21 @@ let remap_bbdcl offset bbdcl =
       let reqs = remap_breqs reqs in
       bbdcl_external_code (vs, code, ikind, reqs)
 
-  | BBDCL_union (vs, cs) ->
+  | BBDCL_union (vs, cs,variance) ->
       let vs = remap_bvs vs in
       let cs = List.map (fun (n,v,evs,d,c,gadt) -> n,v,remap_bvs evs,remap_btype d, remap_btype c, gadt) cs in
-      bbdcl_union (vs, cs)
+      bbdcl_union (vs, cs,variance)
 
-  | BBDCL_struct (vs, cs) ->
+  | BBDCL_struct (vs, cs,variance) ->
       let vs = remap_bvs vs in
       let cs = List.map (fun (n,t) -> n,remap_btype t) cs in
-      bbdcl_struct (vs, cs)
+      bbdcl_struct (vs, cs,variance)
 
-  | BBDCL_cstruct (vs, cs, reqs) ->
+  | BBDCL_cstruct (vs, cs, reqs,variance) ->
       let vs = remap_bvs vs in
       let cs = List.map (fun (n,t) -> n,remap_btype t) cs in
       let reqs = remap_breqs reqs in
-      bbdcl_cstruct (vs, cs, reqs)
+      bbdcl_cstruct (vs, cs, reqs,variance)
 
   | BBDCL_typeclass (props, vs) ->
       bbdcl_typeclass (props, remap_bvs vs)

src/compiler/flx_bind/flx_sig_of_symdef.ml

@@ -61,11 +61,11 @@ let sig_of_symdef symdef sr name i : typecode_t * typecode_t * ((string * expr_t
     in
     typeof_paramspec_t p,r,paramlist
 
-  | SYMDEF_cstruct (ls, _) ->
+  | SYMDEF_cstruct (ls, _,_) ->
     type_of_list (List.map snd ls), `TYP_index (sr,name,i),
      Some (List.map (fun (p,_) -> p,None) ls)
 
-  | SYMDEF_struct ls ->
+  | SYMDEF_struct (ls,_) ->
     type_of_list (List.map snd ls), `TYP_index (sr,name,i),
      Some (List.map (fun (p,_) -> p,None) ls)
 

src/compiler/flx_bind/flx_strr.ml

@@ -228,8 +228,8 @@ print_endline ("_strr Variant type " ^ Flx_print.sbt bsym_table t);
 print_endline ("Strr on nominal type");
 *)
       begin match Flx_lookup_state.hfind "lookup:_strr" sym_table i with
-      | { Flx_sym.id=name; Flx_sym.vs=(vs,_); Flx_sym.symdef=Flx_types.SYMDEF_struct ls } 
-      | { Flx_sym.id=name; Flx_sym.vs=(vs,_); Flx_sym.symdef=Flx_types.SYMDEF_cstruct (ls,_) } -> 
+      | { Flx_sym.id=name; Flx_sym.vs=(vs,_); Flx_sym.symdef=Flx_types.SYMDEF_struct (ls,_) } 
+      | { Flx_sym.id=name; Flx_sym.vs=(vs,_); Flx_sym.symdef=Flx_types.SYMDEF_cstruct (ls,_,_) } -> 
         let first = ref true in
         let e = cats (
           List.fold_left (fun acc (s,_) -> 
@@ -242,7 +242,7 @@ print_endline ("Strr on nominal type");
           ) (mks "}") 
         in 
         be rs e
-      | { Flx_sym.id=name; Flx_sym.vs=(vs,_); Flx_sym.symdef=Flx_types.SYMDEF_union ls } -> 
+      | { Flx_sym.id=name; Flx_sym.vs=(vs,_); Flx_sym.symdef=Flx_types.SYMDEF_union (ls,_) } -> 
 (*
 print_endline ("Strr on union " ^ name);
 *)

src/compiler/flx_bind/flx_struct_apply.ml

@@ -7,8 +7,8 @@ let cal_struct_apply_to_record
   rs sr f (ea, ta as a) i ts' 
 =
   let id,vs,fls = match Flx_lookup_state.hfind "lookup" state.Flx_lookup_state.sym_table i with
-    | { Flx_sym.id=id; vs=vs; symdef=Flx_types.SYMDEF_struct ls }
-    | { Flx_sym.id=id; vs=vs; symdef=Flx_types.SYMDEF_cstruct (ls,_) } -> id,vs,ls
+    | { Flx_sym.id=id; vs=vs; symdef=Flx_types.SYMDEF_struct (ls,_) }
+    | { Flx_sym.id=id; vs=vs; symdef=Flx_types.SYMDEF_cstruct (ls,_,_) } -> id,vs,ls
     | _ -> assert false
   in
   let cmp (s1,t1) (s2, t2) = compare s1 s2 in

src/compiler/flx_bind/flx_symtab.ml

@@ -1349,9 +1349,9 @@ print_endline (string_of_int symbol_index ^ " Adding instance type " ^ id ^ "="
       (* Add the type variables to the private symbol table. *)
       add_tvars privtab
 
-  | DCL_abs (quals, c, reqs) ->
+  | DCL_abs (quals, c, reqs, variance) ->
       (* Add the abs to the sym_table. *)
-      add_symbol ~pubtab ~privtab symbol_index id sr (SYMDEF_abs (quals, c, reqs));
+      add_symbol ~pubtab ~privtab symbol_index id sr (SYMDEF_abs (quals, c, reqs, variance));
 
       (* Possibly add the abs to the private symbol table. *)
       if access = `Public then add_unique pub_name_map id symbol_index;
@@ -1479,7 +1479,7 @@ print_endline ("Adding callback " ^ id ^ "<"^string_of_int symbol_index^"> type=
         add_symbol ~pubtab ~privtab ftdef_index ftdef_id sr ft_symdef
       end
 
-  | DCL_union (its) ->
+  | DCL_union (its,variance) ->
       let tvars = List.map (fun (s,_,_)-> `TYP_name (sr,s,[])) (fst ivs) in
       let utype = `TYP_name (sr, id, tvars) in
       let its' =
@@ -1503,7 +1503,7 @@ print_endline ("Adding callback " ^ id ^ "<"^string_of_int symbol_index^"> type=
       in
 
       (* Add union to sym_table. *)
-      add_symbol ~pubtab ~privtab symbol_index id sr (SYMDEF_union its');
+      add_symbol ~pubtab ~privtab symbol_index id sr (SYMDEF_union (its',variance));
 
       (* Add type variables to symbol table and the private name lookup table of union. *)
       add_tvars privtab;
@@ -1600,12 +1600,12 @@ print_endline ("Adding callback " ^ id ^ "<"^string_of_int symbol_index^"> type=
         add_symbol ~pubtab:ctorpubtab ~privtab:ctorprivtab ~ivs:localivs dfn_idx component_name sr ctor_dcl2
       end its'
 
-  | DCL_cstruct (sts, reqs) ->
+  | DCL_cstruct (sts, reqs,variance) ->
       let tvars = List.map (fun (s,_,_)-> `AST_name (sr,s,[])) (fst ivs) in
       let stype = `AST_name(sr, id, tvars) in
 
       (* Add symbols to sym_table *)
-      add_symbol ~pubtab ~privtab symbol_index id sr ( SYMDEF_cstruct (sts, reqs));
+      add_symbol ~pubtab ~privtab symbol_index id sr ( SYMDEF_cstruct (sts, reqs,variance));
 
       (* Possibly add the struct to the public symbol table. *)
       if access = `Public then add_unique pub_name_map id symbol_index;
@@ -1617,12 +1617,12 @@ print_endline ("Adding callback " ^ id ^ "<"^string_of_int symbol_index^"> type=
       add_tvars privtab
 
 
-  | DCL_struct sts ->
+  | DCL_struct (sts,variance) ->
       let tvars = List.map (fun (s,_,_)-> `AST_name (sr,s,[])) (fst ivs) in
       let stype = `AST_name(sr, id, tvars) in
 
       (* Add symbols to sym_table *)
-      add_symbol ~pubtab ~privtab symbol_index id sr ( SYMDEF_struct sts);
+      add_symbol ~pubtab ~privtab symbol_index id sr ( SYMDEF_struct (sts,variance));
 
       (* Possibly add the struct to the public symbol table. *)
       if access = `Public then add_unique pub_name_map id symbol_index;

src/compiler/flx_core/flx_ast.ml

@@ -535,18 +535,24 @@ and statement_t =
       Flx_srcref.t *
       Flx_id.t *
       vs_list_t *
-      (Flx_id.t * int option * vs_list_t * typecode_t * typecode_t option) list
+      (Flx_id.t * int option * vs_list_t * typecode_t * typecode_t option) list *
+      variance_list_t (* corresponding to vs_list *)
+
   | STMT_struct of
       Flx_srcref.t *
       Flx_id.t *
       vs_list_t *
-      (Flx_id.t * typecode_t) list
+      (Flx_id.t * typecode_t) list *
+      variance_list_t (* corresponding to vs_list *)
+
   | STMT_cstruct of
       Flx_srcref.t *
       Flx_id.t *
       vs_list_t *
       (Flx_id.t * typecode_t) list *
-      raw_req_expr_t
+      raw_req_expr_t *
+      variance_list_t (* corresponding to vs_list *)
+
   | STMT_type_alias of Flx_srcref.t * Flx_id.t * vs_list_t * typecode_t
   | STMT_type_function of Flx_srcref.t * Flx_id.t * ks_list_t * typecode_t
   | STMT_inherit of Flx_srcref.t * Flx_id.t * vs_list_t * qualified_name_t
@@ -980,9 +986,9 @@ let src_of_stmt (e : statement_t) = match e with
   | STMT_insert (s,_,_,_,_,_)
   | STMT_code (s,_,_)
   | STMT_noreturn_code (s,_,_)
-  | STMT_union (s, _,_,_)
-  | STMT_struct (s,_,_,_)
-  | STMT_cstruct (s,_,_,_,_)
+  | STMT_union (s, _,_,_,_)
+  | STMT_struct (s,_,_,_,_)
+  | STMT_cstruct (s,_,_,_,_,_)
   | STMT_typeclass (s,_,_,_)
   | STMT_begin_typeclass (s,_,_)
   | STMT_instance (s,_,_,_)