diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 941b4149fa..c99b047686 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -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 ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index cdd47cae9a..fae39cd229 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -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 diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 3ad5b6c7ee..5576421742 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -53,4 +53,4 @@ MACRO: smart-if ( pred true false -- ) '[ _ preserving _ _ if ] ; MACRO: smart-apply ( quot n -- ) - [ dup inputs ] dip '[ _ _ mnapply ] ; + [ dup inputs ] dip '[ _ _ _ mnapply ] ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index c75e890c27..0d413f1346 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -663,6 +663,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep { (simd-select) [ emit-simd-select ] } { alien-vector [ emit-alien-vector ] } { set-alien-vector [ emit-set-alien-vector ] } + { assert-positive [ drop ] } } enable-intrinsics ; enable-simd diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 913111b8ea..93b1e6fa92 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ; inline : sheeple-test ( -- string ) { } sheeple ; : compiled-use? ( key word -- ? ) - "compiled-uses" word-prop 2 key? ; + "definition-dependencies" word-prop member-eq? ; [ "sheeple" ] [ sheeple-test ] unit-test [ t ] [ \ sheeple-test optimized? ] unit-test diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index e017636009..340e455291 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -26,9 +26,11 @@ TUPLE: gif-lzw < lzw ; dup end-of-information-code>> 1 + initial-uncompress-table >>table dup initial-code-size>> >>code-size ; +ERROR: code-size-zero ; + : ( input code-size class -- obj ) new - swap >>code-size + swap [ code-size-zero ] when-zero >>code-size dup code-size>> >>initial-code-size dup code-size>> 1 - 2^ >>clear-code dup clear-code>> 1 + >>end-of-information-code diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index be450f7479..d5284133b2 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -293,6 +293,9 @@ M: duplicate-slot-names summary M: invalid-slot-name summary drop "Invalid slot name" ; +M: bad-inheritance summary + drop "Circularity in inheritance chain" ; + M: not-in-a-method-error summary drop "call-next-method can only be called in a method definition" ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 84b6565de1..477be4a20f 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -113,3 +113,12 @@ IN: generalizations.tests [ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test + +[ { 1 2 3 } { 4 5 6 } ] +[ 1 2 3 4 5 6 [ 3array ] [ 3array ] 3 2 nspread* ] unit-test + +[ ] +[ [ 2array ] 2 0 mnapply ] unit-test + +[ ] +[ 2 0 nspread* ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 667cff7b8a..dd0665b534 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences sequences.private math combinators macros math.order math.ranges quotations fry effects -memoize.private ; +memoize.private arrays ; IN: generalizations << @@ -100,10 +100,20 @@ MACRO: nspread ( quots n -- ) MACRO: spread* ( n -- ) [ [ ] ] [ - 1 swap [a,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as + [1,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as [ call ] compose ] if-zero ; +MACRO: nspread* ( m n -- ) + [ drop [ ] ] [ + [ * 0 ] [ drop neg ] 2bi + rest >array dup length iota + [ + '[ [ [ _ ndip ] curry ] _ ndip ] + ] 2map dup rest-slice [ [ compose ] compose ] map! drop + [ ] concat-as [ call ] compose + ] if-zero ; + MACRO: cleave* ( n -- ) [ [ ] ] [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] @@ -112,6 +122,9 @@ MACRO: cleave* ( n -- ) : napply ( quot n -- ) [ dupn ] [ spread* ] bi ; inline +: mnapply ( quot m n -- ) + [ nip dupn ] [ nspread* ] 2bi ; inline + : apply-curry ( ...a quot n -- ) [ [curry] ] dip napply ; inline @@ -124,10 +137,6 @@ MACRO: cleave* ( n -- ) MACRO: mnswap ( m n -- ) 1 + '[ _ -nrot ] swap '[ _ _ napply ] ; -MACRO: mnapply ( quot m n -- ) - swap - [ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ; - MACRO: nweave ( n -- ) [ dup iota [ '[ _ _ mnswap ] ] with map ] keep '[ _ _ ncleave ] ; diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 254f1843f4..b095eae5d5 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -45,3 +45,5 @@ PRIVATE> : [1,b] ( b -- range ) 1 swap [a,b] ; inline : [0,b) ( b -- range ) 0 swap [a,b) ; inline + +: [1,b) ( b -- range ) 1 swap [a,b) ; inline diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 2bf92f64a3..175c34ad9d 100644 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -86,8 +86,9 @@ HELP: sample } { $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." } { $examples - { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ." - "{ 3 2 }" + { $unchecked-example "USING: random prettyprint ;" + "{ 1 2 3 } 2 sample ." + "{ 3 2 }" } } ; diff --git a/basis/random/random.factor b/basis/random/random.factor index 1e54c56728..eeaa1f8f2c 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types assocs byte-arrays byte-vectors -combinators fry io.backend io.binary kernel locals math -math.bitwise math.constants math.functions math.ranges -namespaces sequences sets summary system vocabs.loader ; +USING: accessors alien.c-types arrays assocs byte-arrays +byte-vectors combinators fry io.backend io.binary kernel locals +math math.bitwise math.constants math.functions math.order +math.ranges namespaces sequences sets summary system +vocabs.loader ; IN: random SYMBOL: system-random-generator @@ -61,29 +62,20 @@ M: sequence random : random-32 ( -- n ) random-generator get random-32* ; -: randomize ( seq -- seq ) - dup length [ dup 1 > ] +: randomize-n-last ( seq n -- seq ) + [ dup length dup ] dip - 1 max '[ dup _ > ] [ [ random ] [ 1 - ] bi [ pick exchange ] keep ] while drop ; +: randomize ( seq -- seq ) + dup length randomize-n-last ; + ERROR: too-many-samples seq n ; - - : sample ( seq n -- seq' ) 2dup [ length ] dip < [ too-many-samples ] when - swap [ length ] [ ] bi H{ } clone - '[ _ dup random _ _ next-sample ] replicate ; + [ [ length iota >array ] dip [ randomize-n-last ] keep tail-slice* ] + [ drop ] 2bi nths ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep remove-nth! drop ; diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor index 146db91172..04049b542d 100644 --- a/basis/random/sfmt/sfmt.factor +++ b/basis/random/sfmt/sfmt.factor @@ -111,7 +111,7 @@ M:: sfmt generate ( sfmt -- ) : ( sfmt -- uint-array uint-4-array ) state>> - [ n>> 4 * 1 swap [a,b] >uint-array ] [ seed>> ] bi + [ n>> 4 * [1,b] >uint-array ] [ seed>> ] bi [ [ [ -30 shift ] [ ] bi bitxor diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index dfb5b7fa30..19d3a2cbb9 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -9,6 +9,7 @@ compiler.units definitions generic generic.standard generic.single tools.deploy.config combinators classes classes.builtin slots.private grouping command-line ; QUALIFIED: bootstrap.stage2 +QUALIFIED: classes.private QUALIFIED: compiler.crossref QUALIFIED: compiler.errors QUALIFIED: continuations @@ -332,14 +333,14 @@ IN: tools.deploy.shaker { gensym name>char-hook - next-method-quot-cache - class-and-cache - class-not-cache - class-or-cache - class<=-cache - classes-intersect-cache - implementors-map - update-map + classes.private:next-method-quot-cache + classes.private:class-and-cache + classes.private:class-not-cache + classes.private:class-or-cache + classes.private:class<=-cache + classes.private:classes-intersect-cache + classes.private:implementors-map + classes.private:update-map main-vocab-hook compiler.crossref:compiled-crossref compiler.crossref:compiled-generic-crossref diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index ecf66834ce..9366aa49c2 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 7b931c80e8..2c286cb3f6 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -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 diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 30697eb6a8..543a2f7420 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -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 : classes ( -- seq ) implementors-map get keys ; @@ -63,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 @@ -74,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 @@ -105,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 ; + + 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 -- ) @@ -169,7 +186,11 @@ GENERIC: update-methods ( class seq -- ) dup class-usages [ nip [ update-class ] each ] [ update-methods ] 2bi ; +: check-inheritance ( subclass superclass -- ) + 2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ; + : define-class ( word superclass members participants metaclass -- ) + [ 2dup check-inheritance ] 3dip make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ; : forget-predicate ( class -- ) @@ -182,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 ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 242f099ea0..a3c1d5d607 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -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 diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index d174bb55ad..0569149392 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -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 diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 8a48a25160..fa0a6e8d37 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -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? [ diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index dadfa59917..7a63b88a65 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/core/classes/predicate/predicate-tests.factor @@ -1,5 +1,6 @@ USING: math tools.test classes.algebra words kernel sequences assocs -accessors eval definitions compiler.units generic ; +accessors eval definitions compiler.units generic strings classes +generic.single ; IN: classes.predicate.tests PREDICATE: negative < integer 0 < ; @@ -42,3 +43,47 @@ M: tuple-d ptest' drop tuple-d ; [ tuple-a ] [ tuple-b new ptest' ] unit-test [ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test + +PREDICATE: bad-inheritance-predicate < string ; +[ + "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate < bad-inheritance-predicate ;" eval( -- ) +] [ error>> bad-inheritance? ] must-fail-with + +PREDICATE: bad-inheritance-predicate2 < string ; +PREDICATE: bad-inheritance-predicate3 < bad-inheritance-predicate2 ; +[ + "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate2 < bad-inheritance-predicate3 ;" eval( -- ) +] [ error>> bad-inheritance? ] must-fail-with + +! This must not fail +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 diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index c0dfb4efa0..25feac7989 100644 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -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 diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 2b9fd7b89b..12a4226b2c 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -153,3 +153,11 @@ TUPLE: bad-inheritance-tuple3 < bad-inheritance-tuple2 ; [ "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple2 < bad-inheritance-tuple3 ;" eval( -- ) ] [ error>> bad-inheritance? ] must-fail-with + +! This must not fail +TUPLE: tup ; +UNION: u tup ; + +[ ] [ "IN: classes.tuple.parser.tests TUPLE: u < tup ;" eval( -- ) ] unit-test + +[ t ] [ u new tup? ] unit-test diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 626cbd63df..812f75a591 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sets namespaces make sequences parser lexer combinators words classes.parser classes.tuple arrays -slots math assocs parser.notes classes.algebra ; +slots math assocs parser.notes classes classes.algebra ; IN: classes.tuple.parser : slot-names ( slots -- seq ) @@ -56,18 +56,11 @@ ERROR: invalid-slot-name name ; : parse-tuple-slots ( -- ) ";" parse-tuple-slots-delim ; -ERROR: bad-inheritance class superclass ; - -: check-inheritance ( class1 class2 -- class1 class2 ) - 2dup swap class<= [ bad-inheritance ] when ; - : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS - scan 2dup = [ ] when { + scan { { ";" [ tuple f ] } - { "<" [ - scan-word check-inheritance [ parse-tuple-slots ] { } make - ] } + { "<" [ scan-word [ parse-tuple-slots ] { } make ] } [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] } case dup check-duplicate-slots diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index aa99ac3194..c4c2e83e95 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -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 ;" "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 ( -- ) ;" "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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 620c65c865..e3b5126713 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 { "*" } ; + 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 { "*" } ; - : 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? diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 9fe13ba3ed..07f8494a59 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -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 diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 240fdd96e0..f4edb5e8ba 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -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) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 5a98173a89..ff38ee39ea 100644 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -207,8 +207,7 @@ M: integer forget-test 3 + ; [ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test [ { } ] [ - \ + compiled-usage keys - [ method-body? ] filter + \ + effect-dependencies-of keys [ method-body? ] filter [ "method-generic" word-prop \ forget-test eq? ] filter ] unit-test