Commit c1eed545 authored by Pietro Abate's avatar Pietro Abate

[r2003-03-16 14:05:39 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-16 14:08:16+00:00
parent aea0ca4a
......@@ -121,7 +121,7 @@ let debug ppf = function
let mk_builtin () =
let bi = List.map (fun (n,t) -> [n, mk noloc (Ast.Internal t)])
let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)])
Builtin.types in
glb_env := List.fold_left Typer.register_global_types !glb_env bi
......@@ -191,7 +191,7 @@ let run ppf ppf_err input =
try Parser.prog input
with
| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
| Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
in
let (type_decls,fun_decls) =
List.fold_left
......
......@@ -22,7 +22,7 @@ let ppf_err = Format.err_formatter
let do_file s =
let (src, chan) =
if s = "" then (`Stream, stdin) else (`File s, open_in s) in
Location.set_source src;
Location.push_source src;
let input = Stream.of_channel chan in
let ok = Cduce.run ppf ppf_err input in
if s <> "" then close_in chan;
......
......@@ -249,7 +249,7 @@ let main (cgi : Netcgi.std_activation) =
let exec src =
let ppf = Format.str_formatter
and input = Stream.of_string src in
Location.set_source (`String src);
Location.push_source (`String src);
Location.set_protected true;
Location.warning_ppf := ppf;
......
type loc = int * int
type source = [ `None | `File of string | `Stream | `String of string ]
type loc = source * int * int
type viewport = [ `Html | `Text ]
let source = ref `None
let source_stack = ref []
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
let warning_ppf = ref Format.std_formatter
exception Location of loc * exn
exception Generic of string
let raise_loc i j exn = raise (Location ((!source,i,j),exn))
let raise_generic s = raise (Generic s)
let raise_loc_generic loc s = raise (Location (loc, Generic s))
let noloc = (-1,-1)
let source = ref `None
let set_source s = source := s
let noloc = (`None,-1,-1)
let nopos = (-1,-1)
let viewport = ref `Text
let set_viewport v = viewport := v
......@@ -33,8 +40,8 @@ let get_line_number src i =
close_in ic;
r
let print_loc ppf (i,j) =
match !source with
let print_loc ppf (src,i,j) =
match src with
| `None -> Format.fprintf ppf "somewhere (no source defined !)"
| `Stream | `String _ ->
Format.fprintf ppf "at chars %i-%i" i j
......@@ -42,18 +49,18 @@ let print_loc ppf (i,j) =
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
Format.fprintf ppf "at line %i (chars %i-%i), file %s"
l1 c1 c2 fn
else
Format.fprintf ppf "at lines %i (char %i) - %i (char %i)"
l1 c1 l2 c2
Format.fprintf ppf "at lines %i (char %i) - %i (char %i), file %s"
l1 c1 l2 c2 fn
let extr s i j =
Netencoding.Html.encode_from_latin1
(String.sub s i (j - i))
let dump_loc ppf (i,j) =
match (!source, !viewport) with
let dump_loc ppf (src,i,j) =
match (src, !viewport) with
| (`String s, `Html) ->
if (i < 0) then
Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
......@@ -69,8 +76,8 @@ 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)
let html_hilight ppf (i,j) =
match (!source, !viewport) with
let html_hilight ppf (src,i,j) =
match (src, !viewport) with
| `String s, `Html ->
if (i < 0) then
Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
......@@ -87,10 +94,9 @@ let html_hilight ppf (i,j) =
type 'a located = { loc : loc; descr : 'a }
type expr = A | B of expr located
let mk loc x = { loc = loc; descr = x }
let mk (i,j) x = { loc = (!source,i,j); descr = x }
let mk_loc loc x = { loc = loc; descr = x }
let mknoloc x = { loc = noloc; descr = x }
let protect ppf f =
match !viewport with
......
(* Locations in source file,
and presentation of results and errors *)
type loc = int * int
type source = [ `None | `File of string | `Stream | `String of string ]
type loc = source * int * int
exception Location of loc * exn
exception Generic of string
val noloc:loc
val nopos:int * int
val raise_loc: int -> int -> exn -> 'a
val raise_generic: string -> 'a
val raise_loc_generic: loc -> string -> 'a
type source = [ `None | `File of string | `Stream | `String of string ]
val set_source: source -> unit
val push_source: source -> unit
val pop_source: unit -> unit
val warning_ppf : Format.formatter ref
......@@ -24,7 +27,9 @@ val dump_loc: Format.formatter -> loc -> unit
val html_hilight: Format.formatter -> loc -> unit
type 'a located = { loc : loc; descr : 'a }
val mk: loc -> 'a -> 'a located
val mk: int * int -> 'a -> 'a located
val mk_loc: loc -> 'a -> 'a located
val mknoloc: 'a -> 'a located
(* Are we working in a protected environement (web prototype ...) ? *)
......
......@@ -26,14 +26,14 @@ let rec tuple loc = function
| [] -> assert false
let tuple_queue =
List.fold_right (fun x q -> mk x.loc (Pair (x, q)))
List.fold_right (fun x q -> mk_loc x.loc (Pair (x, q)))
let char = mk noloc (Internal (Types.char Chars.any))
let char = mknoloc (Internal (Types.char Chars.any))
let string_regexp = Star (Elem char)
let cst_nil = mk noloc (Cst (Types.Atom Sequence.nil_atom))
let cst_nil = mknoloc (Cst (Types.Atom Sequence.nil_atom))
let seq_of_string pos s =
let (pos,_) = pos in
......@@ -44,7 +44,7 @@ let seq_of_string pos s =
aux [] (String.length s)
exception Error of string
let error loc s = raise (Location (loc, Error s))
let error (i,j) s = Location.raise_loc i j (Error s)
let make_record loc r =
LabelMap.from_list (fun _ _ -> error loc "Duplicated record field") r
......@@ -60,21 +60,38 @@ let char_list pos s =
List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.mk_char c)))) s
let include_stack = ref []
EXTEND
GLOBAL: prog expr pat regexp const;
prog: [
[ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; EOI -> l ]
[ l = LIST0 [ p = phrase; ";;" -> p ]; EOI -> List.flatten l ]
];
phrase: [
[ (p,e) = let_binding -> LetDecl (p,e)
[ (p,e) = let_binding -> [ mk loc (LetDecl (p,e)) ]
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
EvalStatement (mk loc (Match (e1,[p,e2])))
| LIDENT "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t)
| LIDENT "debug"; d = debug_directive -> Debug d
[ mk loc (EvalStatement (mk loc (Match (e1,[p,e2])))) ]
| LIDENT "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| LIDENT "debug"; d = debug_directive -> [ mk loc (Debug d) ]
| LIDENT "include"; s = STRING2 ->
protect_op "File inclusion";
(* avoid looping; should issue an error ? *)
if List.mem s !include_stack then []
else (
include_stack := s :: !include_stack;
let chan = open_in s in
Location.push_source (`File s);
let input = Stream.of_channel chan in
let l = Grammar.Entry.parse prog input in
close_in chan;
Location.pop_source ();
include_stack := List.tl !include_stack;
l
)
] |
[ e = expr -> EvalStatement e
[ e = expr -> [ mk loc (EvalStatement e) ]
]
];
......@@ -93,8 +110,8 @@ EXTEND
[ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
| "try"; e = SELF; "with"; b = branches ->
let default =
(mk noloc (Capture (ident "x")),
mk noloc (Op ("raise",[mk noloc (Var (ident "x"))]))) in
(mknoloc (Capture (ident "x")),
mknoloc (Op ("raise",[mknoloc (Var (ident "x"))]))) in
mk loc (Try (e,b@[default]))
| "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
| "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
......@@ -102,7 +119,7 @@ EXTEND
and p2 = mk loc (Internal (Builtin.false_type)) in
mk loc (Match (e, [p1,e1; p2,e2]))
| "transform"; e = SELF; "with"; b = branches ->
let default = mk noloc (Capture (ident "x")), cst_nil in
let default = mknoloc (Capture (ident "x")), cst_nil in
mk loc (Op ("flatten", [mk loc (Map (e,b@[default]))]))
| "fun"; (f,a,b) = fun_decl ->
mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
......@@ -173,7 +190,7 @@ EXTEND
(fun x q ->
match x with
| `Elems l -> tuple_queue l q
| `Explode x -> mk x.loc (Op ("@",[x;q]))
| `Explode x -> mk_loc x.loc (Op ("@",[x;q]))
) l e
| t = [ a = TAG ->
mk loc (Cst (Types.Atom (Atoms.mk a)))
......@@ -197,7 +214,7 @@ EXTEND
let_binding: [
[ "let"; p = pat; "="; e = expr -> (p,e)
| "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, mk noloc (Forget (e,t)))
| "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, mknoloc (Forget (e,t)))
| "let"; "fun"; (f,a,b) = fun_decl ->
let p = match f with
| Some x -> mk loc (Capture x)
......@@ -226,8 +243,8 @@ EXTEND
| `Classic (p2,a,b) -> f,(p1,p2)::a,b
| `Compact (targ1,args,tres,body) ->
let args = (p1,targ1) :: args in
let targ = multi_prod noloc (List.map snd args) in
let arg = multi_prod noloc (List.map fst args) in
let targ = multi_prod nopos (List.map snd args) in
let arg = multi_prod nopos (List.map fst args) in
let b = [arg, body] in
let a = [targ,tres] in
(f,a,b)
......@@ -319,7 +336,7 @@ EXTEND
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
q = [ ";"; q = pat -> q
| -> mk noloc (Internal (Sequence.nil_type)) ];
| -> mknoloc (Internal (Sequence.nil_type)) ];
"]" -> mk loc (Regexp (r,q))
| t = [
[ "<"; LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any)))
......@@ -398,6 +415,7 @@ let pat = Grammar.Entry.parse pat
and expr = Grammar.Entry.parse expr
and prog = Grammar.Entry.parse prog
module From_string = struct
let pat s = Grammar.Entry.parse pat' (Stream.of_string s)
let expr s = expr (Stream.of_string s)
......
......@@ -69,7 +69,7 @@ let nb_classes = 34
let keywords = Hashtbl.create 17
let error i j exn = raise (Location.Location ((i,j),exn))
let error = Location.raise_loc
exception Illegal_character of char
exception Unterminated_comment
exception Unterminated_string
......
......@@ -12,7 +12,7 @@ classes
{
let keywords = Hashtbl.create 17
let error i j exn = raise (Location.Location ((i,j),exn))
let error = Location.raise_loc
exception Illegal_character of char
exception Unterminated_comment
exception Unterminated_string
......
......@@ -116,14 +116,14 @@ module Regexp = struct
| Star r -> RStar (propagate vars r)
| WeakStar r -> RWeakStar (propagate vars r)
| SeqCapture (v,x) ->
let v= mk !re_loc (Capture v) in
propagate (fun p -> mk !re_loc (And (vars p,v))) x
let v= mk_loc !re_loc (Capture v) in
propagate (fun p -> mk_loc !re_loc (And (vars p,v))) x
let dummy_pat = mk noloc (PatVar "DUMMY")
let dummy_pat = mknoloc (PatVar "DUMMY")
let cup r1 r2 =
if r1 == dummy_pat then r2 else
if r2 == dummy_pat then r1 else
mk !re_loc (Or (r1,r2))
mk_loc !re_loc (Or (r1,r2))
(*TODO: review this compilation schema to avoid explosion when
coding (Optional x) by (Or(Epsilon,x)); memoization ... *)
......@@ -143,7 +143,7 @@ module Regexp = struct
| REpsilon :: rest ->
compile fin e rest
| RElem (_,p) :: rest ->
mk !re_loc (Prod (p, guard_compile fin rest))
mk_loc !re_loc (Prod (p, guard_compile fin rest))
| RSeq (r1,r2) :: rest ->
compile fin e (r1 :: r2 :: rest)
| RAlt (r1,r2) :: rest ->
......@@ -158,7 +158,7 @@ module Regexp = struct
with
Not_found ->
let n = name () in
let v = mk !re_loc (PatVar n) in
let v = mk_loc !re_loc (PatVar n) in
memo := Memo.add seq v !memo;
let d = compile fin (ref Coind.empty) seq in
assert (d != dummy_pat);
......@@ -225,8 +225,8 @@ module Regexp = struct
let constant_nil t v =
mk !re_loc
(And (t, (mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))
mk_loc !re_loc
(And (t, (mk_loc !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))
let compile loc regexp queue : ppat =
re_loc := loc;
......@@ -245,7 +245,7 @@ module Regexp = struct
to_compile := [];
*)
mk !re_loc (Recurs (n,d))
mk_loc !re_loc (Recurs (n,d))
end
let compile_regexp = Regexp.compile noloc
......
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