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

classes: If a tuple class with subclasses is redefined into something that's not a tuple class, subclasses are changed to inherit from 'tuple' instead of being forgotten. Also, changing the metaclass of a union or intersection member no longer removes it from the union or intersection. Finally, make some internal words private

release
Slava Pestov 2010-02-01 02:48:39 +13:00
parent 3addfcc2ad
commit e929d906ce
16 changed files with 199 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
basis/bootstrap/image/image.factor
View File

@ -5,12 +5,13 @@ hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
prettyprint sequences strings sbufs vectors words quotations
assocs system layouts splitting grouping growable classes
classes.builtin classes.tuple classes.tuple.private vocabs
vocabs.loader source-files definitions debugger
quotations.private combinators combinators.short-circuit
math.order math.private accessors slots.private
generic.single.private compiler.units compiler.constants fry
locals bootstrap.image.syntax generalizations ;
classes.private classes.builtin classes.tuple
classes.tuple.private vocabs vocabs.loader source-files
definitions debugger quotations.private combinators
combinators.short-circuit math.order math.private accessors
slots.private generic.single.private compiler.units
compiler.constants fry locals bootstrap.image.syntax
generalizations ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@ -342,9 +343,7 @@ M: float '
: t, ( -- ) t t-offset fixup ;
M: f '
#! f is #define F RETAG(0,F_TYPE)
drop \ f type-number ;
M: f ' drop \ f type-number ;
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;

17
basis/classes/struct/struct.factor
View File

@ -1,12 +1,13 @@
! (c)Joe Groff, Daniel Ehrenberg bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays classes classes.parser classes.tuple classes.tuple.parser
classes.tuple.private combinators combinators.short-circuit
combinators.smart cpu.architecture definitions functors.backend
fry generalizations generic.parser kernel kernel.private lexer
libc locals macros make math math.order parser quotations
sequences slots slots.private specialized-arrays vectors words
summary namespaces assocs vocabs.parser math.functions
USING: accessors alien alien.c-types alien.data alien.parser
arrays byte-arrays classes classes.private classes.parser
classes.tuple classes.tuple.parser classes.tuple.private
combinators combinators.short-circuit combinators.smart
cpu.architecture definitions functors.backend fry
generalizations generic.parser kernel kernel.private lexer libc
locals macros make math math.order parser quotations sequences
slots slots.private specialized-arrays vectors words summary
namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays ;
QUALIFIED: math
IN: classes.struct

11
core/bootstrap/primitives.factor
View File

@ -3,11 +3,12 @@
USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io io.encodings.ascii kernel math
math.private math.order namespaces make parser sequences strings
vectors words quotations assocs layouts classes classes.builtin
classes.tuple classes.tuple.private kernel.private vocabs
vocabs.loader source-files definitions slots classes.union
classes.intersection classes.predicate compiler.units
bootstrap.image.private io.files accessors combinators ;
vectors words quotations assocs layouts classes classes.private
classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots classes.union classes.intersection classes.predicate
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush

2
core/classes/algebra/algebra-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax kernel classes words
USING: help.markup help.syntax kernel classes classes.private words
checksums checksums.crc32 sequences math ;
IN: classes.algebra

6
core/classes/algebra/algebra.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
kernel.private sets math.order ;
USING: kernel classes classes.private combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private sets math.order ;
IN: classes.algebra
<PRIVATE

6
core/classes/builtin/builtin.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes classes.algebra classes.algebra.private
words kernel kernel.private namespaces sequences math
math.private combinators assocs quotations ;
USING: accessors classes classes.private classes.algebra
classes.algebra.private words kernel kernel.private namespaces
sequences math math.private combinators assocs quotations ;
IN: classes.builtin
SYMBOL: builtins

125
core/classes/classes.factor
View File

