Commit 5dd9400e authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2007-06-12 12:58:41 by afrisch] starting to upgrade to OCaml 3.10

Original author: afrisch
Date: 2007-06-12 12:59:44+00:00
parent 36908774
...@@ -66,14 +66,14 @@ ifeq ($(NATIVE), true) ...@@ -66,14 +66,14 @@ ifeq ($(NATIVE), true)
EXTENSION_LIB = cmxa EXTENSION_LIB = cmxa
CAML=ocamlopt CAML=ocamlopt
COMPILE = $(CAMLOPT) COMPILE = $(CAMLOPT)
LINK = $(CAMLOPT) -linkpkg gramlib.cmxa camlp4.cmxa pr_o.cmx LINK = $(CAMLOPT) -linkpkg camlp4lib.cmxa
SYNTAX += -symbol ocaml_compiler=\"native\" SYNTAX += -symbol ocaml_compiler=\"native\"
else else
EXTENSION = cmo EXTENSION = cmo
EXTENSION_LIB = cma EXTENSION_LIB = cma
COMPILE = $(CAMLC) COMPILE = $(CAMLC)
CAML=ocamlc CAML=ocamlc
LINK = $(CAMLC) -custom -linkpkg gramlib.cma camlp4.cma pr_o.cmo LINK = $(CAMLC) -custom -linkpkg camlp4lib.cma
SYNTAX += -symbol ocaml_compiler=\"bytecode\" SYNTAX += -symbol ocaml_compiler=\"bytecode\"
endif endif
...@@ -131,7 +131,7 @@ CLEAN_DIRS = $(DIRS) tools tests ...@@ -131,7 +131,7 @@ CLEAN_DIRS = $(DIRS) tools tests
# Objects to build # Objects to build
OBJECTS = \ OBJECTS = \
driver/config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo \ driver/cduce_config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo \
misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.cmo \ misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.cmo \
\ \
types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \ types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \
...@@ -151,7 +151,7 @@ OBJECTS = \ ...@@ -151,7 +151,7 @@ OBJECTS = \
compile/lambda.cmo \ compile/lambda.cmo \
runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \ runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \
\ \
parser/location.cmo parser/url.cmo \ parser/cduce_loc.cmo parser/url.cmo \
parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \ parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \
\ \
typing/typed.cmo typing/typepat.cmo types/externals.cmo typing/typer.cmo \ typing/typed.cmo typing/typepat.cmo types/externals.cmo typing/typer.cmo \
...@@ -281,7 +281,7 @@ $(ALL_INTERFACES): misc/q_symbol.cmo ...@@ -281,7 +281,7 @@ $(ALL_INTERFACES): misc/q_symbol.cmo
misc/q_symbol.cmo: misc/q_symbol.ml misc/q_symbol.cmo: misc/q_symbol.ml
@echo "Build $@" @echo "Build $@"
$(HIDE)$(CAMLC) -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo' $< $(HIDE)$(CAMLC) -c -pp camlp4orf $<
.ml.cmo: .ml.cmo:
@echo "Build $@" @echo "Build $@"
......
...@@ -174,7 +174,7 @@ let compile_rec_funs env funs = ...@@ -174,7 +174,7 @@ let compile_rec_funs env funs =
(****************************************) (****************************************)
open Location open Cduce_loc
let eval ~run ~show (tenv,cenv,codes) e = let eval ~run ~show (tenv,cenv,codes) e =
let (e,t) = Typer.type_expr tenv e in let (e,t) = Typer.type_expr tenv e in
......
open Location open Cduce_loc
type type_fun = Types.t -> bool -> Types.t type type_fun = Types.t -> bool -> Types.t
let register op arity typ eval = let register op arity typ eval =
......
open Location open Cduce_loc
type type_fun = Types.t -> bool -> Types.t type type_fun = Types.t -> bool -> Types.t
val register: val register:
......
This diff is collapsed.
open Location open Cduce_loc
open Ident open Ident
let () = Stats.gettimeofday := Unix.gettimeofday let () = Stats.gettimeofday := Unix.gettimeofday
...@@ -79,8 +79,8 @@ let directive_help ppf = ...@@ -79,8 +79,8 @@ let directive_help ppf =
let rec print_exn ppf = function let rec print_exn ppf = function
| Location (loc, w, exn) -> | Location (loc, w, exn) ->
Location.print_loc ppf (loc,w); Cduce_loc.print_loc ppf (loc,w);
Location.html_hilight (loc,w); Cduce_loc.html_hilight (loc,w);
print_exn ppf exn print_exn ppf exn
| Value.CDuceExn v -> | Value.CDuceExn v ->
Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@." Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
...@@ -121,9 +121,9 @@ let rec print_exn ppf = function ...@@ -121,9 +121,9 @@ let rec print_exn ppf = function
U.print (Librarian.name cu) U.print (Librarian.name cu)
Ident.print x Ident.print x
| Ulexer.Error (i,j,s) -> | Ulexer.Error (i,j,s) ->
let loc = Location.loc_of_pos (i,j), `Full in let loc = Cduce_loc.loc_of_pos (i,j), `Full in
Location.print_loc ppf loc; Cduce_loc.print_loc ppf loc;
Location.html_hilight loc; Cduce_loc.html_hilight loc;
Format.fprintf ppf "%s" s Format.fprintf ppf "%s" s
| Parser.Error s | Stream.Error s -> | Parser.Error s | Stream.Error s ->
Format.fprintf ppf "Parsing error: %a@." print_protect s Format.fprintf ppf "Parsing error: %a@." print_protect s
...@@ -145,7 +145,7 @@ let rec print_exn ppf = function ...@@ -145,7 +145,7 @@ let rec print_exn ppf = function
Format.fprintf ppf "Invalid object file %s@." f Format.fprintf ppf "Invalid object file %s@." f
| Librarian.CannotOpen f -> | Librarian.CannotOpen f ->
Format.fprintf ppf "Cannot open file %s@." f Format.fprintf ppf "Cannot open file %s@." f
| Location.Generic s -> | Cduce_loc.Generic s ->
Format.fprintf ppf "%a@." print_protect s Format.fprintf ppf "%a@." print_protect s
| Ns.Label.Not_unique ((ns1,s1),(ns2,s2)) -> | Ns.Label.Not_unique ((ns1,s1),(ns2,s2)) ->
Format.fprintf ppf "Collision on label hash: {%a}:%a, {%a}:%a" Format.fprintf ppf "Collision on label hash: {%a}:%a, {%a}:%a"
......
...@@ -35,19 +35,19 @@ let () = ...@@ -35,19 +35,19 @@ let () =
ignore (Unix.alarm 10); ignore (Unix.alarm 10);
Sys.set_signal Sys.sigalrm Sys.set_signal Sys.sigalrm
(Sys.Signal_handle (fun _ -> raise (Cduce.Escape Timeout))); (Sys.Signal_handle (fun _ -> raise (Cduce.Escape Timeout)));
let v = Location.get_viewport () in let v = Cduce_loc.get_viewport () in
let ppf = Html.ppf v let ppf = Html.ppf v
and input = Stream.of_string src in and input = Stream.of_string src in
Format.pp_set_margin ppf 60; Format.pp_set_margin ppf 60;
Location.push_source (`String src); Cduce_loc.push_source (`String src);
Location.set_protected true; Cduce_loc.set_protected true;
Config.init_all (); Cduce_config.init_all ();
let ok = Cduce.script ppf ppf input in let ok = Cduce.script ppf ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n"; if ok then Format.fprintf ppf "@\nOk.@\n";
Html.get v Html.get v
in in
Location.set_viewport (Html.create true); Cduce_loc.set_viewport (Html.create true);
let prog = Buffer.create 1024 in let prog = Buffer.create 1024 in
(try while true do Buffer.add_string prog (read_line ()); Buffer.add_string prog "\n" done; (try while true do Buffer.add_string prog (read_line ()); Buffer.add_string prog "\n" done;
with End_of_file -> ()); with End_of_file -> ());
......
open Location open Cduce_loc
open Ident open Ident
...@@ -77,17 +77,17 @@ let show ppf id t v = ...@@ -77,17 +77,17 @@ let show ppf id t v =
let compile verbose name src = let compile verbose name src =
protect_op "Compile external file"; protect_op "Compile external file";
let ic = let ic =
if src = "" then (Location.push_source `Stream; stdin) if src = "" then (Cduce_loc.push_source `Stream; stdin)
else else
try Location.push_source (`File src); open_in src try Cduce_loc.push_source (`File src); open_in src
with Sys_error _ -> raise (CannotOpen src) in with Sys_error _ -> raise (CannotOpen src) in
let input = Stream.of_channel ic in let input = Stream.of_channel ic in
let p = let p =
try Parser.prog input try Parser.prog input
with with
| Stdpp.Exc_located (_, (Location _ | Ulexer.Error _ as e)) -> raise e | Ulexer.Loc.Exc_located (_, (Location _ | Ulexer.Error _ as e)) -> raise e
| Stdpp.Exc_located ((i,j), e) -> | Ulexer.Loc.Exc_located ((i,j), e) ->
raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e raise_loc i j e
in in
if src <> "" then close_in ic; if src <> "" then close_in ic;
......
...@@ -15,7 +15,7 @@ let version () = ...@@ -15,7 +15,7 @@ let version () =
Printf.eprintf "built on %s\n" <:symbol<build_date>>; Printf.eprintf "built on %s\n" <:symbol<build_date>>;
Printf.eprintf "using OCaml %s compiler\n" <:symbol<ocaml_compiler>>; Printf.eprintf "using OCaml %s compiler\n" <:symbol<ocaml_compiler>>;
Printf.eprintf "Supported features: \n"; Printf.eprintf "Supported features: \n";
List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Config.descrs ()); List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Cduce_config.descrs ());
exit 0 exit 0
let specs = let specs =
...@@ -29,7 +29,7 @@ let specs = ...@@ -29,7 +29,7 @@ let specs =
"(for --compile) show types of exported values"; "(for --compile) show types of exported values";
"--obj-dir", Arg.String (fun s -> out_dir := s :: !out_dir), "--obj-dir", Arg.String (fun s -> out_dir := s :: !out_dir),
"(for --compile) directory for the compiled .cdo file"; "(for --compile) directory for the compiled .cdo file";
"-I", Arg.String (fun s -> Location.obj_path := s::!Location.obj_path), "-I", Arg.String (fun s -> Cduce_loc.obj_path := s::!Cduce_loc.obj_path),
" add one directory to the lookup path for .cdo/.cmi and include files"; " add one directory to the lookup path for .cdo/.cmi and include files";
"--stdin", Arg.Unit (fun () -> src := "" :: !src), "--stdin", Arg.Unit (fun () -> src := "" :: !src),
" read CDuce script on standard input"; " read CDuce script on standard input";
...@@ -40,7 +40,7 @@ let specs = ...@@ -40,7 +40,7 @@ let specs =
src := s :: !src) src := s :: !src)
else args := s :: !args), else args := s :: !args),
" the first argument after is the source, then the arguments"; " the first argument after is the source, then the arguments";
"--no", Arg.String Config.inhibit, "--no", Arg.String Cduce_config.inhibit,
" disable a feature (cduce -v to get a list of features)"; " disable a feature (cduce -v to get a list of features)";
"--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary), "--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
" print profiling/debugging information"; " print profiling/debugging information";
...@@ -124,7 +124,7 @@ let toploop () = ...@@ -124,7 +124,7 @@ let toploop () =
Cduce.toplevel := true; Cduce.toplevel := true;
Librarian.run_loaded := true; Librarian.run_loaded := true;
let buf_in = Buffer.create 1024 in let buf_in = Buffer.create 1024 in
Location.push_source (`Buffer buf_in); Cduce_loc.push_source (`Buffer buf_in);
let read _i = let read _i =
if !bol then if !bol then
if !Ulexer.in_comment then outflush "* " else outflush "> "; if !Ulexer.in_comment then outflush "* " else outflush "> ";
...@@ -151,26 +151,26 @@ let argv args = ...@@ -151,26 +151,26 @@ let argv args =
let main () = let main () =
at_exit (fun () -> Stats.dump Format.std_formatter); at_exit (fun () -> Stats.dump Format.std_formatter);
Location.set_viewport (Html.create false); Cduce_loc.set_viewport (Html.create false);
match mode () with match mode () with
| `Toplevel args -> | `Toplevel args ->
Config.init_all (); Cduce_config.init_all ();
Builtin.argv := argv args; Builtin.argv := argv args;
toploop () toploop ()
| `Script (f,args) -> | `Script (f,args) ->
Config.init_all (); Cduce_config.init_all ();
Builtin.argv := argv args; Builtin.argv := argv args;
Cduce.compile_run f Cduce.compile_run f
| `Compile (f,o) -> | `Compile (f,o) ->
Config.init_all (); Cduce_config.init_all ();
Cduce.compile f o Cduce.compile f o
| `Run (f,args) -> | `Run (f,args) ->
Config.init_all (); Cduce_config.init_all ();
Builtin.argv := argv args; Builtin.argv := argv args;
Cduce.run f Cduce.run f
| `Mlstub f -> | `Mlstub f ->
Config.init_all (); Cduce_config.init_all ();
Librarian.prepare_stub f Librarian.prepare_stub f
| `Topstub f -> | `Topstub f ->
Config.init_all (); Cduce_config.init_all ();
!Librarian.make_wrapper f !Librarian.make_wrapper f
...@@ -129,11 +129,11 @@ let main (cgi : Netcgi.std_activation) = ...@@ -129,11 +129,11 @@ let main (cgi : Netcgi.std_activation) =
let dialog content = html_form p content in let dialog content = html_form p content in
let exec src = let exec src =
let v = Location.get_viewport () in let v = Cduce_loc.get_viewport () in
let ppf = Html.ppf v let ppf = Html.ppf v
and input = Stream.of_string src in and input = Stream.of_string src in
Location.push_source (`String src); Cduce_loc.push_source (`String src);
Location.set_protected true; Cduce_loc.set_protected true;
let ok = Cduce.script ppf ppf input in let ok = Cduce.script ppf ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n"; if ok then Format.fprintf ppf "@\nOk.@\n";
...@@ -144,7 +144,7 @@ let main (cgi : Netcgi.std_activation) = ...@@ -144,7 +144,7 @@ let main (cgi : Netcgi.std_activation) =
dialog src dialog src
in in
Location.set_viewport (Html.create true); Cduce_loc.set_viewport (Html.create true);
html_header p; html_header p;
let prog = cgi # argument_value "prog" in let prog = cgi # argument_value "prog" in
(match cmd with (match cmd with
......
open Camlp4.PreCast
module Caml_syntax = Syntax
let symbols = ref [] let symbols = ref []
let define s = let define s =
let i = let i =
try String.index s '=' try String.index s '='
with Not_found -> failwith ("Invalid symbol definition :" ^ s) in with Not_found -> failwith ("Invalid symbol definition :" ^ s) in
symbols := let symbol = String.sub s 0 i in
(String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)) :: let value =
!symbols Gram.parse_string
Caml_syntax.expr (Loc.mk "<from-string>") (String.sub s (i + 1) (String.length s - i - 1))
in
symbols := (symbol, value) :: !symbols
EXTEND EXTEND Caml_syntax.Gram
GLOBAL: Pcaml.str_item; GLOBAL: Caml_syntax.str_item;
Pcaml.str_item: FIRST Caml_syntax.str_item: FIRST
[ [ "ifdef"; c = UIDENT; "then"; e1 = SELF; [ [ "ifdef"; c = UIDENT; "then"; e1 = SELF;
"else"; e2 = SELF -> "else"; e2 = SELF ->
if List.mem_assoc c !symbols then e1 else e2 if List.mem_assoc c !symbols then e1 else e2
| "ifdef"; c = UIDENT; "then"; e1 = SELF -> | "ifdef"; c = UIDENT; "then"; e1 = SELF ->
if List.mem_assoc c !symbols then e1 else <:str_item< declare end >> if List.mem_assoc c !symbols then e1 else <:str_item<>>
| "ifndef"; c = UIDENT; "then"; e1 = SELF; | "ifndef"; c = UIDENT; "then"; e1 = SELF;
"else"; e2 = SELF -> "else"; e2 = SELF ->
if List.mem_assoc c !symbols then e2 else e1 if List.mem_assoc c !symbols then e2 else e1
| "ifndef"; c = UIDENT; "then"; e1 = SELF -> | "ifndef"; c = UIDENT; "then"; e1 = SELF ->
if List.mem_assoc c !symbols then <:str_item< declare end >> else e1 if List.mem_assoc c !symbols then <:str_item<>> else e1
] ]; ] ];
END END
let expr _ s = let expr _ _ s =
try List.assoc s !symbols try List.assoc s !symbols
with Not_found -> failwith ("No definition for symbol " ^ s) with Not_found -> failwith ("No definition for symbol " ^ s)
let _ = let _ =
Quotation.add "symbol" (Quotation.ExStr expr); Quotation.add "symbol" Quotation.DynAst.expr_tag expr;
Pcaml.add_option "-symbol" (Arg.String define) Camlp4.Options.add "-symbol" (Arg.String define)
"<symbol=value> Define a symbol" "<symbol=value> Define a symbol"
...@@ -516,29 +516,20 @@ let stub ty_env c_env exts values mk prolog = ...@@ -516,29 +516,20 @@ let stub ty_env c_env exts values mk prolog =
let items_expr = List.map (fun (_,e,_) -> e) items in let items_expr = List.map (fun (_,e,_) -> e) items in
let items_pat = List.map (fun (p,_,_) -> p) items in let items_pat = List.map (fun (p,_,_) -> p) items in
let m =
[ <:str_item< open Cduce_lib >>;
<:str_item< Config.init_all () >>;
<:str_item<
value (types,set_externals,slots,run) =
Librarian.ocaml_stub $str:String.escaped raw$ >> ] @
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
[ <:str_item< set_externals [|$list:exts$|] >>;
<:str_item< run () >> ] @
(if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in
let items_expr =
match items_expr with
| [] -> <:expr< () >>
| l -> <:expr< ($list:l$) >> in
let str_items = let str_items =
[ <:str_item< <:str_item<
value ($list:items_pat$) = value ($paCom_of_list items_pat$) =
let module C = struct let module C = struct
$list:m$ open Cduce_lib;
end in $items_expr$ >>, (Lexing.dummy_pos, Lexing.dummy_pos) ] in Cduce_config.init_all ();
value (types,set_externals,slots,run) =
Librarian.ocaml_stub $str:String.escaped raw$;
value rec $biAnd_of_list g$;
set_externals [|$exSem_of_list exts$|];
run ();
value $biAnd_of_list items_def$;
end in ($exCom_of_list items_expr$) >> in
print_endline prolog; print_endline prolog;
!Pcaml.print_implem str_items !Pcaml.print_implem str_items
(* let exe = Filename.concat (Filename.dirname Sys.argv.(0)) "cdo2ml" in (* let exe = Filename.concat (Filename.dirname Sys.argv.(0)) "cdo2ml" in
...@@ -599,12 +590,12 @@ let wrapper values = ...@@ -599,12 +590,12 @@ let wrapper values =
values in values in
let g = global_transl () in let g = global_transl () in
let m = if g = [] then exts else <:str_item< value rec $list:g$ >>::exts in <:str_item<
let m = [ <:str_item< open Cduce_lib >>; open Cduce_lib;
<:str_item< Config.init_all () >>] @ m in Cduce_config.init_all ();
value rec $biAnd_of_list g$;
<:str_item< declare $list:m$ end >> $stSem_of_list exts$;
>>
let gen_wrapper vals = let gen_wrapper vals =
try try
......
(* Abstract syntax as produced by the parser *) (* Abstract syntax as produced by the parser *)
open Location open Cduce_loc
open Ident open Ident
type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ] type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ]
...@@ -9,7 +9,7 @@ type pprog = pmodule_item list ...@@ -9,7 +9,7 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located and pmodule_item = pmodule_item' located
and pmodule_item' = and pmodule_item' =
| TypeDecl of (Location.loc * U.t) * ppat | TypeDecl of (Cduce_loc.loc * U.t) * ppat
| SchemaDecl of U.t * string | SchemaDecl of U.t * string
| LetDecl of ppat * pexpr | LetDecl of ppat * pexpr
| FunDecl of pexpr | FunDecl of pexpr
...@@ -86,7 +86,7 @@ and pexpr = ...@@ -86,7 +86,7 @@ and pexpr =
and label = U.t and label = U.t
and abstr = { and abstr = {
fun_name : (Location.loc * U.t) option; fun_name : (Cduce_loc.loc * U.t) option;
fun_iface : (ppat * ppat) list; fun_iface : (ppat * ppat) list;
fun_body : branches fun_body : branches
} }
...@@ -100,7 +100,7 @@ and ppat' = ...@@ -100,7 +100,7 @@ and ppat' =
| PatVar of U.t list | PatVar of U.t list
| Cst of pexpr | Cst of pexpr
| NsT of U.t | NsT of U.t
| Recurs of ppat * (Location.loc * U.t * ppat) list | Recurs of ppat * (Cduce_loc.loc * U.t * ppat) list
| Internal of Types.descr | Internal of Types.descr
| Or of ppat * ppat | Or of ppat * ppat
| And of ppat * ppat | And of ppat * ppat
...@@ -123,7 +123,7 @@ and regexp = ...@@ -123,7 +123,7 @@ and regexp =
| Alt of regexp * regexp | Alt of regexp * regexp
| Star of regexp | Star of regexp
| WeakStar of regexp | WeakStar of regexp
| SeqCapture of Location.loc * U.t * regexp | SeqCapture of Cduce_loc.loc * U.t * regexp
let pat_true = mknoloc (Internal Builtin_defs.true_type) let pat_true = mknoloc (Internal Builtin_defs.true_type)
......
...@@ -11,7 +11,7 @@ let load_url s = ...@@ -11,7 +11,7 @@ let load_url s =
let () = let () =
Config.register Cduce_config.register
"curl" "curl"
"Load external URLs with curl" "Load external URLs with curl"
(fun () -> Url.url_loader := load_url) (fun () -> Url.url_loader := load_url)