Commit 145ce8aa authored by Pietro Abate's avatar Pietro Abate

[r2003-06-17 15:49:59 by cvscast] Review type-checking of strings (TODO: clean the parser; improve

pretty-printing of errors)

Original author: cvscast
Date: 2003-06-17 15:50:00+00:00
parent e90966c8
......@@ -43,9 +43,9 @@ let dump_env ppf =
let rec print_exn ppf = function
| Location (loc, exn) ->
Format.fprintf ppf "Error %a:@." Location.print_loc loc;
Format.fprintf ppf "%a" Location.html_hilight loc;
| Location (loc, w, exn) ->
Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
Format.fprintf ppf "%a" Location.html_hilight (loc,w);
print_exn ppf exn
| Value.CDuceExn v ->
Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
......@@ -173,7 +173,7 @@ let rec phrases ppf phs = match phs with
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
if not !quiet then
Location.dump_loc ppf e.Typed.exp_loc;
Location.dump_loc ppf (e.Typed.exp_loc,`Full);
let v = Eval.eval !eval_env e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@." print_norm t print_value v;
......
......@@ -52,11 +52,11 @@ let l6 = [ 1 2 3 ] @ [ 4 5 6 ]
(* Inside [...], it is possible to escape a subsequence with a ! *)
let l7 = [ 1 2 !l6 !l1 5 ]
";"seqtypes","(* Sequence types are defined with regular expression over types *)
type IntList = [ Int* ];;
type IntStringList = [ (Int String)* ];;
type IntNonEmptyList = [ Int+ ];;
type IntList = [ Int* ]
type IntStringList = [ (Int String)* ]
type IntNonEmptyList = [ Int+ ]
let l : IntList = [ 1 2 3 ];;
let l : IntList = [ 1 2 3 ]
";"integers","(* Yes, CDuce can handle large integers! *)
let facto (Int -> Int)
| 0 | 1 -> 1
......
......@@ -45,6 +45,7 @@ and pexpr =
| Pair of pexpr * pexpr
| Xml of pexpr * pexpr
| RecordLitt of pexpr label_map
| String of U.uindex * U.uindex * U.t * pexpr
(* Data destructors *)
| Match of pexpr * branches
......
type source = [ `None | `File of string | `Stream | `String of string ]
type loc = source * int * int
type precise = [ `Full | `Char of int ]
type viewport = [ `Html | `Text ]
let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
......@@ -23,12 +25,12 @@ let current_dir () =
let warning_ppf = ref Format.std_formatter
exception Location of loc * exn
exception Location of loc * precise * exn
exception Generic of string
let raise_loc i j exn = raise (Location ((!source,i,j),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, Generic s))
let raise_loc_generic loc s = raise (Location (loc, `Full, Generic s))
let noloc = (`None,-1,-1)
let nopos = (-1,-1)
......@@ -51,26 +53,30 @@ let get_line_number src i =
close_in ic;
r
let print_loc ppf (src,i,j) =
let print_precise ppf = function
| `Full -> ()
| `Char i -> Format.fprintf ppf " (char # %i)" i
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" i j
Format.fprintf ppf "at chars %i-%i%a" i j print_precise w
| `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), file %s"
l1 c1 c2 fn
Format.fprintf ppf "at line %i (chars %i-%i)%a, file %s"
l1 c1 c2 print_precise w fn
else
Format.fprintf ppf "at lines %i (char %i) - %i (char %i), file %s"
l1 c1 l2 c2 fn
Format.fprintf ppf "at lines %i (char %i) - %i (char %i)%a, file %s"
l1 c1 l2 c2 print_precise w fn
let extr s i j =
Netencoding.Html.encode_from_latin1
(String.sub s i (j - i))
let dump_loc ppf (src,i,j) =
let dump_loc ppf ((src,i,j),w) =
match (src, !viewport) with
| (`String s, `Html) ->
if (i < 0) then
......@@ -87,7 +93,7 @@ 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 (src,i,j) =
let html_hilight ppf ((src,i,j),w) =
match (src, !viewport) with
| `String s, `Html ->
if (i < 0) then
......
......@@ -3,7 +3,9 @@
type source = [ `None | `File of string | `Stream | `String of string ]
type loc = source * int * int
exception Location of loc * exn
type precise = [ `Full | `Char of int ]
exception Location of loc * precise * exn
exception Generic of string
val noloc:loc
val nopos:int * int
......@@ -26,9 +28,9 @@ val set_viewport: viewport -> unit
val protect: Format.formatter -> (Format.formatter -> unit) -> unit
val print_loc: Format.formatter -> loc -> unit
val dump_loc: Format.formatter -> loc -> unit
val html_hilight: Format.formatter -> loc -> unit
val print_loc: Format.formatter -> loc * precise -> unit
val dump_loc: Format.formatter -> loc * precise -> unit
val html_hilight: Format.formatter -> loc * precise -> unit
type 'a located = { loc : loc; descr : 'a }
val mk: int * int -> 'a -> 'a located
......
......@@ -129,6 +129,7 @@ EXTEND
| "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "type"; x = LIDENT -> error loc "Type identifiers must be capitalized"
| "schema"; name = UIDENT; "="; uri = STRING2 ->
protect_op "schema";
let schema_doc = Schema_xml.pxp_tree_of (get_string uri) in
let schema = Schema_parser.parse_schema schema_doc in
[ mk loc (SchemaDecl (name, schema))]
......@@ -276,6 +277,7 @@ EXTEND
let l = List.fold_right
(fun x q ->
match x with
| `String (loc,i,j,s) -> exp loc (String (i,j,s,q))
| `Elems l -> tuple_queue l q
| `Explode x -> Op ("@",[x;q])
) l e
......@@ -288,14 +290,19 @@ EXTEND
exp loc (Xml (t, Pair (a,c)))
| "{"; r = [ expr_record_spec | -> exp loc (RecordLitt LabelMap.empty) ]; "}" -> r
| s = STRING2 ->
exp loc (tuple (char_list loc s @ [cst_nil]))
let s = U.mk (get_string s) in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
(* exp loc (tuple (char_list loc s @ [cst_nil])) *)
| a = LIDENT -> exp loc (Var (ident a))
]
];
seq_elem: [
[ x = STRING1 -> `Elems (char_list loc x)
[ x = STRING1 ->
let s = U.mk (get_string x) in
`String (loc, U.start_index s, U.end_index s, s)
(* `Elems (char_list loc x) *)
| e = expr LEVEL "no_appl" -> `Elems [e]
| "!"; e = expr LEVEL "no_appl" -> `Explode e
]
......
......@@ -269,9 +269,9 @@ and comment engine lexbuf =
Buffer.clear string_buff;
let ender = Lexing.lexeme lexbuf in
(try string ender engine lexbuf
with Location.Location (_,Unterminated_string) ->
with Location.Location (_,_,Unterminated_string) ->
let st = List.hd !comment_start_pos in
error st (st+2) Unterminated_string_in_comment);
error st (st+2) Unterminated_string_in_comment);
Buffer.clear string_buff;
comment engine lexbuf )
| 3 -> (
......
......@@ -141,9 +141,9 @@ and comment = parse
Buffer.clear string_buff;
let ender = Lexing.lexeme lexbuf in
(try string ender engine lexbuf
with Location.Location (_,Unterminated_string) ->
with Location.Location (_,_,Unterminated_string) ->
let st = List.hd !comment_start_pos in
error st (st+2) Unterminated_string_in_comment);
error st (st+2) Unterminated_string_in_comment);
Buffer.clear string_buff;
comment engine lexbuf }
| eof
......
......@@ -23,6 +23,7 @@ let rec eval env e0 = match e0.Typed.exp_descr with
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> Xml (eval env e1, eval env e2, eval env e3)
| Typed.Xml (_,_) -> assert false
| Typed.Cst c -> const c
| Typed.String (i,j,s,e) -> String_utf8 (i,j,s, eval env e)
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
| Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
......
......@@ -32,6 +32,7 @@ and texpr' =
| Pair of texpr * texpr
| Xml of texpr * texpr
| RecordLitt of texpr label_map
| String of U.uindex * U.uindex * U.t * texpr
(* Data destructors *)
| Match of texpr * branches
......
......@@ -7,8 +7,8 @@
let warning loc msg =
Format.fprintf !Location.warning_ppf "Warning %a:@\n%a%s@\n"
Location.print_loc loc
Location.html_hilight loc
Location.print_loc (loc,`Full)
Location.html_hilight (loc,`Full)
msg
(* I. Transform the abstract syntax of types and patterns into
......@@ -29,7 +29,8 @@ exception WrongLabel of Types.descr * label
exception UnboundId of id
exception Error of string
let raise_loc loc exn = raise (Location (loc,exn))
let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
let error loc msg = raise_loc loc (Error msg)
(* Schema datastructures *)
......@@ -580,7 +581,7 @@ let pat p =
flush_fv ();
try pat_node s
with Patterns.Error e -> raise_loc_generic p.loc e
| Location (loc,exn) when loc = noloc -> raise (Location (p.loc, exn))
| Location (loc,_,exn) when loc = noloc -> raise (Location (p.loc, `Full, exn))
(* II. Build skeleton *)
......@@ -652,6 +653,9 @@ let rec expr loc = function
in fv := Fv.cup !fv fv2; e)
r in
exp loc !fv (Typed.RecordLitt r)
| String (i,j,s,e) ->
let (fv,e) = expr loc e in
exp loc fv (Typed.String (i,j,s,e))
| Op (op,le) ->
let (fvs,ltes) = List.split (List.map (expr loc) le) in
let fv = List.fold_left Fv.cup Fv.empty fvs in
......@@ -737,9 +741,16 @@ let require loc t s =
let check loc t s =
require loc t s; t
let should_have loc constr s =
let check_str loc ofs t s =
if not (Types.subtype t s) then raise_loc_str loc ofs (Constraint (t, s));
t
let should_have loc constr s =
raise_loc loc (ShouldHave (constr,s))
let should_have_str loc ofs constr s =
raise_loc_str loc ofs (ShouldHave (constr,s))
let flatten loc arg constr precise =
let constr' = Sequence.star
(Sequence.approx (Types.cap Sequence.any constr)) in
......@@ -840,6 +851,9 @@ and type_check' loc env e constr precise = match e with
| Cst c ->
check loc (Types.constant c) constr
| String (i,j,s,e) ->
type_check_string loc env 0 s i j e constr precise
| Dot (e,l) ->
let t = type_check env e Types.Record.any true in
let t =
......@@ -889,6 +903,23 @@ and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
else
constr
and type_check_string loc env ofs s i j e constr precise =
if U.equal_index i j then type_check env e constr precise
else
let rects = Types.Product.normal constr in
if Types.Product.is_empty rects
then should_have_str loc ofs constr "but it is a string"
else
let need_s = Types.Product.need_second rects in
let (ch,i') = U.next s i in
let ch = Chars.mk_int ch in
let tch = Types.constant (Types.Char ch) in
let t1 = check_str loc ofs tch (Types.Product.pi1 rects) in
let c2 = Types.Product.constraint_on_2 rects t1 in
let t2 = type_check_string loc env (ofs + 1) s i' j e c2 precise in
if precise then Types.times (Types.cons t1) (Types.cons t2)
else constr
and type_record loc env r constr precise =
(* try to get rid of precise = true for values of fields *)
(* also: the use equivalent of need_second to optimize... *)
......
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