Commit 5ed31ef4 authored by Pietro Abate's avatar Pietro Abate

[r2002-11-09 10:42:14 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-09 10:42:16+00:00
parent 093f0462
......@@ -29,16 +29,19 @@ RUNTIME = runtime/value.cmo \
DRIVER = driver/cduce.cmo
TOPLEVEL = toplevel/toploop.cmo
OBJECTS = $(MISC) $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
CDUCE = $(OBJECTS) $(DRIVER) driver/run.cmo
WEBIFACE = $(OBJECTS) $(DRIVER) driver/webiface.cmo
TOPLEVEL = $(OBJECTS) toplevel/toploop.cmo
XOBJECTS = $(OBJECTS:.cmo=.cmx)
XDRIVER = $(DRIVER:.cmo=.cmx)
XCDUCE = $(CDUCE:.cmo=.cmx)
DEBUG = -g
PACKAGES = pxp-engine,pxp-lex-iso88591,wlexing,camlp4,num
PACKAGES = pxp-engine,pxp-lex-iso88591,wlexing,camlp4,num,cgi
OCAMLCP = ocamlc
OCAMLC = ocamlfind $(OCAMLCP) -package $(PACKAGES)
OCAMLOPT = ocamlfind ocamlopt -package $(PACKAGES)
......@@ -57,11 +60,14 @@ all.cmxa: $(XOBJECTS)
$(OCAMLOPT) -a -o $@ $(XOBJECTS)
cduce: $(OBJECTS) $(DRIVER)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(OBJECTS) $(DRIVER)
cduce: $(CDUCE)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(CDUCE)
toplevel: $(TOPLEVEL)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(TOPLEVEL)
toplevel: $(OBJECTS) $(TOPLEVEL)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(OBJECTS) $(TOPLEVEL)
webiface: $(WEBIFACE)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(WEBIFACE)
dtd2cduce: tools/dtd2cduce.cmo
......@@ -90,7 +96,7 @@ clean:
rm -f parser/wlexer.ml
rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~
rm -f cduce cduce.opt ocamlprof.dump
rm -f dtd2cduce pool
rm -f dtd2cduce pool webiface
rm -Rf prepro
......
......@@ -7,11 +7,11 @@ parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
types/intervals.cmi parser/location.cmi types/sequence.cmi \
types/types.cmi parser/wlexer.cmo parser/parser.cmi
types/intervals.cmi parser/lexer.cmo parser/location.cmi \
types/sequence.cmi types/types.cmi parser/wlexer.cmo parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/intervals.cmx parser/location.cmx types/sequence.cmx \
types/types.cmx parser/wlexer.cmx parser/parser.cmi
types/intervals.cmx parser/lexer.cmx parser/location.cmx \
types/sequence.cmx types/types.cmx parser/wlexer.cmx parser/parser.cmi
parser/wlexer.cmo: parser/location.cmi
parser/wlexer.cmx: parser/location.cmx
typing/typed.cmo: parser/location.cmi types/patterns.cmi types/sortedMap.cmi \
......@@ -84,10 +84,12 @@ runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
types/types.cmx runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typer.cmi \
types/types.cmi runtime/value.cmi parser/wlexer.cmo
types/types.cmi runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typer.cmx \
types/types.cmx runtime/value.cmx parser/wlexer.cmx
types/types.cmx runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
driver/run.cmo: driver/cduce.cmi parser/location.cmi
driver/run.cmx: driver/cduce.cmx parser/location.cmx
parser/parser.cmi: parser/ast.cmo
typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi
types/boolean.cmi: types/sortedList.cmi
......
open Location
exception Usage
let () =
List.iter
(fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
Builtin.types
let (source,input_channel) =
match Array.length Sys.argv with
| 1 -> ("",stdin)
| 2 -> let s = Sys.argv.(1) in (s, open_in s)
| _ -> raise Usage
let () = Location.set_source source
let input = Stream.of_channel input_channel
let ppf = Format.std_formatter
let prog () =
try Parser.prog input
with
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
let print_norm ppf d =
Types.Print.print_descr ppf ((*Types.normalize*) d)
......@@ -69,12 +45,12 @@ let rec print_exn ppf = function
Format.fprintf ppf "String literal not terminated@\n"
| Wlexer.Unterminated_string_in_comment ->
Format.fprintf ppf "This comment contains an unterminated string literal@\n"
| Parser.Error s ->
| Parser.Error s | Stream.Error s ->
Format.fprintf ppf "Parsing error: %s@\n" s
| exn ->
Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
let debug = function
let debug ppf = function
| `Filter (t,p) ->
Format.fprintf ppf "[DEBUG:filter]@\n";
let t = Typer.typ t
......@@ -143,51 +119,66 @@ let debug = function
Format.fprintf ppf "%a@\n" aux r
*)
let typing_env = ref Typer.Env.empty
let eval_env = ref Eval.Env.empty
let insert_type_bindings =
List.iter (fun (x,t) ->
typing_env := Typer.Env.add x t !typing_env;
Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
let type_decl decl =
insert_type_bindings (Typer.type_let_decl !typing_env decl)
let eval_decl decl =
let bindings = Eval.eval_let_decl !eval_env decl in
let mk_builtin () =
List.iter
(fun (x,v) ->
Eval.enter_global x v;
Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
) bindings
let phrase ph =
match ph.descr with
| Ast.EvalStatement e ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check !typing_env e Types.any true in
Format.fprintf ppf "|- %a@\n@." print_norm t;
let v = Eval.eval !eval_env e in
Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
| Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
| Ast.LetDecl (p,e) ->
let decl = Typer.let_decl p e in
type_decl decl;
eval_decl decl
| Ast.TypeDecl _ -> ()
| Ast.Debug l -> debug l
| _ -> assert false
let do_fun_decls decls =
let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
insert_type_bindings (Typer.type_rec_funs !typing_env decls);
List.iter eval_decl decls
(fun (n,t) -> Typer.register_global_types [n, mk noloc (Ast.Internal t)])
Builtin.types
let () =
let run ppf input =
let typing_env = ref Typer.Env.empty in
let eval_env = ref Eval.Env.empty in
let insert_type_bindings =
List.iter (fun (x,t) ->
typing_env := Typer.Env.add x t !typing_env;
Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
in
let type_decl decl =
insert_type_bindings (Typer.type_let_decl !typing_env decl)
in
let eval_decl decl =
let bindings = Eval.eval_let_decl !eval_env decl in
List.iter
(fun (x,v) ->
Eval.enter_global x v;
Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
) bindings
in
let phrase ph =
match ph.descr with
| Ast.EvalStatement e ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check !typing_env e Types.any true in
Format.fprintf ppf "|- %a@\n@." print_norm t;
let v = Eval.eval !eval_env e in
Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
| Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
| Ast.LetDecl (p,e) ->
let decl = Typer.let_decl p e in
type_decl decl;
eval_decl decl
| Ast.TypeDecl _ -> ()
| Ast.Debug l -> debug ppf l
| _ -> assert false
in
let do_fun_decls decls =
let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
insert_type_bindings (Typer.type_rec_funs !typing_env decls);
List.iter eval_decl decls
in
try
let p = prog () in
mk_builtin ();
let p =
try Parser.prog input
with
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
in
let (type_decls,fun_decls) =
List.fold_left
(fun ((typs,funs) as accu) ph -> match ph.descr with
......@@ -201,10 +192,7 @@ let () =
List.iter phrase p
with
| (Failure _ | Not_found | Invalid_argument _) as e ->
raise e (* To get the ocamlrun stack trace *)
raise e (* To get ocamlrun stack trace *)
| exn -> print_exn ppf exn
val print_exn: Format.formatter -> exn -> unit
val run : Format.formatter -> char Stream.t -> unit
let input_channel =
match Array.length Sys.argv with
| 1 -> Location.set_source `Stream; stdin
| 2 -> let fn = Sys.argv.(1) in Location.set_source (`File fn); open_in fn
| _ -> Printf.eprintf "Usage: cduce [script]\n"; exit 2
in
let input = Stream.of_channel input_channel
and ppf = Format.std_formatter in
Cduce.run ppf input
open Netcgi
let main (cgi : Netcgi.std_activation) =
try
cgi # set_header ();
let cmd = cgi # argument_value "cmd" in
Location.set_source (`String cmd);
let ppf = Format.str_formatter
and input = Stream.of_string cmd in
Cduce.run ppf input;
let res = Format.flush_str_formatter () in
cgi # output # output_string ("\
<html>
<head>
<title>CDuce online prototype</title>
</head>
<body>
<h1>CDuce online prototype</h1>
Command == [" ^ cmd ^ "]<br>
Result:<pre>" ^ res ^ "</pre>
<form method=get>
<input type=text name=cmd length=30>
</form>
</body>
</html>
");
cgi # output # commit_work()
with
exn ->
cgi # output # rollback_work();
cgi # set_header ~status:`Internal_server_error ();
cgi # output # output_string "<h1>Internal software error!</h1>";
cgi # output # commit_work()
let () =
let operating_type = Netcgi.buffered_transactional_optype in
let cgi = new Netcgi.std_activation ~operating_type () in
main cgi;
cgi # finalize ()
type loc = int * int
type source = [ `None | `File of string | `Stream | `String of string ]
exception Location of loc * exn
let noloc = (-1,-1)
let source = ref ""
let source = ref `None
let set_source s = source := s
let get_line_number src i =
......@@ -22,18 +24,19 @@ let get_line_number src i =
r
let print_loc ppf (i,j) =
if !source = "" then
Format.fprintf ppf "at chars %i-%i" i j
else (
let (l1,c1) = get_line_number !source i
and (l2,c2) = get_line_number !source j in
if l1 = l2 then
Format.fprintf ppf "at line %i (chars %i-%i)"
l1 c1 c2
else
Format.fprintf ppf "at lines %i (char %i) - %i (char %i)"
l1 c1 l2 c2
)
match !source with
| `None -> Format.fprintf ppf "somewhere (no source defined !)"
| `Stream | `String _ ->
Format.fprintf ppf "at chars %i-%i" i j
| `File fn ->
let (l1,c1) = get_line_number fn i
and (l2,c2) = get_line_number fn j in
if l1 = l2 then
Format.fprintf ppf "at line %i (chars %i-%i)"
l1 c1 c2
else
Format.fprintf ppf "at lines %i (char %i) - %i (char %i)"
l1 c1 l2 c2
type 'a located = { loc : loc; descr : 'a }
......
type loc = int * int
type source = [ `None | `File of string | `Stream | `String of string ]
exception Location of loc * exn
val set_source: string -> unit
val set_source: source -> unit
val noloc:loc
val get_line_number: string -> int -> int * int
......
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