diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index e7984f7ec3..23363c30ad 100755 --- 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 1e1d6a5606..13f768a810 100755 --- 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 ;