Populate tree.

1 files changed, 959 insertions, 0 deletions

diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
new file mode 100644
index 00000000..8f034aee
--- /dev/null
+++ b/src/boot/me/resolve.ml
@@ -0,0 +1,959 @@
+open Semant;;
+open Common;;
+
+(*
+ * Resolution passes:
+ *
+ *   - build multiple 'scope' hashtables mapping slot_key -> node_id
+ *   - build single 'type inference' hashtable mapping node_id -> slot
+ *
+ *   (note: not every slot is identified; only those that are declared
+ *    in statements and/or can participate in local type inference.
+ *    Those in function signatures are not, f.e. Also no type values
+ *    are identified, though module items are. )
+ *
+ *)
+
+
+let log cx = Session.log "resolve"
+  cx.ctxt_sess.Session.sess_log_resolve
+  cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+  if cx.ctxt_sess.Session.sess_log_resolve
+  then thunk ()
+  else ()
+;;
+
+
+let block_scope_forming_visitor
+    (cx:ctxt)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+  let visit_block_pre b =
+    if not (Hashtbl.mem cx.ctxt_block_items b.id)
+    then htab_put cx.ctxt_block_items b.id (Hashtbl.create 0);
+    if not (Hashtbl.mem cx.ctxt_block_slots b.id)
+    then htab_put cx.ctxt_block_slots b.id (Hashtbl.create 0);
+    inner.Walk.visit_block_pre b
+  in
+    { inner with Walk.visit_block_pre = visit_block_pre }
+;;
+
+
+let stmt_collecting_visitor
+    (cx:ctxt)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+  let block_ids = Stack.create () in
+  let visit_block_pre (b:Ast.block) =
+    Stack.push b.id block_ids;
+    inner.Walk.visit_block_pre b
+  in
+  let visit_block_post (b:Ast.block) =
+    inner.Walk.visit_block_post b;
+    ignore (Stack.pop block_ids)
+  in
+
+  let visit_for_block
+      ((si:Ast.slot identified),(ident:Ast.ident))
+      (block_id:node_id)
+      : unit =
+    let slots = Hashtbl.find cx.ctxt_block_slots block_id in
+    let key = Ast.KEY_ident ident in
+      log cx "found decl of '%s' in for-loop block header" ident;
+      htab_put slots key si.id;
+      htab_put cx.ctxt_slot_keys si.id key
+  in
+
+  let visit_stmt_pre stmt =
+    begin
+      htab_put cx.ctxt_all_stmts stmt.id stmt;
+      match stmt.node with
+          Ast.STMT_decl d ->
+            begin
+              let bid = Stack.top block_ids in
+              let items = Hashtbl.find cx.ctxt_block_items bid in
+              let slots = Hashtbl.find cx.ctxt_block_slots bid in
+              let check_and_log_ident id ident =
+                if Hashtbl.mem items ident ||
+                  Hashtbl.mem slots (Ast.KEY_ident ident)
+                then
+                  err (Some id)
+                    "duplicate declaration '%s' in block" ident
+                else
+                  log cx "found decl of '%s' in block" ident
+              in
+              let check_and_log_tmp id tmp =
+                if Hashtbl.mem slots (Ast.KEY_temp tmp)
+                then
+                  err (Some id)
+                    "duplicate declaration of temp #%d in block"
+                    (int_of_temp tmp)
+                else
+                  log cx "found decl of temp #%d in block" (int_of_temp tmp)
+              in
+              let check_and_log_key id key =
+                match key with
+                    Ast.KEY_ident i -> check_and_log_ident id i
+                  | Ast.KEY_temp t -> check_and_log_tmp id t
+              in
+                match d with
+                    Ast.DECL_mod_item (ident, item) ->
+                      check_and_log_ident item.id ident;
+                      htab_put items ident item.id
+                  | Ast.DECL_slot (key, sid) ->
+                      check_and_log_key sid.id key;
+                      htab_put slots key sid.id;
+                      htab_put cx.ctxt_slot_keys sid.id key
+            end
+        | Ast.STMT_for f ->
+            visit_for_block f.Ast.for_slot f.Ast.for_body.id
+        | Ast.STMT_for_each f ->
+            visit_for_block f.Ast.for_each_slot f.Ast.for_each_head.id
+        | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms } ->
+            let rec resolve_pat block pat =
+              match pat with
+                  Ast.PAT_slot ({ id = slot_id }, ident) ->
+                    let slots = Hashtbl.find cx.ctxt_block_slots block.id in
+                    let key = Ast.KEY_ident ident in
+                    htab_put slots key slot_id;
+                    htab_put cx.ctxt_slot_keys slot_id key
+                | Ast.PAT_tag (_, pats) -> Array.iter (resolve_pat block) pats
+                | Ast.PAT_lit _ | Ast.PAT_wild -> ()
+            in
+            Array.iter (fun { node = (p, b) } -> resolve_pat b p) arms
+        | _ -> ()
+    end;
+    inner.Walk.visit_stmt_pre stmt
+  in
+    { inner with
+        Walk.visit_block_pre = visit_block_pre;
+        Walk.visit_block_post = visit_block_post;
+        Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+
+let all_item_collecting_visitor
+    (cx:ctxt)
+    (path:Ast.name_component Stack.t)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+
+  let items = Stack.create () in
+
+  let push_on_item_arg_list item_id arg_id =
+    let existing =
+      match htab_search cx.ctxt_frame_args item_id with
+          None -> []
+        | Some x -> x
+    in
+      htab_put cx.ctxt_slot_is_arg arg_id ();
+      Hashtbl.replace cx.ctxt_frame_args item_id (arg_id :: existing)
+  in
+
+  let note_header item_id header =
+    Array.iter
+      (fun (sloti,ident) ->
+         let key = Ast.KEY_ident ident in
+           htab_put cx.ctxt_slot_keys sloti.id key;
+           push_on_item_arg_list item_id sloti.id)
+      header;
+  in
+
+  let visit_mod_item_pre n p i =
+    Stack.push i.id items;
+    Array.iter (fun p -> htab_put cx.ctxt_all_defns p.id
+                  (DEFN_ty_param p.node)) p;
+    htab_put cx.ctxt_all_defns i.id (DEFN_item i.node);
+    htab_put cx.ctxt_all_item_names i.id (Walk.path_to_name path);
+    log cx "collected item #%d: %s" (int_of_node i.id) n;
+    begin
+      (* FIXME: this is incomplete. *)
+      match i.node.Ast.decl_item with
+          Ast.MOD_ITEM_fn f ->
+            note_header i.id f.Ast.fn_input_slots;
+        | Ast.MOD_ITEM_obj ob ->
+            note_header i.id ob.Ast.obj_state;
+        | Ast.MOD_ITEM_tag (header_slots, _, _) ->
+            let skey i = Printf.sprintf "_%d" i in
+              note_header i.id
+                (Array.mapi (fun i s -> (s, skey i)) header_slots)
+        | _ -> ()
+    end;
+      inner.Walk.visit_mod_item_pre n p i
+  in
+
+  let visit_mod_item_post n p i =
+    inner.Walk.visit_mod_item_post n p i;
+    ignore (Stack.pop items)
+  in
+
+  let visit_obj_fn_pre obj ident fn =
+    htab_put cx.ctxt_all_defns fn.id (DEFN_obj_fn (obj.id, fn.node));
+    htab_put cx.ctxt_all_item_names fn.id (Walk.path_to_name path);
+    note_header fn.id fn.node.Ast.fn_input_slots;
+    inner.Walk.visit_obj_fn_pre obj ident fn
+  in
+
+  let visit_obj_drop_pre obj b =
+    htab_put cx.ctxt_all_defns b.id (DEFN_obj_drop obj.id);
+    htab_put cx.ctxt_all_item_names b.id (Walk.path_to_name path);
+    inner.Walk.visit_obj_drop_pre obj b
+  in
+
+  let visit_stmt_pre s =
+    begin
+      match s.node with
+          Ast.STMT_for_each fe ->
+            let id = fe.Ast.for_each_body.id in
+              htab_put cx.ctxt_all_defns id
+                (DEFN_loop_body (Stack.top items));
+              htab_put cx.ctxt_all_item_names id
+                (Walk.path_to_name path);
+        | _ -> ()
+    end;
+    inner.Walk.visit_stmt_pre s;
+  in
+
+    { inner with
+        Walk.visit_mod_item_pre = visit_mod_item_pre;
+        Walk.visit_mod_item_post = visit_mod_item_post;
+        Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+        Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+        Walk.visit_stmt_pre = visit_stmt_pre; }
+;;
+
+
+let lookup_type_node_by_name
+    (cx:ctxt)
+    (scopes:scope list)
+    (name:Ast.name)
+    : node_id =
+  iflog cx (fun _ ->
+              log cx "lookup_simple_type_by_name %a"
+                Ast.sprintf_name name);
+  match lookup_by_name cx scopes name with
+      None -> err None "unknown name: %a" Ast.sprintf_name name
+    | Some (_, id) ->
+        match htab_search cx.ctxt_all_defns id with
+            Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type _ })
+          | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj _ })
+          | Some (DEFN_ty_param _) -> id
+          | _ ->
+              err None "Found non-type binding for %a"
+                Ast.sprintf_name name
+;;
+
+
+let get_ty_references
+    (t:Ast.ty)
+    (cx:ctxt)
+    (scopes:scope list)
+    : node_id list =
+  let base = ty_fold_list_concat () in
+  let ty_fold_named n =
+    [ lookup_type_node_by_name cx scopes n ]
+  in
+  let fold = { base with ty_fold_named = ty_fold_named } in
+    fold_ty fold t
+;;
+
+
+let type_reference_and_tag_extracting_visitor
+    (cx:ctxt)
+    (scopes:(scope list) ref)
+    (node_to_references:(node_id,node_id list) Hashtbl.t)
+    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+  let visit_mod_item_pre id params item =
+    begin
+      match item.node.Ast.decl_item with
+          Ast.MOD_ITEM_type ty ->
+            begin
+              log cx "extracting references for type node %d"
+                (int_of_node item.id);
+              let referenced = get_ty_references ty cx (!scopes) in
+                List.iter
+                  (fun i -> log cx "type %d references type %d"
+                     (int_of_node item.id) (int_of_node i)) referenced;
+                htab_put node_to_references item.id referenced;
+                match ty with
+                    Ast.TY_tag ttag ->
+                      htab_put all_tags item.id (ttag, (!scopes))
+                  | _ -> ()
+            end
+        | _ -> ()
+    end;
+    inner.Walk.visit_mod_item_pre id params item
+  in
+    { inner with
+        Walk.visit_mod_item_pre = visit_mod_item_pre }
+;;
+
+
+type recur_info =
+    { recur_all_nodes: node_id list;
+      recur_curr_iso: (node_id array) option; }
+;;
+
+let empty_recur_info =
+  { recur_all_nodes = [];
+    recur_curr_iso = None }
+;;
+
+let push_node r n =
+  { r with recur_all_nodes = n :: r.recur_all_nodes }
+;;
+
+let set_iso r i =
+  { r with recur_curr_iso = Some i }
+;;
+
+
+let index_in_curr_iso (recur:recur_info) (node:node_id) : int option =
+  match recur.recur_curr_iso with
+      None -> None
+    | Some iso ->
+        let rec search i =
+          if i >= (Array.length iso)
+          then None
+          else
+            if iso.(i) = node
+            then Some i
+            else search (i+1)
+        in
+          search 0
+;;
+
+let need_ty_tag t =
+  match t with
+      Ast.TY_tag ttag -> ttag
+    | _ -> err None "needed ty_tag"
+;;
+
+
+let rec ty_iso_of
+    (cx:ctxt)
+    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+    (n:node_id)
+    : Ast.ty =
+  let _ = iflog cx (fun _ -> log cx "+++ ty_iso_of #%d" (int_of_node n)) in
+  let group_table = Hashtbl.find recursive_tag_groups n in
+  let group_array = Array.of_list (htab_keys group_table) in
+  let compare_nodes a_id b_id =
+    (* FIXME: this should sort by the sorted name-lists of the
+     *constructors* of the tag, not the tag type name. *)
+    let a_name = Hashtbl.find cx.ctxt_all_item_names a_id in
+    let b_name = Hashtbl.find cx.ctxt_all_item_names b_id in
+      compare a_name b_name
+  in
+  let recur = set_iso (push_node empty_recur_info n) group_array in
+  let resolve_member member =
+    let (tag, scopes) = Hashtbl.find all_tags member in
+    let ty = Ast.TY_tag tag in
+    let ty = resolve_type cx scopes recursive_tag_groups all_tags recur ty in
+      need_ty_tag ty
+  in
+    Array.sort compare_nodes group_array;
+    log cx "resolving node %d, %d-member iso group"
+      (int_of_node n) (Array.length group_array);
+    Array.iteri (fun i n -> log cx "member %d: %d" i
+                   (int_of_node n)) group_array;
+    let group = Array.map resolve_member group_array in
+    let rec search i =
+      if i >= (Array.length group_array)
+      then err None "node is not a member of its own iso group"
+      else
+        if group_array.(i) = n
+        then i
+        else search (i+1)
+    in
+    let iso =
+      Ast.TY_iso { Ast.iso_index = (search 0);
+                   Ast.iso_group = group }
+    in
+    iflog cx (fun _ ->
+                log cx "--- ty_iso_of #%d ==> %a"
+                  (int_of_node n) Ast.sprintf_ty iso);
+      iso
+
+
+and lookup_type_by_name
+    (cx:ctxt)
+    (scopes:scope list)
+    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+    (recur:recur_info)
+    (name:Ast.name)
+    : ((scope list) * node_id * Ast.ty) =
+  iflog cx (fun _ ->
+              log cx "+++ lookup_type_by_name %a"
+                Ast.sprintf_name name);
+  match lookup_by_name cx scopes name with
+      None -> err None "unknown name: %a" Ast.sprintf_name name
+    | Some (scopes', id) ->
+        let ty, params =
+          match htab_search cx.ctxt_all_defns id with
+              Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type t;
+                                Ast.decl_params = params }) ->
+                (t, Array.map (fun p -> p.node) params)
+            | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj ob;
+                                Ast.decl_params = params }) ->
+                (Ast.TY_obj (ty_obj_of_obj ob),
+                 Array.map (fun p -> p.node) params)
+            | Some (DEFN_ty_param (_, x)) ->
+                (Ast.TY_param x, [||])
+            | _ ->
+                err None "Found non-type binding for %a"
+                  Ast.sprintf_name name
+        in
+        let args =
+          match name with
+              Ast.NAME_ext (_, Ast.COMP_app (_, args)) -> args
+            | Ast.NAME_base (Ast.BASE_app (_, args)) -> args
+            | _ -> [| |]
+        in
+        let args =
+          iflog cx (fun _ -> log cx
+                      "lookup_type_by_name %a resolving %d type args"
+                      Ast.sprintf_name name
+                      (Array.length args));
+          Array.mapi
+            begin
+              fun i t ->
+                let t =
+                  resolve_type cx scopes recursive_tag_groups
+                    all_tags recur t
+                in
+                  iflog cx (fun _ -> log cx
+                              "lookup_type_by_name resolved arg %d to %a" i
+                              Ast.sprintf_ty t);
+                  t
+            end
+            args
+        in
+          iflog cx
+            begin
+              fun _ ->
+                log cx
+                  "lookup_type_by_name %a found ty %a"
+                  Ast.sprintf_name name Ast.sprintf_ty ty;
+                log cx "applying %d type args to %d params"
+                  (Array.length args) (Array.length params);
+                log cx "params: %s"
+                  (Ast.fmt_to_str Ast.fmt_decl_params params);
+                log cx "args: %s"
+                  (Ast.fmt_to_str Ast.fmt_app_args args);
+            end;
+          let ty = rebuild_ty_under_params ty params args true in
+            iflog cx (fun _ -> log cx "--- lookup_type_by_name %a ==> %a"
+                        Ast.sprintf_name name
+                        Ast.sprintf_ty ty);
+            (scopes', id, ty)
+
+and resolve_type
+    (cx:ctxt)
+    (scopes:(scope list))
+    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+    (recur:recur_info)
+    (t:Ast.ty)
+    : Ast.ty =
+  let _ = iflog cx (fun _ -> log cx "+++ resolve_type %a" Ast.sprintf_ty t) in
+  let base = ty_fold_rebuild (fun t -> t) in
+  let ty_fold_named name =
+    let (scopes, node, t) =
+      lookup_type_by_name cx scopes recursive_tag_groups all_tags recur name
+    in
+      iflog cx (fun _ ->
+                  log cx "resolved type name '%a' to item %d with ty %a"
+                  Ast.sprintf_name name (int_of_node node) Ast.sprintf_ty t);
+      match index_in_curr_iso recur node with
+          Some i -> Ast.TY_idx i
+        | None ->
+            if Hashtbl.mem recursive_tag_groups node
+            then
+              begin
+                let ttag = need_ty_tag t in
+                  Hashtbl.replace all_tags node (ttag, scopes);
+                  ty_iso_of cx recursive_tag_groups all_tags node
+              end
+            else
+              if List.mem node recur.recur_all_nodes
+              then (err (Some node) "infinite recursive type definition: '%a'"
+                      Ast.sprintf_name name)
+              else
+                let recur = push_node recur node in
+                  iflog cx (fun _ -> log cx "recursively resolving type %a"
+                              Ast.sprintf_ty t);
+                  resolve_type cx scopes recursive_tag_groups all_tags recur t
+  in
+  let fold =
+    { base with
+        ty_fold_named = ty_fold_named; }
+  in
+  let t' = fold_ty fold t in
+    iflog cx (fun _ ->
+                log cx "--- resolve_type %a ==> %a"
+                  Ast.sprintf_ty t Ast.sprintf_ty t');
+    t'
+;;
+
+
+let type_resolving_visitor
+    (cx:ctxt)
+    (scopes:(scope list) ref)
+    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+
+  let resolve_ty (t:Ast.ty) : Ast.ty =
+    resolve_type cx (!scopes) recursive_tag_groups all_tags empty_recur_info t
+  in
+
+  let resolve_slot (s:Ast.slot) : Ast.slot =
+    match s.Ast.slot_ty with
+        None -> s
+      | Some ty -> { s with Ast.slot_ty = Some (resolve_ty ty) }
+  in
+
+  let resolve_slot_identified
+      (s:Ast.slot identified)
+      : (Ast.slot identified) =
+    try
+      let slot = resolve_slot s.node in
+        { s with node = slot }
+    with
+        Semant_err (None, e) -> raise (Semant_err ((Some s.id), e))
+  in
+
+  let visit_slot_identified_pre slot =
+    let slot = resolve_slot_identified slot in
+      htab_put cx.ctxt_all_defns slot.id (DEFN_slot slot.node);
+      log cx "collected resolved slot #%d with type %s" (int_of_node slot.id)
+        (match slot.node.Ast.slot_ty with
+             None -> "??"
+           | Some t -> (Ast.fmt_to_str Ast.fmt_ty t));
+      inner.Walk.visit_slot_identified_pre slot
+  in
+
+  let visit_mod_item_pre id params item =
+    begin
+      try
+        match item.node.Ast.decl_item with
+            Ast.MOD_ITEM_type ty ->
+              let ty =
+                resolve_type cx (!scopes) recursive_tag_groups
+                  all_tags empty_recur_info ty
+              in
+                log cx "resolved item %s, defining type %a"
+                  id Ast.sprintf_ty ty;
+                htab_put cx.ctxt_all_type_items item.id ty;
+                htab_put cx.ctxt_all_item_types item.id Ast.TY_type
+
+          (* 
+           * Don't resolve the "type" of a mod item; just resolve its
+           * members.
+           *)
+          | Ast.MOD_ITEM_mod _ -> ()
+
+          | Ast.MOD_ITEM_tag (header_slots, _, nid)
+              when Hashtbl.mem recursive_tag_groups nid ->
+              begin
+                match ty_of_mod_item true item with
+                    Ast.TY_fn (tsig, taux) ->
+                      let input_slots =
+                        Array.map
+                          (fun sloti -> resolve_slot sloti.node)
+                          header_slots
+                      in
+                      let output_slot =
+                        interior_slot (ty_iso_of cx recursive_tag_groups
+                                         all_tags nid)
+                      in
+                      let ty =
+                        Ast.TY_fn
+                          ({tsig with
+                              Ast.sig_input_slots = input_slots;
+                              Ast.sig_output_slot = output_slot }, taux)
+                      in
+                        log cx "resolved recursive tag %s, type as %a"
+                          id Ast.sprintf_ty ty;
+                        htab_put cx.ctxt_all_item_types item.id ty
+                  | _ -> bug () "recursive tag with non-function type"
+              end
+
+          | _ ->
+              let t = ty_of_mod_item true item in
+              let ty =
+                resolve_type cx (!scopes) recursive_tag_groups
+                  all_tags empty_recur_info t
+              in
+                log cx "resolved item %s, type as %a" id Ast.sprintf_ty ty;
+                htab_put cx.ctxt_all_item_types item.id ty;
+      with
+          Semant_err (None, e) -> raise (Semant_err ((Some item.id), e))
+    end;
+    inner.Walk.visit_mod_item_pre id params item
+  in
+
+  let visit_obj_fn_pre obj ident fn =
+    let fty =
+      resolve_type cx (!scopes) recursive_tag_groups all_tags
+        empty_recur_info (Ast.TY_fn (ty_fn_of_fn fn.node))
+    in
+      log cx "resolved obj fn %s as %a" ident Ast.sprintf_ty fty;
+      htab_put cx.ctxt_all_item_types fn.id fty;
+      inner.Walk.visit_obj_fn_pre obj ident fn
+  in
+
+  let visit_obj_drop_pre obj b =
+    let fty = mk_simple_ty_fn [| |] in
+      htab_put cx.ctxt_all_item_types b.id fty;
+      inner.Walk.visit_obj_drop_pre obj b
+  in
+
+  let visit_stmt_pre stmt =
+    begin
+      match stmt.node with
+          Ast.STMT_for_each fe ->
+            let id = fe.Ast.for_each_body.id in
+            let fty = mk_simple_ty_iter [| |] in
+              htab_put cx.ctxt_all_item_types id fty;
+        | Ast.STMT_copy (_, Ast.EXPR_unary (Ast.UNOP_cast t, _)) ->
+            let ty = resolve_ty t.node in
+              htab_put cx.ctxt_all_cast_types t.id ty
+        | _ -> ()
+    end;
+    inner.Walk.visit_stmt_pre stmt
+  in
+
+  let visit_lval_pre lv =
+    let rec rebuild_lval' lv =
+      match lv with
+          Ast.LVAL_ext (base, ext) ->
+            let ext =
+              match ext with
+                  Ast.COMP_named (Ast.COMP_ident _)
+                | Ast.COMP_named (Ast.COMP_idx _)
+                | Ast.COMP_atom (Ast.ATOM_literal _) -> ext
+                | Ast.COMP_atom (Ast.ATOM_lval lv) ->
+                    Ast.COMP_atom (Ast.ATOM_lval (rebuild_lval lv))
+                | Ast.COMP_named (Ast.COMP_app (ident, params)) ->
+                    Ast.COMP_named
+                      (Ast.COMP_app (ident, Array.map resolve_ty params))
+            in
+              Ast.LVAL_ext (rebuild_lval' base, ext)
+
+        | Ast.LVAL_base nb ->
+            let node =
+              match nb.node with
+                  Ast.BASE_ident _
+                | Ast.BASE_temp _ -> nb.node
+                | Ast.BASE_app (ident, params) ->
+                    Ast.BASE_app (ident, Array.map resolve_ty params)
+            in
+              Ast.LVAL_base {nb with node = node}
+
+    and rebuild_lval lv =
+      let id = lval_base_id lv in
+      let lv' = rebuild_lval' lv in
+        iflog cx (fun _ -> log cx "rebuilt lval %a as %a (#%d)"
+                    Ast.sprintf_lval lv Ast.sprintf_lval lv'
+                    (int_of_node id));
+        htab_put cx.ctxt_all_lvals id lv';
+        lv'
+    in
+      ignore (rebuild_lval lv);
+      inner.Walk.visit_lval_pre lv
+  in
+
+    { inner with
+        Walk.visit_slot_identified_pre = visit_slot_identified_pre;
+        Walk.visit_mod_item_pre = visit_mod_item_pre;
+        Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+        Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+        Walk.visit_stmt_pre = visit_stmt_pre;
+        Walk.visit_lval_pre = visit_lval_pre; }
+;;
+
+
+let lval_base_resolving_visitor
+    (cx:ctxt)
+    (scopes:(scope list) ref)
+    (inner:Walk.visitor)
+    : Walk.visitor =
+  let lookup_referent_by_ident id ident =
+    log cx "looking up slot or item with ident '%s'" ident;
+    match lookup cx (!scopes) (Ast.KEY_ident ident) with
+        None -> err (Some id) "unresolved identifier '%s'" ident
+      | Some (_, id) -> (log cx "resolved to node id #%d"
+                           (int_of_node id); id)
+  in
+  let lookup_slot_by_temp id temp =
+    log cx "looking up temp slot #%d" (int_of_temp temp);
+    let res = lookup cx (!scopes) (Ast.KEY_temp temp) in
+      match res with
+          None -> err
+            (Some id) "unresolved temp node #%d" (int_of_temp temp)
+        | Some (_, id) ->
+            (log cx "resolved to node id #%d" (int_of_node id); id)
+  in
+  let lookup_referent_by_name_base id nb =
+    match nb with
+        Ast.BASE_ident ident
+      | Ast.BASE_app (ident, _) -> lookup_referent_by_ident id ident
+      | Ast.BASE_temp temp -> lookup_slot_by_temp id temp
+  in
+
+  let visit_lval_pre lv =
+    let rec lookup_lval lv =
+      iflog cx (fun _ ->
+                  log cx "looking up lval #%d"
+                    (int_of_node (lval_base_id lv)));
+      match lv with
+          Ast.LVAL_ext (base, ext) ->
+            begin
+              lookup_lval base;
+              match ext with
+                  Ast.COMP_atom (Ast.ATOM_lval lv') -> lookup_lval lv'
+                | _ -> ()
+            end
+        | Ast.LVAL_base nb ->
+            let referent_id = lookup_referent_by_name_base nb.id nb.node in
+              iflog cx (fun _ -> log cx "resolved lval #%d to referent #%d"
+                          (int_of_node nb.id) (int_of_node referent_id));
+              htab_put cx.ctxt_lval_to_referent nb.id referent_id
+    in
+      lookup_lval lv;
+      inner.Walk.visit_lval_pre lv
+  in
+    { inner with
+        Walk.visit_lval_pre = visit_lval_pre }
+;;
+
+
+
+(*
+ * iso-recursion groups are very complicated.
+ * 
+ *   - iso groups are always rooted at *named* ty_tag nodes
+ * 
+ *   - consider: 
+ * 
+ *    type colour = tag(red, green, blue);
+ *    type list = tag(cons(colour, @list), nil())
+ * 
+ *    this should include list as an iso but not colour,
+ *    should result in:
+ * 
+ *    type list = iso[<0>:tag(cons(tag(red,green,blue),@#1))]
+ * 
+ *   - consider:
+ * 
+ *    type colour = tag(red, green, blue);
+ *    type tree = tag(children(@list), leaf(colour))
+ *    type list = tag(cons(@tree, @list), nil())
+ * 
+ *    this should result in:
+ * 
+ *    type list = iso[<0>:tag(cons(@#2, @#1),nil());
+ *                    1: tag(children(@#1),leaf(tag(red,green,blue)))]
+ * 
+ *  - how can you calculate these?
+ * 
+ *    - start by making a map from named-tag-node-id -> referenced-other-nodes
+ *    - for each member in the set, if you can get from itself to itself, keep
+ *      it, otherwise it's non-recursive => non-interesting, delete it.
+ *    - group the members (now all recursive) by dependency
+ *    - assign index-number to each elt of group
+ *    - fully resolve each elt of group, turning names into numbers or chasing
+ *      through to fully-resolving targets as necessary
+ *    - place group in iso, store differently-indexed value in table for each
+ * 
+ * 
+ *  - what are the illegal forms?
+ *    - recursion that takes indefinite storage to form a tag, eg.
+ * 
+ *      type t = tag(foo(t));
+ *
+ *    - recursion that makes a tag unconstructable, eg:
+ * 
+ *      type t = tag(foo(@t));
+ *)
+
+let resolve_recursion
+    (cx:ctxt)
+    (node_to_references:(node_id,node_id list) Hashtbl.t)
+    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+    : unit =
+
+  let recursive_tag_types = Hashtbl.create 0 in
+
+  let rec can_reach
+      (target:node_id)
+      (visited:node_id list)
+      (curr:node_id)
+      : bool =
+    if List.mem curr visited
+    then false
+    else
+      match htab_search node_to_references curr with
+          None -> false
+        | Some referenced ->
+            if List.mem target referenced
+            then true
+            else List.exists (can_reach target (curr :: visited)) referenced
+  in
+
+  let extract_recursive_tags _ =
+    Hashtbl.iter
+      begin fun id _ ->
+        if can_reach id [] id
+        then begin
+          match Hashtbl.find cx.ctxt_all_defns id with
+              DEFN_item
+                { Ast.decl_item = Ast.MOD_ITEM_type (Ast.TY_tag _) } ->
+                log cx "type %d is a recursive tag" (int_of_node id);
+                Hashtbl.replace recursive_tag_types id ()
+            | _ ->
+                log cx "type %d is recursive, but not a tag" (int_of_node id);
+        end
+        else log cx "type %d is non-recursive" (int_of_node id);
+      end
+      node_to_references
+  in
+
+  let group_recursive_tags _ =
+    while (Hashtbl.length recursive_tag_types) != 0 do
+      let keys = htab_keys recursive_tag_types in
+      let root = List.hd keys in
+      let group = Hashtbl.create 0 in
+      let rec walk visited node =
+        if List.mem node visited
+        then ()
+        else
+          begin
+            if Hashtbl.mem recursive_tag_types node
+            then
+              begin
+                Hashtbl.remove recursive_tag_types node;
+                htab_put recursive_tag_groups node group;
+                htab_put group node ();
+                log cx "recursion group rooted at tag %d contains tag %d"
+                  (int_of_node root) (int_of_node node);
+              end;
+            match htab_search node_to_references node with
+                None -> ()
+              | Some referenced ->
+                  List.iter (walk (node :: visited)) referenced
+          end
+      in
+        walk [] root;
+    done
+  in
+
+    begin
+      extract_recursive_tags ();
+      group_recursive_tags ();
+      log cx "found %d independent type-recursion groups"
+        (Hashtbl.length recursive_tag_groups);
+    end
+;;
+
+let pattern_resolving_visitor
+    (cx:ctxt)
+    (scopes:scope list ref)
+    (inner:Walk.visitor) : Walk.visitor =
+  let visit_stmt_pre stmt =
+    begin
+      match stmt.node with
+        Ast.STMT_alt_tag { Ast.alt_tag_lval = _; Ast.alt_tag_arms = arms } ->
+          let resolve_arm { node = arm } =
+            match fst arm with
+                Ast.PAT_tag (ident, _) ->
+                  begin
+                    match lookup_by_ident cx !scopes ident with
+                        None ->
+                          err None "unresolved tag constructor '%s'" ident
+                      | Some (_, tag_id) ->
+                          match Hashtbl.find cx.ctxt_all_defns tag_id with
+                              DEFN_item {
+                                  Ast.decl_item = Ast.MOD_ITEM_tag _
+                                } -> ()
+                            | _ ->
+                                err None "'%s' is not a tag constructor" ident
+                  end
+              | _ -> ()
+
+          in
+          Array.iter resolve_arm arms
+      | _ -> ()
+    end;
+    inner.Walk.visit_stmt_pre stmt
+  in
+  { inner with Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let process_crate
+    (cx:ctxt)
+    (crate:Ast.crate)
+    : unit =
+  let (scopes:(scope list) ref) = ref [] in
+  let path = Stack.create () in
+
+  let node_to_references = Hashtbl.create 0 in
+  let all_tags = Hashtbl.create 0 in
+  let recursive_tag_groups = Hashtbl.create 0 in
+
+  let passes_0 =
+    [|
+      (block_scope_forming_visitor cx Walk.empty_visitor);
+      (stmt_collecting_visitor cx
+         (all_item_collecting_visitor cx path
+            Walk.empty_visitor));
+      (scope_stack_managing_visitor scopes
+         (type_reference_and_tag_extracting_visitor
+            cx scopes node_to_references all_tags
+            Walk.empty_visitor))
+    |]
+  in
+  let passes_1 =
+    [|
+      (scope_stack_managing_visitor scopes
+         (type_resolving_visitor cx scopes
+            recursive_tag_groups all_tags
+            (lval_base_resolving_visitor cx scopes
+               Walk.empty_visitor)));
+    |]
+  in
+  let passes_2 =
+    [|
+      (scope_stack_managing_visitor scopes
+        (pattern_resolving_visitor cx scopes
+          Walk.empty_visitor))
+    |]
+  in
+    log cx "running primary resolve passes";
+    run_passes cx "resolve collect" path passes_0 (log cx "%s") crate;
+    resolve_recursion cx node_to_references recursive_tag_groups;
+    log cx "running secondary resolve passes";
+    run_passes cx "resolve bind" path passes_1 (log cx "%s") crate;
+    log cx "running tertiary resolve passes";
+    run_passes cx "resolve patterns" path passes_2 (log cx "%s") crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+