[r2004-06-30 17:29:12 by afrisch] Error messages

Original author: afrisch
Date: 2004-06-30 17:29:12+00:00

Makefile.distrib

@@ -149,7 +149,6 @@ OBJECTS = \
  \
  compile/lambda.cmo \
  runtime/value.cmo \
- types/externals.cmo \
  \
  schema/schema_types.cmo \
  schema/schema_xml.cmo \
@@ -160,6 +159,7 @@ OBJECTS = \
  \
  parser/location.cmo parser/url.cmo parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
  \
+ types/externals.cmo \
  typing/typed.cmo typing/typer.cmo \
  \
  runtime/load_xml.cmo runtime/run_dispatch.cmo \

depend

@@ -80,8 +80,8 @@ runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
 runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
     misc/encodings.cmx types/ident.cmx types/intervals.cmx compile/lambda.cmx \
     misc/ns.cmx types/sequence.cmx types/types.cmx runtime/value.cmi 
-types/externals.cmo: types/externals.cmi 
-types/externals.cmx: types/externals.cmi 
+types/externals.cmo: parser/location.cmi types/externals.cmi 
+types/externals.cmx: parser/location.cmx types/externals.cmi 
 schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
     runtime/value.cmi schema/schema_types.cmi 
 schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
@@ -258,6 +258,10 @@ ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
     ocamliface/mlstub.cmi 
 parser/cduce_curl.cmo: driver/config.cmi parser/url.cmi 
 parser/cduce_curl.cmx: driver/config.cmx parser/url.cmx 
+runtime/cduce_pxp.cmo: driver/config.cmi runtime/load_xml.cmi \
+    parser/location.cmi parser/url.cmi 
+runtime/cduce_pxp.cmx: driver/config.cmx runtime/load_xml.cmx \
+    parser/location.cmx parser/url.cmx 
 runtime/cduce_expat.cmo: driver/config.cmi runtime/load_xml.cmi \
     parser/location.cmi parser/url.cmi 
 runtime/cduce_expat.cmx: driver/config.cmx runtime/load_xml.cmx \

driver/run.ml

@@ -72,7 +72,6 @@ let err s =
 let mode () =
   Arg.parse !specs (fun s -> src := s :: !src) 
     "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
-  Config.init_all ();
   match (!compile,!out_dir,!run,!src,!args) with
     | false, _::_, _,  _, _   -> 
 	err "--obj-dir option can be used only with --compile"
@@ -176,16 +175,21 @@ let save () =
 let main () = 
   match mode () with
     | `Toplevel args ->
+	Config.inhibit "ocaml";
+	Config.init_all ();
 	Builtin.argv := argv args;
 	restore ();
 	toploop ();
 	save ()
     | `Script (f,args) ->
+	Config.init_all ();
 	Builtin.argv := argv args;
 	Cduce.compile_run f
     | `Compile (f,o) ->
+	Config.init_all ();
 	Cduce.compile f o
     | `Run (f,args) ->
+	Config.init_all ();
 	Builtin.argv := argv args;
 	Cduce.run f
 	 

ocamliface/cdo2ml.ml

@@ -53,10 +53,10 @@ let () =
 	     (fun (cu,chk) -> <:expr< ($str:str cu$,$str:str chk$) >>)
 	     depend)
       in
-      <:expr< CDuce_all.Librarian.register_unit 
+      <:expr< Cduce_lib.Librarian.register_unit 
 	$str:str name$ $str:str raw$ $str:str digest$ $dep$ >>
     else 
-      <:expr< CDuce_all.Librarian.load_unit $str:str name$ $str:str digest$ >>
+      <:expr< Cduce_lib.Librarian.load_unit $str:str name$ $str:str digest$ >>
   in
   let cu = <:str_item< value cu = $cu$ >> in
 

ocamliface/mlstub.ml

@@ -48,7 +48,7 @@ and typ_descr = function
   | Abstract s -> Types.abstract (Types.Abstract.atom s)
   | Builtin ("list", [t]) -> Types.descr (Sequence.star_node (typ t))
   | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
