Fix stack effect redefinition

basis/alien/c-types/c-types-tests.factor

@@ -4,7 +4,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
 
 \ expand-constants must-infer
 
-: xyz 123 ;
+CONSTANT: xyz 123
 
 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
 

basis/compiler/compiler.factor

@@ -35,11 +35,14 @@ SYMBOLS: +optimized+ +unoptimized+ ;
     [ usage [ word? ] filter ] [ compiled-usage keys ] if
     [ queue-compile ] each ;
 
-: ripple-up? ( word status -- ? )
-    swap "compiled-status" word-prop [ = not ] keep and ;
+: ripple-up? ( status word -- ? )
+    [
+        [ nip changed-effects get key? ]
+        [ "compiled-status" word-prop eq? not ] 2bi or
+    ] keep "compiled-status" word-prop and ;
 
 : save-compiled-status ( word status -- )
-    [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
+    [ over ripple-up? [ ripple-up ] [ drop ] if ]
     [ "compiled-status" set-word-prop ]
     2bi ;
 

basis/compiler/tests/redefine2.factor

@@ -1,12 +1,14 @@
 IN: compiler.tests
 USING: compiler compiler.units tools.test math parser kernel
 sequences sequences.private classes.mixin generic definitions
-arrays words assocs eval ;
+arrays words assocs eval words.symbol ;
 
 DEFER: redefine2-test
 
 [ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
 
+[ t ] [ \ redefine2-test symbol? ] unit-test
+
 [ t ] [ redefine2-test new sequence? ] unit-test
 
 [ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
         [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
     ] if ; inline recursive
 
-: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
+: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline
 
 [ f ] [
     [ { bignum } declare annotate-entry-test-2 ]

core/classes/classes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions assocs kernel kernel.private
 slots.private namespaces make sequences strings words words.symbol
@@ -126,14 +126,19 @@ M: sequence implementors [ implementors ] gather ;
         } spread
     ] H{ } make-assoc ;
 
+: ?define-symbol ( word -- )
+    dup deferred? [ define-symbol ] [ drop ] if ;
+
 : (define-class) ( word props -- )
     [
-        dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
-        dup reset-class
-        dup deferred? [ dup define-symbol ] when
-        dup redefined
-        dup props>>
-    ] dip assoc-union >>props
+        {
+            [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
+            [ reset-class ]
+            [ ?define-symbol ]
+            [ redefined ]
+            [ ]
+        } cleave
+    ] dip [ assoc-union ] curry change-props
     dup predicate-word
     [ 1quotation "predicate" set-word-prop ]
     [ swap "predicating" set-word-prop ]

core/classes/tuple/tuple-tests.factor

@@ -4,7 +4,8 @@ namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
 calendar prettyprint io.streams.string splitting summary
-columns math.order classes.private slots slots.private eval see ;
+columns math.order classes.private slots slots.private eval see
+words.symbol ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -62,7 +63,7 @@ TUPLE: predicate-test ;
 
 C: <predicate-test> predicate-test
 
-: predicate-test drop f ;
+: predicate-test ( a -- ? ) drop f ;
 
 [ t ] [ <predicate-test> predicate-test? ] unit-test
 
@@ -97,7 +98,7 @@ TUPLE: size-test a b c d ;
     size-test tuple-layout second =
 ] unit-test
 
-GENERIC: <yo-momma>
+GENERIC: <yo-momma> ( a -- b )
 
 TUPLE: yo-momma ;
 
@@ -123,7 +124,7 @@ TUPLE: loc-recording ;
 
 TUPLE: forget-robustness ;
 
-GENERIC: forget-robustness-generic
+GENERIC: forget-robustness-generic ( a -- b )
 
 M: forget-robustness forget-robustness-generic ;
 
@@ -493,7 +494,7 @@ must-fail-with
 [ t ] [ "z" accessor-exists? ] unit-test
 
 [ [ ] ] [
-    "IN: classes.tuple.tests GENERIC: forget-accessors-test"
+    "IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
     <string-reader>
     "forget-accessors-test" parse-stream
 ] unit-test
@@ -508,7 +509,7 @@ TUPLE: another-forget-accessors-test ;
 
 
 [ [ ] ] [
-    "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+    "IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
     <string-reader>
     "another-forget-accessors-test" parse-stream
 ] unit-test
@@ -567,7 +568,7 @@ GENERIC: break-me ( obj -- )
 
 [ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
 
-[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
+[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
 
 [ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
 [ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
@@ -666,7 +667,7 @@ DEFER: error-y
 
 [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
 
-[ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test
 
 [ f ] [ \ error-y tuple-class? ] unit-test
 
@@ -731,3 +732,17 @@ SLOT: kex
 
 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
 [ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
+
+DEFER: redefine-tuple-twice
+
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+
+[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test
+
+[ t ] [ \ redefine-tuple-twice deferred? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+
+[ t ] [ \ redefine-tuple-twice symbol? ] unit-test

core/classes/tuple/tuple.factor

@@ -247,8 +247,7 @@ M: tuple-class update-class
             bi
         ] each-subclass
     ]
-    [ define-new-tuple-class ]
-    3bi ;
+    [ define-new-tuple-class ] 3bi ;
 
 : tuple-class-unchanged? ( class superclass slots -- ? )
     [ [ superclass ] [ bootstrap-word ] bi* = ]
@@ -275,7 +274,7 @@ M: word (define-tuple-class)
 
 M: tuple-class (define-tuple-class)
     3dup tuple-class-unchanged?
-    [ 3drop ] [ redefine-tuple-class ] if ;
+    [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
 
 : thrower-effect ( slots -- effect )
     [ dup array? [ first ] when ] map { "*" } <effect> ;

core/compiler/units/units.factor

@@ -148,6 +148,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
+        H{ } clone changed-effects set
         H{ } clone outdated-generics set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
@@ -158,6 +159,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
+        H{ } clone changed-effects set
         H{ } clone outdated-generics set
         H{ } clone forgotten-definitions set
         H{ } clone outdated-tuples set

core/definitions/definitions.factor

@@ -1,13 +1,11 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: definitions
 USING: kernel sequences namespaces assocs graphs math math.order ;
+IN: definitions
 
 ERROR: no-compilation-unit definition ;
 
-SYMBOL: inlined-dependency
-SYMBOL: flushed-dependency
-SYMBOL: called-dependency
+SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
 
 : set-in-unit ( value key assoc -- )
     [ set-at ] [ no-compilation-unit ] if* ;
@@ -17,6 +15,11 @@ SYMBOL: changed-definitions
 : changed-definition ( defspec -- )
     inlined-dependency swap changed-definitions get set-in-unit ;
 
+SYMBOL: changed-effects
+
+: changed-effect ( word -- )
+    dup changed-effects get set-in-unit ;
+
 SYMBOL: changed-generics
 
 SYMBOL: outdated-generics

core/generic/generic.factor

@@ -199,8 +199,7 @@ M: sequence update-methods ( class seq -- )
             2cleave
         ] if
     ]
-    [ 2drop remake-generic ]
-    3tri ;
+    [ 2drop remake-generic ] 3tri ;
 
 M: generic subwords
     [

core/words/words.factor

@@ -164,8 +164,10 @@ CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
 : set-stack-effect ( effect word -- )
     2dup "declared-effect" word-prop = [ 2drop ] [
         swap
+        [ drop changed-effect ]
         [ "declared-effect" set-word-prop ]
-        [ drop dup primitive? [ dup redefined ] unless drop ] 2bi
+        [ drop dup primitive? [ drop ] [ redefined ] if ]
+        2tri
     ] if ;
 
 : define-declared ( word def effect -- )
@@ -192,7 +194,7 @@ M: word reset-word
     {
         "unannotated-def" "parsing" "inline" "recursive"
         "foldable" "flushable" "reading" "writing" "reader"
-        "writer" "declared-effect" "delimiter"
+        "writer" "delimiter"
     } reset-props ;
 
 GENERIC: subwords ( word -- seq )