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 )
: 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 ;
! (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
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
-USING: help.markup help.syntax kernel classes words\r
+USING: help.markup help.syntax kernel classes classes.private words\r
checksums checksums.crc32 sequences math ;\r
IN: classes.algebra\r
\r
! 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
! 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
ERROR: bad-inheritance class superclass ;
+PREDICATE: class < word "class" word-prop ;
+
+<PRIVATE
+
SYMBOL: class<=-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
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 ;
: 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
#! 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
: 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 -- )
: 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 ;
} 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 -- )
[ 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
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 ;
-
-M: class class-forgotten
- nip forget-class ;
+ 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 metaclass-changed
+ swap class? [ drop ] [ forget-class ] if ;
M: class forget* ( class -- )
[ call-next-method ] [ forget-class ] bi ;
! 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
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
! 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 ;
: 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? [
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 < ;
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
! 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
! 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
! 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
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 ;
: 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 ;
] 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
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
+: thrower-effect ( slots -- effect )
+ [ name>> ] map { "*" } <effect> ;
+
PRIVATE>
: define-tuple-class ( class superclass slots -- )
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 ]
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?
! 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
{ $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)
projects / factor.git / commitdiff