@ -8,6 +8,10 @@ IN: classes
ERROR: bad-inheritance class superclass ;
PREDICATE: class < word "class" word-prop ;
<PRIVATE
SYMBOL: class<=-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
@ -35,7 +39,23 @@ SYMBOL: update-map
SYMBOL: implementors-map
PREDICATE: class < word "class" word-prop ;
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
M: class reset-class
{
"class"
"metaclass"
"superclass"
"members"
"participants"
"predicate"
} reset-props ;
M: word reset-class drop ;
PRIVATE>
: classes ( -- seq ) implementors-map get keys ;
@ -65,8 +85,11 @@ M: predicate reset-word
: superclasses ( class -- supers )
[ superclass ] follow reverse ;
: superclass-of? ( class superclass -- ? )
superclasses member-eq? ;
: subclass-of? ( class superclass -- ? )
swap superclasses member? ;
swap superclass-of? ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
@ -76,22 +99,6 @@ M: predicate reset-word
#! Output f for non-classes to work with algebra code
dup class? [ "participants" word-prop ] [ drop f ] if ;
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
M: class reset-class
{
"class"
"metaclass"
"superclass"
"members"
"participants"
"predicate"
} reset-props ;
M: word reset-class drop ;
GENERIC: implementors ( class/classes -- seq )
! update-map
@ -107,6 +114,10 @@ GENERIC: implementors ( class/classes -- seq )
: class-usages ( class -- seq ) [ class-usage ] closure keys ;
M: class implementors implementors-map get at keys ;
M: sequence implementors [ implementors ] gather ;
<PRIVATE
: update-map+ ( class -- )
@ -115,12 +126,8 @@ GENERIC: implementors ( class/classes -- seq )
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
M: class implementors implementors-map get at keys ;
M: sequence implementors [ implementors ] gather ;
: implementors-map+ ( class -- )
H{ } clone swap implementors-map get set-at ;
[ H{ } clone ] dip implementors-map get set-at ;
: implementors-map- ( class -- )
implementors-map get delete-at ;
@ -135,31 +142,39 @@ M: sequence implementors [ implementors ] gather ;
} spread
] H{ } make-assoc ;
GENERIC: metaclass-changed ( use class -- )
: ?metaclass-changed ( class usages/f -- )
dup [ [ metaclass-changed ] with each ] [ 2drop ] if ;
: check-metaclass ( class metaclass -- usages/f )
over class? [
over "metaclass" word-prop eq?
[ drop f ] [ class-usage keys ] if
] [ 2drop f ] if ;
: ?define-symbol ( word -- )
dup deferred? [ define-symbol ] [ drop ] if ;
: (define-class) ( word props -- )
reset-caches
[ drop update-map- ]
[
2dup "metaclass" swap at check-metaclass
{
[ 2drop update-map- ]
[ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]
[ 2drop ?define-symbol ]
[ drop [ assoc-union ] curry change-props drop ]
[
{
[ dup class? [ drop ] [ implementors-map+ ] if ]
[ reset-class ]
[ ?define-symbol ]
[ ]
} cleave
] dip [ assoc-union ] curry change-props
dup create-predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
[ drop t "class" set-word-prop ]
2tri
]
[ drop update-map+ ]
2tri ;
PRIVATE>
2drop
dup create-predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
2bi
]
[ 2drop t "class" set-word-prop ]
[ 2drop update-map+ ]
[ nip ?metaclass-changed ]
} 3cleave ;
GENERIC: update-class ( class -- )
@ -172,7 +187,7 @@ GENERIC: update-methods ( class seq -- )
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
: check-inheritance ( subclass superclass -- )
2dup superclasses member-eq? [ bad-inheritance ] [ 2drop ] if ;
2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
: define-class ( word superclass members participants metaclass -- )
[ 2dup check-inheritance ] 3dip
@ -188,21 +203,21 @@ GENERIC: update-methods ( class seq -- )
GENERIC: forget-methods ( class -- )
GENERIC: class-forgotten ( use class -- )
PRIVATE>
: forget-class ( class -- )
{
[ dup class-usage keys [ class-forgotten ] with each ]
[ forget-predicate ]
[ forget-methods ]
[ implementors-map- ]
[ update-map- ]
[ reset-class ]
} cleave
reset-caches ;
dup f check-metaclass {
[ drop forget-predicate ]
[ drop forget-methods ]
[ drop implementors-map- ]
[ drop update-map- ]
[ drop reset-class ]
[ 2drop reset-caches ]
[ ?metaclass-changed ]
} 2cleave ;
M: class class-forgotten
nip forget-class ;
M: class metaclass-changed
swap class? [ drop ] [ forget-class ] if ;
M: class forget* ( class -- )
[ call-next-method ] [ forget-class ] bi ;

