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 ]
: (M::) ( -- word def )
scan-new-method
[
- [ parse-definition ]
- parse-locals-definition drop
+ [ parse-definition ]
+ parse-locals-method-definition drop
] with-method-definition ;
! 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 ;
: with-method-definition ( method quot -- )
over current-method set call current-method off ; inline
+: 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-definition ] with-method-definition ;
+ scan-new-method [ parse-method-definition ] with-method-definition ;