View mode pointers. Aka propagating const.

src/compiler/flx_bind/flx_bind_apply.ml

@@ -129,7 +129,7 @@ let cal_bind_apply
     *)
     let (ea,ta as a) = be a' in
 (*
-    print_endline ("[bind_expression] GENERAL APPLY " ^ 
+    print_endline ("[bind_apply] GENERAL APPLY " ^ 
       Flx_print.string_of_expr f' ^ " to " ^  Flx_print.string_of_expr a' ^ ", type= " ^ Flx_print.sbt bsym_table ta
     );
 *)
@@ -143,6 +143,8 @@ let cal_bind_apply
 (*
     if not (complete_type ta) then
       print_endline ("*************>>>>>>>>> reduced Apply argument type is not complete!!" ^ sbt bsym_table ta);
+*)
+(*
     print_endline ("Bound argument " ^ Flx_print.sbe bsym_table a ^ " type=" ^ Flx_btype.st ta);
 *)
       (* ---------------------------------------------------------- *)
@@ -180,22 +182,24 @@ let cal_bind_apply
       with Flx_exceptions.TryNext ->
 
 
-      (*
-        print_endline ("Can't interpret apply function "^string_of_expr f'^" as projection, trying as an actual function");
-      *)
+(*
+      print_endline ("Can't interpret apply function "^Flx_print.string_of_expr f'^" as projection, trying as an actual function");
+*)
       try begin (* as a function *)
       try
         let bt,tf as f =
           match Flx_typing2.qualified_name_of_expr f' with
           | Some name ->
 (*
-print_endline ("Checking if " ^ Flx_print.string_of_qualified_name name ^ " is a function");
 if match name with | `AST_name (_,"accumulate",_) -> true | _ -> false then begin
   print_endline "Trying to bind application of accumulate";
 end;
 *)
             let srn = src_of_qualified_name name in
             begin 
+(*
+print_endline ("Checking if " ^ Flx_print.string_of_qualified_name name ^ " is a function with lookup_qn_with_sig'");
+*)
               try  
                  let result = (lookup_qn_with_sig' state bsym_table sr srn env rs name (ta::sigs)) in
 (*
@@ -205,14 +209,17 @@ print_endline ("  WITH TYPE " ^ Flx_print.sbt bsym_table (snd result));
                  result
               with 
               | Not_found -> failwith "lookup_qn_with_sig' threw Not_found"
-              | exn -> raise exn 
+              | exn -> (* print_endline ("NOPE, lookup_qn_with_sig' barfed"); *) raise exn 
             end
           | None ->
             begin 
+(*
+print_endline ("Lookup qn with sig' failed to find a function, lets try bind expression directly in case the name is a variable of function type");
+*)
               try bind_expression' state bsym_table env rs f' (a :: args) 
               with 
               | Not_found -> failwith "bind_expression' XXX threw Not_found"
-              | exn -> raise exn 
+              | exn -> (* print_endline ("Nope, bind expression also failed"); *) raise exn 
             end
         in
 (*
@@ -229,17 +236,15 @@ print_endline ("  WITH TYPE " ^ Flx_print.sbt bsym_table (snd result));
           ->
           begin try
 (*
-           print_endline (" ** Bound LHS of application as function!");
+           print_endline (" ** Bound LHS of application as function! Calling cal_apply to bind it!");
 *)
            let result =  cal_apply state bsym_table sr rs f a  in
 (*
-           print_endline (" ** application of function done!");
+           print_endline (" ** (after cal_apply): application of function done!\n");
 *)
            result
           with exn -> 
-(*
-            print_endline ("!!! cal_apply failed");
-*)
+            (* print_endline ("!!! cal_apply failed"); *) (* NOTE: this isn't necessarily an error if used in tentative binding *)
             raise exn
           end
         (* NOTE THIS CASE HASN'T BEEN CHECKED FOR POLYMORPHISM YET *)

src/compiler/flx_bind/flx_bind_expression.ml

@@ -584,7 +584,7 @@ assert false
   | `EXPR_case_index (sr,e) ->
     let (e',t) as e  = be e in
     begin match t with
-      | BTYP_type_var (_,k) 
+      | BTYP_type_var (_,_,k) 
       | BTYP_inst (_,_,_,k)
         when Flx_kind.kind_ge2 Flx_kind.KIND_compactlinear k
         -> () 
@@ -669,7 +669,7 @@ print_endline ("Evaluating EXPPR_typed_case index=" ^ si v ^ " type=" ^ string_o
 *)
         bexpr_unitsum_case v k  (* const ctor *)
       end
-    | BTYP_type_var (_,Flx_kind.KIND_unitsum) ->
+    | BTYP_type_var (_,_,Flx_kind.KIND_unitsum) ->
       bexpr_const_case (v, t)  (* const ctor *)
 
     | BTYP_compactsum ls
@@ -1338,14 +1338,14 @@ print_endline ("LOOKUP 9A: varname " ^ si i);
     end
 
   | `EXPR_deref (sr,e') ->
-(*
-print_endline ("Binding _deref .. " ^ string_of_expr e);
-*)
     let e,t = be e' in
     begin match unfold "flx_lookup" t with
     | BTYP_ptr (`R,t',_) 
     | BTYP_ptr (`RW,t',_) -> bexpr_deref t' (e,t)
-    | BTYP_ptr (`V,t',_) -> bexpr_deref t' (e,t)
+    | BTYP_ptr (`V,t',_) -> 
+      (* print_endline ("deref of V mode pointer detected");  *)
+      let vt = Flx_btype.viewify_type t' in
+      bexpr_deref vt (e,t)
 
     | _ -> clierrx "[flx_bind/flx_lookup.ml:4856: E207] " sr 
      ("[bind_expression'] Dereference non pointer, type " ^ sbt bsym_table t)

src/compiler/flx_bind/flx_bind_type.ml

@@ -491,7 +491,12 @@ print_endline ("  ***** Bound `TYP_apply: " ^ Flx_btype.st x );
 
   | `TYP_name (sr,s,[]) when List.mem_assoc s rs.as_fixlist ->
     let level, kind = List.assoc s rs.as_fixlist in
-    btyp_fix (level - rs.depth) kind 
+    let fx = btyp_fix (level - rs.depth) kind in
+(*
+print_endline ("######################## Flx_bind_type.TYP_name fixpoint from 'as' name `"^s^"`: " ^ Flx_btype.st fx);
+*)
+    fx
+
 
   | `TYP_name (sr,s,[]) when List.mem_assoc s params ->
     let t = List.assoc s params in

src/compiler/flx_bind/flx_bind_type_index.ml

@@ -116,7 +116,9 @@ print_endline ("Bind type index ts adjusted");
   then begin
     let mt = Flx_guess_meta_type.guess_meta_type state bsym_table bt index in
 (*
-    print_endline ("Flx_bind_type_index: fixpoint, meta type calculated by guess_meta_type!"); 
+    print_endline ("@@@@@@@@@@@@@ Flx_bind_type_index: fixpoint, meta type calculated by guess_meta_type!" ^ Flx_kind.sk mt); 
+    let mt = Flx_kind.kind_max2 mt Flx_kind.kind_type in
+    (* A fix point has to at least be kind type! *)
 *)
     let fixated = btyp_fix ((List.assoc index rs.type_alias_fixlist)-rs.depth) mt in
     fixated

src/compiler/flx_bind/flx_cal_apply.ml

@@ -30,20 +30,19 @@ let cal_apply'
   build_env
   state bsym_table be sr ((be1,t1) as tbe1) ((be2,t2) as tbe2) =
   let original_argument_type = t2 in
+
 (*
-  if t1 <> t1' || t2 <> t2' then begin
-print_endline ("cal_apply' BEFORE NORMALISE, fn = " ^ sbt bsym_table t1' ^ " arg=" ^ sbt bsym_table t2');
-print_endline ("cal_apply', AFTER NORMALISE, fn = " ^ sbt bsym_table t1 ^ " arg=" ^ sbt bsym_table t2);
-  end
-  ;
+print_endline ("\n%%%%%%%%\nFlx_cal_apply: Function type \n" ^ Flx_btype.st t1 ^ "\nArgument type\n`" ^ Flx_btype.st t2 ^ "\n");
 *)
-
   let t1 = Flx_beta.beta_reduce "Flx_cal_apply:cal_apply'" state.counter bsym_table sr t1 in
   let t2 = Flx_beta.beta_reduce "Flx_cal_apply:cal_apply'" state.counter bsym_table sr t2 in
-
+
+(*
+print_endline ("\n%%%%%%%%\nFlx_cal_apply AFTER BETA: Function type \n" ^ Flx_btype.st t1 ^ "\nArgument type\n`" ^ Flx_btype.st t2 ^ "\n");
+*) 
   let result_type,reorder =
-    let argt = unfold "flx_cal_apply" t1 in 
-    match argt with
+    let funt = (* unfold "flx_cal_apply" *) t1 in  (* the UNFOLD IS BUGGED IT PUTS THE WRONG KIND ON THE FIXPOINT *)
+    match funt with
     | BTYP_lineareffector(paramt,_,result_type)
     | BTYP_linearfunction (paramt,result_type)
     | BTYP_effector(paramt,_,result_type)
@@ -55,7 +54,7 @@ print_endline ("cal_apply', AFTER NORMALISE, fn = " ^ sbt bsym_table t1 ^ " arg=
 *)
       let rel = Flx_unify.compare_sigs bsym_table state.counter paramt t2 in
 (*
-      print_endline ("Function domain " ^ sbt bsym_table paramt ^ " " ^str_of_cmp rel ^ " argument type " ^ sbt bsym_table t2);
+      print_endline ("Function domain " ^ sbt bsym_table paramt ^ "\n " ^str_of_cmp rel ^ "\n argument type " ^ sbt bsym_table t2);
 *)
       match rel with
       | `Equal -> 

src/compiler/flx_bind/flx_cal_ret_type.ml

@@ -45,8 +45,6 @@ print_endline ("+++++++++++++++++++++++++++++");
 print_endline ("Cal ret type of " ^ id ^ "<" ^ string_of_int index ^ "> at " ^ Flx_srcref.short_string_of_src sr);
 print_endline ("+++++ UNBOUND return type is " ^ string_of_typecode rt');
     begin match rt' with | `TYP_var j when j = index -> print_endline ("RETURN TYPE UNSPECIFIED") | _ -> () end;
-*)
-(*
 print_endline ("Trying to bind type .. if function index variable, we get a recurse?");
 *)
     let declared_ret = not (index = (match rt' with `TYP_var k -> k | _ -> 0)) in

src/compiler/flx_bind/flx_guess_meta_type.ml

@@ -183,6 +183,8 @@ let guess_meta_type state bsym_table bt index : kind =
       k
 
     | SYMDEF_type_alias t  -> 
-      guess_metatype sr t
+      let mt = guess_metatype sr t in
+      print_endline ("Guess meta type of " ^ Flx_print.string_of_typecode t ^ " as " ^ Flx_kind.sk mt);
+      mt
     | _ -> print_endline ("Dunno, assume a type " ^ string_of_symdef entry id vs); assert false
 

src/compiler/flx_bind/flx_inner_type_of_index.ml

@@ -49,7 +49,6 @@ if debug then
   if List.mem index rs.idx_fixlist then begin
 if debug then
 print_endline "inner_typeof+index returning fixpoint";
-    (* btyp_fix (-rs.depth) (btyp_type 0) *)
     btyp_fix (-rs.depth) (Flx_kind.kind_type) 
   end else
 

src/compiler/flx_bind/flx_overload.ml

@@ -329,6 +329,7 @@ print_endline (" .. found tpattern .. analysing .. " ^ string_of_typecode t);
         | KND_unitsum
         | KND_compactlinear
         | KND_function _ 
+        | KND_view
         | KND_tuple _ -> `TYP_var j',[],[],[],[]
         | _ -> 
          print_endline ("Flx_overload. Expected KND_tpattern, got " ^ str_of_kindcode tp);

src/compiler/flx_bind/flx_resolve_overload.ml

@@ -257,7 +257,7 @@ end;
     Hashtbl.iter (fun i j -> print_endline ("  Rebind index " ^ si i ^ " -> " ^ si j)) remap_table;
 *)
     let rec fbt t = match t with
-      | Flx_btype.BTYP_type_var (i,mt) ->
+      | Flx_btype.BTYP_type_var (i,tvm,mt) ->
 (*
 print_endline ("Examining bound type variable index " ^ si i);
 *)
@@ -273,7 +273,7 @@ print_endline ("Replaced by vmap: " ^ sbt bsym_table r);
 (*
 print_endline ("Not found in vmap, remaping with index remapper: " ^ si j);
 *)
-            Flx_btype.btyp_type_var (j, mt)
+            Flx_btype.btyp_type_varm (j, tvm, mt)
         end
       | x -> Flx_btype.map ~f_bid:fi ~f_btype:fbt x
     in

src/compiler/flx_bind/flx_tconstraint.ml

@@ -38,6 +38,7 @@ print_endline ("Build type constraints for type variable " ^string_of_int i ^":
   | KND_borrowed
   | KND_unitsum (* well this is wrong, it IS a constraint! *) 
   | KND_compactlinear  
+  | KND_view
   | KND_function _ 
   | KND_tuple _ -> bbool true
 

src/compiler/flx_bind/flx_typecode_of_btype.ml

@@ -36,7 +36,7 @@ let typecode_of_btype ?sym_table:(sym_table=None) bsym_table counter sr (t0:Flx_
         let id = Flx_bsym_table.find_id bsym_table i in 
         `TYP_name (sr,id, (List.map tc ts))
 
-      | BTYP_type_var (i,_) -> `TYP_var i
+      | BTYP_type_var (i,_,_) -> `TYP_var i
       | BTYP_uniq t -> `TYP_uniq (tc t)
 (*
         begin match sym_table with 

src/compiler/flx_bind/flx_typeset.ml

@@ -13,7 +13,7 @@ let is_typeset tss1 =
     p1.assignments = [] &&
     BidSet.cardinal p1.pattern_vars = 1 &&
     match p1.pattern,v1 with 
-    | BTYP_type_var (i,KIND_type), BTYP_void
+    | BTYP_type_var (i,_,KIND_type), BTYP_void
       when i = BidSet.choose p1.pattern_vars ->
       begin try 
         List.iter (fun (p,v) -> match p,v with

src/compiler/flx_core/flx_alpha.ml

@@ -6,8 +6,8 @@ let remap map i = try List.assoc i map with Not_found -> i
 
 let rec alpha counter map t = 
   match t with
-  | BTYP_type_var (i, knd) -> 
-    btyp_type_var (remap map i, knd)
+  | BTYP_type_var (i, m, knd) -> 
+    btyp_type_varm (remap map i, m, knd)
 
   | BTYP_type_function (ps,r,b) ->
     let map = List.fold_left (fun acc (i,_) -> (i, fresh_bid counter)::acc) map ps in

src/compiler/flx_core/flx_ast.ml

@@ -79,6 +79,7 @@ and kindcode_t =
   | KND_tpattern of typecode_t
   (* | KND_special of string *)
   | KND_var of string
+  | KND_view
 
 
 and sortcode_t = 

src/compiler/flx_core/flx_beta.ml

@@ -158,7 +158,9 @@ and fixup counter ps body =
      && i + depth +1  = 0 (* looking inside application, one more level *)
      -> print_endline "SPECIAL REDUCTION";
 (* HACK: meta type of fixpoint guessed *)
+(*
 print_endline ("Flx_beta:fixup:aux: hacking meta type of fixpoint!");
+*)
      btyp_fix (i+2) (kind_type) (* elide application AND skip under lambda abstraction *)
 
    | BTYP_type_function (a,b,c) ->
@@ -372,7 +374,7 @@ print_endline ("Beta-reducing typeop " ^ op ^ ", type=" ^ sbt bsym_table t);
   | BTYP_ellipsis -> btyp_ellipsis (* not a value type! *)
   | BTYP_none -> assert false
   | BTYP_fix _ -> (* print_endline "Returning fixpoint"; *)  t
-  | BTYP_type_var (i,_) -> t
+  | BTYP_type_var (i,_,_) -> t
   | BBOOL _ -> t
 
   | BTYP_type_function (p,r,b) -> t

src/compiler/flx_core/flx_bexpr.ml

@@ -178,7 +178,7 @@ let bexpr_deref t ((_,(pt:Flx_btype.t)) as e) : t =
   | _ -> 
   match pt with
   | BTYP_ptr (mode,base,_) ->
-    if base <> t then
+    if base <> t && mode <> `V then
       print_endline ("Flx_bexpr: Warning deref of pointer to type " ^ Flx_btype.st base ^ 
       "given type " ^ Flx_btype.st t)
     ;