dfmc-reader: fix bug in make-hash-literal

documentation/library-reference/source/language-extensions/parser-expansions.rst

@@ -18,7 +18,7 @@ gets transformed, setter-like, into::
 
 The ``<text>`` part can be either *delimited* or *undelimited*. Undelimited
 text can contain anything but commas, semicolons, brackets of any kind, and
-whitespace. There is no ``\`` escape processing. All the following are valid::
+whitespace. All the following are valid::
 
     #:http://opendylan.org/
     #:time:12:30am
@@ -51,3 +51,9 @@ An example parser:
 
 If an appropriate function isn't defined, you get a standard unbound variable
 reference message indicating the # literal.
+
+Note that there is no escape processing except that the end delimiter may be
+escaped with a backslash and *the escape character itself is not removed*. For
+example, ``#:file:"C:\foo\"`` is an error because the end delimiter is escaped
+and therefore the hash literal is unterminated. ``#:file:"C:\foo\""`` results
+in the literal string ``C:\foo\"`` being passed to the parser.

sources/dfmc/reader/interface.dylan

@@ -109,6 +109,11 @@ define serious-program-warning <ratios-not-supported> (<invalid-token>)
   format-arguments token-string;
 end serious-program-warning;
 
+define serious-program-warning <unterminated-parser-expansion>
+  format-string "Unterminated parser expansion %s";
+  format-arguments token-string;
+end serious-program-warning;
+
 define serious-program-warning <invalid-end-of-input> (<reader-error>)
   format-string
     "Unexpected end of input encountered while reading form.";

sources/dfmc/reader/lexer.dylan

@@ -1368,18 +1368,28 @@ define method make-hash-literal
       let start-delimiter = delimiter;
       let end-delimiter
         = as(<integer>, $hash-data-end-delimiters[delimiter-index]);
-      let i :: <integer> = data-start + 1;
-      let char :: <integer> = 0;
-      while (((char := contents[i]) ~== end-delimiter)
-               | (char == end-delimiter & contents[i - 1] == $escape-code))
-        if (char == $newline-code)
-          lexer.line := lexer.line + 1;
-          lexer.line-start := i;
+      iterate loop (i = data-start + 1, prev-char = 0)
+        if (i >= length)
+          note(<unterminated-parser-expansion>,
+               source-location:
+                 record-position-as-location
+                 (source-location.source-location-record,
+                  source-location.source-location-source-position),
+               token-string: extract-string(source-location));
+        else
+          let char :: <integer> = contents[i];
+          if (char == end-delimiter & (prev-char ~== $escape-code))
+            data := extract-string(source-location, start: data-start + 1, end: i);
+            lexer.posn := i + 1;
+          else
+            if (char == $newline-code)
+              lexer.line := lexer.line + 1;
+              lexer.line-start := i;
+            end;
+            loop(i + 1, char);
+          end;
         end;
-        i := i + 1;
-      end;
-      data := extract-string(source-location, start: data-start + 1, end: i);
-      lexer.posn := i + 1;
+      end iterate;
     else
       // Read until whitespace or EOF
       let i :: <integer> = data-start;

sources/dfmc/reader/tests/expressions-test-suite.dylan

@@ -112,7 +112,7 @@ define function verify-hash-literal-function-call
   assert-equal(arg1.fragment-value, arg);
 end function;
 
-define test hash-literal-test ()
+define test hash-literal-ast-test ()
   verify-hash-literal-function-call("#:foo:bar", #"foo-parser", "bar");
   verify-hash-literal-function-call("#:foo:{\nbar\n}", #"foo-parser", "\nbar\n");
 end test;
@@ -136,5 +136,5 @@ define suite expressions-test-suite ()
   test binary->=-test;
   // This doesn't test &, | and := yet.
   test escaped-name-test;
-  test hash-literal-test;
+  test hash-literal-ast-test;
 end suite expressions-test-suite;

sources/dfmc/reader/tests/literal-test-suite.dylan

@@ -229,6 +229,14 @@ define test vector-literal-test ()
   verify-presentation(f, "#[\"a\", b:]");
 end test vector-literal-test;
 
+define test hash-literal-test ()
+  // End delimiter is escaped so the hash literal is not terminated. This used
+  // to crash the compiler, unless '}' appeared somewhere later in the source
+  // record.
+  let source = "#:foo:{\\}";
+  assert-false(read-fragment(source));
+end test;
+
 define suite literal-test-suite ()
   test binary-integer-literal-test;
   test boolean-literal-test;
@@ -243,4 +251,5 @@ define suite literal-test-suite ()
   test string-literal-test;
   test symbol-literal-test;
   test vector-literal-test;
+  test hash-literal-test;
 end suite literal-test-suite;