define-generic and define-simple-generic now take stack effect parameters; math-combination is a singleton instead of a tuple

core/bootstrap/syntax.factor

@@ -9,6 +9,7 @@ IN: bootstrap.syntax
     "!"
     "\""
     "#!"
+    "("
     "(("
     ":"
     ";"

core/generic/generic-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax words classes classes.algebra
 definitions kernel alien sequences math quotations
-generic.standard generic.math combinators prettyprint ;
+generic.standard generic.math combinators prettyprint effects ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
@@ -115,7 +115,7 @@ HELP: make-generic
 $low-level-note ;
 
 HELP: define-generic
-{ $values { "word" word } { "combination" "a method combination" } }
+{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } }
 { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
 { $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
 

core/generic/generic-tests.factor

@@ -186,7 +186,7 @@ M: f generic-forget-test-3 ;
 
 [ f ] [ f generic-forget-test-3 ] unit-test
 
-: a-word ;
+: a-word ( -- ) ;
 
 GENERIC: a-generic ( a -- b )
 
@@ -196,7 +196,7 @@ M: integer a-generic a-word ;
 
 [ t ] [ "m" get \ a-word usage memq? ] unit-test
 
-[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
+[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
 
 [ f ] [ "m" get \ a-word usage memq? ] unit-test
 

core/generic/generic.factor

@@ -185,13 +185,22 @@ M: sequence update-methods ( class seq -- )
         [ changed-generic ] [ remake-generic drop ] 2bi
     ] with each ;
 
-: define-generic ( word combination -- )
-    over "combination" word-prop over = [ drop ] [
-        2dup "combination" set-word-prop
-        over "methods" word-prop values forget-all
-        over H{ } clone "methods" set-word-prop
-        dupd define-default-method
-    ] if remake-generic ;
+: define-generic ( word combination effect -- )
+    [ nip swap set-stack-effect ]
+    [
+        drop
+        2dup [ "combination" word-prop ] dip = [ 2drop ] [
+            {
+                [ "combination" set-word-prop ]
+                [ drop "methods" word-prop values forget-all ]
+                [ drop H{ } clone "methods" set-word-prop ]
+                [ define-default-method ]
+            }
+            2cleave
+        ] if
+    ]
+    [ 2drop remake-generic ]
+    3tri ;
 
 M: generic subwords
     [

core/generic/math/math.factor

@@ -72,7 +72,7 @@ SYMBOL: picker
         \ dispatch ,
     ] [ ] make ; inline
 
-TUPLE: math-combination ;
+SINGLETON: math-combination
 
 M: math-combination make-default-method
     drop default-math-method ;

core/generic/parser/parser.factor

@@ -1,12 +1,15 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel words generic namespaces ;
+USING: parser kernel words generic namespaces effects.parser ;
 IN: generic.parser
 
 ERROR: not-in-a-method-error ;
 
 : CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
 
+: (GENERIC:) ( quot -- )
+    [ CREATE-GENERIC ] dip call complete-effect define-generic ; inline
+
 : create-method-in ( class generic -- method )
     create-method dup set-word dup save-location ;
 

core/generic/standard/standard-docs.factor

@@ -1,5 +1,5 @@
 USING: generic help.markup help.syntax sequences math
-math.parser ;
+math.parser effects ;
 IN: generic.standard
 
 HELP: no-method
@@ -28,7 +28,7 @@ HELP: hook-combination
 } ;
 
 HELP: define-simple-generic
-{ $values { "word" "a word" } }
+{ $values { "word" "a word" } { "effect" effect } }
 { $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
 
 { standard-combination hook-combination } related-words

core/generic/standard/standard-tests.factor

@@ -280,16 +280,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
     V{ } my-var [ call-next-hooker ] with-variable
 ] unit-test
 
-GENERIC: no-stack-effect-decl
-
-M: hashtable no-stack-effect-decl ;
-M: vector no-stack-effect-decl ;
-M: sbuf no-stack-effect-decl ;
-
-[ ] [ \ no-stack-effect-decl see ] unit-test
-
-[ ] [ \ no-stack-effect-decl def>> . ] unit-test
-
 ! Cross-referencing with generic words
 TUPLE: xref-tuple-1 ;
 TUPLE: xref-tuple-2 < xref-tuple-1 ;

core/generic/standard/standard.factor

@@ -24,7 +24,7 @@ M: quotation engine>quot
 ERROR: no-method object generic ;
 
 : error-method ( word -- quot )
-    picker swap [ no-method ] curry append ;
+    [ picker ] dip [ no-method ] curry append ;
 
 : push-method ( method specializer atomic assoc -- )
     [
@@ -56,7 +56,7 @@ ERROR: no-method object generic ;
 
 : find-default ( methods -- quot )
     #! Side-effects methods.
-    object bootstrap-word swap delete-at* [
+    [ object bootstrap-word ] dip delete-at* [
         drop generic get "default-method" word-prop mangle-method
     ] unless ;
 
@@ -104,8 +104,10 @@ PREDICATE: standard-generic < generic
 PREDICATE: simple-generic < standard-generic
     "combination" word-prop #>> zero? ;
 
-: define-simple-generic ( word -- )
-    T{ standard-combination f 0 } define-generic ;
+CONSTANT: simple-combination T{ standard-combination f 0 }
+
+: define-simple-generic ( word effect -- )
+    [ simple-combination ] dip define-generic ;
 
 : with-standard ( combination quot -- quot' )
     [ #>> (dispatch#) ] dip with-variable ; inline

core/slots/slots.factor

@@ -21,7 +21,7 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
         object bootstrap-word >>class ;
 
 : define-typecheck ( class generic quot props -- )
-    [ dup define-simple-generic create-method ] 2dip
+    [ create-method ] 2dip
     [ [ props>> ] [ drop ] [ ] tri* update ]
     [ drop define ]
     3bi ;
@@ -36,7 +36,6 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
 
 : reader-word ( name -- word )
     ">>" append "accessors" create
-    dup (( object -- value )) "declared-effect" set-word-prop
     dup t "reader" set-word-prop ;
 
 : reader-props ( slot-spec -- assoc )
@@ -46,13 +45,18 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
         t "flushable" set
     ] H{ } make-assoc ;
 
+: define-reader-generic ( name -- )
+    reader-word (( object -- value )) define-simple-generic ;
+
 : define-reader ( class slot-spec -- )
-    [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
-    define-typecheck ;
+    [ nip name>> define-reader-generic ]
+    [
+        [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
+        define-typecheck
+    ] 2bi ;
 
 : writer-word ( name -- word )
     "(>>" ")" surround "accessors" create
-    dup (( value object -- )) "declared-effect" set-word-prop
     dup t "writer" set-word-prop ;
 
 ERROR: bad-slot-value value class ;
@@ -92,9 +96,14 @@ ERROR: bad-slot-value value class ;
 : writer-props ( slot-spec -- assoc )
     "writing" associate ;
 
+: define-writer-generic ( name -- )
+    writer-word (( object value -- )) define-simple-generic ;
+
 : define-writer ( class slot-spec -- )
-    [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
-    define-typecheck ;
+    [ nip name>> define-writer-generic ] [
+        [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
+        define-typecheck
+    ] 2bi ;
 
 : setter-word ( name -- word )
     ">>" prepend "accessors" create ;
@@ -134,8 +143,8 @@ ERROR: bad-slot-value value class ;
 
 : define-protocol-slot ( name -- )
     {
-        [ reader-word define-simple-generic ]
-        [ writer-word define-simple-generic ]
+        [ define-reader-generic ]
+        [ define-writer-generic ]
         [ define-setter ]
         [ define-changer ]
     } cleave ;

core/syntax/syntax-docs.factor

@@ -508,8 +508,8 @@ HELP: P"
 HELP: (
 { $syntax "( inputs -- outputs )" }
 { $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
-{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
-{ $notes "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ;
+{ $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." }
+{ $see-also "effect-declaration" } ;
 
 HELP: ((
 { $syntax "(( inputs -- outputs ))" }

core/syntax/syntax.factor

@@ -127,6 +127,11 @@ IN: bootstrap.syntax
         ";" parse-tokens
         [ create-class-in define-singleton-class ] each
     ] define-core-syntax
+
+    "DEFER:" [
+        scan current-vocab create
+        [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
+    ] define-core-syntax
     
     "ALIAS:" [
         CREATE-WORD scan-word define-alias
@@ -136,32 +141,24 @@ IN: bootstrap.syntax
         CREATE scan-object define-constant
     ] define-core-syntax
 
-    "DEFER:" [
-        scan current-vocab create
-        [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
-    ] define-core-syntax
-
     ":" [
         (:) define-declared
     ] define-core-syntax
 
     "GENERIC:" [
-        CREATE-GENERIC define-simple-generic
+        [ simple-combination ] (GENERIC:)
     ] define-core-syntax
 
     "GENERIC#" [
-        CREATE-GENERIC
-        scan-word <standard-combination> define-generic
+        [ scan-word <standard-combination> ] (GENERIC:)
     ] define-core-syntax
 
     "MATH:" [
-        CREATE-GENERIC
-        T{ math-combination } define-generic
+        [ math-combination ] (GENERIC:)
     ] define-core-syntax
 
     "HOOK:" [
-        CREATE-GENERIC scan-word
-        <hook-combination> define-generic
+        [ scan-word <hook-combination> ] (GENERIC:)
     ] define-core-syntax
 
     "M:" [
@@ -220,6 +217,10 @@ IN: bootstrap.syntax
         scan-object forget
     ] define-core-syntax
 
+    "(" [
+        ")" parse-effect drop
+    ] define-core-syntax
+
     "((" [
         "))" parse-effect parsed
     ] define-core-syntax