From 4558bf34146fde9b20878dfc0dcb79b6e6c7a037 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Thu, 13 Oct 2011 16:40:52 -0700
Subject: [PATCH] Change method parsing to validate stack effects.  Fixes #236.

---
 basis/locals/parser/parser.factor | 14 +++++++++----
 core/generic/parser/parser.factor | 35 ++++++++++++++++++++++++++++---
 2 files changed, 42 insertions(+), 7 deletions(-)

diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor
index 09f75a0fa0..4d4731048a 100644
--- a/basis/locals/parser/parser.factor
+++ b/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 ]
@@ -83,6 +89,6 @@ M: lambda-parser parse-quotation ( -- quotation )
 : (M::) ( -- word def )
     scan-new-method
     [
-        [ parse-definition ] 
-        parse-locals-definition drop
+        [ parse-definition ]
+        parse-locals-method-definition drop
     ] with-method-definition ;
diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor
index 652fafc2e3..14b8529018 100644
--- a/core/generic/parser/parser.factor
+++ b/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 ;