PR#6604: Only allow directives with filename and at the beginning of …

…the line (#931)

Changes

@@ -35,6 +35,11 @@ be mentioned in the 4.06 section below instead of here.)
 
 ### Bug fixes
 
+* PR#6604, GPR#931: Only allow directives with filename and at the beginning of
+  the line
+  (Tadeu Zagallo, report by Roberto Di Cosmo,
+   review by Hongbo Zhang, David Allsopp, Gabriel Scherer, Xavier Leroy)
+
 Release branch for 4.06:
 ------------------------
 

parsing/lexer.mll

@@ -439,25 +439,12 @@ rule token = parse
         lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
         STAR
       }
-  | ("#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
-        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?) as directive
-        [^ '\010' '\013'] * newline
-      {
-        match int_of_string num with
-        | exception _ ->
-            (* PR#7165 *)
-            let loc = Location.curr lexbuf in
-            let explanation = "line number out of range" in
-            let error = Invalid_directive (directive, Some explanation) in
-            raise (Error (error, loc))
-        | line_num ->
-           (* Documentation says that the line number should be
-              positive, but we have never guarded against this and it
-              might have useful hackish uses. *)
-            update_loc lexbuf name line_num true 0;
-            token lexbuf
+  | "#"
+      { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in
+        if not (at_beginning_of_line lexbuf.lex_start_p)
+        then HASH
+        else try directive lexbuf with Failure _ -> HASH
       }
-  | "#"  { HASH }
   | "&"  { AMPERSAND }
   | "&&" { AMPERAMPER }
   | "`"  { BACKQUOTE }
@@ -529,6 +516,25 @@ rule token = parse
                      Location.curr lexbuf))
       }
 
+and directive = parse
+  | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive)
+        [^ '\010' '\013'] *
+      {
+        match int_of_string num with
+        | exception _ ->
+            (* PR#7165 *)
+            let loc = Location.curr lexbuf in
+            let explanation = "line number out of range" in
+            let error = Invalid_directive ("#" ^ directive, Some explanation) in
+            raise (Error (error, loc))
+        | line_num ->
+           (* Documentation says that the line number should be
+              positive, but we have never guarded against this and it
+              might have useful hackish uses. *)
+            update_loc lexbuf (Some name) (line_num - 1) true 0;
+            token lexbuf
+      }
 and comment = parse
     "(*"
       { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;

testsuite/tests/parsing/pr6604.ml

@@ -0,0 +1 @@
+#1

testsuite/tests/parsing/pr6604.ml.reference

@@ -0,0 +1,2 @@
+File "pr6604.ml", line 1, characters 0-1:
+Error: Syntax error

testsuite/tests/parsing/pr6604_2.ml

@@ -0,0 +1 @@
+ #1 "pr6604.ml"

testsuite/tests/parsing/pr6604_2.ml.reference

@@ -0,0 +1,2 @@
+File "pr6604_2.ml", line 1, characters 1-2:
+Error: Syntax error

testsuite/tests/parsing/pr6604_3.ml

@@ -0,0 +1,4 @@
+# 1 "pr6604.ml"
+
+# 3 "pr6604.ml"
+# 4 "pr6604.ml"

testsuite/tests/parsing/pr6604_3.ml.reference

@@ -0,0 +1,2 @@
+[]
+

testsuite/tests/parsing/pr7165.ml

@@ -1,4 +1,4 @@
 (* this is a lexer directive with an out-of-bound integer;
    it should result in a lexing error instead of an
    uncaught exception as in PR#7165 *)
-#9342101923012312312
+#9342101923012312312 ""

testsuite/tests/parsing/pr7165.ml.reference

@@ -1,2 +1,2 @@
-File "pr7165.ml", line 4, characters 0-21:
-Error: Invalid lexer directive "#9342101923012312312": line number out of range
+File "pr7165.ml", line 4, characters 1-23:
+Error: Invalid lexer directive "#9342101923012312312 \"\"": line number out of range