6
core/classes/intersection/intersection.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words accessors sequences kernel assocs combinators classes
classes.algebra classes.algebra.private classes.builtin
namespaces arrays math quotations ;
USING: words accessors sequences kernel assocs combinators
classes classes.private classes.algebra classes.algebra.private
classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class

20
core/classes/mixin/mixin-tests.factor
View File

@ -128,3 +128,23 @@ SYMBOL: not-a-mixin
TUPLE: a-class ;
[ [ \ a-class \ not-a-mixin add-mixin-instance ] with-compilation-unit ] must-fail
! Changing a mixin member's metaclass should not remove it from the mixin
MIXIN: metaclass-change-mixin
TUPLE: metaclass-change ;
INSTANCE: metaclass-change metaclass-change-mixin
GENERIC: metaclass-change-generic ( a -- b )
M: metaclass-change-mixin metaclass-change-generic ;
[ T{ metaclass-change } ] [ T{ metaclass-change } metaclass-change-generic ] unit-test
[ ] [ "IN: classes.mixin.tests USE: math UNION: metaclass-change integer ;" eval( -- ) ] unit-test
[ 0 ] [ 0 metaclass-change-generic ] unit-test
! Forgetting a mixin member class should remove it from the mixin
[ ] [ [ metaclass-change forget-class ] with-compilation-unit ] unit-test
[ t ] [ metaclass-change-mixin members empty? ] unit-test

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

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.algebra.private
classes.union classes.union.private words kernel sequences
definitions combinators arrays assocs generic accessors ;
USING: classes classes.private classes.algebra
classes.algebra.private classes.union classes.union.private
words kernel sequences definitions combinators arrays assocs
generic accessors ;
IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
@ -75,7 +76,8 @@ M: class add-mixin-instance
: remove-mixin-instance ( class mixin -- )
[ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
M: mixin-class metaclass-changed
over class? [ 2drop ] [ remove-mixin-instance ] if ;
: define-mixin-class ( class -- )
dup mixin-class? [

30
core/classes/predicate/predicate-tests.factor
View File

@ -1,5 +1,6 @@
USING: math tools.test classes.algebra words kernel sequences assocs
accessors eval definitions compiler.units generic strings classes ;
accessors eval definitions compiler.units generic strings classes
generic.single ;
IN: classes.predicate.tests
PREDICATE: negative < integer 0 < ;
@ -59,3 +60,30 @@ PREDICATE: tup < string ;
UNION: u tup ;
[ ] [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test
! Changing the metaclass of the predicate superclass should work
GENERIC: change-meta-test ( a -- b )
TUPLE: change-meta-test-class length ;
PREDICATE: change-meta-test-predicate < change-meta-test-class length>> 2 > ;
M: change-meta-test-predicate change-meta-test length>> ;
[ f ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test
[ T{ change-meta-test-class f 0 } change-meta-test ] [ no-method? ] must-fail-with
[ 7 ] [ T{ change-meta-test-class f 7 } change-meta-test ] unit-test
[ ] [ "IN: classes.predicate.tests USE: arrays UNION: change-meta-test-class array ;" eval( -- ) ] unit-test
! Should not have changed
[ change-meta-test-class ] [ change-meta-test-predicate superclass ] unit-test
[ { } change-meta-test ] [ no-method? ] must-fail-with
[ 4 ] [ { 1 2 3 4 } change-meta-test ] unit-test
[ ] [ [ \ change-meta-test-class forget-class ] with-compilation-unit ] unit-test
[ f ] [ change-meta-test-predicate class? ] unit-test
[ t ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test

6
core/classes/predicate/predicate.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.algebra.private kernel
namespaces make words sequences quotations arrays kernel.private
assocs combinators ;
USING: classes classes.private classes.algebra
classes.algebra.private kernel namespaces make words sequences
quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class

74
core/classes/tuple/tuple-tests.factor
View File

@ -511,58 +511,6 @@ TUPLE: another-forget-accessors-test ;
! Missing error check
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
! Class forget messyness
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test
[ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ]
unit-test
[ { subclass-forget-test-3 } ]
[ subclass-forget-test-3 class-usages ]
unit-test
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] 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 -- )
[ ] [ [ M\ 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
! Insufficient type checking
[ \ vocab tuple>array drop ] must-fail
@ -784,3 +732,25 @@ TUPLE: code-heap-ref ;
! Data heap reference
[ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
[ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
! If the metaclass of a superclass changes into something other
! than a tuple class, the tuple needs to have its superclass reset
TUPLE: metaclass-change ;
TUPLE: metaclass-change-subclass < metaclass-change ;
[ metaclass-change ] [ metaclass-change-subclass superclass ] unit-test
[ ] [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
[ t ] [ metaclass-change-subclass tuple-class? ] unit-test
[ tuple ] [ metaclass-change-subclass superclass ] unit-test
! Reshaping bug related to the above
TUPLE: a-g ;
TUPLE: g < a-g ;
[ ] [ g new "g" set ] unit-test
[ ] [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
[ t ] [ g new layout-of "g" get layout-of eq? ] unit-test

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

@ -13,9 +13,6 @@ PREDICATE: tuple-class < class
ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
@ -35,6 +32,9 @@ M: tuple class layout-of 2 slot { word } declare ; inline
: tuple-size ( tuple -- size )
layout-of 3 slot { fixnum } declare ; inline
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
@ -49,14 +49,14 @@ M: tuple class layout-of 2 slot { word } declare ; inline
] 2each
] if-bootstrapping ; inline
PRIVATE>
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
PRIVATE>
: tuple>array ( tuple -- array )
prepare-tuple>array
[ copy-tuple-slots ] dip
@ -247,6 +247,9 @@ M: class valid-superclass? drop f ;
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
: thrower-effect ( slots -- effect )
[ name>> ] map { "*" } <effect> ;
PRIVATE>
: define-tuple-class ( class superclass slots -- )
@ -261,9 +264,6 @@ M: tuple-class (define-tuple-class)
3dup tuple-class-unchanged?
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
: thrower-effect ( slots -- effect )
[ name>> ] map { "*" } <effect> ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ]
[ 2drop reset-generic ]
@ -293,6 +293,11 @@ M: tuple-class reset-class
bi
] bi ;
M: tuple-class metaclass-changed
! Our superclass is no longer a tuple class, redefine with
! default superclass
nip tuple over "slots" word-prop define-tuple-class ;
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?

7
core/compiler/units/units.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
classes.tuple.private generic source-files.errors
kernel.private ;
sequences words vocabs definitions hashtables init sets math
math.order classes classes.private classes.algebra classes.tuple
classes.tuple.private generic source-files.errors kernel.private ;
IN: compiler.units
SYMBOL: old-definitions

4
core/generic/generic-docs.factor
View File

@ -163,10 +163,6 @@ HELP: create-method
{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
{ $notes "To define a method, pass the output value to " { $link define } "." } ;
HELP: forget-methods
{ $values { "class" class } }
{ $description "Remove all method definitions which specialize on the class." } ;
{ sort-classes order } related-words
HELP: (call-next-method)