diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/me/resolve.ml | 19 | ||||
| -rw-r--r-- | src/boot/me/semant.ml | 148 |
2 files changed, 79 insertions, 88 deletions
diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml index d0b54a74..4fafa05f 100644 --- a/src/boot/me/resolve.ml +++ b/src/boot/me/resolve.ml @@ -423,7 +423,10 @@ let type_resolving_visitor 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 + htab_put cx.ctxt_all_item_types item.id Ast.TY_type; + if Hashtbl.mem cx.ctxt_all_item_names item.id then + Hashtbl.add cx.ctxt_user_type_names ty + (Hashtbl.find cx.ctxt_all_item_names item.id) (* * Don't resolve the "type" of a mod item; just resolve its @@ -880,19 +883,7 @@ let process_crate end; (* Post-resolve, we can establish a tag cache. *) cx.ctxt_tag_cache <- Some (Hashtbl.create 0); - cx.ctxt_rebuild_cache <- Some (Hashtbl.create 0); - - (* Also index all the type names for future error messages. *) - Hashtbl.iter - begin - fun item_id ty -> - let item_names = cx.Semant.ctxt_all_item_names in - if Hashtbl.mem item_names item_id then - Hashtbl.add cx.Semant.ctxt_user_type_names ty - (Hashtbl.find item_names item_id) - end - cx.Semant.ctxt_all_type_items; - + cx.ctxt_rebuild_cache <- Some (Hashtbl.create 0) ;; (* diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index f6be30af..0bb6a8bb 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -969,6 +969,79 @@ let ty_fold_rebuild (id:Ast.ty -> Ast.ty) id (Ast.TY_constrained (t, constrs))) } ;; +let rec pretty_ty_str (cx:ctxt) (fallback:(Ast.ty -> string)) (ty:Ast.ty) = + let cache = cx.ctxt_user_type_names in + if Hashtbl.mem cache ty then + let names = List.map (Ast.sprintf_name ()) (Hashtbl.find_all cache ty) in + String.concat " = " names + else + match ty with + Ast.TY_vec ty' -> "vec[" ^ (pretty_ty_str cx fallback ty') ^ "]" + | Ast.TY_chan ty' -> + "chan[" ^ (pretty_ty_str cx fallback ty') ^ "]" + | Ast.TY_port ty' -> + "port[" ^ (pretty_ty_str cx fallback ty') ^ "]" + | Ast.TY_box ty' -> "@" ^ (pretty_ty_str cx fallback ty') + | Ast.TY_mutable ty' -> + "(mutable " ^ (pretty_ty_str cx fallback ty') ^ ")" + | Ast.TY_constrained (ty', _) -> + "(" ^ (pretty_ty_str cx fallback ty') ^ " : <constrained>)" + | Ast.TY_tup tys -> + let tys_str = Array.map (pretty_ty_str cx fallback) tys in + "tup(" ^ (String.concat ", " (Array.to_list tys_str)) ^ ")" + | Ast.TY_rec fields -> + let format_field (ident, ty') = + ident ^ "=" ^ (pretty_ty_str cx fallback ty') + in + let fields = Array.to_list (Array.map format_field fields) in + "rec(" ^ (String.concat ", " fields) ^ ")" + | Ast.TY_fn (fnsig, _) -> + let format_slot slot = + match slot.Ast.slot_ty with + None -> Common.bug () "no ty in slot" + | Some ty' -> pretty_ty_str cx fallback ty' + in + let fn_args = Array.map format_slot fnsig.Ast.sig_input_slots in + let fn_args_str = String.concat ", " (Array.to_list fn_args) in + let fn_rv_str = format_slot fnsig.Ast.sig_output_slot in + Printf.sprintf "fn(%s) -> %s" fn_args_str fn_rv_str + | Ast.TY_tag { Ast.tag_id = tag_id; Ast.tag_args = args } -> + let tag_info = Hashtbl.find cx.ctxt_all_tag_info tag_id in + let tag_idents = tag_info.tag_idents in + let item_id = ref None in + (* Ugly hack ahead... *) + begin + try + Hashtbl.iter + begin + fun _ (_, item_id', _) -> + item_id := Some item_id'; raise Exit + end + tag_idents + with Exit -> (); + end; + begin + match !item_id with + None -> fallback ty + | Some item_id -> + let item_types = cx.ctxt_all_item_types in + let ty = Hashtbl.find item_types item_id in + let args_suffix = + if Array.length args == 0 then "" + else + Printf.sprintf "[%s]" + (String.concat "," + (Array.to_list + (Array.map + (pretty_ty_str cx fallback) + args))) + in + (pretty_ty_str cx fallback ty) ^ args_suffix + end + + | _ -> fallback ty (* TODO: we can do better for objects *) +;; + let rec rebuild_ty_under_params (cx:ctxt) (src_tag:Ast.ty_tag option) @@ -981,7 +1054,7 @@ let rec rebuild_ty_under_params then err None "mismatched type-params: %s has %d param(s) but %d given" - (Ast.sprintf_ty () ty) + (pretty_ty_str cx (Ast.sprintf_ty ()) ty) (Array.length params) (Array.length args) else @@ -2679,79 +2752,6 @@ let glue_str (cx:ctxt) (g:glue) : string = | GLUE_vec_grow -> "glue$vec_grow" ;; -let rec pretty_ty_str (cx:ctxt) (fallback:(Ast.ty -> string)) (ty:Ast.ty) = - let cache = cx.ctxt_user_type_names in - if Hashtbl.mem cache ty then - let names = List.map (Ast.sprintf_name ()) (Hashtbl.find_all cache ty) in - String.concat " = " names - else - match ty with - Ast.TY_vec ty' -> "vec[" ^ (pretty_ty_str cx fallback ty') ^ "]" - | Ast.TY_chan ty' -> - "chan[" ^ (pretty_ty_str cx fallback ty') ^ "]" - | Ast.TY_port ty' -> - "port[" ^ (pretty_ty_str cx fallback ty') ^ "]" - | Ast.TY_box ty' -> "@" ^ (pretty_ty_str cx fallback ty') - | Ast.TY_mutable ty' -> - "(mutable " ^ (pretty_ty_str cx fallback ty') ^ ")" - | Ast.TY_constrained (ty', _) -> - "(" ^ (pretty_ty_str cx fallback ty') ^ " : <constrained>)" - | Ast.TY_tup tys -> - let tys_str = Array.map (pretty_ty_str cx fallback) tys in - "tup(" ^ (String.concat ", " (Array.to_list tys_str)) ^ ")" - | Ast.TY_rec fields -> - let format_field (ident, ty') = - ident ^ "=" ^ (pretty_ty_str cx fallback ty') - in - let fields = Array.to_list (Array.map format_field fields) in - "rec(" ^ (String.concat ", " fields) ^ ")" - | Ast.TY_fn (fnsig, _) -> - let format_slot slot = - match slot.Ast.slot_ty with - None -> Common.bug () "no ty in slot" - | Some ty' -> pretty_ty_str cx fallback ty' - in - let fn_args = Array.map format_slot fnsig.Ast.sig_input_slots in - let fn_args_str = String.concat ", " (Array.to_list fn_args) in - let fn_rv_str = format_slot fnsig.Ast.sig_output_slot in - Printf.sprintf "fn(%s) -> %s" fn_args_str fn_rv_str - | Ast.TY_tag { Ast.tag_id = tag_id; Ast.tag_args = args } -> - let tag_info = Hashtbl.find cx.ctxt_all_tag_info tag_id in - let tag_idents = tag_info.tag_idents in - let item_id = ref None in - (* Ugly hack ahead... *) - begin - try - Hashtbl.iter - begin - fun _ (_, item_id', _) -> - item_id := Some item_id'; raise Exit - end - tag_idents - with Exit -> (); - end; - begin - match !item_id with - None -> fallback ty - | Some item_id -> - let item_types = cx.ctxt_all_item_types in - let ty = Hashtbl.find item_types item_id in - let args_suffix = - if Array.length args == 0 then "" - else - Printf.sprintf "[%s]" - (String.concat "," - (Array.to_list - (Array.map - (pretty_ty_str cx fallback) - args))) - in - (pretty_ty_str cx fallback ty) ^ args_suffix - end - - | _ -> fallback ty (* TODO: we can do better for objects *) -;; - (* * Local Variables: * fill-column: 78; |