Commit cd3b0426 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Various cleanups.

parent 1fd8f0a3
......@@ -2,5 +2,5 @@ S .
S ./**
B .
B ./**
PKG dynlink num netstring sedlex.ppx ocaml-compiler-libs.common ocaml-compiler-libs.shadow netclient curl pxp-lex-utf8 pxp-lex-iso88591 pxp-engine expat
PKG dynlink num netstring sedlex.ppx ocaml-compiler-libs.common netclient curl pxp-lex-utf8 pxp-lex-iso88591 pxp-engine expat
FLG -open Cduce_lib
......@@ -26,9 +26,6 @@ endif
PACKAGES=dynlink num netstring sedlex.ppx
SYNTAX=-loc "_loc"
SYNTAX_PARSER=-syntax camlp4o $(SYNTAX:%=-ppopt %)
OPT=-warn-error +a-58
......@@ -54,9 +51,7 @@ compile/cduce_lib__lambda.cmo runtime/cduce_lib__run_dispatch.cmo \
runtime/cduce_lib__explain.cmo runtime/cduce_lib__eval.cmo \
parser/cduce_lib__cduce_loc.cmo parser/cduce_lib__url.cmo \
parser/cduce_lib__ast.cmo \
\
parser/cduce_lib__cparser.cmo parser/cduce_lib__csedlexer.cmo parser/cduce_lib__parse.cmo\
\
parser/cduce_lib__parser.cmo parser/cduce_lib__sedlexer.cmo parser/cduce_lib__parse.cmo\
typing/cduce_lib__typed.cmo \
typing/cduce_lib__typepat.cmo types/cduce_lib__externals.cmo \
typing/cduce_lib__typer.cmo compile/cduce_lib__compile.cmo \
......@@ -149,10 +144,9 @@ LIBRARY_CMX := $(subst /,/cduce_lib__, $(LIBRARY_ML))
LIBRARY_CMX := $(LIBRARY_CMX:.ml=.cmx)
GENERATED_SOURCES=cduce.modules cduce_lib.mli cduce_lib.ml driver/cduce_full_config.ml \
parser/cparser.ml parser/cparser.mli \
parser/parser.ml parser/parser.mli \
$(GENERATED_ML_IFACE) \
runtime/ocaml_obj_compat.ml
PP_SOURCES=parser/parser.ml
INCLUDES=$(DIRS:%=-I %) -I .
......@@ -231,12 +225,12 @@ cduce_lib.cmxa: cduce_lib.cmx $(LIBRARY_OBJECTS:.cmo=.cmx)
@echo "Packing $@"
$(HIDE) $(OCAMLOPT) -a $^ -o $@
depend: $(GENERATED_SOURCES) $(PP_SOURCES)
depend: $(GENERATED_SOURCES)
@echo "Computing dependencies ..."
$(HIDE) $(OCAMLFIND) ocamldep -slash -package "$(PACKAGES)" \
$(INCLUDES) -as-map cduce_lib.ml -map cduce_lib.mli > depend
$(HIDE) $(OCAMLFIND) ocamldep -slash -package "$(PACKAGES)" \
$(INCLUDES) -map cduce_lib.mli $(DEPEND) `echo $(PP_SOURCES) $(GENERATED_SOURCES) | sed -e 's/cduce_lib.ml.\?//g'` >> depend
$(INCLUDES) -map cduce_lib.mli $(DEPEND) `echo $(GENERATED_SOURCES) | sed -e 's/cduce_lib.ml.\?//g'` >> depend
@for d in $(LIBRARY_OBJECTS:.cmo=); do \
s=`echo "$$d" | sed -e 's:cduce_lib__::g'`; \
sed -e "s:$${s}[.]:$${d}.:g" depend >> depend.tmp; \
......@@ -290,14 +284,10 @@ cduce_lib.cmx: cduce_lib.ml
@echo "Building $@"
$(HIDE) $(OCAMLOPT) $(INCLUDES) -no-alias-deps -w -49 -c $<
parser/cparser.ml parser/cparser.mli &: parser/cparser.mly
parser/parser.ml parser/parser.mli &: parser/parser.mly
@echo "Building $@ with menhir"
$(HIDE) menhir $<
.mlp.ml:
@echo "Building $@"
$(HIDE) camlp4o -printer o -I `ocamlfind query ulex` pa_ulex.cma -loc _loc -impl $< -o $@
.mli.cmi:
@echo "Building $@"
$(HIDE) $(COMPILE) -open Cduce_lib $<
......@@ -333,7 +323,7 @@ $(LIBRARY_CMX): cduce_lib.cmx
clean: clean_doc
@echo "Cleaning"
$(HIDE) rm -f $(ALL_OBJECTS) $(ALL_OBJECTS:.cmo=.cmx) $(ALL_OBJECTS:.cmo=.cmi) $(ALL_OBJECTS:.cmo=.o) \
cduce_lib.cm* cduce_lib.[oa] $(PP_SOURCES) \
cduce_lib.cm* cduce_lib.[oa] \
$(BINARIES) \
configure.log
......
......@@ -134,7 +134,7 @@ let toploop () =
Cduce_loc.push_source (`Buffer buf_in);
let read _i =
if !bol then
if !Csedlexer.in_comment then outflush "* " else outflush "> ";
if !Sedlexer.in_comment then outflush "* " else outflush "> ";
try
let c = input_char stdin in
Buffer.add_char buf_in c;
......
(* TODO: handle encodings of the input for pretty printing
fragments of code *)
type source = [ `None | `File of string | `Stream | `String of string
| `Buffer of Buffer.t ]
type source =
[ `None | `File of string | `Stream | `String of string | `Buffer of Buffer.t ]
type loc = source * int * int
type precise = [ `Full | `Char of int ]
let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
if s1 = s2 then
if i1 = -1 then loc2 else if i2 = -1 then loc1 else
(s1, min i1 i2, max j1 j2)
let merge_loc ((s1, i1, j1) as loc1) ((s2, i2, j2) as loc2) =
if s1 = s2 then
if i1 = -1 then loc2
else if i2 = -1 then loc1
else (s1, min i1 i2, max j1 j2)
else loc1
let source = ref `None
let source_stack = ref []
let push_source s = source_stack := !source :: !source_stack; source := s
let pop_source () =
let push_source s =
source_stack := !source :: !source_stack;
source := s
let pop_source () =
match !source_stack with
| [] -> assert false
| s::rem -> source_stack := rem; source := s
| [] -> assert false
| s :: rem ->
source_stack := rem;
source := s
let current_dir () =
match !source with
| `File s -> Filename.dirname s
| _ -> ""
match !source with `File s -> Filename.dirname s | _ -> ""
exception Location of loc * precise * exn
exception Generic of string
let raise_loc i j exn = raise (Location ((!source,i,j),`Full,exn))
let raise_loc i j exn = raise (Location ((!source, i, j), `Full, exn))
let raise_generic s = raise (Generic s)
let raise_loc_generic loc s = raise (Location (loc, `Full, Generic s))
let noloc = (`None,-1,-1)
let nopos = (-1,-1)
let noloc = (`None, -1, -1)
let nopos = (-1, -1)
let viewport = ref (Html.create false)
let set_viewport v = viewport := v
let get_viewport () = !viewport
(* Note: this is incorrect. Directives #utf8,... should
......@@ -45,18 +59,16 @@ let get_viewport () = !viewport
count the lines. *)
let get_line_start lb i =
let rec count line start lb = match%sedlex lb with
let rec count line start lb =
match%sedlex lb with
| '\n' | "\n\r" | '\r' ->
if (Sedlexing.lexeme_start lb >= i) then (line, start)
else
aux (line + 1) (Sedlexing.lexeme_end lb)
| eof ->
(line, start)
| any ->
aux line start
| _ -> assert false
if Sedlexing.lexeme_start lb >= i then (line, start)
else aux (line + 1) (Sedlexing.lexeme_end lb)
| eof -> (line, start)
| any -> aux line start
| _ -> assert false
and aux line start =
if (Sedlexing.lexeme_start lb >= i) then (line, start)
if Sedlexing.lexeme_start lb >= i then (line, start)
else count line start lb
in
aux 1 0
......@@ -69,103 +81,100 @@ let get_line_number src i =
r
let get_line_number_str src i =
let lb = Sedlexing.Utf8.from_string src in
let lb = Sedlexing.Utf8.from_string src in
get_line_start lb i
let print_precise ppf = function
| `Full -> ()
| `Full -> ()
| `Char i -> Format.fprintf ppf "Char %i of the string:@\n" i
let print_loc ppf ((src,i,j),w) =
let print_loc ppf ((src, i, j), w) =
match src with
| `None -> () (*Format.fprintf ppf "somewhere (no source defined !)"*)
| `Stream | `String _ ->
Format.fprintf ppf "At chars %i-%i:@\n%a" i j print_precise w
| `Buffer b ->
(* let b = Buffer.contents b in
let (l1,start1) = get_line_number_str b i in *)
Format.fprintf ppf "Characters %i-%i:@\n%a"
i j
print_precise w
| `File fn ->
let (l1,start1) = get_line_number fn i in
Format.fprintf ppf "File \"%s\", line %i, characters %i-%i:@\n%a"
fn l1 (i - start1) (j - start1)
print_precise w
| `None -> ()
(*Format.fprintf ppf "somewhere (no source defined !)"*)
| `Stream | `String _ ->
Format.fprintf ppf "At chars %i-%i:@\n%a" i j print_precise w
| `Buffer b ->
(* let b = Buffer.contents b in
let (l1,start1) = get_line_number_str b i in *)
Format.fprintf ppf "Characters %i-%i:@\n%a" i j print_precise w
| `File fn ->
let l1, start1 = get_line_number fn i in
Format.fprintf ppf "File \"%s\", line %i, characters %i-%i:@\n%a" fn l1
(i - start1) (j - start1) print_precise w
let extr s i j =
try
let n = min (String.length s) j - i in
if n <= 0 then "" else String.sub s i n
with e -> failwith (Printf.sprintf "Cduce_loc.extr len=%i i=%i j=%i"
(String.length s) i j )
with e ->
failwith
(Printf.sprintf "Cduce_loc.extr len=%i i=%i j=%i" (String.length s) i j)
let dump_loc ((src,i,j),w) =
let dump_loc ((src, i, j), w) =
let v = get_viewport () in
match (src, Html.is_html v) with
| (`String s, true) ->
if (i < 0) then
Html.markup v "b" (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
else
Html.markup v "i" (fun ppf -> Format.fprintf ppf "%s" (extr s i j))
| _ -> ()
| `String s, true ->
if i < 0 then
Html.markup v "b" (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
else Html.markup v "i" (fun ppf -> Format.fprintf ppf "%s" (extr s i j))
| _ -> ()
let rec beg_of_line s i =
if (i <= 0) || (s.[i-1] = '\n') || (s.[i-1] = '\r')
then i else beg_of_line s (i - 1)
if i <= 0 || s.[i - 1] = '\n' || s.[i - 1] = '\r' then i
else beg_of_line s (i - 1)
let rec end_of_line s i =
if (i >= String.length s) || (s.[i] = '\n') || (s.[i] = '\r')
then i else end_of_line s (i + 1)
if i >= String.length s || s.[i] = '\n' || s.[i] = '\r' then i
else end_of_line s (i + 1)
let html_hilight ((src,i,j),w) =
let html_hilight ((src, i, j), w) =
let v = get_viewport () in
match (src, Html.is_html v) with
| `String s, true ->
if (i < 0) then
Html.markup v "b"
(fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
else
let i0 = beg_of_line s i in
let j0 = end_of_line s j in
Html.markup v "i"
(fun ppf ->
Format.fprintf ppf "%s" (extr s i0 i);
Html.mark v "<font color=\"red\"><b>";
Format.fprintf ppf "%s" (extr s i j);
Html.mark v "</b></font>";
Format.fprintf ppf "%s@." (extr s j j0);
)
| _ -> ()
| `String s, true ->
if i < 0 then
Html.markup v "b" (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
else
let i0 = beg_of_line s i in
let j0 = end_of_line s j in
Html.markup v "i" (fun ppf ->
Format.fprintf ppf "%s" (extr s i0 i);
Html.mark v "<font color=\"red\"><b>";
Format.fprintf ppf "%s" (extr s i j);
Html.mark v "</b></font>";
Format.fprintf ppf "%s@." (extr s j j0))
| _ -> ()
type 'a located = { loc : loc; descr : 'a }
let mk_located (i,j) x = { loc = (!source,i,j); descr = x }
let mk_loc loc x = { loc = loc; descr = x }
let mk_located (i, j) x = { loc = (!source, i, j); descr = x }
let mk_loc loc x = { loc; descr = x }
let mknoloc x = { loc = noloc; descr = x }
let loc_of_pos (i,j) = (!source,i,j)
let loc_of_pos (i, j) = (!source, i, j)
let protected = ref false
let set_protected p = protected := p
let is_protected () = !protected
let protect_op op =
if (!protected) then
raise
(Generic (op ^ ": operation not authorized in the web prototype"))
if !protected then
raise (Generic (op ^ ": operation not authorized in the web prototype"))
let obj_path = ref [ "" ]
let resolve_filename s =
if Filename.is_relative s then
try
let p =
List.find
(fun p -> Sys.file_exists (Filename.concat p s))
(current_dir () :: !obj_path) in
let p =
List.find
(fun p -> Sys.file_exists (Filename.concat p s))
(current_dir () :: !obj_path)
in
Filename.concat p s
with Not_found -> s
else s
(* Locations in source file,
and presentation of results and errors *)
(* include Camlp4.Sig.Loc *)
type source =
[ `None | `File of string | `Stream | `String of string
| `Buffer of Buffer.t ]
[ `None | `File of string | `Stream | `String of string | `Buffer of Buffer.t ]
type loc = source * int * int
type precise = [ `Full | `Char of int ]
exception Location of loc * precise * exn
exception Generic of string
val noloc:loc
val nopos:int * int
val noloc : loc
val nopos : int * int
val merge_loc : loc -> loc -> loc
val merge_loc: loc -> loc -> loc
val raise_loc : int -> int -> exn -> 'a
val raise_loc: int -> int -> exn -> 'a
val raise_generic: string -> 'a
val raise_loc_generic: loc -> string -> 'a
val raise_generic : string -> 'a
val push_source: source -> unit
val pop_source: unit -> unit
val raise_loc_generic : loc -> string -> 'a
val push_source : source -> unit
val pop_source : unit -> unit
val current_dir : unit -> string
val set_viewport: Html.t -> unit
val get_viewport: unit -> Html.t
val set_viewport : Html.t -> unit
val get_viewport : unit -> Html.t
(*
val protect: Format.formatter -> (Format.formatter -> unit) -> unit
*)
val print_loc: Format.formatter -> loc * precise -> unit
val dump_loc: loc * precise -> unit
val html_hilight: loc * precise -> unit
val print_loc : Format.formatter -> loc * precise -> unit
val dump_loc : loc * precise -> unit
val html_hilight : loc * precise -> unit
type 'a located = { loc : loc; descr : 'a }
val mk_located: int * int -> 'a -> 'a located
val mk_loc: loc -> 'a -> 'a located
val mknoloc: 'a -> 'a located
val loc_of_pos : int * int -> loc
val mk_located : int * int -> 'a -> 'a located
val mk_loc : loc -> 'a -> 'a located
val mknoloc : 'a -> 'a located
val loc_of_pos : int * int -> loc
(* Are we working in a protected environement (web prototype ...) ? *)
val set_protected : bool -> unit
val is_protected : unit -> bool
val protect_op : string -> unit
val obj_path : string list ref
val obj_path: string list ref
val resolve_filename: string -> string
val resolve_filename : string -> string
(* Taken from Menhir/Lib/Convert.ml*)
let for_sedlex parser =
fun lexer ->
let lexbuf : Lexing.lexbuf =
Lexing.from_string ""
in
let lexer (lexbuf : Lexing.lexbuf) =
let token, startp, endp = lexer() in
lexbuf.Lexing.lex_start_p <- startp;
lexbuf.Lexing.lex_curr_p <- endp;
token
in
parser lexer lexbuf
let for_sedlex parser lexer =
let lexbuf : Lexing.lexbuf = Lexing.from_string "" in
let lexer (lexbuf : Lexing.lexbuf) =
let token, startp, endp = lexer () in
lexbuf.Lexing.lex_start_p <- startp;
lexbuf.Lexing.lex_curr_p <- endp;
token
in
parser lexer lexbuf
(**)
let mk_lexbuf cs =
(* Workaround the sedlex functions buffer 512 characters before
propagating them, making it unusable with interactive input *)
propagating them, making it unusable with interactive input *)
let uchars = Bytes.make 4 '\000' in
let lexbuf =
Sedlexing.create (fun arr pos _num ->
let module U = Encodings.Utf8 in
try
let next cs = Stream.next cs in
Bytes.set uchars 0 '\000';
Bytes.set uchars 1 '\000';
Bytes.set uchars 2 '\000';
Bytes.set uchars 3 '\000';
let c0 = next cs in
let () =
match c0 with
| '\x00' .. '\x7f' -> Bytes.set uchars 0 c0
| '\xc0' .. '\xdf' ->
Bytes.set uchars 0 c0;
Bytes.set uchars 1 (next cs)
| '\xe0' .. '\xef' ->
Bytes.set uchars 0 c0;
Bytes.set uchars 1 (next cs);
Bytes.set uchars 2 (next cs)
| '\xf0' .. '\xf7' ->
Bytes.set uchars 0 c0;
Bytes.set uchars 1 (next cs);
Bytes.set uchars 2 (next cs);
Bytes.set uchars 3 (next cs)
| _ -> raise Sedlexing.MalFormed
in
let us = U.mk (Bytes.unsafe_to_string uchars) in
let uc = U.get us (U.start_index us) in
arr.(pos) <- Uchar.unsafe_of_int uc;
1
Sedlexing.create (fun arr pos _num ->
let module U = Encodings.Utf8 in
try
let next cs = Stream.next cs in
Bytes.set uchars 0 '\000';
Bytes.set uchars 1 '\000';
Bytes.set uchars 2 '\000';
Bytes.set uchars 3 '\000';
let c0 = next cs in
let () =
match c0 with
| '\x00' .. '\x7f' -> Bytes.set uchars 0 c0
| '\xc0' .. '\xdf' ->
Bytes.set uchars 0 c0;
Bytes.set uchars 1 (next cs)
| '\xe0' .. '\xef' ->
Bytes.set uchars 0 c0;
Bytes.set uchars 1 (next cs);
Bytes.set uchars 2 (next cs)
| '\xf0' .. '\xf7' ->
Bytes.set uchars 0 c0;
Bytes.set uchars 1 (next cs);
Bytes.set uchars 2 (next cs);
Bytes.set uchars 3 (next cs)
| _ -> raise Sedlexing.MalFormed
in
let us = U.mk (Bytes.unsafe_to_string uchars) in
let uc = U.get us (U.start_index us) in
arr.(pos) <- Uchar.unsafe_of_int uc;
1
with Stream.Failure -> 0)
in
Sedlexing.set_position lexbuf
Lexing.{ pos_fname = "";
pos_lnum = 1;
pos_bol = 0;
pos_cnum = 0 };
Csedlexer.eat_shebang lexbuf;
lexbuf
in
Sedlexing.set_position lexbuf
Lexing.{ pos_fname = ""; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 };
Sedlexer.eat_shebang lexbuf;
lexbuf
let include_stack = ref []
let pre_prog = for_sedlex Cparser.prog
let pre_prog = for_sedlex Parser.prog
let close_in ic =
try close_in ic with _ -> ()
let close_in ic = try close_in ic with _ -> ()
let exit_include ic =
close_in ic;
Cduce_loc.pop_source ();
include_stack := List.tl !include_stack
let last_tok = ref Cparser.EOI
let last_tok = ref Parser.EOI
let last_tok_pos = ref (Lexing.dummy_pos, Lexing.dummy_pos)
let rec token lexbuf =
let f = Sedlexing.with_tokenizer Csedlexer.token lexbuf in
let f () =
let f = Sedlexing.with_tokenizer Sedlexer.token lexbuf in
let f () =
let tok, p1, p2 = f () in
let tok =
match !last_tok, tok with
| Cparser.INCLUDE, Cparser.STRING2 path ->
Cduce_loc.protect_op "File inclusion";
let path = Cduce_loc.resolve_filename path in
if List.mem path !include_stack then tok
else begin
let ic =
try
open_in path
with
Sys_error msg ->
let tok =
match (!last_tok, tok) with
| Parser.INCLUDE, Parser.STRING2 path -> (
Cduce_loc.protect_op "File inclusion";
let path = Cduce_loc.resolve_filename path in
if List.mem path !include_stack then tok
else
let ic =
try open_in path
with Sys_error msg ->
let last_p1, _ = !last_tok_pos in
Cduce_loc.raise_loc last_p1.Lexing.pos_cnum p2.Lexing.pos_cnum
(Ast.Parsing_error (Format.sprintf "include \"%s\" : %s" path msg))
in
include_stack := path :: !include_stack;
Cduce_loc.push_source (`File path);
try
let cs = Stream.of_channel ic in
let newlb = mk_lexbuf cs in
let past = pre_prog (token newlb) in
exit_include ic;
Cparser.RESOLVED_INCLUDE past
with e ->
exit_include ic;