More redefinition fixes
parent
39180371de
commit
80720cea0d
|
@ -76,8 +76,8 @@ M: word reset-class drop ;
|
|||
tri
|
||||
] { } make ;
|
||||
|
||||
: class-usages ( class -- assoc )
|
||||
[ update-map get at ] closure ;
|
||||
: class-usages ( class -- seq )
|
||||
[ update-map get at ] closure keys ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -116,13 +116,11 @@ GENERIC: update-class ( class -- )
|
|||
|
||||
M: class update-class drop ;
|
||||
|
||||
GENERIC: update-methods ( class assoc -- )
|
||||
GENERIC: update-methods ( class seq -- )
|
||||
|
||||
: update-classes ( class -- )
|
||||
dup class-usages
|
||||
[ nip keys [ update-class ] each ]
|
||||
[ update-methods ]
|
||||
2bi ;
|
||||
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
|
||||
|
||||
: define-class ( word superclass members participants metaclass -- )
|
||||
#! If it was already a class, update methods after.
|
||||
|
|
|
@ -39,7 +39,7 @@ TUPLE: check-mixin-class mixin ;
|
|||
|
||||
: update-classes/new ( mixin -- )
|
||||
class-usages
|
||||
[ keys [ update-class ] each ]
|
||||
[ [ update-class ] each ]
|
||||
[ implementors [ make-generic ] each ] bi ;
|
||||
|
||||
: add-mixin-instance ( class mixin -- )
|
||||
|
|
|
@ -109,6 +109,7 @@ TUPLE: yo-momma ;
|
|||
[
|
||||
[ t ] [ \ yo-momma class? ] unit-test
|
||||
[ ] [ \ yo-momma forget ] unit-test
|
||||
[ ] [ \ <yo-momma> forget ] unit-test
|
||||
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
|
||||
|
||||
[ f ] [ \ yo-momma crossref get at ] unit-test
|
||||
|
@ -552,11 +553,11 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
|
|||
|
||||
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
|
||||
|
||||
[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
|
||||
[ { subclass-forget-test-2 } ]
|
||||
[ subclass-forget-test-2 class-usages ]
|
||||
unit-test
|
||||
|
||||
[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
|
||||
[ { subclass-forget-test-3 } ]
|
||||
[ subclass-forget-test-3 class-usages ]
|
||||
unit-test
|
||||
|
||||
|
@ -565,3 +566,32 @@ unit-test
|
|||
[ subclass-forget-test-3 new ] must-fail
|
||||
|
||||
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
|
||||
|
||||
! More
|
||||
DEFER: subclass-reset-test
|
||||
DEFER: subclass-reset-test-1
|
||||
DEFER: subclass-reset-test-2
|
||||
DEFER: subclass-reset-test-3
|
||||
|
||||
GENERIC: break-me ( obj -- )
|
||||
|
||||
[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
|
||||
|
||||
[ ] [ "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
|
||||
|
||||
[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
|
||||
[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
|
||||
[ subclass-forget-test-3 new ] must-fail
|
||||
|
||||
[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
|
||||
|
||||
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
|
||||
|
|
|
@ -166,7 +166,7 @@ M: tuple-class update-class
|
|||
3tri ;
|
||||
|
||||
: subclasses ( class -- classes )
|
||||
class-usages keys [ tuple-class? ] filter ;
|
||||
class-usages [ tuple-class? ] filter ;
|
||||
|
||||
: each-subclass ( class quot -- )
|
||||
>r subclasses r> each ; inline
|
||||
|
|
|
@ -72,10 +72,12 @@ GENERIC: generate-node ( node -- next )
|
|||
|
||||
: word-dataflow ( word -- effect dataflow )
|
||||
[
|
||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] when
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] when
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
[
|
||||
dup "cannot-infer" word-prop [ cannot-infer-effect ] when
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] when
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
] maybe-cannot-infer
|
||||
] with-infer ;
|
||||
|
||||
: intrinsics ( #call -- quot )
|
||||
|
|
|
@ -157,31 +157,31 @@ GENERIC: implementors ( class/classes -- seq )
|
|||
M: class implementors
|
||||
all-words [ "methods" word-prop key? ] with filter ;
|
||||
|
||||
M: assoc implementors
|
||||
M: sequence implementors
|
||||
all-words [
|
||||
"methods" word-prop keys
|
||||
swap [ key? ] curry contains?
|
||||
swap [ memq? ] curry contains?
|
||||
] with filter ;
|
||||
|
||||
: forget-methods ( class -- )
|
||||
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
||||
|
||||
M: class forget* ( class -- )
|
||||
[
|
||||
class-usages [
|
||||
drop
|
||||
: forget-class ( class -- )
|
||||
class-usages [
|
||||
{
|
||||
[ "predicate" word-prop [ forget ] each ]
|
||||
[ forget-methods ]
|
||||
[ update-map- ]
|
||||
[ reset-class ]
|
||||
tri
|
||||
] assoc-each
|
||||
]
|
||||
[ call-next-method ] bi ;
|
||||
} cleave
|
||||
] each ;
|
||||
|
||||
M: assoc update-methods ( class assoc -- )
|
||||
M: class forget* ( class -- )
|
||||
[ forget-class ] [ call-next-method ] bi ;
|
||||
|
||||
M: sequence update-methods ( class seq -- )
|
||||
implementors [
|
||||
[ update-generic ]
|
||||
[ make-generic drop ] 2bi
|
||||
[ update-generic ] [ make-generic drop ] 2bi
|
||||
] with each ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
|
|
|
@ -421,6 +421,9 @@ TUPLE: missing-effect word ;
|
|||
[ "inferred-effect" set-word-prop ]
|
||||
2tri ;
|
||||
|
||||
: maybe-cannot-infer ( word quot -- )
|
||||
[ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
|
||||
|
||||
: infer-word ( word -- effect )
|
||||
[
|
||||
[
|
||||
|
@ -431,7 +434,7 @@ TUPLE: missing-effect word ;
|
|||
finish-word
|
||||
current-effect
|
||||
] with-scope
|
||||
] [ ] [ t "cannot-infer" set-word-prop ] cleanup ;
|
||||
] maybe-cannot-infer ;
|
||||
|
||||
: custom-infer ( word -- )
|
||||
#! Customized inference behavior
|
||||
|
|
|
@ -539,8 +539,7 @@ SYMBOL: interactive-vocabs
|
|||
|
||||
: reset-removed-classes ( -- )
|
||||
removed-classes
|
||||
filter-moved [ class? ] filter
|
||||
[ [ forget-methods ] [ reset-class ] bi ] each ;
|
||||
filter-moved [ class? ] filter [ forget-class ] each ;
|
||||
|
||||
: fix-class-words ( -- )
|
||||
#! If a class word had a compound definition which was
|
||||
|
|
Loading…
Reference in New Issue