Commit bcf40231 authored by Kim Nguyễn's avatar Kim Nguyễn

Add a warning when the lexer encounters the ambiguous ``[ 'a'a ]'' and

suggest to put a space before the second quote.

Move the auxiliary 'warning' function from the typechecker to the
Cduce_loc module.

Re-indent some comments in ulexer.ml
parent b05e438f
...@@ -13,6 +13,7 @@ let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) = ...@@ -13,6 +13,7 @@ let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
else loc1 else loc1
let source = ref `None let source = ref `None
let get_source () = !source
let source_stack = ref [] let source_stack = ref []
let push_source s = source_stack := !source :: !source_stack; source := s let push_source s = source_stack := !source :: !source_stack; source := s
let pop_source () = let pop_source () =
...@@ -181,3 +182,9 @@ let resolve_filename s = ...@@ -181,3 +182,9 @@ let resolve_filename s =
include Camlp4.PreCast.Loc include Camlp4.PreCast.Loc
let warning loc msg =
let v = get_viewport () in
let ppf = if Html.is_html v then Html.ppf v else Format.err_formatter in
print_loc ppf (loc,`Full);
html_hilight (loc,`Full);
Format.fprintf ppf "Warning: %s@." msg
...@@ -24,6 +24,7 @@ val raise_loc_generic: loc -> string -> 'a ...@@ -24,6 +24,7 @@ val raise_loc_generic: loc -> string -> 'a
val push_source: source -> unit val push_source: source -> unit
val pop_source: unit -> unit val pop_source: unit -> unit
val get_source : unit -> source
val current_dir : unit -> string val current_dir : unit -> string
...@@ -45,6 +46,7 @@ val mknoloc: 'a -> 'a located ...@@ -45,6 +46,7 @@ val mknoloc: 'a -> 'a located
val loc_of_pos : int * int -> loc val loc_of_pos : int * int -> loc
val warning : loc -> string -> unit
(* Are we working in a protected environement (web prototype ...) ? *) (* Are we working in a protected environement (web prototype ...) ? *)
val set_protected : bool -> unit val set_protected : bool -> unit
......
...@@ -189,8 +189,9 @@ let regexp ncname = ( xml_letter ncname_char* ) | ('_' ncname_char+) ...@@ -189,8 +189,9 @@ let regexp ncname = ( xml_letter ncname_char* ) | ('_' ncname_char+)
let regexp qname = (ncname ':')? ncname let regexp qname = (ncname ':')? ncname
(* We want to write _ \ (xml_letter | '_') but we can't due to a limitation in ulex. (* We want to write _ \ (xml_letter | '_') but we can't due to a
we define explicitely this regexp, based on the definition in ulex-1.1 limitation in ulex. we define explicitely this regexp, based on
the definition in ulex-1.1
*) *)
let regexp not_ncname_letter = [^ (* base_char *) let regexp not_ncname_letter = [^ (* base_char *)
0x0041-0x005A 0x0061-0x007A 0x00C0-0x00D6 0x00D8-0x00F6 0x0041-0x005A 0x0061-0x007A 0x00C0-0x00D6 0x00D8-0x00F6
...@@ -259,7 +260,6 @@ let regexp not_ncname_letter = [^ (* base_char *) ...@@ -259,7 +260,6 @@ let regexp not_ncname_letter = [^ (* base_char *)
'_' '_'
] ]
let illegal lexbuf = let illegal lexbuf =
error error
(L.lexeme_start lexbuf) (L.lexeme_start lexbuf)
...@@ -270,6 +270,10 @@ let in_comment = ref false ...@@ -270,6 +270,10 @@ let in_comment = ref false
let return lexbuf tok = (tok, L.loc lexbuf) let return lexbuf tok = (tok, L.loc lexbuf)
let return_loc i j tok = (tok, (i,j)) let return_loc i j tok = (tok, (i,j))
let warning lexbuf msg =
let i, j = L.loc lexbuf in
Cduce_loc.warning (Cduce_loc.get_source (), i, j) msg
let rec token = lexer let rec token = lexer
| xml_blank+ -> token lexbuf | xml_blank+ -> token lexbuf
...@@ -290,15 +294,22 @@ let rec token = lexer ...@@ -290,15 +294,22 @@ let rec token = lexer
| ["?+*"] "?" | "#" -> | ["?+*"] "?" | "#" ->
return lexbuf (KEYWORD (L.utf8_lexeme lexbuf)) return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
(* the three followning rules work together and are replicated in the comment lexer *) (* the three followning rules work together and are replicated in the
comment lexer *)
| "'" ([^ '\t' '\n' '\r' '\''] | '\\' '\'')* "'" (not_ncname_letter | eof) -> | "'" ([^ '\t' '\n' '\r' '\''] | '\\' '\'')* "'" (not_ncname_letter | eof) ->
(* two single quotes not followed by an xml_letter must be a string (* two single quotes not followed by an xml_letter must be a string
we put it back call an auxiliary lexer to consume the first ' and read it as a string. we put it back call an auxiliary lexer to consume the first '
*) and read it as a string. *)
L.rollback lexbuf; L.rollback lexbuf;
do_string lexbuf do_string lexbuf
| "'" ncname "'" ncname ->
let s = L.utf8_lexeme lexbuf in
warning lexbuf
(Printf.sprintf "ambiguous sequence of polymorphic variables (%s). Add a space before the second quote." s);
L.rollback lexbuf;
do_variable lexbuf
| "'" ncname -> | "'" ncname ->
(* then try to read it as variable *) (* then try to read it as variable *)
...@@ -306,8 +317,8 @@ let rec token = lexer ...@@ -306,8 +317,8 @@ let rec token = lexer
return lexbuf (PVAR (s)) return lexbuf (PVAR (s))
| ('"' | "'") -> | ('"' | "'") ->
(* otherwise we will fail for sure, but try to read it character by character as a string (* otherwise we will fail for sure, but try to read it character by
to get a decent error message *) character as a string to get a decent error message *)
L.rollback lexbuf; L.rollback lexbuf;
do_string lexbuf do_string lexbuf
...@@ -335,6 +346,12 @@ and do_string = lexer ...@@ -335,6 +346,12 @@ and do_string = lexer
(if double then STRING2 s else STRING1 s) (if double then STRING2 s else STRING1 s)
| _ -> assert false | _ -> assert false
and do_variable = lexer
| "'" ncname ->
let s = L.utf8_sub_lexeme lexbuf 1 (L.lexeme_length lexbuf - 1) in
return lexbuf (PVAR (s))
| _ -> assert false
and comment start = lexer and comment start = lexer
| "(*" -> | "(*" ->
comment (L.lexeme_start lexbuf) lexbuf; comment (L.lexeme_start lexbuf) lexbuf;
......
...@@ -8,13 +8,6 @@ let (<) (x:int) y = x < y ...@@ -8,13 +8,6 @@ let (<) (x:int) y = x < y
let (>=) (x:int) y = x >= y let (>=) (x:int) y = x >= y
let (>) (x:int) y = x > y let (>) (x:int) y = x > y
let warning loc msg =
let v = Cduce_loc.get_viewport () in
let ppf = if Html.is_html v then Html.ppf v else Format.err_formatter in
Cduce_loc.print_loc ppf (loc,`Full);
Cduce_loc.html_hilight (loc,`Full);
Format.fprintf ppf "Warning: %s@." msg
exception NonExhaustive of Types.descr exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr exception Constraint of Types.descr * Types.descr
exception ShouldHave of Types.descr * string exception ShouldHave of Types.descr * string
......
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