-  | Builtin ("CDuce_all.Value.t", []) -> Types.any
+  | Builtin ("Cduce_lib.Value.t", []) -> Types.any
   | Builtin ("unit", []) -> Sequence.nil_type
   | Var i -> Types.descr (!vars).(i)
   | _ -> assert false
@@ -268,7 +268,7 @@ and to_cd_descr e = function
 	 <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
       )
 
-  | Builtin ("CDuce_all.Value.t", []) -> e
+  | Builtin ("Cduce_lib.Value.t", []) -> e
   | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
   | Var _ -> e
   | _ -> assert false
@@ -386,7 +386,7 @@ and to_ml_descr e = function
       let e = <:expr< Value.get_field $e$ $label_ascii "get"$ >> in
       let e = <:expr< Eval.eval_apply $e$ Value.nil >> in
       <:expr< Pervasives.ref $to_ml e t$ >>
-  | Builtin ("CDuce_all.Value.t", []) -> e
+  | Builtin ("Cduce_lib.Value.t", []) -> e
   | Builtin ("unit", []) -> <:expr< ignore $e$ >>
   | Var _ -> e
   | _ -> assert false
@@ -469,7 +469,7 @@ let stub name ty_env c_env values =
      let (v1,v2,...,vn) = 
      let module C = struct
       let cu = ...
-      open CDuce_all
+      open Cduce_lib
       let types = ...
       let rec <global translation functions>
       <fills external slots>
@@ -483,7 +483,7 @@ let stub name ty_env c_env values =
   let items_pat = List.map (fun (p,_,_) -> p) items in
 
   let m = 
-    [ <:str_item< open CDuce_all >>;
+    [ <:str_item< open Cduce_lib >>;
       <:str_item< value types = Librarian.registered_types cu >> ] @
     (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
     [ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
@@ -516,24 +516,22 @@ let register () =
 
   Externals.register :=
   (fun i s args ->
-     let (t,n) = 
-       try Mltypes.find_value s 
-       with Not_found ->
-	 Printf.eprintf "Cannot resolve the external symbol %s\n" s;
-	 exit 1
-     in
-     let m = List.length args in
-     if n <> m then
-       (
-	 Printf.eprintf "Wrong arity for external symbol %s (real arity = %i; given = %i)\n" s n m;
-	 exit 1
-       );
-     exts := (s, t) :: !exts;
-
-     vars := Array.of_list args;
-     let cdt = Types.descr (typ t) in
-     vars := [| |];
-     cdt
+     try
+       let (t,n) = Mltypes.find_value s in
+       let m = List.length args in
+       if n <> m then
+	 Location.raise_generic
+	   (Printf.sprintf 
+	      "Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
+       exts := (s, t) :: !exts;
+
+       vars := Array.of_list args;
+       let cdt = Types.descr (typ t) in
+       vars := [| |];
+       cdt
+     with Not_found -> 
+       Location.raise_generic
+         (Printf.sprintf "Cannot resolve ocaml external %s" s)
   )
 
 let () =

types/externals.ml

@@ -2,9 +2,14 @@ let nb_ext_syms = ref 0
 
 let nb () = !nb_ext_syms
 
-let register = ref (fun i s args -> assert false)
+let register = 
+  ref (fun i s args -> 
+	 Location.raise_generic "No built-in support for ocaml externals")
 
 let resolve s args =
   let i = !nb_ext_syms in
+  let x = !register i s args in
   incr nb_ext_syms;
-  (i, !register i s args)
+  (i,x)
+
+

types/externals.mli

@@ -2,4 +2,4 @@ val nb: unit -> int
 
 val register: ref (int -> string -> Types.Node.t list -> Types.t)
 
-val resolve: string -> Types.Node.t list -> int * Types.t 
+val resolve: string -> Types.Node.t list -> (int * Types.t)

typing/typer.ml

@@ -948,9 +948,11 @@ let rec expr env loc = function
       extern loc env s args
 
   and extern loc env s args = 
-      let args = List.map (typ env) args in
+    let args = List.map (typ env) args in
+    try
       let (i,t) = Externals.resolve s args in
       exp loc Fv.empty (Typed.External (t,i))
+    with exn -> raise_loc loc exn
 	      
   and branches env b = 
     let fv = ref Fv.empty in