Commit 2e678f4e authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2004-06-30 17:29:12+00:00
parent 2c8136b9
......@@ -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 \
......
......@@ -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 \
......
......@@ -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
......
......@@ -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
......
......@@ -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 () =
......
......@@ -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)
......@@ -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)
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment