diff --git a/vendors/Preproc/E_Lexer.mli b/vendors/Preproc/E_Lexer.mli new file mode 100644 index 000000000..56925da5d --- /dev/null +++ b/vendors/Preproc/E_Lexer.mli @@ -0,0 +1,20 @@ +(* Module for lexing boolean expressions of conditional directives *) + +(* Regions *) + +module Region = Simple_utils.Region + +val string_of_token : E_Parser.token -> string + +(* Errors *) + +type error = Invalid_character of char + +val format : + ?offsets:bool -> error Region.reg -> file:bool -> string Region.reg + +(* Lexing boolean expressions (may raise [Error]) *) + +exception Error of error Region.reg + +val scan : Lexing.lexbuf -> E_Parser.token diff --git a/vendors/Preproc/E_Lexer.mll b/vendors/Preproc/E_Lexer.mll index 41b0c312e..d476d9299 100644 --- a/vendors/Preproc/E_Lexer.mll +++ b/vendors/Preproc/E_Lexer.mll @@ -27,22 +27,19 @@ let string_of_token = function (* Errors *) -module Error = - struct - type t = Invalid_character of char +type error = Invalid_character of char - let to_string = function - Invalid_character c -> - sprintf "Invalid character '%c' (%d).\n" c (Char.code c) +let error_to_string = function + Invalid_character c -> + sprintf "Invalid character '%c' (%d).\n" c (Char.code c) - let format ?(offsets=true) Region.{region; value} ~file = - let msg = to_string value - and reg = region#to_string ~file ~offsets `Byte in - let value = sprintf "Preprocessing error %s:\n%s" reg msg - in Region.{value; region} - end +let format ?(offsets=true) Region.{region; value} ~file = + let msg = error_to_string value + and reg = region#to_string ~file ~offsets `Byte in + let value = sprintf "Preprocessing error %s:\n%s" reg msg + in Region.{value; region} -exception Error of Error.t Region.reg +exception Error of error Region.reg let mk_reg buffer = let start = Lexing.lexeme_start_p buffer |> Pos.from_byte @@ -95,7 +92,7 @@ rule scan = parse | "!=" { NEQ } | "!" { NOT } | "//" { inline_com lexbuf } -| _ as c { fail (Error.Invalid_character c) lexbuf } +| _ as c { fail (Invalid_character c) lexbuf } and inline_com = parse newline { Lexing.new_line lexbuf; EOL } diff --git a/vendors/Preproc/E_LexerMain.ml b/vendors/Preproc/E_LexerMain.ml index a45d3118e..3ffed4506 100644 --- a/vendors/Preproc/E_LexerMain.ml +++ b/vendors/Preproc/E_LexerMain.ml @@ -5,7 +5,7 @@ let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg let options = EvalOpt.read ();; match open_in options#input with - exception Sys_error msg -> prerr_endline msg + exception Sys_error msg -> highlight msg | cin -> let buffer = Lexing.from_channel cin in let open Lexing in @@ -18,6 +18,6 @@ match open_in options#input with if token <> E_Parser.EOL then iter () | exception E_Lexer.Error err -> let formatted = - E_Lexer.Error.format ~offsets:options#offsets ~file:true err + E_Lexer.format ~offsets:options#offsets ~file:true err in highlight formatted.Region.value in iter (); close_in cin diff --git a/vendors/Preproc/E_ParserMain.ml b/vendors/Preproc/E_ParserMain.ml index 564745af8..8a6b6b1ff 100644 --- a/vendors/Preproc/E_ParserMain.ml +++ b/vendors/Preproc/E_ParserMain.ml @@ -5,7 +5,7 @@ let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg let options = EvalOpt.read ();; match open_in options#input with - exception Sys_error msg -> prerr_endline msg + exception Sys_error msg -> highlight msg | cin -> let buffer = Lexing.from_channel cin in let open Lexing in @@ -20,15 +20,15 @@ match open_in options#input with with E_Lexer.Error error -> let formatted = - E_Lexer.Error.format + E_Lexer.format ~offsets:options#offsets ~file:true error in highlight formatted.Region.value | E_Parser.Error -> let region = Preproc.mk_reg buffer - and value = Preproc.Error.Parse_error in + and value = Preproc.Parse_error in let error = Region.{value; region} in let formatted = - Preproc.Error.format ~offsets:options#offsets - ~file:true error + Preproc.format ~offsets:options#offsets + ~file:true error in highlight formatted.Region.value in close_in cin diff --git a/vendors/Preproc/Preproc.mli b/vendors/Preproc/Preproc.mli new file mode 100644 index 000000000..0cb0929b6 --- /dev/null +++ b/vendors/Preproc/Preproc.mli @@ -0,0 +1,50 @@ +(* The main module of the preprocessor (see [lex]) *) + +(* Regions *) + +module Region = Simple_utils.Region + +val mk_reg : Lexing.lexbuf -> Region.t + +(* Errors *) + +type error = + Invalid_directive of string +| Directive_inside_line +| Missing_endif +| Invalid_line_indicator of string +| No_line_indicator +| End_line_indicator +| Newline_in_string +| Open_comment +| Open_string +| Dangling_endif +| Open_region_in_conditional +| Dangling_endregion +| Conditional_in_region +| If_follows_elif +| Else_follows_else +| Dangling_else +| Elif_follows_else +| Dangling_elif +| Reserved_symbol of string +| Multiply_defined_symbol of string +| Error_directive of string +| Parse_error +| No_line_comment_or_blank +| Invalid_symbol + +val format : + ?offsets:bool -> error Region.reg -> file:bool -> string Region.reg + +(* Preprocessing a lexing buffer (might raise [Error]). *) + +exception Error of Buffer.t * error Region.reg + +val lex : Lexing.lexbuf -> Buffer.t + +(* Evaluation of boolean expressions *) + +module Env : Set.S with type elt = string + +val eval : Env.t -> E_AST.t -> bool diff --git a/vendors/Preproc/Preproc.mll b/vendors/Preproc/Preproc.mll index 7359918f7..a4585852c 100644 --- a/vendors/Preproc/Preproc.mll +++ b/vendors/Preproc/Preproc.mll @@ -22,16 +22,6 @@ let sprintf = Printf.sprintf | char::l -> Bytes.set bytes i char; fill (i-1) l in fill (len-1) p |> Bytes.to_string -(* The call [explode s a] is the list made by pushing the characters - in the string [s] on top of [a], in reverse order. For example, - [explode "ba" ['c';'d'] = ['a'; 'b'; 'c'; 'd']]. *) - -let explode s acc = - let rec push = function - 0 -> acc - | i -> s.[i-1] :: push (i-1) -in push (String.length s) - (* The type [mode] defines the two scanning modes of the preprocessor: either we copy the current characters or we skip them. *) @@ -88,109 +78,106 @@ type state = { (* ERRORS *) -module Error = - struct - type t = - Invalid_directive of string - | Directive_inside_line - | Missing_endif - | Invalid_line_indicator of string - | No_line_indicator - | End_line_indicator - | Newline_in_string - | Open_comment - | Open_string - | Dangling_endif - | Open_region_in_conditional - | Dangling_endregion - | Conditional_in_region - | If_follows_elif - | Else_follows_else - | Dangling_else - | Elif_follows_else - | Dangling_elif - | Reserved_symbol of string - | Multiply_defined_symbol of string - | Error_directive of string - | Parse_error - | No_line_comment_or_blank - | Invalid_symbol +type error = + Invalid_directive of string +| Directive_inside_line +| Missing_endif +| Invalid_line_indicator of string +| No_line_indicator +| End_line_indicator +| Newline_in_string +| Open_comment +| Open_string +| Dangling_endif +| Open_region_in_conditional +| Dangling_endregion +| Conditional_in_region +| If_follows_elif +| Else_follows_else +| Dangling_else +| Elif_follows_else +| Dangling_elif +| Reserved_symbol of string +| Multiply_defined_symbol of string +| Error_directive of string +| Parse_error +| No_line_comment_or_blank +| Invalid_symbol - let to_string = function - Invalid_directive name -> - sprintf "Invalid directive \"%s\"." name - | Directive_inside_line -> - sprintf "Directive inside a line." - | Missing_endif -> - sprintf "Missing #endif directive." - | Invalid_line_indicator id -> - sprintf "Invalid line indicator \"%s\".\n\ - Hint: Try \"default\" or \"hidden\"." id - | No_line_indicator -> - sprintf "Missing line indicator." - | End_line_indicator -> - sprintf "Invalid ending of numerical line indicator.\n\ - Hint: Try a string, end of line, or a line comment." - | Newline_in_string -> - sprintf "Invalid newline character in string." - | Open_comment -> - sprintf "Unterminated comment." - | Open_string -> - sprintf "Unterminated string.\n\ - Hint: Close with double quotes." - | Dangling_endif -> - sprintf "Dangling #endif directive.\n\ - Hint: Remove it or add a #if before." - | Open_region_in_conditional -> - sprintf "Unterminated of #region in conditional.\n\ - Hint: Close with #endregion before #endif." - | Dangling_endregion -> - sprintf "Dangling #endregion directive.\n\ - Hint: Remove it or use #region before." - | Conditional_in_region -> - sprintf "Conditional in region.\n\ - Hint: Remove the conditional or the region." - | If_follows_elif -> - sprintf "Directive #if found in a clause #elif." - | Else_follows_else -> - sprintf "Directive #else found in a clause #else." - | Dangling_else -> - sprintf "Directive #else without #if." - | Elif_follows_else -> - sprintf "Directive #elif found in a clause #else." - | Dangling_elif -> - sprintf "Dangling #elif directive.\n\ - Hint: Remove it or add a #if before." - | Reserved_symbol sym -> - sprintf "Reserved symbol \"%s\".\n\ - Hint: Use another symbol." sym - | Multiply_defined_symbol sym -> - sprintf "Multiply-defined symbol \"%s\".\n\ - Hint: Change the name or remove one definition." sym - | Error_directive msg -> - msg - | Parse_error -> - "Parse error in expression." - | No_line_comment_or_blank -> - "Line comment or whitespace expected." - | Invalid_symbol -> - "Expected a symbol (identifier)." +let error_to_string = function + Invalid_directive name -> + sprintf "Invalid directive \"%s\"." name +| Directive_inside_line -> + sprintf "Directive inside a line." +| Missing_endif -> + sprintf "Missing #endif directive." +| Invalid_line_indicator id -> + sprintf "Invalid line indicator \"%s\".\n\ + Hint: Try \"default\" or \"hidden\"." id +| No_line_indicator -> + sprintf "Missing line indicator." +| End_line_indicator -> + sprintf "Invalid ending of numerical line indicator.\n\ + Hint: Try a string, end of line, or a line comment." +| Newline_in_string -> + sprintf "Invalid newline character in string." +| Open_comment -> + sprintf "Unterminated comment." +| Open_string -> + sprintf "Unterminated string.\n\ + Hint: Close with double quotes." +| Dangling_endif -> + sprintf "Dangling #endif directive.\n\ + Hint: Remove it or add a #if before." +| Open_region_in_conditional -> + sprintf "Unterminated of #region in conditional.\n\ + Hint: Close with #endregion before #endif." +| Dangling_endregion -> + sprintf "Dangling #endregion directive.\n\ + Hint: Remove it or use #region before." +| Conditional_in_region -> + sprintf "Conditional in region.\n\ + Hint: Remove the conditional or the region." +| If_follows_elif -> + sprintf "Directive #if found in a clause #elif." +| Else_follows_else -> + sprintf "Directive #else found in a clause #else." +| Dangling_else -> + sprintf "Directive #else without #if." +| Elif_follows_else -> + sprintf "Directive #elif found in a clause #else." +| Dangling_elif -> + sprintf "Dangling #elif directive.\n\ + Hint: Remove it or add a #if before." +| Reserved_symbol sym -> + sprintf "Reserved symbol \"%s\".\n\ + Hint: Use another symbol." sym +| Multiply_defined_symbol sym -> + sprintf "Multiply-defined symbol \"%s\".\n\ + Hint: Change the name or remove one definition." sym +| Error_directive msg -> + msg +| Parse_error -> + "Parse error in expression." +| No_line_comment_or_blank -> + "Line comment or whitespace expected." +| Invalid_symbol -> + "Expected a symbol (identifier)." - let format ?(offsets=true) Region.{region; value} ~file = - let msg = to_string value - and reg = region#to_string ~file ~offsets `Byte in - let value = sprintf "Preprocessing error %s:\n%s" reg msg - in Region.{value; region} -end +let format ?(offsets=true) Region.{region; value} ~file = + let msg = error_to_string value + and reg = region#to_string ~file ~offsets `Byte in + let value = sprintf "Preprocessing error %s:\n%s" reg msg + in Region.{value; region} -exception Error of state * Error.t Region.reg +exception Error of Buffer.t * error Region.reg let mk_reg buffer = let start = Lexing.lexeme_start_p buffer |> Pos.from_byte and stop = Lexing.lexeme_end_p buffer |> Pos.from_byte in Region.make ~start ~stop -let stop value state region = raise (Error (state, Region.{region; value})) +let stop value state region = raise (Error (state.out, Region.{region; value})) let fail error state buffer = stop error state (mk_reg buffer) (* The function [reduce_cond] is called when a #endif directive is @@ -198,9 +185,9 @@ let fail error state buffer = stop error state (mk_reg buffer) let reduce_cond state region = let rec reduce = function - [] -> stop Error.Dangling_endif state region + [] -> stop Dangling_endif state region | If mode::trace -> trace, mode - | Region::_ -> stop Error.Open_region_in_conditional state region + | Region::_ -> stop Open_region_in_conditional state region | _::trace -> reduce trace in reduce state.trace @@ -209,9 +196,9 @@ let reduce_cond state region = let reduce_reg state region = match state.trace with - [] -> stop Error.Dangling_endregion state region + [] -> stop Dangling_endregion state region | Region::trace -> trace - | _ -> stop Error.Conditional_in_region state region + | _ -> stop Conditional_in_region state region (* The function [extend] is called when encountering conditional directives #if, #else and #elif. As its name suggests, it extends @@ -220,11 +207,11 @@ let reduce_reg state region = let extend cond state region = match cond, state.trace with - If _, Elif _::_ -> stop Error.If_follows_elif state region - | Else, Else::_ -> stop Error.Else_follows_else state region - | Else, [] -> stop Error.Dangling_else state region - | Elif _, Else::_ -> stop Error.Elif_follows_else state region - | Elif _, [] -> stop Error.Dangling_elif state region + If _, Elif _::_ -> stop If_follows_elif state region + | Else, Else::_ -> stop Else_follows_else state region + | Else, [] -> stop Dangling_else state region + | Elif _, Else::_ -> stop Elif_follows_else state region + | Elif _, [] -> stop Dangling_elif state region | hd, tl -> hd::tl (* The function [last_mode] seeks the last mode as recorded in the @@ -272,8 +259,8 @@ let expr state buffer : mode = try E_Parser.expr E_Lexer.scan buffer with E_Parser.Error -> let region = mk_reg buffer in - let value = Error.Parse_error - in raise (Error (state, Region.{value; region})) in + let value = Parse_error + in raise (Error (state.out, Region.{value; region})) in let () = print state "\n" in if eval state.env ast then Copy else Skip @@ -428,9 +415,9 @@ rule scan state = parse | Inline -> copy state lexbuf; scan state lexbuf } | directive { if not (List.mem id directives) - then fail (Error.Invalid_directive id) state lexbuf; + then fail (Invalid_directive id) state lexbuf; if state.offset = Inline - then fail Error.Directive_inside_line state lexbuf; + then fail Directive_inside_line state lexbuf; let region = mk_reg lexbuf in match id with "include" -> @@ -473,9 +460,9 @@ rule scan state = parse | "define" -> let id, region = variable state lexbuf in if id="true" || id="false" - then stop (Error.Reserved_symbol id) state region; + then stop (Reserved_symbol id) state region; if Env.mem id state.env - then stop (Error.Multiply_defined_symbol id) state region; + then stop (Multiply_defined_symbol id) state region; let state = {state with env = Env.add id state.env; offset = Prefix 0} in scan state lexbuf @@ -485,7 +472,7 @@ rule scan state = parse offset = Prefix 0} in scan state lexbuf | "error" -> - stop (Error.Error_directive (message [] lexbuf)) state region + stop (Error_directive (message [] lexbuf)) state region (* | "warning" -> let start_p, end_p = region in @@ -523,7 +510,7 @@ rule scan state = parse } | eof { match state.trace with [] -> expand_offset state; state - | _ -> fail Error.Missing_endif state lexbuf } + | _ -> fail Missing_endif state lexbuf } | '"' { if state.mode = Copy then begin expand_offset state; @@ -560,7 +547,7 @@ and variable state = parse and symbol state = parse ident as id { id, mk_reg lexbuf } -| _ { fail Error.Invalid_symbol state lexbuf } +| _ { fail Invalid_symbol state lexbuf } (* Line indicator (#line) *) @@ -574,8 +561,8 @@ and line_indicator state = parse match id with "default" | "hidden" -> print state (id ^ message [] lexbuf) - | _ -> fail (Error.Invalid_line_indicator id) state lexbuf } -| _ { fail Error.No_line_indicator state lexbuf } + | _ -> fail (Invalid_line_indicator id) state lexbuf } +| _ { fail No_line_indicator state lexbuf } and end_indicator state = parse blank+ { copy state lexbuf; end_indicator state lexbuf } @@ -586,7 +573,7 @@ and end_indicator state = parse | '"' { copy state lexbuf; in_string (mk_reg lexbuf) state lexbuf; opt_line_com state lexbuf } -| _ { fail Error.End_line_indicator state lexbuf } +| _ { fail End_line_indicator state lexbuf } and opt_line_com state = parse nl { proc_nl state lexbuf } @@ -600,7 +587,7 @@ and skip_line state = parse nl { proc_nl state lexbuf } | blank+ { skip_line state lexbuf } | "//" { in_line_com {state with mode=Skip} lexbuf } -| _ { fail Error.No_line_comment_or_blank state lexbuf } +| _ { fail No_line_comment_or_blank state lexbuf } | eof { () } and message acc = parse @@ -620,7 +607,7 @@ and in_line_com state = parse and in_block_com opening state = parse nl { proc_nl state lexbuf; in_block_com opening state lexbuf } | "*/" { copy state lexbuf } -| eof { stop Error.Open_comment state opening } +| eof { stop Open_comment state opening } | _ { copy state lexbuf; in_block_com opening state lexbuf } (* Include a file *) @@ -637,8 +624,8 @@ and scan_inclusion state = parse and in_inclusion opening acc len state = parse '"' { mk_str len acc } -| nl { fail Error.Newline_in_string state lexbuf } -| eof { stop Error.Open_string state opening } +| nl { fail Newline_in_string state lexbuf } +| eof { stop Open_string state opening } | _ as c { in_inclusion opening (c::acc) (len+1) state lexbuf } (* Strings *) @@ -646,8 +633,8 @@ and in_inclusion opening acc len state = parse and in_string opening state = parse "\\\"" { copy state lexbuf; in_string opening state lexbuf } | '"' { copy state lexbuf } -| nl { fail Error.Newline_in_string state lexbuf } -| eof { stop Error.Open_string state opening } +| nl { fail Newline_in_string state lexbuf } +| eof { stop Open_string state opening } | _ { copy state lexbuf; in_string opening state lexbuf } diff --git a/vendors/Preproc/PreprocMain.ml b/vendors/Preproc/PreprocMain.ml index 93b00c193..a07eed957 100644 --- a/vendors/Preproc/PreprocMain.ml +++ b/vendors/Preproc/PreprocMain.ml @@ -1,9 +1,11 @@ module Region = Simple_utils.Region +let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg + let options = EvalOpt.read ();; match open_in options#input with - exception Sys_error msg -> prerr_endline msg + exception Sys_error msg -> highlight msg | cin -> let buffer = Lexing.from_channel cin in let open Lexing in @@ -14,12 +16,12 @@ match open_in options#input with pp -> print_string (Buffer.contents pp) | exception E_Lexer.Error err -> let formatted = - E_Lexer.Error.format ~offsets:options#offsets ~file:true err - in prerr_endline formatted.Region.value - | exception Preproc.Error (state, err) -> + E_Lexer.format ~offsets:options#offsets ~file:true err + in highlight formatted.Region.value + | exception Preproc.Error (out, err) -> let formatted = - Preproc.Error.format ~offsets:options#offsets ~file:true err in + Preproc.format ~offsets:options#offsets ~file:true err in begin - print_string (Buffer.contents state.Preproc.out); - prerr_endline formatted.Region.value + print_string (Buffer.contents out); + highlight formatted.Region.value end