Tidy up handling of unimplemented features. These are expected (if undesirable) sorts of error, we should handle better than "backtrace and exit 2".

Author: graydon

src/boot/driver/main.ml

@@ -238,7 +238,7 @@ let _ =
 ;;
 
 
-let (crate:Ast.crate) =
+let parse_input_crate _ : Ast.crate =
   Session.time_inner "parse" sess
     begin
       fun _ ->
@@ -292,6 +292,15 @@ let (crate:Ast.crate) =
     end
 ;;
 
+let (crate:Ast.crate) =
+  try
+    parse_input_crate()
+  with
+      Not_implemented (ido, str) ->
+        Session.report_err sess ido str;
+        { node = Ast.empty_crate'; id = Common.Node 0 }
+;;
+
 exit_if_failed ()
 ;;
 
@@ -399,9 +408,16 @@ let main_pipeline _ =
           exit_if_failed ()
 ;;
 
-if sess.Session.sess_alt_backend
-then Glue.alt_pipeline sess sem_cx crate
-else main_pipeline ()
+try
+  if sess.Session.sess_alt_backend
+  then Glue.alt_pipeline sess sem_cx crate
+  else main_pipeline ()
+with
+    Not_implemented (ido, str) ->
+      Session.report_err sess ido str
+;;
+
+exit_if_failed ()
 ;;
 
 if sess.Session.sess_report_timing

src/boot/driver/session.ml

@@ -101,6 +101,19 @@ let filename_of (fo:filename option) : filename =
     | Some f -> f
 ;;
 
+let report_err sess ido str =
+  let spano = match ido with
+      None -> None
+    | Some id -> get_span sess id
+  in
+    match spano with
+        None ->
+          fail sess "Error: %s\n%!" str
+      | Some span ->
+          fail sess "%s:E:Error: %s\n%!"
+            (string_of_span span) str
+;;
+
 (*
  * Local Variables:
  * fill-column: 78;

src/boot/fe/ast.ml

@@ -457,6 +457,18 @@ and crate' =
 and crate = crate' identified
 ;;
 
+let empty_crate' =
+  { crate_items = ({ view_imports = Hashtbl.create 0;
+                     view_exports = Hashtbl.create 0 },
+                   Hashtbl.create 0);
+    crate_meta = [||];
+    crate_auth = Hashtbl.create 0;
+    crate_required = Hashtbl.create 0;
+    crate_required_syms = Hashtbl.create 0;
+    crate_main = None;
+    crate_files = Hashtbl.create 0 }
+;;
+
 (*
  * NB: names can only be type-parametric in their *last* path-entry.
  * All path-entries before that must be ident or idx (non-parametric).

src/boot/fe/cexp.ml

@@ -605,14 +605,7 @@ let with_err_handling sess thunk =
                (Session.string_of_pos pos) cx)
           ps.pstate_ctxt;
         let apos = lexpos ps in
-          span ps apos apos
-            { Ast.crate_items = (Item.empty_view, Hashtbl.create 0);
-              Ast.crate_meta = [||];
-              Ast.crate_auth = Hashtbl.create 0;
-              Ast.crate_required = Hashtbl.create 0;
-              Ast.crate_required_syms = Hashtbl.create 0;
-              Ast.crate_main = None;
-              Ast.crate_files = Hashtbl.create 0 }
+          span ps apos apos Ast.empty_crate'
 ;;
 
 

src/boot/llvm/lltrans.ml

@@ -330,8 +330,7 @@ let trans_crate
 
       | Ast.TY_tag _ | Ast.TY_iso _ | Ast.TY_idx _
       | Ast.TY_obj _ | Ast.TY_type ->
-          raise (Not_implemented
-                   ("trans_ty_full " ^ (Ast.sprintf_ty() ty)))
+          Common.unimpl None "LLVM type translation for: %a" Ast.sprintf_ty ty
 
       | Ast.TY_param _ | Ast.TY_named _ ->
           bug () "unresolved type in lltrans"
@@ -566,9 +565,10 @@ let trans_crate
             ()  (* Modules simply contain other items that are translated
                    on their own. *)
 
-        | _ -> raise (Not_implemented
-                        ("declare_mod_item " ^
-                           (Ast.sprintf_mod_item() (name,mod_item))))
+        | _ ->
+            Common.unimpl (Some id)
+              "LLVM module declaration for: %a"
+              Ast.sprintf_mod_item (name, mod_item)
   in
 
   let trans_fn
@@ -715,12 +715,15 @@ let trans_crate
                 match referent with
                     Semant.DEFN_slot _ -> Hashtbl.find slot_to_llvalue id
                   | Semant.DEFN_item _ -> Hashtbl.find llitems id
-                  | _ -> raise
-                      (Not_implemented
-                         ("referent of " ^ (Ast.sprintf_lval() lval)))
+                  | _ ->
+                      Common.unimpl (Some id)
+                        "LLVM base-referent translation of: %a"
+                        Ast.sprintf_lval lval
               end
-          | Ast.LVAL_ext _ -> raise
-              (Not_implemented ("trans_lval " ^ (Ast.sprintf_lval() lval)))
+          | Ast.LVAL_ext _ ->
+              Common.unimpl (Some (Semant.lval_base_id lval))
+                        "LLVM lval translation of: %a"
+                        Ast.sprintf_lval lval
       in
 
       let trans_atom (atom:Ast.atom) : Llvm.llvalue =
@@ -746,8 +749,10 @@ let trans_crate
           | Ast.BINOP_div -> Llvm.build_sdiv lllhs llrhs llid llbuilder
           | Ast.BINOP_mod -> Llvm.build_srem lllhs llrhs llid llbuilder
 
-          | _ -> raise
-              (Not_implemented ("build_binop " ^ (Ast.sprintf_binop() op)))
+          | _ ->
+              Common.unimpl None
+                "LLVM binop trranslation of: %a"
+                Ast.sprintf_binop op
       in
 
       let trans_binary_expr
@@ -770,9 +775,10 @@ let trans_crate
           build_binop op lllhs llrhs
       in
 
-      let trans_unary_expr e = raise
-        (Not_implemented ("trans_unary_expr " ^
-                            (Ast.sprintf_expr() (Ast.EXPR_unary e))))
+      let trans_unary_expr e =
+        Common.unimpl None
+          "LLVM unary-expression translation of: %a"
+          Ast.sprintf_expr (Ast.EXPR_unary e)
       in
 
       let trans_expr (expr:Ast.expr) : Llvm.llvalue =
@@ -945,8 +951,10 @@ let trans_crate
               | Ast.STMT_decl _ ->
                   trans_tail ()
 
-              | _ -> raise (Not_implemented
-                              ("trans_stmts " ^ (Ast.sprintf_stmt() head)))
+              | _ ->
+                  Common.unimpl (Some head.id)
+                    "LLVM statement translation of: %a"
+                    Ast.sprintf_stmt head
 
     (* 
      * Translates an AST block to one or more LLVM basic blocks and returns

src/boot/me/semant.ml

@@ -261,23 +261,10 @@ let new_ctxt sess abi crate =
   }
 ;;
 
-let report_err cx ido str =
-  let sess = cx.ctxt_sess in
-  let spano = match ido with
-      None -> None
-    | Some id -> (Session.get_span sess id)
-  in
-    match spano with
-        None ->
-          Session.fail sess "Error: %s\n%!" str
-      | Some span ->
-          Session.fail sess "%s:E:Error: %s\n%!"
-            (Session.string_of_span span) str
-;;
 
 let bugi (cx:ctxt) (i:node_id) =
   let k s =
-    report_err cx (Some i) s;
+    Session.report_err cx.ctxt_sess (Some i) s;
     failwith s
   in Printf.ksprintf k
 ;;
@@ -1857,7 +1844,8 @@ let run_passes
         Session.time_inner name sess
           (fun _ -> Array.iteri do_pass passes)
       with
-          Semant_err (ido, str) -> report_err cx ido str
+          Semant_err (ido, str) ->
+            Session.report_err cx.ctxt_sess ido str
 ;;
 
 (* Rust type -> IL type conversion. *)

src/boot/me/type.ml

@@ -950,15 +950,14 @@ let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit =
     }
   in
 
-  try
-    Walk.walk_crate
-      (Walk.path_managing_visitor path
-        (Semant.mod_item_logging_visitor
-          cx
-          cx.Semant.ctxt_sess.Session.sess_log_type log 0 path
-          (visitor cx Walk.empty_visitor)))
-      crate
-  with Common.Semant_err (ido, str) -> Semant.report_err cx ido str;
+  let passes =
+    [|
+      (visitor cx Walk.empty_visitor)
+    |]
+  in
+  let log_flag = cx.Semant.ctxt_sess.Session.sess_log_type in
+    Semant.run_passes cx "type" path passes log_flag log crate
+;;
 
 (*
  * Local Variables:

src/boot/util/common.ml

@@ -26,7 +26,7 @@ let bug _ =
 ;;
 
 (* TODO: On some joyous day, remove me. *)
-exception Not_implemented of string
+exception Not_implemented of ((node_id option) * string)
 ;;
 
 exception Semant_err of ((node_id option) * string)
@@ -39,6 +39,13 @@ let err (idopt:node_id option) =
     Printf.ksprintf k
 ;;
 
+let unimpl (idopt:node_id option) =
+  let k s =
+    raise (Not_implemented (idopt, "unimplemented " ^ s))
+  in
+    Printf.ksprintf k
+;;
+
 (* Some ubiquitous low-level types. *)
 
 type target =