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

Merge branch 'master' of git://github.com/slavapestov/factor

db4
erikc 2010-01-31 16:57:12 -08:00
parent c86bedd912 fa042f6578
commit 98a71d3521
31 changed files with 294 additions and 215 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

2
basis/combinators/smart/smart.factor
View File

@ -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 ] ;

1
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -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

2
basis/compiler/tests/redefine3.factor
View File

@ -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 <groups> key? ;
"definition-dependencies" word-prop member-eq? ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test

4
basis/compression/lzw/lzw.factor
View File

@ -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 ;
: <lzw-uncompress> ( 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

3
basis/debugger/debugger.factor
View File

@ -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" ;

9
basis/generalizations/generalizations-tests.factor
View File

@ -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

21
basis/generalizations/generalizations.factor
View File

@ -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
<range> rest >array dup length iota <reversed>
[
'[ [ [ _ 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 <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;

2
basis/math/ranges/ranges.factor
View File

@ -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

5
basis/random/random-docs.factor
View File

@ -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 }"
}
} ;

32
basis/random/random.factor
View File

@ -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 ;
<PRIVATE
:: next-sample ( length n seq hashtable -- elt )
n hashtable key? [
length n 1 + length mod seq hashtable next-sample
] [
n hashtable conjoin
n seq nth
] if ;
PRIVATE>
: 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 ;

2
basis/random/sfmt/sfmt.factor
View File

@ -111,7 +111,7 @@ M:: sfmt generate ( sfmt -- )
: <sfmt-array> ( 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

17
basis/tools/deploy/shaker/shaker.factor
View File

@ -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

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

129
core/classes/classes.factor
View File

@ -6,6 +6,12 @@ vectors math quotations combinators sorting effects graphs
vocabs sets ;
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
@ -33,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 ;
@ -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 ;
<PRIVATE
: update-map+ ( class -- )
@ -113,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 ;
@ -133,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 -- )
@ -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 ;

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? [

47
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 ;
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

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

8
core/classes/tuple/parser/parser-tests.factor
View File

@ -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

15
core/classes/tuple/parser/parser.factor
View File

@ -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

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)

3
core/generic/generic-tests.factor
View File

@ -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