Add parser logic to catch common mistake

diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index e7984f7ec3e05156f50a2792867d912f7d0e6190..23363c30ad13cf588d8c9ec88ad9189d55a725a1 100755 (executable)
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -358,6 +358,18 @@ HELP: scan-word
 { $errors "Throws an error if the token does not name a word, and does not parse as a number." }
 $parsing-note ;
 
+HELP: invalid-slot-name
+{ $values { "name" string } }
+{ $description "Throws an " { $link invalid-slot-name } " error." }
+{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
+{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
+    { $code
+        "TUPLE: my-mistaken-tuple slot-a slot-b"
+        ""
+        ": some-word ( a b c -- ) ... ;"
+    }
+} ;
+
 HELP: unexpected
 { $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
 { $description "Throws an " { $link unexpected } " error." }

diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 1e1d6a56068bd4305fdef8e3e928d53b58ecd7c0..13f768a810e9590ccf7d9c1af978c4dbd978cf04 100755 (executable)
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -184,6 +184,9 @@ M: parse-error summary
 M: parse-error compute-restarts
     error>> compute-restarts ;
 
+M: parse-error error-help
+    error>> error-help ;
+
 SYMBOL: use
 SYMBOL: in
 
@@ -298,12 +301,35 @@ M: no-word-error summary
         ] "" make note.
     ] with each ;
 
+ERROR: invalid-slot-name name ;
+
+M: invalid-slot-name summary
+    drop
+    "Invalid slot name" ;
+
+: (parse-tuple-slots) ( -- )
+    #! This isn't meant to enforce any kind of policy, just
+    #! to check for mistakes of this form:
+    #!
+    #! TUPLE: blahblah foo bing
+    #!
+    #! : ...
+    scan {
+        { [ dup not ] [ unexpected-eof ] }
+        { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
+        { [ dup ";" = ] [ drop ] }
+        [ , (parse-tuple-slots) ]
+    } cond ;
+
+: parse-tuple-slots ( -- seq )
+    [ (parse-tuple-slots) ] { } make ;
+
 : parse-tuple-definition ( -- class superclass slots )
     CREATE-CLASS
     scan {
         { ";" [ tuple f ] }
-        { "<" [ scan-word ";" parse-tokens ] }
-        [ >r tuple ";" parse-tokens r> prefix ]
+        { "<" [ scan-word parse-tuple-slots ] }
+        [ >r tuple parse-tuple-slots r> prefix ]
     } case 3dup check-slot-shadowing ;
 
 ERROR: staging-violation word ;