steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix ERROR:, erg's mixin bug

db4
Slava Pestov 2008-07-04 01:32:11 -05:00
parent 74d87e5a41
commit 091484de98
7 changed files with 221 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
core/classes/classes-tests.factor
View File

@ -6,154 +6,6 @@ classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs ;
IN: classes.tests
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
! Test redefinition of classes
UNION: union-1 fixnum float ;
GENERIC: generic-update-test ( x -- y )
M: union-1 generic-update-test drop "union-1" ;
[ f ] [ bignum union-1 class<= ] unit-test
[ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class<= ] unit-test
[ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ "union-1" ] [ 8 generic-update-test ] unit-test
[ -7 generic-update-test ] must-fail
! Test mixins
MIXIN: sequence-mixin
INSTANCE: array sequence-mixin
INSTANCE: vector sequence-mixin
INSTANCE: slice sequence-mixin
MIXIN: assoc-mixin
INSTANCE: hashtable assoc-mixin
GENERIC: collection-size ( x -- y )
M: sequence-mixin collection-size length ;
M: assoc-mixin collection-size assoc-size ;
[ t ] [ array sequence-mixin class<= ] unit-test
[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
[ 3 ] [ { 1 2 3 } collection-size ] unit-test
[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
DEFER: mx1
FORGET: mx1
MIXIN: mx1
INSTANCE: integer mx1
[ t ] [ integer mx1 class<= ] unit-test
[ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test
[ \ mx1 forget ] with-compilation-unit
! Empty unions were causing problems
GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
M: empty-union-1 empty-union-test ;
UNION: empty-union-2 ;
M: empty-union-2 empty-union-test ;
! Redefining a class didn't update containing unions
UNION: redefine-bug-1 fixnum ;
UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ bignum redefine-bug-2 class<= ] unit-test
USE: io.streams.string
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
[ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
] times
! Method flattening interfered with mixin update
MIXIN: flat-mx-1
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
! Test generic see and parsing
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
[ t ] [ 3 object instance? ] unit-test
[ t ] [ 3 fixnum instance? ] unit-test
[ f ] [ 3 float instance? ] unit-test

16
core/classes/classes.factor
View File

@ -72,6 +72,7 @@ M: class reset-class
"superclass"
"members"
"participants"
"predicate"
} reset-props ;
M: word reset-class drop ;
@ -87,8 +88,9 @@ GENERIC: implementors ( class/classes -- seq )
tri
] { } make ;
: class-usages ( class -- seq )
[ update-map get at ] closure keys ;
: class-usage ( class -- seq ) update-map get at ;
: class-usages ( class -- seq ) [ class-usage ] closure keys ;
<PRIVATE
@ -163,16 +165,20 @@ GENERIC: update-methods ( class seq -- )
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
GENERIC: class-forgotten ( use class -- )
: forget-class ( class -- )
class-usages [
{
[ dup class-usage keys [ class-forgotten ] with each ]
[ forget-predicate ]
[ forget-methods ]
[ implementors-map- ]
[ update-map- ]
[ reset-class ]
} cleave
] each ;
} cleave ;
M: class class-forgotten
nip forget-class ;
M: class forget* ( class -- )
[ call-next-method ] [ forget-class ] bi ;

107
core/classes/mixin/mixin-tests.factor Normal file
View File

@ -0,0 +1,107 @@
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs ;
IN: classes.mixin.tests
! Test mixins
MIXIN: sequence-mixin
INSTANCE: array sequence-mixin
INSTANCE: vector sequence-mixin
INSTANCE: slice sequence-mixin
MIXIN: assoc-mixin
INSTANCE: hashtable assoc-mixin
GENERIC: collection-size ( x -- y )
M: sequence-mixin collection-size length ;
M: assoc-mixin collection-size assoc-size ;
[ t ] [ array sequence-mixin class<= ] unit-test
[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
[ 3 ] [ { 1 2 3 } collection-size ] unit-test
[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
DEFER: mx1
FORGET: mx1
MIXIN: mx1
INSTANCE: integer mx1
[ t ] [ integer mx1 class<= ] unit-test
[ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test
[ \ mx1 forget ] with-compilation-unit
USE: io.streams.string
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.mixin.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test
[ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.mixin.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test
] times
! Method flattening interfered with mixin update
MIXIN: flat-mx-1
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
! Too eager with reset-class
[ ] [ "IN: classes.mixin.tests MIXIN: blah SINGLETON: boo INSTANCE: boo blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
[ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test

2
core/classes/mixin/mixin.factor
View File

@ -65,6 +65,8 @@ TUPLE: check-mixin-class mixin ;
update-classes
] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.
TUPLE: mixin-instance loc class mixin ;

9
core/classes/tuple/tuple.factor
View File

@ -260,8 +260,13 @@ M: tuple-class define-tuple-class
: define-error-class ( class superclass slots -- )
[ define-tuple-class ]
[ [ dup [ boa throw ] curry ] [ drop ] [ thrower-effect ] tri* ] 3bi
define-declared ;
[ 2drop reset-generic ]
[
[ dup [ boa throw ] curry ]
[ drop ]
[ thrower-effect ]
tri* define-declared
] 3tri ;
M: tuple-class reset-class
[

88
core/classes/union/union-tests.factor Normal file
View File

@ -0,0 +1,88 @@
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs io.streams.string ;
IN: classes.union.tests
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
! Test redefinition of classes
UNION: union-1 fixnum float ;
GENERIC: generic-update-test ( x -- y )
M: union-1 generic-update-test drop "union-1" ;
[ f ] [ bignum union-1 class<= ] unit-test
[ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class<= ] unit-test
[ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ "union-1" ] [ 8 generic-update-test ] unit-test
[ -7 generic-update-test ] must-fail
! Empty unions were causing problems
GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
M: empty-union-1 empty-union-test ;
UNION: empty-union-2 ;
M: empty-union-2 empty-union-test ;
! Redefining a class didn't update containing unions
UNION: redefine-bug-1 fixnum ;
UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ bignum redefine-bug-2 class<= ] unit-test
! Too eager with reset-class
[ ] [ "IN: classes.union.tests SINGLETON: foo UNION: blah foo ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
[ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
GENERIC: test-generic ( x -- y )
TUPLE: a-tuple ;
UNION: a-union a-tuple ;
M: a-union test-generic ;
[ f ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
[ ] [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test
[ t ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test

1
core/syntax/syntax.factor
View File

@ -175,7 +175,6 @@ IN: bootstrap.syntax
"ERROR:" [
parse-tuple-definition
pick reset-generic
pick save-location
define-error-class
] define-syntax