Implement STMT_init_box in trans, clean up some of the semant table-accessors.

6 files changed, 39 insertions, 51 deletions

diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml
index f49f450adcb..7b54de257d3 100644
--- a/src/boot/me/dwarf.ml
+++ b/src/boot/me/dwarf.ml
@@ -2463,7 +2463,7 @@ let dwarf_visitor
                 then get_abbrev_code abbrev_formal
                 else get_abbrev_code abbrev_variable
               in
-              let resolved_slot = referent_to_slot cx s.id in
+              let resolved_slot = get_slot cx s.id in
               let emit_var_die slot_loc =
                 let var_die =
                   SEQ [|
diff --git a/src/boot/me/layout.ml b/src/boot/me/layout.ml
index 208dc47087e..365acbf941c 100644
--- a/src/boot/me/layout.ml
+++ b/src/boot/me/layout.ml
@@ -140,7 +140,7 @@ let layout_visitor
       (slots:node_id array)
       : unit =
     let accum (off,align) id : (size * size) =
-      let slot = referent_to_slot cx id in
+      let slot = get_slot cx id in
       let rt = slot_referent_type cx.ctxt_abi slot in
       let (elt_size, elt_align) = rty_layout rt in
         if vregs_ok
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 1e6c462cddb..182c68115de 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -306,18 +306,32 @@ let referent_is_item (cx:ctxt) (id:node_id) : bool =
     | _ -> false
 ;;
 
-(* coerce an lval definition id to a slot *)
-let referent_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
-  match Hashtbl.find cx.ctxt_all_defns id with
-      DEFN_slot slot -> slot
-    | _ -> bugi cx id "unknown slot"
+let rec lval_base_id (lv:Ast.lval) : node_id =
+  match lv with
+      Ast.LVAL_base nbi -> nbi.id
+    | Ast.LVAL_ext (lv, _) -> lval_base_id lv
+;;
+
+let get_item (cx:ctxt) (node:node_id) : Ast.mod_item_decl =
+  match htab_search cx.ctxt_all_defns node with
+      Some (DEFN_item item) -> item
+    | Some _ -> bugi cx node "defn is not an item"
+    | None -> bugi cx node "missing defn"
+;;
+
+let get_slot (cx:ctxt) (node:node_id) : Ast.slot =
+  match htab_search cx.ctxt_all_defns node with
+      Some (DEFN_slot slot) -> slot
+    | Some _ -> bugi cx node "defn is not a slot"
+    | None -> bugi cx node "missing defn"
 ;;
 
 (* coerce an lval reference id to its definition slot *)
-let lval_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
-  match resolve_lval_id cx id with
-      DEFN_slot slot -> slot
-    | _ -> bugi cx id "unknown slot"
+let lval_base_to_slot (cx:ctxt) (lval:Ast.lval) : Ast.slot identified =
+  let lid = lval_base_id lval in
+  let rid = lval_to_referent cx lid in
+  let slot = get_slot cx rid in
+    { node = slot; id = rid }
 ;;
 
 let get_stmt_depth (cx:ctxt) (id:node_id) : int =
@@ -534,22 +548,6 @@ let rec lval_to_name (lv:Ast.lval) : Ast.name =
           Ast.NAME_ext (lval_to_name lv, comp)
 ;;
 
-let rec lval_base_id (lv:Ast.lval) : node_id =
-  match lv with
-      Ast.LVAL_base nbi -> nbi.id
-    | Ast.LVAL_ext (lv, _) -> lval_base_id lv
-;;
-
-let rec lval_base_slot (cx:ctxt) (lv:Ast.lval) : node_id option =
-  match lv with
-      Ast.LVAL_base nbi ->
-        let referent = lval_to_referent cx nbi.id in
-          if referent_is_slot cx referent
-          then Some referent
-          else None
-    | Ast.LVAL_ext (lv, _) -> lval_base_slot cx lv
-;;
-
 let rec lval_slots (cx:ctxt) (lv:Ast.lval) : node_id array =
   match lv with
       Ast.LVAL_base nbi ->
@@ -1193,20 +1191,6 @@ let lval_is_direct_mod (cx:ctxt) (lval:Ast.lval) : bool =
         | _ -> false
 ;;
 
-let get_item (cx:ctxt) (node:node_id) : Ast.mod_item_decl =
-  match htab_search cx.ctxt_all_defns node with
-      Some (DEFN_item item) -> item
-    | Some _ -> bugi cx node "defn is not an item"
-    | None -> bugi cx node "missing defn"
-;;
-
-let get_slot (cx:ctxt) (node:node_id) : Ast.slot =
-  match htab_search cx.ctxt_all_defns node with
-      Some (DEFN_slot slot) -> slot
-    | Some _ -> bugi cx node "defn is not a slot"
-    | None -> bugi cx node "missing defn"
-;;
-
 let lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty =
   (*
     FIXME: The correct definition of this function is just: 
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index 830cf1ee13c..9e8cfb14e71 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -446,7 +446,7 @@ let trans_visitor
   in
 
   let slot_id_referent_type (slot_id:node_id) : Il.referent_ty =
-    slot_referent_type abi (referent_to_slot cx slot_id)
+    slot_referent_type abi (get_slot cx slot_id)
   in
 
   let caller_args_cell (args_rty:Il.referent_ty) : Il.cell =
@@ -959,12 +959,11 @@ let trans_visitor
               in
                 trans_slot_lval_ext base_ty base_cell comp
 
-          | Ast.LVAL_base nb ->
-              let slot = lval_to_slot cx nb.id in
-              let referent = lval_to_referent cx nb.id in
-              let cell = cell_of_block_slot referent in
-              let ty = slot_ty slot in
-              let cell = deref_slot initializing cell slot in
+          | Ast.LVAL_base _ ->
+              let sloti = lval_base_to_slot cx lv in
+              let cell = cell_of_block_slot sloti.id in
+              let ty = slot_ty sloti.node in
+              let cell = deref_slot initializing cell sloti.node in
                 deref_ty initializing cell ty
       in
         iflog
@@ -4173,6 +4172,11 @@ let trans_visitor
                   trans_init_chan dst p
           end
 
+      | Ast.STMT_init_box (dst, src) ->
+          let sloti = lval_base_to_slot cx dst in
+          let cell = cell_of_block_slot sloti.id in
+            trans_init_slot_from_atom CLONE_none cell sloti.node src
+
       | Ast.STMT_block block ->
           trans_block block
 
diff --git a/src/boot/me/transutil.ml b/src/boot/me/transutil.ml
index d7fbb566488..9daccd40445 100644
--- a/src/boot/me/transutil.ml
+++ b/src/boot/me/transutil.ml
@@ -153,7 +153,7 @@ let iter_block_slots
     Hashtbl.iter
       begin
         fun key slot_id ->
-          let slot = referent_to_slot cx slot_id in
+          let slot = get_slot cx slot_id in
             fn key slot_id slot
       end
       block_slots
@@ -180,7 +180,7 @@ let iter_arg_slots
           begin
             fun slot_id ->
               let key = Hashtbl.find cx.ctxt_slot_keys slot_id in
-              let slot = referent_to_slot cx slot_id in
+              let slot = get_slot cx slot_id in
                 fn key slot_id slot
           end
           ls
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index e0ebe4ee1e2..764fdc96154 100644
--- a/src/boot/me/typestate.ml
+++ b/src/boot/me/typestate.ml
@@ -68,7 +68,7 @@ let determine_constr_key
                           if referent_is_slot cx aid
                           then
                             if type_has_state
-                              (slot_ty (referent_to_slot cx aid))
+                              (slot_ty (get_slot cx aid))
                             then err (Some aid)
                               "predicate applied to slot of mutable type"
                             else aid