Change method parsing to validate stack effects. Fixes #236.

basis/locals/parser/parser.factor

@@ -68,13 +68,19 @@ M: lambda-parser parse-quotation ( -- quotation )
     dup
     in>> [ dup pair? [ first ] when ] map make-locals ;
 
-: parse-locals-definition ( word reader -- word quot effect )
-    [ parse-locals ] dip
+: (parse-locals-definition) ( effect vars assoc reader -- word quot effect )
     ((parse-lambda)) <lambda>
     [ nip "lambda" set-word-prop ]
     [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
     [ drop nip ] 3tri ; inline
 
+: parse-locals-definition ( word reader -- word quot effect )
+    [ parse-locals ] dip (parse-locals-definition) ; inline
+
+: parse-locals-method-definition ( word reader -- word quot effect )
+    [ parse-locals pick check-method-effect ] dip
+    (parse-locals-definition) ; inline
+
 : (::) ( -- word def effect )
     scan-new-word
     [ parse-definition ]
@@ -84,5 +90,5 @@ M: lambda-parser parse-quotation ( -- quotation )
     scan-new-method
     [
         [ parse-definition ]
-        parse-locals-definition drop
+        parse-locals-method-definition drop
     ] with-method-definition ;

core/generic/parser/parser.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel words generic namespaces effects.parser ;
+USING: accessors arrays combinators effects effects.parser
+generic kernel namespaces parser quotations sequences words ;
 IN: generic.parser
 
 ERROR: not-in-a-method-error ;
@@ -24,6 +25,34 @@ SYMBOL: current-method
 : with-method-definition ( method quot -- )
     over current-method set call current-method off ; inline
 
-: (M:) ( -- method def )
-    scan-new-method [ parse-definition ] with-method-definition ;
+: generic-effect ( word -- effect )
+    "method-generic" word-prop "declared-effect" word-prop ;
+
+: method-effect= ( method-effect generic-effect -- ? )
+    [ [ in>> length ] bi@ = ]
+    [
+        over terminated?>>
+        [ 2drop t ] [ [ out>> length ] bi@ = ] if
+    ] 2bi and ;
+
+ERROR: bad-method-effect ;
+
+: check-method-effect ( effect -- )
+    word generic-effect method-effect= [ bad-method-effect ] unless ;
+
+: ?execute-parsing ( word/number -- seq )
+    dup parsing-word?
+    [ V{ } clone swap execute-parsing ] [ 1array ] if ;
+
+: parse-method-definition ( -- quot )
+    scan-datum {
+        { \ ( [ ")" parse-effect check-method-effect parse-definition ] }
+        { \ ; [ [ ] ] }
+        [ ?execute-parsing \ ; parse-until append >quotation ]
+    } case ;
+
+PRIVATE>
+
+: (M:) ( -- method def )
+    scan-new-method [ parse-method-definition ] with-method-definition ;