PR#6604: Only allow directives with filename and at the beginning of the line (#931)

10 files changed, 44 insertions, 21 deletions

diff --git a/Changes b/Changes
index 68543792a7..0d1fbe5df5 100644
--- a/Changes
+++ b/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:
 ------------------------
 
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 1e385a044a..89079d4bcc 100644
--- a/parsing/lexer.mll
+++ b/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;
diff --git a/testsuite/tests/parsing/pr6604.ml b/testsuite/tests/parsing/pr6604.ml
new file mode 100644
index 0000000000..e3a9368692
--- /dev/null
+++ b/testsuite/tests/parsing/pr6604.ml
@@ -0,0 +1 @@
+#1
diff --git a/testsuite/tests/parsing/pr6604.ml.reference b/testsuite/tests/parsing/pr6604.ml.reference
new file mode 100644
index 0000000000..515b2317bd
--- /dev/null
+++ b/testsuite/tests/parsing/pr6604.ml.reference
@@ -0,0 +1,2 @@
+File "pr6604.ml", line 1, characters 0-1:
+Error: Syntax error
diff --git a/testsuite/tests/parsing/pr6604_2.ml b/testsuite/tests/parsing/pr6604_2.ml
new file mode 100644
index 0000000000..e929b1110a
--- /dev/null
+++ b/testsuite/tests/parsing/pr6604_2.ml
@@ -0,0 +1 @@
+ #1 "pr6604.ml"
diff --git a/testsuite/tests/parsing/pr6604_2.ml.reference b/testsuite/tests/parsing/pr6604_2.ml.reference
new file mode 100644
index 0000000000..dbbb95a9d7
--- /dev/null
+++ b/testsuite/tests/parsing/pr6604_2.ml.reference
@@ -0,0 +1,2 @@
+File "pr6604_2.ml", line 1, characters 1-2:
+Error: Syntax error
diff --git a/testsuite/tests/parsing/pr6604_3.ml b/testsuite/tests/parsing/pr6604_3.ml
new file mode 100644
index 0000000000..82f9bf27dc
--- /dev/null
+++ b/testsuite/tests/parsing/pr6604_3.ml
@@ -0,0 +1,4 @@
+# 1 "pr6604.ml"
+
+# 3 "pr6604.ml"
+# 4 "pr6604.ml"
diff --git a/testsuite/tests/parsing/pr6604_3.ml.reference b/testsuite/tests/parsing/pr6604_3.ml.reference
new file mode 100644
index 0000000000..7dd4387521
--- /dev/null
+++ b/testsuite/tests/parsing/pr6604_3.ml.reference
@@ -0,0 +1,2 @@
+[]
+
diff --git a/testsuite/tests/parsing/pr7165.ml b/testsuite/tests/parsing/pr7165.ml
index ba6835b401..00124a7b52 100644
--- a/testsuite/tests/parsing/pr7165.ml
+++ b/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 ""
diff --git a/testsuite/tests/parsing/pr7165.ml.reference b/testsuite/tests/parsing/pr7165.ml.reference
index fd59df840c..886efe1adc 100644
--- a/testsuite/tests/parsing/pr7165.ml.reference
+++ b/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