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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2008-07-14 18:17:34 -07:00
parent ec46665170 8782ef8c5f
commit a0a6f4090f
85 changed files with 1610 additions and 784 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
core/alien/c-types/c-types.factor
View File

@ -151,8 +151,9 @@ M: byte-array byte-length length ;
swap dup length memcpy ; swap dup length memcpy ;
: (define-nth) ( word type quot -- ) : (define-nth) ( word type quot -- )
>r heap-size [ rot * >fixnum ] swap prefix [
r> append define-inline ; \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make define-inline ;
: nth-word ( name vocab -- word ) : nth-word ( name vocab -- word )
>r "-nth" append r> create ; >r "-nth" append r> create ;

5
core/assocs/assocs-docs.factor
View File

@ -44,10 +44,11 @@ ARTICLE: "assocs-protocol" "Associative mapping protocol"
{ $subsection set-at } { $subsection set-at }
{ $subsection delete-at } { $subsection delete-at }
{ $subsection clear-assoc } { $subsection clear-assoc }
"The following two words are optional:" "The following three words are optional:"
{ $subsection value-at* }
{ $subsection new-assoc } { $subsection new-assoc }
{ $subsection assoc-like } { $subsection assoc-like }
"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode } " generic words. Two utility words will help with the implementation of the last two:" "Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode* } " generic words. Two utility words will help with the implementation of the last two:"
{ $subsection assoc= } { $subsection assoc= }
{ $subsection assoc-hashcode } { $subsection assoc-hashcode }
"Finally, assoc classes should define a word for converting other types of assocs; conventionally, such words are named " { $snippet ">" { $emphasis "class" } } " where " { $snippet { $emphasis "class" } } " is the class name. Such a word can be implemented using a utility:" "Finally, assoc classes should define a word for converting other types of assocs; conventionally, such words are named " { $snippet ">" { $emphasis "class" } } " where " { $snippet { $emphasis "class" } } " is the class name. Such a word can be implemented using a utility:"

24
core/bootstrap/primitives.factor
View File

@ -121,7 +121,7 @@ bootstrapping? on
[ [ dup pair? [ first2 create ] when ] map ] map ; [ [ dup pair? [ first2 create ] when ] map ] map ;
: define-builtin-slots ( class slots -- ) : define-builtin-slots ( class slots -- )
prepare-slots 1 make-slots prepare-slots make-slots 1 finalize-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ; [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- ) : define-builtin ( symbol slotspec -- )
@ -273,18 +273,16 @@ bi
{ "echelon" { "fixnum" "math" } read-only } { "echelon" { "fixnum" "math" } read-only }
} define-builtin } define-builtin
"tuple" "kernel" create { "tuple" "kernel" create
[ { } define-builtin ] [ { } define-builtin ]
[ { "delegate" } "slot-names" set-word-prop ] [ define-tuple-layout ]
[ define-tuple-layout ] [
[ { "delegate" } make-slots
{ "delegate" } [ drop ] [ finalize-tuple-slots ] 2bi
[ drop ] [ generate-tuple-slots ] 2bi [ "slots" set-word-prop ]
[ "slots" set-word-prop ] [ define-accessors ]
[ define-accessors ] 2bi
2bi ] tri
]
} cleave
! Create special tombstone values ! Create special tombstone values
"tombstone" "hashtables.private" create "tombstone" "hashtables.private" create

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

@ -1,35 +1,44 @@
IN: classes.tuple.parser.tests IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units ; sequences math kernel slots tools.test parser compiler.units
arrays classes.tuple ;
TUPLE: test-1 ; TUPLE: test-1 ;
[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test [ t ] [ test-1 "slots" word-prop empty? ] unit-test
TUPLE: test-2 < test-1 ; TUPLE: test-2 < test-1 ;
[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test [ t ] [ test-2 "slots" word-prop empty? ] unit-test
[ test-1 ] [ test-2 superclass ] unit-test [ test-1 ] [ test-2 superclass ] unit-test
TUPLE: test-3 a ; TUPLE: test-3 a ;
[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test [ { "a" } ] [ test-3 "slots" word-prop [ name>> ] map ] unit-test
[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test [ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
TUPLE: test-4 < test-3 b ; TUPLE: test-4 < test-3 b ;
[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test [ { "b" } ] [ test-4 "slots" word-prop [ name>> ] map ] unit-test
TUPLE: test-5 { a integer } ; TUPLE: test-5 { a integer } ;
[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test [ { { "a" integer } } ]
[
test-5 "slots" word-prop
[ [ name>> ] [ class>> ] bi 2array ] map
] unit-test
TUPLE: test-6 < test-5 { b integer } ; TUPLE: test-6 < test-5 { b integer } ;
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test [ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test [ { { "b" integer } } ]
[
test-6 "slots" word-prop
[ [ name>> ] [ class>> ] bi 2array ] map
] unit-test
TUPLE: test-7 { b integer initial: 3 } ; TUPLE: test-7 { b integer initial: 3 } ;
@ -39,6 +48,8 @@ TUPLE: test-8 { b integer read-only } ;
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test [ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
DEFER: foo
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] [ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
[ error>> invalid-slot-name? ] [ error>> invalid-slot-name? ]
must-fail-with must-fail-with
@ -51,17 +62,33 @@ must-fail-with
[ error>> unexpected-eof? ] [ error>> unexpected-eof? ]
must-fail-with must-fail-with
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] 2 [
[ error>> no-initial-value? ] [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
[ error>> no-initial-value? ]
must-fail-with
[ f ] [ \ foo tuple-class? ] unit-test
] times
2 [
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
[ error>> bad-initial-value? ]
must-fail-with
[ f ] [ \ foo tuple-class? ] unit-test
] times
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
[ error>> duplicate-slot-names? ]
must-fail-with must-fail-with
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] [ f ] [ \ foo tuple-class? ] unit-test
[ error>> bad-initial-value? ]
must-fail-with
[ ] [ [ ] [
[ [
{ test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 } { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 foo }
[ dup class? [ forget-class ] [ drop ] if ] each [ dup class? [ forget-class ] [ drop ] if ] each
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test

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

@ -4,10 +4,11 @@ USING: accessors kernel sets namespaces sequences summary parser
lexer combinators words classes.parser classes.tuple arrays ; lexer combinators words classes.parser classes.tuple arrays ;
IN: classes.tuple.parser IN: classes.tuple.parser
: slot-names ( slots -- seq )
[ dup array? [ first ] when ] map ;
: shadowed-slots ( superclass slots -- shadowed ) : shadowed-slots ( superclass slots -- shadowed )
[ all-slots [ name>> ] map ] [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
[ [ dup array? [ first ] when ] map ]
bi* intersect ;
: check-slot-shadowing ( class superclass slots -- ) : check-slot-shadowing ( class superclass slots -- )
shadowed-slots [ shadowed-slots [
@ -20,11 +21,19 @@ IN: classes.tuple.parser
] "" make note. ] "" make note.
] with each ; ] with each ;
ERROR: duplicate-slot-names names ;
M: duplicate-slot-names summary
drop "Duplicate slot names" ;
: check-duplicate-slots ( slots -- )
slot-names duplicates
dup empty? [ drop ] [ duplicate-slot-names ] if ;
ERROR: invalid-slot-name name ; ERROR: invalid-slot-name name ;
M: invalid-slot-name summary M: invalid-slot-name summary
drop drop "Invalid slot name" ;
"Invalid slot name" ;
: parse-long-slot-name ( -- ) : parse-long-slot-name ( -- )
[ scan , \ } parse-until % ] { } make ; [ scan , \ } parse-until % ] { } make ;
@ -38,7 +47,7 @@ M: invalid-slot-name summary
#! : ... #! : ...
{ {
{ [ dup not ] [ unexpected-eof ] } { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] } { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop f ] } { [ dup ";" = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ] [ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond ; } cond ;
@ -52,4 +61,6 @@ M: invalid-slot-name summary
{ ";" [ tuple f ] } { ";" [ tuple f ] }
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] } { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
} case 3dup check-slot-shadowing ; } case
dup check-duplicate-slots
3dup check-slot-shadowing ;

4
core/classes/tuple/tuple-docs.factor
View File

@ -346,11 +346,9 @@ HELP: tuple
$nl $nl
"Tuple classes have additional word properties:" "Tuple classes have additional word properties:"
{ $list { $list
{ { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" } { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" } { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
{ { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" } { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
} } ; } } ;
HELP: define-tuple-predicate HELP: define-tuple-predicate

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

@ -443,36 +443,36 @@ TUPLE: redefinition-problem-2 ;
! Hardcore unit tests ! Hardcore unit tests
USE: threads USE: threads
\ thread slot-names "slot-names" set \ thread "slots" word-prop "slots" set
[ ] [ [ ] [
[ [
\ thread tuple { "xxx" } "slot-names" get append \ thread tuple { "xxx" } "slots" get append
define-tuple-class define-tuple-class
] with-compilation-unit ] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop [ 1337 sleep ] "Test" spawn drop
[ [
\ thread tuple "slot-names" get \ thread tuple "slots" get
define-tuple-class define-tuple-class
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
USE: vocabs USE: vocabs
\ vocab slot-names "slot-names" set \ vocab "slots" word-prop "slots" set
[ ] [ [ ] [
[ [
\ vocab tuple { "xxx" } "slot-names" get append \ vocab tuple { "xxx" } "slots" get append
define-tuple-class define-tuple-class
] with-compilation-unit ] with-compilation-unit
all-words drop all-words drop
[ [
\ vocab tuple "slot-names" get \ vocab tuple "slots" get
define-tuple-class define-tuple-class
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test

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

@ -22,18 +22,6 @@ ERROR: not-a-tuple object ;
<PRIVATE <PRIVATE
: (tuple) ( layout -- tuple )
#! In non-optimized code, this word simply calls the
#! <tuple> primitive. In optimized code, an intrinsic
#! is generated which allocates a tuple but does not set
#! any of its slots. This means that any code that uses
#! (tuple) must fill in the slots before the next
#! call to GC.
#!
#! This word is only used in the expansion of <tuple-boa>,
#! where this invariant is guaranteed to hold.
<tuple> ;
: tuple-layout ( class -- layout ) : tuple-layout ( class -- layout )
"layout" word-prop ; "layout" word-prop ;
@ -86,9 +74,6 @@ M: tuple-class slots>tuple
: >tuple ( seq -- tuple ) : >tuple ( seq -- tuple )
unclip slots>tuple ; unclip slots>tuple ;
: slot-names ( class -- seq )
"slot-names" word-prop ;
ERROR: bad-superclass class ; ERROR: bad-superclass class ;
<PRIVATE <PRIVATE
@ -116,7 +101,7 @@ ERROR: bad-superclass class ;
: superclass-size ( class -- n ) : superclass-size ( class -- n )
superclasses but-last-slice superclasses but-last-slice
[ slot-names length ] sigma ; [ "slots" word-prop length ] sigma ;
: (instance-check-quot) ( class -- quot ) : (instance-check-quot) ( class -- quot )
[ [
@ -150,19 +135,18 @@ ERROR: bad-superclass class ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ; dup tuple-prototype "prototype" set-word-prop ;
: generate-tuple-slots ( class slots -- slot-specs ) : finalize-tuple-slots ( class slots -- slots )
over superclass-size 2 + make-slots deprecated-slots ; over superclass-size 2 + finalize-slots deprecated-slots ;
: define-tuple-slots ( class -- ) : define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots dup dup "slots" word-prop finalize-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ] ! new [ define-accessors ] ! new
[ define-slots ] ! old [ define-slots ] ! old
2tri ; 2bi ;
: make-tuple-layout ( class -- layout ) : make-tuple-layout ( class -- layout )
[ ] [ ]
[ [ superclass-size ] [ slot-names length ] bi + ] [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
[ superclasses dup length 1- ] tri [ superclasses dup length 1- ] tri
<tuple-layout> ; <tuple-layout> ;
@ -223,8 +207,9 @@ M: tuple-class update-class
} cleave ; } cleave ;
: define-new-tuple-class ( class superclass slots -- ) : define-new-tuple-class ( class superclass slots -- )
make-slots
[ drop f f tuple-class define-class ] [ drop f f tuple-class define-class ]
[ nip "slot-names" set-word-prop ] [ nip "slots" set-word-prop ]
[ 2drop update-classes ] [ 2drop update-classes ]
3tri ; 3tri ;
@ -248,7 +233,7 @@ M: tuple-class update-class
3bi ; 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? ) : tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
: valid-superclass? ( class -- ? ) : valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ; [ tuple-class? ] [ tuple eq? ] bi or ;
@ -293,7 +278,7 @@ M: tuple-class reset-class
[ call-next-method ] [ call-next-method ]
[ [
{ {
"layout" "slots" "slot-names" "boa-check" "prototype" "layout" "slots" "boa-check" "prototype"
} reset-props } reset-props
] bi ] bi
] bi ; ] bi ;

2
core/cpu/architecture/architecture.factor
View File

@ -162,8 +162,6 @@ PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ; PREDICATE: small-tagged < integer v>operand small-enough? ;
PREDICATE: inline-array < integer 32 < ;
: if-small-struct ( n size true false -- ? ) : if-small-struct ( n size true false -- ? )
>r >r over not over struct-small-enough? and >r >r over not over struct-small-enough? and
[ nip r> call r> drop ] [ r> drop r> call ] if ; [ nip r> call r> drop ] [ r> drop r> call ] if ;

118
core/cpu/ppc/assembler/assembler-tests.factor Normal file
View File

@ -0,0 +1,118 @@
IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
vocabs sequences ;
: test-assembler ( expected quot -- )
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;
{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
{ HEX: 38400001 } [ 1 2 LI ] test-assembler
{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
{ HEX: 48000001 } [ 1 B ] test-assembler
{ HEX: 48000001 } [ 1 BL ] test-assembler
{ HEX: 41800004 } [ 1 BLT ] test-assembler
{ HEX: 41810004 } [ 1 BGT ] test-assembler
{ HEX: 40810004 } [ 1 BLE ] test-assembler
{ HEX: 40800004 } [ 1 BGE ] test-assembler
{ HEX: 41800004 } [ 1 BLT ] test-assembler
{ HEX: 40820004 } [ 1 BNE ] test-assembler
{ HEX: 41820004 } [ 1 BEQ ] test-assembler
{ HEX: 41830004 } [ 1 BO ] test-assembler
{ HEX: 40830004 } [ 1 BNO ] test-assembler
{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
{ HEX: 4e800020 } [ BLR ] test-assembler
{ HEX: 4e800021 } [ BLRL ] test-assembler
{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
{ HEX: 4e800420 } [ BCTR ] test-assembler
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
"cpu.ppc.assembler" words [ must-infer ] each

396
core/cpu/ppc/assembler/assembler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: generator.fixup generic kernel memory namespaces USING: generator.fixup kernel namespaces words io.binary math
words math math.bitfields math.order io.binary ; math.order cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler IN: cpu.ppc.assembler
! See the Motorola or IBM documentation for details. The opcode ! See the Motorola or IBM documentation for details. The opcode
@ -15,215 +15,195 @@ IN: cpu.ppc.assembler
! !
! 14 15 10 STW ! 14 15 10 STW
: insn ( operand opcode -- ) { 26 0 } bitfield , ; ! D-form
: a-form ( d a b c xo rc -- n ) { 0 1 6 11 16 21 } bitfield ; D: ADDI 14
: b-form ( bo bi bd aa lk -- n ) { 0 1 2 16 21 } bitfield ; D: ADDIC 12
: s>u16 ( s -- u ) HEX: ffff bitand ; D: ADDIC. 13
: d-form ( d a simm -- n ) s>u16 { 0 16 21 } bitfield ; D: ADDIS 15
: sd-form ( d a simm -- n ) s>u16 { 0 21 16 } bitfield ; D: CMPI 11
: i-form ( li aa lk -- n ) { 0 1 0 } bitfield ; D: CMPLI 10
: x-form ( a s b rc xo -- n ) { 1 0 11 21 16 } bitfield ; D: LBZ 34
: xfx-form ( d spr xo -- n ) { 1 11 21 } bitfield ; D: LBZU 35
: xo-form ( d a b oe rc xo -- n ) { 1 0 10 11 16 21 } bitfield ; D: LFD 50
D: LFDU 51
D: LFS 48
D: LFSU 49
D: LHA 42
D: LHAU 43
D: LHZ 40
D: LHZU 41
D: LWZ 32
D: LWZU 33
D: MULI 7
D: MULLI 7
D: STB 38
D: STBU 39
D: STFD 54
D: STFDU 55
D: STFS 52
D: STFSU 53
D: STH 44
D: STHU 45
D: STW 36
D: STWU 37
: ADDI d-form 14 insn ; : LI 0 rot ADDI ; : SUBI neg ADDI ; ! SD-form
: ADDIS d-form 15 insn ; : LIS 0 rot ADDIS ; SD: ANDI 28
SD: ANDIS 29
SD: ORI 24
SD: ORIS 25
SD: XORI 26
SD: XORIS 27
: ADDIC d-form 12 insn ; : SUBIC neg ADDIC ; ! X-form
X: AND 0 28 31
X: AND. 1 28 31
X: CMP 0 0 31
X: CMPL 0 32 31
X: EQV 0 284 31
X: EQV. 1 284 31
X: FCMPO 0 32 63
X: FCMPU 0 0 63
X: LBZUX 0 119 31
X: LBZX 0 87 31
X: LHAUX 0 375 31
X: LHAX 0 343 31
X: LHZUX 0 311 31
X: LHZX 0 279 31
X: LWZUX 0 55 31
X: LWZX 0 23 31
X: NAND 0 476 31
X: NAND. 1 476 31
X: NOR 0 124 31
X: NOR. 1 124 31
X: OR 0 444 31
X: OR. 1 444 31
X: ORC 0 412 31
X: ORC. 1 412 31
X: SLW 0 24 31
X: SLW. 1 24 31
X: SRAW 0 792 31
X: SRAW. 1 792 31
X: SRAWI 0 824 31
X: SRW 0 536 31
X: SRW. 1 536 31
X: STBUX 0 247 31
X: STBX 0 215 31
X: STHUX 0 439 31
X: STHX 0 407 31
X: STWUX 0 183 31
X: STWX 0 151 31
X: XOR 0 316 31
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ; ! XO-form
XO: ADD 0 0 266 31
XO: ADD. 0 1 266 31
XO: ADDC 0 0 10 31
XO: ADDC. 0 1 10 31
XO: ADDCO 1 0 10 31
XO: ADDCO. 1 1 10 31
XO: ADDE 0 0 138 31
XO: ADDE. 0 1 138 31
XO: ADDEO 1 0 138 31
XO: ADDEO. 1 1 138 31
XO: ADDO 1 0 266 31
XO: ADDO. 1 1 266 31
XO: DIVW 0 0 491 31
XO: DIVW. 0 1 491 31
XO: DIVWO 1 0 491 31
XO: DIVWO. 1 1 491 31
XO: DIVWU 0 0 459 31
XO: DIVWU. 0 1 459 31
XO: DIVWUO 1 0 459 31
XO: DIVWUO. 1 1 459 31
XO: MULHW 0 0 75 31
XO: MULHW. 0 1 75 31
XO: MULHWU 0 0 11 31
XO: MULHWU. 0 1 11 31
XO: MULLW 0 0 235 31
XO: MULLW. 0 1 235 31
XO: MULLWO 1 0 235 31
XO: MULLWO. 1 1 235 31
XO: SUBF 0 0 40 31
XO: SUBF. 0 1 40 31
XO: SUBFC 0 0 8 31
XO: SUBFC. 0 1 8 31
XO: SUBFCO 1 0 8 31
XO: SUBFCO. 1 1 8 31
XO: SUBFE 0 0 136 31
XO: SUBFE. 0 1 136 31
XO: SUBFEO 1 0 136 31
XO: SUBFEO. 1 1 136 31
XO: SUBFO 1 0 40 31
XO: SUBFO. 1 1 40 31
XO1: NEG 0 0 104 31
XO1: NEG. 0 1 104 31
XO1: NEGO 1 0 104 31
XO1: NEGO. 1 1 104 31
: MULI d-form 7 insn ; ! A-form
: RLWINM ( d a b c xo -- ) 0 21 a-insn ;
: RLWINM. ( d a b c xo -- ) 1 21 a-insn ;
: FADD ( d a b -- ) 0 21 0 63 a-insn ;
: FADD. ( d a b -- ) 0 21 1 63 a-insn ;
: FSUB ( d a b -- ) 0 20 0 63 a-insn ;
: FSUB. ( d a b -- ) 0 20 1 63 a-insn ;
: FMUL ( d a c -- ) 0 swap 25 0 63 a-insn ;
: FMUL. ( d a c -- ) 0 swap 25 1 63 a-insn ;
: FDIV ( d a b -- ) 0 18 0 63 a-insn ;
: FDIV. ( d a b -- ) 0 18 1 63 a-insn ;
: FSQRT ( d b -- ) 0 swap 0 22 0 63 a-insn ;
: FSQRT. ( d b -- ) 0 swap 0 22 1 63 a-insn ;
: (ADD) 266 xo-form 31 insn ; ! Branches
: ADD 0 0 (ADD) ; : ADD. 0 1 (ADD) ; : B ( dest -- ) 0 0 (B) ;
: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ; : BL ( dest -- ) 0 1 (B) ;
BC: LT 12 0
BC: GE 4 0
BC: GT 12 1
BC: LE 4 1
BC: EQ 12 2
BC: NE 4 2
BC: O 12 3
BC: NO 4 3
B: CLR 0 8 0 0 19
B: CLRL 0 8 0 1 19
B: CCTR 0 264 0 0 19
: BLR ( -- ) 20 BCLR ;
: BLRL ( -- ) 20 BCLRL ;
: BCTR ( -- ) 20 BCCTR ;
: (ADDC) 10 xo-form 31 insn ; ! Special registers
: ADDC 0 0 (ADDC) ; : ADDC. 0 1 (ADDC) ; MFSPR: XER 1
: ADDCO 1 0 (ADDC) ; : ADDCO. 1 1 (ADDC) ; MFSPR: LR 8
MFSPR: CTR 9
MTSPR: XER 1
MTSPR: LR 8
MTSPR: CTR 9
: (ADDE) 138 xo-form 31 insn ; ! Pseudo-instructions
: ADDE 0 0 (ADDE) ; : ADDE. 0 1 (ADDE) ; : LI 0 rot ADDI ; inline
: ADDEO 1 0 (ADDE) ; : ADDEO. 1 1 (ADDE) ; : SUBI neg ADDI ; inline
: LIS 0 rot ADDIS ; inline
: ANDI sd-form 28 insn ; : SUBIC neg ADDIC ; inline
: ANDIS sd-form 29 insn ; : SUBIC. neg ADDIC. ; inline
: NOT dup NOR ; inline
: (AND) 28 x-form 31 insn ; : NOT. dup NOR. ; inline
: AND 0 (AND) ; : AND. 0 (AND) ; : MR dup OR ; inline
: MR. dup OR. ; inline
: (DIVW) 491 xo-form 31 insn ; : (SLWI) 0 31 pick - ; inline
: DIVW 0 0 (DIVW) ; : DIVW. 0 1 (DIVW) ; : SLWI ( d a b -- ) (SLWI) RLWINM ;
: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ; : SLWI. ( d a b -- ) (SLWI) RLWINM. ;
: (SRWI) 32 over - swap 31 ; inline
: (DIVWU) 459 xo-form 31 insn ; : SRWI ( d a b -- ) (SRWI) RLWINM ;
: DIVWU 0 0 (DIVWU) ; : DIVWU. 0 1 (DIVWU) ; : SRWI. ( d a b -- ) (SRWI) RLWINM. ;
: DIVWUO 1 0 (DIVWU) ; : DIVWUO. 1 1 (DIVWU) ; : LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: (EQV) 284 x-form 31 insn ; : LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
: EQV 0 (EQV) ; : EQV. 1 (EQV) ;
: (NAND) 476 x-form 31 insn ;
: NAND 0 (NAND) ; : NAND. 1 (NAND) ;
: (NOR) 124 x-form 31 insn ;
: NOR 0 (NOR) ; : NOR. 1 (NOR) ;
: NOT dup NOR ; : NOT. dup NOR. ;
: ORI sd-form 24 insn ; : ORIS sd-form 25 insn ;
: (OR) 444 x-form 31 insn ;
: OR 0 (OR) ; : OR. 1 (OR) ;
: (ORC) 412 x-form 31 insn ;
: ORC 0 (ORC) ; : ORC. 1 (ORC) ;
: MR dup OR ; : MR. dup OR. ;
: (MULHW) 75 xo-form 31 insn ;
: MULHW 0 0 (MULHW) ; : MULHW. 0 1 (MULHW) ;
: MULLI d-form 7 insn ;
: (MULHWU) 11 xo-form 31 insn ;
: MULHWU 0 0 (MULHWU) ; : MULHWU. 0 1 (MULHWU) ;
: (MULLW) 235 xo-form 31 insn ;
: MULLW 0 0 (MULLW) ; : MULLW. 0 1 (MULLW) ;
: MULLWO 1 0 (MULLW) ; : MULLWO. 1 1 (MULLW) ;
: (SLW) 24 x-form 31 insn ;
: SLW 0 (SLW) ; : SLW. 1 (SLW) ;
: (SRAW) 792 x-form 31 insn ;
: SRAW 0 (SRAW) ; : SRAW. 1 (SRAW) ;
: (SRW) 536 x-form 31 insn ;
: SRW 0 (SRW) ; : SRW. 1 (SRW) ;
: SRAWI 0 824 x-form 31 insn ;
: (SUBF) 40 xo-form 31 insn ;
: SUBF 0 0 (SUBF) ; : SUBF. 0 1 (SUBF) ;
: SUBFO 1 0 (SUBF) ; : SUBFO. 1 1 (SUBF) ;
: (SUBFC) 8 xo-form 31 insn ;
: SUBFC 0 0 (SUBFC) ; : SUBFC. 0 1 (SUBFC) ;
: SUBFCO 1 0 (SUBFC) ; : SUBFCO. 1 1 (SUBFC) ;
: (SUBFE) 136 xo-form 31 insn ;
: SUBFE 0 0 (SUBFE) ; : SUBFE. 0 1 (SUBFE) ;
: SUBFEO 1 0 (SUBFE) ; : SUBFEO. 1 1 (SUBFE) ;
: (EXTSB) 0 swap 954 x-form 31 insn ;
: EXTSB 0 (EXTSB) ;
: EXTSB. 1 (EXTSB) ;
: XORI sd-form 26 insn ; : XORIS sd-form 27 insn ;
: (XOR) 316 x-form 31 insn ;
: XOR 0 (XOR) ; : XOR. 1 (XOR) ;
: (NEG) 0 -rot 104 xo-form 31 insn ;
: NEG 0 0 (NEG) ; : NEG. 0 1 (NEG) ;
: NEGO 1 0 (NEG) ; : NEGO. 1 1 (NEG) ;
: CMPI d-form 11 insn ;
: CMPLI d-form 10 insn ;
: CMP 0 0 x-form 31 insn ;
: CMPL 0 32 x-form 31 insn ;
: (RLWINM) a-form 21 insn ;
: RLWINM 0 (RLWINM) ; : RLWINM. 1 (RLWINM) ;
: (SLWI) 0 31 pick - ;
: SLWI (SLWI) RLWINM ; : SLWI. (SLWI) RLWINM. ;
: (SRWI) 32 over - swap 31 ;
: SRWI (SRWI) RLWINM ; : SRWI. (SRWI) RLWINM. ;
: LBZ d-form 34 insn ; : LBZU d-form 35 insn ;
: LHA d-form 42 insn ; : LHAU d-form 43 insn ;
: LHZ d-form 40 insn ; : LHZU d-form 41 insn ;
: LWZ d-form 32 insn ; : LWZU d-form 33 insn ;
: LBZX 0 87 x-form 31 insn ; : LBZUX 0 119 x-form 31 insn ;
: LHAX 0 343 x-form 31 insn ; : LHAUX 0 375 x-form 31 insn ;
: LHZX 0 279 x-form 31 insn ; : LHZUX 0 311 x-form 31 insn ;
: LWZX 0 23 x-form 31 insn ; : LWZUX 0 55 x-form 31 insn ;
: STB d-form 38 insn ; : STBU d-form 39 insn ;
: STH d-form 44 insn ; : STHU d-form 45 insn ;
: STW d-form 36 insn ; : STWU d-form 37 insn ;
: STBX 0 215 x-form 31 insn ; : STBUX 247 x-form 31 insn ;
: STHX 0 407 x-form 31 insn ; : STHUX 439 x-form 31 insn ;
: STWX 0 151 x-form 31 insn ; : STWUX 183 x-form 31 insn ;
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) i-form 18 insn ;
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
: B 0 0 (B) ; : BL 0 1 (B) ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 b-form 16 insn ;
M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
: BLT 12 0 rot BC ; : BGE 4 0 rot BC ;
: BGT 12 1 rot BC ; : BLE 4 1 rot BC ;
: BEQ 12 2 rot BC ; : BNE 4 2 rot BC ;
: BO 12 3 rot BC ; : BNO 4 3 rot BC ;
: BCLR 0 8 0 0 b-form 19 insn ;
: BLR 20 BCLR ;
: BCLRL 0 8 0 1 b-form 19 insn ;
: BLRL 20 BCLRL ;
: BCCTR 0 264 0 0 b-form 19 insn ;
: BCTR 20 BCCTR ;
: MFSPR 5 shift 339 xfx-form 31 insn ;
: MFXER 1 MFSPR ; : MFLR 8 MFSPR ; : MFCTR 9 MFSPR ;
: MTSPR 5 shift 467 xfx-form 31 insn ;
: MTXER 1 MTSPR ; : MTLR 8 MTSPR ; : MTCTR 9 MTSPR ;
: LOAD32 >r w>h/h r> tuck LIS dup rot ORI ;
: LOAD ( n r -- )
#! PowerPC cannot load a 32 bit literal in one instruction.
>r dup -32768 32767 between? [ r> LI ] [ r> LOAD32 ] if ;
! Floating point
: LFS d-form 48 insn ; : LFSU d-form 49 insn ;
: LFD d-form 50 insn ; : LFDU d-form 51 insn ;
: STFS d-form 52 insn ; : STFSU d-form 53 insn ;
: STFD d-form 54 insn ; : STFDU d-form 55 insn ;
: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
: FMR 0 (FMR) ; : FMR. 1 (FMR) ;
: (FCTIWZ) >r 0 -rot r> 15 x-form 63 insn ;
: FCTIWZ 0 (FCTIWZ) ; : FCTIWZ. 1 (FCTIWZ) ;
: (FADD) >r 0 21 r> a-form 63 insn ;
: FADD 0 (FADD) ; : FADD. 1 (FADD) ;
: (FSUB) >r 0 20 r> a-form 63 insn ;
: FSUB 0 (FSUB) ; : FSUB. 1 (FSUB) ;
: (FMUL) >r 0 swap 25 r> a-form 63 insn ;
: FMUL 0 (FMUL) ; : FMUL. 1 (FMUL) ;
: (FDIV) >r 0 18 r> a-form 63 insn ;
: FDIV 0 (FDIV) ; : FDIV. 1 (FDIV) ;
: (FSQRT) >r 0 swap 0 22 r> a-form 63 insn ;
: FSQRT 0 (FSQRT) ; : FSQRT. 1 (FSQRT) ;
: FCMPU 0 0 x-form 63 insn ;
: FCMPO 0 32 x-form 63 insn ;

93
core/cpu/ppc/assembler/backend/backend.factor Normal file
View File

@ -0,0 +1,93 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generator.fixup kernel namespaces sequences
words math math.bitfields io.binary parser lexer ;
IN: cpu.ppc.assembler.backend
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
: a-insn ( d a b c xo rc opcode -- )
[ { 0 1 6 11 16 21 } bitfield ] dip insn ;
: b-insn ( bo bi bd aa lk opcode -- )
[ { 0 1 2 16 21 } bitfield ] dip insn ;
: s>u16 ( s -- u ) HEX: ffff bitand ;
: d-insn ( d a simm opcode -- )
[ s>u16 { 0 16 21 } bitfield ] dip insn ;
: define-d-insn ( word opcode -- )
[ d-insn ] curry (( d a simm -- )) define-declared ;
: D: CREATE scan-word define-d-insn ; parsing
: sd-insn ( d a simm opcode -- )
[ s>u16 { 0 21 16 } bitfield ] dip insn ;
: define-sd-insn ( word opcode -- )
[ sd-insn ] curry (( d a simm -- )) define-declared ;
: SD: CREATE scan-word define-sd-insn ; parsing
: i-insn ( li aa lk opcode -- )
[ { 0 1 0 } bitfield ] dip insn ;
: x-insn ( a s b rc xo opcode -- )
[ { 1 0 11 21 16 } bitfield ] dip insn ;
: (X) ( -- word quot )
CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
: X: (X) (( a s b -- )) define-declared ; parsing
: (1) ( quot -- quot' ) [ 0 ] prepose ;
: X1: (X) (1) (( a s -- )) define-declared ; parsing
: xfx-insn ( d spr xo opcode -- )
[ { 1 11 21 } bitfield ] dip insn ;
: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
: MFSPR:
CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
(( d -- )) define-declared ; parsing
: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
: MTSPR:
CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
(( d -- )) define-declared ; parsing
: xo-insn ( d a b oe rc xo opcode -- )
[ { 1 0 10 11 16 21 } bitfield ] dip insn ;
: (XO) ( -- word quot )
CREATE scan-word scan-word scan-word scan-word
[ xo-insn ] 2curry 2curry ;
: XO: (XO) (( a s b -- )) define-declared ; parsing
: XO1: (XO) (1) (( a s -- )) define-declared ; parsing
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;
M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
: CREATE-B ( -- word ) scan "B" prepend create-in ;
: BC:
CREATE-B scan-word scan-word
[ rot BC ] 2curry (( c -- )) define-declared ; parsing
: B:
CREATE-B scan-word scan-word scan-word scan-word scan-word
[ b-insn ] curry curry curry curry curry
(( bo -- )) define-declared ; parsing

313
core/cpu/ppc/bootstrap.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel kernel.private namespaces
cpu.ppc.assembler generator.fixup compiler.units system cpu.ppc.assembler generator.fixup compiler.units
compiler.constants math layouts words vocabs ; compiler.constants math math.private layouts words words.private
vocabs slots.private ;
IN: bootstrap.ppc IN: bootstrap.ppc
4 \ cell set 4 \ cell set
@ -11,9 +12,7 @@ big-endian on
4 jit-code-format set 4 jit-code-format set
: ds-reg 14 ; : ds-reg 14 ;
: quot-reg 3 ; : rs-reg 15 ;
: temp-reg 6 ;
: aux-reg 11 ;
: factor-area-size 4 bootstrap-cells ; : factor-area-size 4 bootstrap-cells ;
@ -24,86 +23,286 @@ big-endian on
: xt-save stack-frame 2 bootstrap-cells - ; : xt-save stack-frame 2 bootstrap-cells - ;
[ [
! Load word 0 6 LOAD32
0 temp-reg LOAD32 6 dup 0 LWZ
temp-reg dup 0 LWZ 11 6 profile-count-offset LWZ
! Bump profiling counter 11 11 1 tag-fixnum ADDI
aux-reg temp-reg profile-count-offset LWZ 11 6 profile-count-offset STW
aux-reg dup 1 tag-fixnum ADDI 11 6 word-code-offset LWZ
aux-reg temp-reg profile-count-offset STW 11 11 compiled-header-size ADDI
! Load word->code 11 MTCTR
aux-reg temp-reg word-code-offset LWZ
! Compute word XT
aux-reg dup compiled-header-size ADDI
! Jump to XT
aux-reg MTCTR
BCTR BCTR
] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define ] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define
[ [
0 temp-reg LOAD32 ! load XT 0 6 LOAD32
0 MFLR ! load return address 0 MFLR
1 1 stack-frame neg ADDI ! create stack frame 1 1 stack-frame SUBI
temp-reg 1 xt-save STW ! save XT 6 1 xt-save STW
stack-frame temp-reg LI ! load frame size stack-frame 6 LI
temp-reg 1 next-save STW ! save frame size 6 1 next-save STW
0 1 lr-save stack-frame + STW ! save return address 0 1 lr-save stack-frame + STW
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
[ [
0 temp-reg LOAD32 ! load literal 0 6 LOAD32
temp-reg dup 0 LWZ ! indirection 6 dup 0 LWZ
temp-reg ds-reg 4 STWU ! push literal 6 ds-reg 4 STWU
] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define ] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define
[ [
0 temp-reg LOAD32 ! load primitive address 0 6 LOAD32
4 1 MR ! pass stack pointer to primitive 6 ds-reg 4 STWU
temp-reg MTCTR ! jump to primitive ] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
[
0 6 LOAD32
4 1 MR
6 MTCTR
BCTR BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define ] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
[ [ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
0 BL
] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
[ [ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
0 B
] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
: jit-call-quot ( -- ) : jit-call-quot ( -- )
temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt 4 3 quot-xt-offset LWZ
temp-reg MTCTR ! jump to quotation-xt 4 MTCTR
BCTR ; BCTR ;
[ [
0 quot-reg LOAD32 ! point quot-reg at false branch 0 3 LOAD32
temp-reg ds-reg 0 LWZ ! load boolean 6 ds-reg 0 LWZ
0 temp-reg \ f tag-number CMPI ! compare it with f 0 6 \ f tag-number CMPI
2 BNE ! skip next insn if its not f 2 BNE
quot-reg dup 4 ADDI ! point quot-reg at true branch 3 3 4 ADDI
quot-reg dup 0 LWZ ! load the branch 3 3 0 LWZ
ds-reg dup 4 SUBI ! pop boolean ds-reg dup 4 SUBI
jit-call-quot jit-call-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define ] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
[ [
0 quot-reg LOAD32 ! load dispatch array 0 3 LOAD32
quot-reg dup 0 LWZ ! indirection 3 3 0 LWZ
temp-reg ds-reg 0 LWZ ! load index 6 ds-reg 0 LWZ
temp-reg dup 1 SRAWI ! turn it into an array offset 6 6 1 SRAWI
quot-reg dup temp-reg ADD ! compute quotation location 3 3 6 ADD
quot-reg dup array-start-offset LWZ ! load quotation 3 3 array-start-offset LWZ
ds-reg dup 4 SUBI ! pop index ds-reg dup 4 SUBI
jit-call-quot jit-call-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
[ [
0 1 lr-save stack-frame + LWZ ! load return address 0 1 lr-save stack-frame + LWZ
1 1 stack-frame ADDI ! pop stack frame 1 1 stack-frame ADDI
0 MTLR ! get ready to return 0 MTLR
] f f f jit-epilog jit-define ] f f f jit-epilog jit-define
[ BLR ] f f f jit-return jit-define [ BLR ] f f f jit-return jit-define
! Sub-primitives
! Quotations and words
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
jit-call-quot
] f f f \ (call) define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 3 word-xt-offset LWZ
4 MTCTR
BCTR
] f f f \ (execute) define-sub-primitive
! Objects
[
3 ds-reg 0 LWZ
3 3 tag-mask get ANDI
3 3 tag-bits get SLWI
3 ds-reg 0 STW
] f f f \ tag define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZU
3 3 1 SRAWI
4 4 0 0 31 tag-bits get - RLWINM
4 3 3 LWZX
3 ds-reg 0 STW
] f f f \ slot define-sub-primitive
! Shufflers
[
ds-reg dup 4 SUBI
] f f f \ drop define-sub-primitive
[
ds-reg dup 8 SUBI
] f f f \ 2drop define-sub-primitive
[
ds-reg dup 12 SUBI
] f f f \ 3drop define-sub-primitive
[
3 ds-reg 0 LWZ
3 ds-reg 4 STWU
] f f f \ dup define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
ds-reg dup 8 ADDI
3 ds-reg 0 STW
4 ds-reg -4 STW
] f f f \ 2dup define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
5 ds-reg -8 LWZ
ds-reg dup 12 ADDI
3 ds-reg 0 STW
4 ds-reg -4 STW
5 ds-reg -8 STW
] f f f \ 3dup define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
3 ds-reg 0 STW
] f f f \ nip define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 8 SUBI
3 ds-reg 0 STW
] f f f \ 2nip define-sub-primitive
[
3 ds-reg -4 LWZ
3 ds-reg 4 STWU
] f f f \ over define-sub-primitive
[
3 ds-reg -8 LWZ
3 ds-reg 4 STWU
] f f f \ pick define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
4 ds-reg 0 STW
3 ds-reg 4 STWU
] f f f \ dupd define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
3 ds-reg 4 STWU
4 ds-reg -4 STW
3 ds-reg -8 STW
] f f f \ tuck define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
3 ds-reg -4 STW
4 ds-reg 0 STW
] f f f \ swap define-sub-primitive
[
3 ds-reg -4 LWZ
4 ds-reg -8 LWZ
3 ds-reg -8 STW
4 ds-reg -4 STW
] f f f \ swapd define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
5 ds-reg -8 LWZ
4 ds-reg -8 STW
3 ds-reg -4 STW
5 ds-reg 0 STW
] f f f \ rot define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
5 ds-reg -8 LWZ
3 ds-reg -8 STW
5 ds-reg -4 STW
4 ds-reg 0 STW
] f f f \ -rot define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
3 rs-reg 4 STWU
] f f f \ >r define-sub-primitive
[
3 rs-reg 0 LWZ
rs-reg dup 4 SUBI
3 ds-reg 4 STWU
] f f f \ r> define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
0 3 LOAD32
3 3 0 LWZ
4 ds-reg 0 LWZ
5 ds-reg -4 LWZU
5 0 4 CMP
2 swap execute ! magic number
\ f tag-number 3 LI
3 ds-reg 0 STW ;
: define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip
define-sub-primitive ;
\ BEQ \ eq? define-jit-compare
\ BGE \ fixnum>= define-jit-compare
\ BLE \ fixnum<= define-jit-compare
\ BGT \ fixnum> define-jit-compare
\ BLT \ fixnum< define-jit-compare
! Math
: jit-math ( insn -- )
3 ds-reg 0 LWZ
4 ds-reg -4 LWZU
[ 5 3 4 ] dip execute
5 ds-reg 0 STW ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZU
4 4 tag-bits get SRAWI
5 3 4 MULLW
5 ds-reg 0 STW
] f f f \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
[
3 ds-reg 0 LWZ
3 3 NOT
3 3 tag-mask get XORI
3 ds-reg 0 STW
] f f f \ fixnum-bitnot define-sub-primitive
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

32
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -1,14 +1,13 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler USING: accessors alien alien.accessors alien.c-types arrays
cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
kernel.private math math.private namespaces sequences words cpu.architecture kernel kernel.private math math.private
generic quotations byte-arrays hashtables hashtables.private namespaces sequences words generic quotations byte-arrays
generator generator.registers generator.fixup sequences.private hashtables hashtables.private generator generator.registers
sbufs vectors system layouts math.floats.private generator.fixup sequences.private sbufs vectors system layouts
classes classes.tuple classes.tuple.private sbufs.private math.floats.private classes slots.private combinators
vectors.private strings.private slots.private combinators compiler.constants optimizer.allot ;
compiler.constants ;
IN: cpu.ppc.intrinsics IN: cpu.ppc.intrinsics
: %slot-literal-known-tag : %slot-literal-known-tag
@ -445,38 +444,33 @@ IN: cpu.ppc.intrinsics
! Store tagged ptr in reg ! Store tagged ptr in reg
"tuple" get tuple %store-tagged "tuple" get tuple %store-tagged
] H{ ] H{
{ +input+ { { [ tuple-layout? ] "layout" } } } { +input+ { { [ ] "layout" } } }
{ +scratch+ { { f "tuple" } } } { +scratch+ { { f "tuple" } } }
{ +output+ { "tuple" } } { +output+ { "tuple" } }
} define-intrinsic } define-intrinsic
\ <array> [ \ (array) [
array "n" get 2 + cells %allot array "n" get 2 + cells %allot
! Store length ! Store length
"n" operand 12 LI "n" operand 12 LI
12 11 cell STW 12 11 cell STW
! Store initial element
"n" get [ "initial" operand 11 rot 2 + cells STW ] each
! Store tagged ptr in reg ! Store tagged ptr in reg
"array" get object %store-tagged "array" get object %store-tagged
] H{ ] H{
{ +input+ { { [ inline-array? ] "n" } { f "initial" } } } { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } } { +scratch+ { { f "array" } } }
{ +output+ { "array" } } { +output+ { "array" } }
} define-intrinsic } define-intrinsic
\ <byte-array> [ \ (byte-array) [
byte-array "n" get 2 cells + %allot byte-array "n" get 2 cells + %allot
! Store length ! Store length
"n" operand 12 LI "n" operand 12 LI
12 11 cell STW 12 11 cell STW
! Store initial element
0 12 LI
"n" get cell align cell /i [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg ! Store tagged ptr in reg
"array" get object %store-tagged "array" get object %store-tagged
] H{ ] H{
{ +input+ { { [ inline-array? ] "n" } } } { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } } { +scratch+ { { f "array" } } }
{ +output+ { "array" } } { +output+ { "array" } }
} define-intrinsic } define-intrinsic

17
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -6,8 +6,7 @@ kernel.private math math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system sbufs sbufs.private vectors vectors.private layouts system
classes.tuple.private strings.private slots.private strings.private slots.private compiler.constants optimizer.allot ;
compiler.constants ;
IN: cpu.x86.intrinsics IN: cpu.x86.intrinsics
! Type checks ! Type checks
@ -298,37 +297,33 @@ IN: cpu.x86.intrinsics
"tuple" get tuple %store-tagged "tuple" get tuple %store-tagged
] %allot ] %allot
] H{ ] H{
{ +input+ { { [ tuple-layout? ] "layout" } } } { +input+ { { [ ] "layout" } } }
{ +scratch+ { { f "tuple" } { f "scratch" } } } { +scratch+ { { f "tuple" } { f "scratch" } } }
{ +output+ { "tuple" } } { +output+ { "tuple" } }
} define-intrinsic } define-intrinsic
\ <array> [ \ (array) [
array "n" get 2 + cells [ array "n" get 2 + cells [
! Store length ! Store length
1 object@ "n" operand MOV 1 object@ "n" operand MOV
! Zero out the rest of the tuple
"n" get [ 2 + object@ "initial" operand MOV ] each
! Store tagged ptr in reg ! Store tagged ptr in reg
"array" get object %store-tagged "array" get object %store-tagged
] %allot ] %allot
] H{ ] H{
{ +input+ { { [ inline-array? ] "n" } { f "initial" } } } { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } } { +scratch+ { { f "array" } } }
{ +output+ { "array" } } { +output+ { "array" } }
} define-intrinsic } define-intrinsic
\ <byte-array> [ \ (byte-array) [
byte-array "n" get 2 cells + [ byte-array "n" get 2 cells + [
! Store length ! Store length
1 object@ "n" operand MOV 1 object@ "n" operand MOV
! Store initial element
"n" get cell align cell /i [ 2 + object@ 0 MOV ] each
! Store tagged ptr in reg ! Store tagged ptr in reg
"array" get object %store-tagged "array" get object %store-tagged
] %allot ] %allot
] H{ ] H{
{ +input+ { { [ inline-array? ] "n" } } } { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } } { +scratch+ { { f "array" } } }
{ +output+ { "array" } } { +output+ { "array" } }
} define-intrinsic } define-intrinsic

6
core/debugger/debugger.factor
View File

@ -212,6 +212,12 @@ M: not-a-tuple summary
M: bad-superclass summary M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ; drop "Tuple classes can only inherit from other tuple classes" ;
M: no-initial-value summary
drop "Initial value must be provided for slots specialized to this class" ;
M: bad-initial-value summary
drop "Incompatible initial value" ;
M: no-cond summary M: no-cond summary
drop "Fall-through in cond" ; drop "Fall-through in cond" ;

5
core/hashtables/hashtables-docs.factor
View File

@ -93,11 +93,6 @@ HELP: hash-deleted+
{ $description "Called to increment the deleted entry counter when an entry is removed with " { $link delete-at } } { $description "Called to increment the deleted entry counter when an entry is removed with " { $link delete-at } }
{ $side-effects "hash" } ; { $side-effects "hash" } ;
HELP: (set-hash)
{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } { "new?" "a boolean" } }
{ $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. User code should use " { $link set-at } " instead, which grows the hashtable if necessary." }
{ $side-effects "hash" } ;
HELP: grow-hash HELP: grow-hash
{ $values { "hash" hashtable } } { $values { "hash" hashtable } }
{ $description "Enlarges the capacity of a hashtable. User code does not need to call this word directly." } { $description "Enlarges the capacity of a hashtable. User code does not need to call this word directly." }

13
core/hashtables/hashtables-tests.factor
View File

@ -164,3 +164,16 @@ H{ } "x" set
[ { "one" "two" 3 } ] [ [ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test ] unit-test
! We want this to work
[ ] [ hashtable new "h" set ] unit-test
[ 0 ] [ "h" get assoc-size ] unit-test
[ f f ] [ "goo" "h" get at* ] unit-test
[ ] [ 1 2 "h" get set-at ] unit-test
[ 1 ] [ "h" get assoc-size ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test

29
core/hashtables/hashtables.factor
View File

@ -20,15 +20,18 @@ TUPLE: hashtable
: probe ( array i -- array i ) : probe ( array i -- array i )
2 fixnum+fast over wrap ; inline 2 fixnum+fast over wrap ; inline
: (key@) ( key keys i -- array n ? ) : no-key ( key array -- array n ? ) nip f f ; inline
: (key@) ( key array i -- array n ? )
3dup swap array-nth 3dup swap array-nth
dup ((empty)) eq? dup ((empty)) eq?
[ 3drop nip f f ] [ [ 3drop no-key ] [
= [ rot drop t ] [ probe (key@) ] if = [ rot drop t ] [ probe (key@) ] if
] if ; inline ] if ; inline
: key@ ( key hash -- array n ? ) : key@ ( key hash -- array n ? )
array>> 2dup hash@ (key@) ; inline array>> dup array-capacity 0 eq?
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array ) : <hash-array> ( n -- array )
1+ next-power-of-2 4 * ((empty)) <array> ; inline 1+ next-power-of-2 4 * ((empty)) <array> ; inline
@ -63,25 +66,20 @@ TUPLE: hashtable
: hash-deleted+ ( hash -- ) : hash-deleted+ ( hash -- )
[ 1+ ] change-deleted drop ; inline [ 1+ ] change-deleted drop ; inline
: (set-hash) ( value key hash -- new? )
2dup new-key@
[ rot hash-count+ set-nth-pair t ]
[ rot drop set-nth-pair f ] if ; inline
: (rehash) ( hash alist -- ) : (rehash) ( hash alist -- )
swap [ swapd (set-hash) drop ] curry assoc-each ; swap [ swapd set-at ] curry assoc-each ; inline
: hash-large? ( hash -- ? ) : hash-large? ( hash -- ? )
[ count>> 3 fixnum*fast ] [ count>> 3 fixnum*fast 1 fixnum+fast ]
[ array>> array-capacity ] bi > ; [ array>> array-capacity ] bi fixnum> ; inline
: hash-stale? ( hash -- ? ) : hash-stale? ( hash -- ? )
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- ) : grow-hash ( hash -- )
[ dup >alist swap assoc-size 1+ ] keep [ dup >alist swap assoc-size 1+ ] keep
[ reset-hash ] keep [ reset-hash ] keep
swap (rehash) ; swap (rehash) ; inline
: ?grow-hash ( hash -- ) : ?grow-hash ( hash -- )
dup hash-large? [ dup hash-large? [
@ -122,7 +120,10 @@ M: hashtable assoc-size ( hash -- n )
r> (rehash) ; r> (rehash) ;
M: hashtable set-at ( value key hash -- ) M: hashtable set-at ( value key hash -- )
dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ; dup ?grow-hash
2dup new-key@
[ rot hash-count+ set-nth-pair ]
[ rot drop set-nth-pair ] if ;
: associate ( value key -- hash ) : associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ; 2 <hashtable> [ set-at ] keep ;

19
core/heaps/heaps.factor
View File

@ -5,8 +5,6 @@ USING: kernel math sequences arrays assocs sequences.private
growable accessors math.order ; growable accessors math.order ;
IN: heaps IN: heaps
MIXIN: priority-queue
GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop* ( heap -- )
@ -36,13 +34,10 @@ TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ; : <max-heap> ( -- max-heap ) max-heap <heap> ;
INSTANCE: min-heap priority-queue M: heap heap-empty? ( heap -- ? )
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
data>> empty? ; data>> empty? ;
M: priority-queue heap-size ( heap -- n ) M: heap heap-size ( heap -- n )
data>> length ; data>> length ;
<PRIVATE <PRIVATE
@ -152,7 +147,7 @@ DEFER: down-heap
PRIVATE> PRIVATE>
M: priority-queue heap-push* ( value key heap -- entry ) M: heap heap-push* ( value key heap -- entry )
[ <entry> dup ] keep [ data-push ] keep up-heap ; [ <entry> dup ] keep [ data-push ] keep up-heap ;
: heap-push ( value key heap -- ) heap-push* drop ; : heap-push ( value key heap -- ) heap-push* drop ;
@ -163,7 +158,7 @@ M: priority-queue heap-push* ( value key heap -- entry )
: >entry< ( entry -- key value ) : >entry< ( entry -- key value )
[ value>> ] [ key>> ] bi ; [ value>> ] [ key>> ] bi ;
M: priority-queue heap-peek ( heap -- value key ) M: heap heap-peek ( heap -- value key )
data-first >entry< ; data-first >entry< ;
: entry>index ( entry heap -- n ) : entry>index ( entry heap -- n )
@ -172,7 +167,7 @@ M: priority-queue heap-peek ( heap -- value key )
] unless ] unless
entry-index ; entry-index ;
M: priority-queue heap-delete ( entry heap -- ) M: heap heap-delete ( entry heap -- )
[ entry>index ] keep [ entry>index ] keep
2dup heap-size 1- = [ 2dup heap-size 1- = [
nip data-pop* nip data-pop*
@ -182,10 +177,10 @@ M: priority-queue heap-delete ( entry heap -- )
down-heap down-heap
] if ; ] if ;
M: priority-queue heap-pop* ( heap -- ) M: heap heap-pop* ( heap -- )
dup data-first swap heap-delete ; dup data-first swap heap-delete ;
M: priority-queue heap-pop ( heap -- value key ) M: heap heap-pop ( heap -- value key )
dup data-first [ swap heap-delete ] keep >entry< ; dup data-first [ swap heap-delete ] keep >entry< ;
: heap-pop-all ( heap -- alist ) : heap-pop-all ( heap -- alist )

3
core/inference/known-words/known-words.factor
View File

@ -540,9 +540,6 @@ set-primitive-effect
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect \ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable \ <tuple> make-flushable
\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
\ (tuple) make-flushable
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect \ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
\ <tuple-layout> make-foldable \ <tuple-layout> make-foldable

45
core/inspector/inspector.factor
View File

@ -33,10 +33,10 @@ SYMBOL: +editable+
: write-value ( mirror key -- ) : write-value ( mirror key -- )
<value-ref> write-slot-editor ; <value-ref> write-slot-editor ;
: describe-row ( obj key n -- ) : describe-row ( mirror key n -- )
[ [
+number-rows+ get [ pprint-cell ] [ drop ] if +number-rows+ get [ pprint-cell ] [ drop ] if
2dup write-key write-value [ write-key ] [ write-value ] 2bi
] with-row ; ] with-row ;
: summary. ( obj -- ) [ summary ] keep write-object nl ; : summary. ( obj -- ) [ summary ] keep write-object nl ;
@ -48,21 +48,19 @@ SYMBOL: +editable+
sort-keys values sort-keys values
] [ keys ] if ; ] [ keys ] if ;
: describe* ( obj flags -- ) : describe* ( obj mirror keys -- )
clone [ rot summary.
dup summary. dup empty? [
make-mirror dup sorted-keys dup empty? [ 2drop
2drop ] [
] [ dup enum? [ +sequence+ on ] when
dup enum? [ +sequence+ on ] when standard-table-style [
standard-table-style [ swap [ -rot describe-row ] curry each-index
dup length ] tabular-output
rot [ -rot describe-row ] curry 2each ] if ;
] tabular-output
] if
] bind ;
: describe ( obj -- ) H{ } describe* ; : describe ( obj -- )
dup make-mirror dup sorted-keys describe* ;
M: tuple error. describe ; M: tuple error. describe ;
@ -78,19 +76,21 @@ M: tuple error. describe ;
SYMBOL: inspector-hook SYMBOL: inspector-hook
[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global [ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
SYMBOL: inspector-stack SYMBOL: inspector-stack
SYMBOL: me SYMBOL: me
: reinspect ( obj -- ) : reinspect ( obj -- )
dup me set [ me set ]
dup make-mirror dup mirror set keys \ keys set [
inspector-hook get call ; dup make-mirror dup mirror set dup sorted-keys dup \ keys set
inspector-hook get call
] bi ;
: (inspect) ( obj -- ) : (inspect) ( obj -- )
dup inspector-stack get push reinspect ; [ inspector-stack get push ] [ reinspect ] bi ;
: key@ ( n -- key ) \ keys get nth ; : key@ ( n -- key ) \ keys get nth ;
@ -123,6 +123,7 @@ SYMBOL: me
"&add ( value key -- ) add new slot" print "&add ( value key -- ) add new slot" print
"&delete ( n -- ) remove a slot" print "&delete ( n -- ) remove a slot" print
"&rename ( key n -- ) change a slot's key" print "&rename ( key n -- ) change a slot's key" print
"&globals ( -- ) inspect global namespace" print
"&help -- display this message" print "&help -- display this message" print
nl ; nl ;
@ -133,3 +134,5 @@ SYMBOL: me
: inspect ( obj -- ) : inspect ( obj -- )
inspector-stack get [ (inspect) ] [ inspector ] if ; inspector-stack get [ (inspect) ] [ inspector ] if ;
: &globals ( -- ) global inspect ;

100
core/optimizer/allot/allot.factor Normal file
View File

@ -0,0 +1,100 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences sequences.private classes.tuple
classes.tuple.private kernel effects words quotations namespaces
definitions math math.order layouts alien.accessors
slots.private arrays byte-arrays inference.dataflow
inference.known-words inference.state optimizer.inlining
optimizer.backend ;
IN: optimizer.allot
! Expand memory allocation primitives into simpler constructs
! to simplify the backend.
: first-input ( #call -- obj ) dup in-d>> first node-literal ;
: (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ;
\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
\ (tuple) make-flushable
! if the input to new is a literal tuple class, we can expand it
: literal-new? ( #call -- ? )
first-input tuple-class? ;
: new-quot ( class -- quot )
dup all-slots 1 tail ! delegate slot
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
: expand-new ( #call -- node )
dup first-input
[ +inlined+ depends-on ] [ new-quot ] bi
f splice-quot ;
\ new {
{ [ dup literal-new? ] [ expand-new ] }
} define-optimizers
: tuple-boa-quot ( layout -- quot )
[
dup ,
[ nip (tuple) ] %
size>> 1 - [ 3 + ] map <reversed>
[ [ set-slot ] curry [ keep ] curry % ] each
[ f over 2 set-slot ] %
] [ ] make ;
: expand-tuple-boa ( #call -- node )
dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
\ <tuple-boa> {
{ [ t ] [ expand-tuple-boa ] }
} define-optimizers
: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
\ (array) { integer } { array } <effect> set-primitive-effect
\ (array) make-flushable
: <array>-quot ( n -- quot )
[
dup ,
[ (array) ] %
[ \ 2dup , , [ swap set-array-nth ] % ] each
\ 2nip ,
] [ ] make ;
: literal-<array>? ( #call -- ? )
first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
: expand-<array> ( #call -- node )
dup first-input <array>-quot f splice-quot ;
\ <array> {
{ [ dup literal-<array>? ] [ expand-<array> ] }
} define-optimizers
: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
\ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
\ (byte-array) make-flushable
: bytes>cells ( m -- n ) cell align cell /i ;
: <byte-array>-quot ( n -- quot )
[
dup ,
[ nip (byte-array) ] %
bytes>cells [ cell * ] map
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
] [ ] make ;
: literal-<byte-array>? ( #call -- ? )
first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
: expand-<byte-array> ( #call -- node )
dup first-input <byte-array>-quot f splice-quot ;
\ <byte-array> {
{ [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }
} define-optimizers

33
core/optimizer/known-words/known-words.factor
View File

@ -9,7 +9,7 @@ classes.tuple classes.predicate classes.tuple.private classes
classes.algebra sequences.private combinators byte-arrays classes.algebra sequences.private combinators byte-arrays
byte-vectors slots.private inference.dataflow inference.state byte-vectors slots.private inference.dataflow inference.state
inference.class optimizer.def-use optimizer.backend inference.class optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining ; optimizer.pattern-match optimizer.inlining optimizer.allot ;
IN: optimizer.known-words IN: optimizer.known-words
{ <tuple> <tuple-boa> (tuple) } [ { <tuple> <tuple-boa> (tuple) } [
@ -25,37 +25,6 @@ IN: optimizer.known-words
dup class? [ drop tuple ] unless 1array f dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop ] "output-classes" set-word-prop
! if the input to new is a literal tuple class, we can expand it
: literal-new? ( #call -- ? )
dup in-d>> first node-literal tuple-class? ;
: new-quot ( class -- quot )
dup all-slots 1 tail ! delegate slot
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
: expand-new ( #call -- node )
dup dup in-d>> first node-literal
[ +inlined+ depends-on ] [ new-quot ] bi
f splice-quot ;
\ new {
{ [ dup literal-new? ] [ expand-new ] }
} define-optimizers
: tuple-boa-quot ( layout -- quot )
[ (tuple) ]
swap size>> 1 - [ 3 + ] map <reversed>
[ [ set-slot ] curry [ keep ] curry ] map concat
[ f over 2 set-slot ]
3append ;
: expand-tuple-boa ( #call -- node )
dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
\ <tuple-boa> {
{ [ t ] [ expand-tuple-boa ] }
} define-optimizers
! the output of clone has the same type as the input ! the output of clone has the same type as the input
{ clone (clone) } [ { clone (clone) } [
[ [

15
core/optimizer/math/math.factor
View File

@ -406,7 +406,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
: convert-mod-to-and ( #call -- node ) : convert-mod-to-and ( #call -- node )
dup dup
dup node-in-d second node-literal 1- dup in-d>> second node-literal 1-
[ nip bitand ] curry f splice-quot ; [ nip bitand ] curry f splice-quot ;
\ mod [ \ mod [
@ -438,6 +438,19 @@ most-negative-fixnum most-positive-fixnum [a,b]
} }
} define-optimizers } define-optimizers
: convert-*-to-shift? ( #call -- ? )
dup in-d>> second node-literal
dup integer? [ power-of-2? ] [ drop f ] if ;
: convert-*-to-shift ( #call -- ? )
dup dup in-d>> second node-literal log2
[ nip fixnum-shift-fast ] curry
f splice-quot ;
\ fixnum*fast {
{ [ dup convert-*-to-shift? ] [ convert-*-to-shift ] }
} define-optimizers
{ + - * / } { + - * / }
[ { number number } "input-classes" set-word-prop ] each [ { number number } "input-classes" set-word-prop ] each

7
core/optimizer/optimizer-tests.factor
View File

@ -384,3 +384,10 @@ PREDICATE: list < improper-list
[ 1 [ "hi" + drop ] compile-call ] must-fail [ 1 [ "hi" + drop ] compile-call ] must-fail
[ "hi" f [ <array> drop ] compile-call ] must-fail [ "hi" f [ <array> drop ] compile-call ] must-fail
TUPLE: some-tuple x ;
: allot-regression ( a -- b )
[ ] curry some-tuple boa ;
[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test

5
core/optimizer/optimizer.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math optimizer.control optimizer.known-words optimizer.math optimizer.allot
optimizer.collect optimizer.inlining inference.class ; optimizer.control optimizer.collect optimizer.inlining
inference.class ;
IN: optimizer IN: optimizer
: optimize-1 ( node -- newnode ? ) : optimize-1 ( node -- newnode ? )

21
core/prettyprint/prettyprint.factor
View File

@ -277,13 +277,32 @@ M: array pprint-slot-name
f <inset unclip text pprint-elements block> f <inset unclip text pprint-elements block>
\ } pprint-word block> ; \ } pprint-word block> ;
: unparse-slot ( slot-spec -- array )
[
dup name>> ,
dup class>> object eq? [
dup class>> ,
initial: ,
dup initial>> ,
] unless
dup read-only>> [
read-only ,
] when
drop
] { } make ;
: pprint-slot ( slot-spec -- )
unparse-slot
dup length 1 = [ first ] when
pprint-slot-name ;
M: tuple-class see-class* M: tuple-class see-class*
<colon \ TUPLE: pprint-word <colon \ TUPLE: pprint-word
dup pprint-word dup pprint-word
dup superclass tuple eq? [ dup superclass tuple eq? [
"<" text dup superclass pprint-word "<" text dup superclass pprint-word
] unless ] unless
<block slot-names [ pprint-slot-name ] each block> <block "slots" word-prop [ pprint-slot ] each block>
pprint-; block> ; pprint-; block> ;
M: word see-class* drop ; M: word see-class* drop ;

50
core/sequences/sequences-docs.factor
View File

@ -124,16 +124,28 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection each } { $subsection each }
{ $subsection reduce } { $subsection reduce }
{ $subsection interleave } { $subsection interleave }
{ $subsection 2each }
{ $subsection 2reduce }
"Mapping:" "Mapping:"
{ $subsection map } { $subsection map }
{ $subsection 2map } { $subsection map-as }
{ $subsection accumulate } { $subsection accumulate }
{ $subsection produce } { $subsection produce }
"Filtering:" "Filtering:"
{ $subsection push-if } { $subsection push-if }
{ $subsection filter } ; { $subsection filter }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection contains? }
{ $subsection all? }
"Testing how elements are related:"
{ $subsection monotonic? }
{ $subsection "sequence-2combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
{ $subsection 2each }
{ $subsection 2reduce }
{ $subsection 2map }
{ $subsection 2map-as }
{ $subsection 2all? } ;
ARTICLE: "sequences-tests" "Testing sequences" ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:" "Testing for an empty sequence:"
@ -147,12 +159,7 @@ ARTICLE: "sequences-tests" "Testing sequences"
{ $subsection head? } { $subsection head? }
{ $subsection tail? } { $subsection tail? }
{ $subsection subseq? } { $subsection subseq? }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection contains? }
{ $subsection all? }
{ $subsection 2all? }
"Testing how elements are related:" "Testing how elements are related:"
{ $subsection monotonic? }
{ $subsection all-eq? } { $subsection all-eq? }
{ $subsection all-equal? } ; { $subsection all-equal? } ;
@ -456,6 +463,15 @@ HELP: map
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } } { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ; { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: map-as
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
{ $example "USING: prettyprint strings sequences ;" "\"Hello\" [ 1string ] { } map-as ." "{ \"H\" \"e\" \"l\" \"l\" \"o\" }" }
"Note that " { $link map } " could not be used here, because it would create another string to hold results, and one-element strings cannot themselves be elements of strings."
} ;
HELP: change-nth HELP: change-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } } { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." } { $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
@ -478,8 +494,7 @@ HELP: max-length
HELP: 2each HELP: 2each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } } { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } }
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } { $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
HELP: 2reduce HELP: 2reduce
{ $values { "seq1" sequence } { $values { "seq1" sequence }
@ -488,18 +503,19 @@ HELP: 2reduce
{ "quot" "a quotation with stack effect " { "quot" "a quotation with stack effect "
{ $snippet "( prev elt1 elt2 -- next )" } } { $snippet "( prev elt1 elt2 -- next )" } }
{ "result" "the final result" } } { "result" "the final result" } }
{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } { $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
{ $notes "If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." } ;
HELP: 2map HELP: 2map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } } { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
HELP: 2map-as
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all? HELP: 2all?
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } } { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } { $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
HELP: find HELP: find
{ $values { "seq" sequence } { $values { "seq" sequence }

7
core/sequences/sequences.factor
View File

@ -383,10 +383,13 @@ PRIVATE>
: 2reduce ( seq1 seq2 identity quot -- result ) : 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline >r -rot r> 2each ; inline
: 2map ( seq1 seq2 quot -- newseq ) : 2map-as ( seq1 seq2 quot exemplar -- newseq )
pick >r (2each) over r> >r (2each) over r>
[ [ collect ] keep ] new-like ; inline [ [ collect ] keep ] new-like ; inline
: 2map ( seq1 seq2 quot -- newseq )
pick 2map-as ; inline
: 2all? ( seq1 seq2 quot -- ? ) : 2all? ( seq1 seq2 quot -- ? )
(2each) all-integers? ; inline (2each) all-integers? ; inline

8
core/sets/sets-docs.factor
View File

@ -8,6 +8,7 @@ $nl
{ $subsection prune } { $subsection prune }
"Test for duplicates:" "Test for duplicates:"
{ $subsection all-unique? } { $subsection all-unique? }
{ $subsection duplicates }
"Set operations on sequences:" "Set operations on sequences:"
{ $subsection diff } { $subsection diff }
{ $subsection intersect } { $subsection intersect }
@ -64,6 +65,13 @@ HELP: prune
{ $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ; } ;
HELP: duplicates
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence consisting of elements which occur more than once in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" }
} ;
HELP: all-unique? HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } } { $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." } { $description "Tests whether a sequence contains any repeated elements." }

3
core/sets/sets.factor
View File

@ -16,6 +16,9 @@ IN: sets
[ ] [ length <hashtable> ] [ length <vector> ] tri [ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ; [ [ (prune) ] 2curry each ] keep ;
: duplicates ( seq -- newseq )
H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ;
: gather ( seq quot -- newseq ) : gather ( seq quot -- newseq )
map concat prune ; inline map concat prune ; inline

13
core/slots/slots.factor
View File

@ -188,9 +188,14 @@ M: array make-slot
[ dup empty? not ] [ peel-off-attributes ] [ ] while drop [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
check-initial-value ; check-initial-value ;
: make-slots ( slots base -- specs ) M: slot-spec make-slot
over length [ + ] with map check-initial-value ;
[ [ make-slot ] dip >>offset ] 2map ;
: make-slots ( slots -- specs )
[ make-slot ] map ;
: finalize-slots ( specs base -- specs )
over length [ + ] with map [ >>offset ] 2map ;
: slot-named ( name specs -- spec/f ) : slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ; [ name>> = ] with find nip ;

2
core/words/words-docs.factor
View File

@ -140,8 +140,6 @@ $nl
{ { $snippet "\"constructor\"" } { $link "tuple-constructors" } } { { $snippet "\"constructor\"" } { $link "tuple-constructors" } }
{ { $snippet "\"slot-names\"" } { $link "tuples" } }
{ { $snippet "\"type\"" } { $link "builtin-classes" } } { { $snippet "\"type\"" } { $link "builtin-classes" } }
{ { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } } { { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } }

2
extra/bake/bake.factor
View File

@ -94,4 +94,4 @@ MACRO: bake ( seq -- quot ) [bake] ;
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing : `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing : `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
: `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing : `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

14
extra/benchmark/beust1/beust1.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.ranges math.parser math.vectors sets sequences
kernel io ;
IN: benchmark.beust1
: count-numbers ( max -- n )
1 [a,b] [ number>string all-unique? ] count ; inline
: beust ( -- )
10000000 count-numbers
number>string " unique numbers." append print ;
MAIN: beust

41
extra/benchmark/beust2/beust2.factor Normal file
View File

@ -0,0 +1,41 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.ranges math.parser sequences kernel io locals ;
IN: benchmark.beust2
! http://crazybob.org/BeustSequence.java.html
:: (count-numbers) ( remaining first value used max listener -- ? )
10 first - [| i |
[let* | digit [ i first + ]
mask [ digit 2^ ]
value' [ i value + ] |
used mask bitand zero? [
value max > [ t ] [
remaining 1 <= [
listener call f
] [
remaining 1-
0
value' 10 *
used mask bitor
max
listener
(count-numbers)
] if
] if
] [ f ] if
]
] contains? ; inline
:: count-numbers ( max listener -- )
10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ;
inline
:: beust ( -- )
[let | i! [ 0 ] |
10000000000 [ i 1+ i! ] count-numbers
i number>string " unique numbers." append print
] ;
MAIN: beust

6
extra/color-picker/color-picker.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.parser models USING: kernel math math.functions math.parser models
models.filter models.range models.compose sequences ui models.filter models.range models.compose sequences ui
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.render math.geometry.rect ; ui.gadgets.sliders ui.render math.geometry.rect accessors ;
IN: color-picker IN: color-picker
! Simple example demonstrating the use of models. ! Simple example demonstrating the use of models.

44
extra/ctags/ctags-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.syntax help.markup kernel prettyprint sequences strings ; USING: help.syntax help.markup kernel prettyprint sequences strings words math ;
IN: ctags IN: ctags
ARTICLE: "ctags" "Ctags file" ARTICLE: "ctags" "Ctags file"
@ -6,7 +6,10 @@ ARTICLE: "ctags" "Ctags file"
{ $subsection ctags } { $subsection ctags }
{ $subsection ctags-write } { $subsection ctags-write }
{ $subsection ctag-strings } { $subsection ctag-strings }
{ $subsection ctag } ; { $subsection ctag }
{ $subsection ctag-word }
{ $subsection ctag-path }
{ $subsection ctag-lineno } ;
HELP: ctags ( path -- ) HELP: ctags ( path -- )
{ $values { "path" "a pathname string" } } { $values { "path" "a pathname string" } }
@ -57,4 +60,41 @@ HELP: ctag ( seq -- str )
} }
} ; } ;
HELP: ctag-lineno ( ctag -- n )
{ $values { "ctag" sequence }
{ "n" integer } }
{ $description "Provides de line number " { $snippet "n" } " from a sequence in ctag format " }
{ $examples
{ $example
"USING: kernel ctags prettyprint ;"
"{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-lineno ."
"91"
}
} ;
HELP: ctag-path ( ctag -- path )
{ $values { "ctag" sequence }
{ "path" string } }
{ $description "Provides a path string " { $snippet "path" } " from a sequence in ctag format" }
{ $examples
{ $example
"USING: kernel ctags prettyprint ;"
"{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-path ."
"\"resource:extra/unix/unix.factor\""
}
} ;
HELP: ctag-word ( ctag -- word )
{ $values { "ctag" sequence }
{ "word" word } }
{ $description "Provides the " { $snippet "word" } " from a sequence in ctag format " }
{ $examples
{ $example
"USING: kernel ctags prettyprint ;"
"{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-word ."
"if"
}
} ;
ABOUT: "ctags" ABOUT: "ctags"

16
extra/ctags/ctags-tests.factor
View File

@ -1,6 +1,21 @@
USING: kernel ctags tools.test io.backend sequences arrays prettyprint ; USING: kernel ctags tools.test io.backend sequences arrays prettyprint ;
IN: ctags.tests IN: ctags.tests
[ t ] [
91
{ if { "resource:extra/unix/unix.factor" 91 } } ctag-lineno =
] unit-test
[ t ] [
"resource:extra/unix/unix.factor"
{ if { "resource:extra/unix/unix.factor" 91 } } ctag-path =
] unit-test
[ t ] [
\ if
{ if { "resource:extra/unix/unix.factor" 91 } } ctag-word =
] unit-test
[ t ] [ [ t ] [
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append
{ if { "resource:extra/unix/unix.factor" 91 } } ctag = { if { "resource:extra/unix/unix.factor" 91 } } ctag =
@ -10,3 +25,4 @@ IN: ctags.tests
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings = { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings =
] unit-test ] unit-test

27
extra/ctags/ctags.factor
View File

@ -9,29 +9,36 @@ io.encodings.ascii math.parser vocabs definitions
namespaces words sorting ; namespaces words sorting ;
IN: ctags IN: ctags
: ctag-word ( ctag -- word )
first ;
: ctag-path ( ctag -- path )
second first ;
: ctag-lineno ( ctag -- n )
second second ;
: ctag ( seq -- str ) : ctag ( seq -- str )
[ [
dup first ?word-name % dup ctag-word ?word-name %
"\t" % "\t" %
second dup first normalize-path % dup ctag-path normalize-path %
"\t" % "\t" %
second number>string % ctag-lineno number>string %
] "" make ; ] "" make ;
: ctag-strings ( seq1 -- seq2 ) : ctag-strings ( seq1 -- seq2 )
{ } swap [ ctag suffix ] each ; [ ctag ] map ;
: ctags-write ( seq path -- ) : ctags-write ( seq path -- )
[ ctag-strings ] dip ascii set-file-lines ; [ ctag-strings ] dip ascii set-file-lines ;
: (ctags) ( -- seq ) : (ctags) ( -- seq )
{ } all-words [ all-words [
dup where [ dup where [
2array suffix 2array
] [ ] when*
drop ] map [ sequence? ] filter ;
] if*
] each ;
: ctags ( path -- ) : ctags ( path -- )
(ctags) sort-keys swap ctags-write ; (ctags) sort-keys swap ctags-write ;

1
extra/ctags/etags/authors.txt Normal file
View File

@ -0,0 +1 @@
Alfredo Beaumont

39
extra/ctags/etags/etags-docs.factor Normal file
View File

@ -0,0 +1,39 @@
USING: help.syntax help.markup kernel prettyprint sequences strings words math ;
IN: ctags.etags
ARTICLE: "etags" "Etags file"
{ $emphasis "Etags" } " generates a index file of every factor word in etags format as supported by emacs and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags#Etags_2" } "."
{ $subsection etags }
{ $subsection etags-write }
{ $subsection etag-strings }
{ $subsection etag-header }
HELP: etags ( path -- )
{ $values { "path" string } }
{ $description "Generates a index file in etags format and stores in " { $snippet "path" } "." }
{ $examples
{ $unchecked-example
"USING: ctags.etags ;"
"\"ETAGS\" etags"
""
}
} ;
HELP: etags-write ( alist path -- )
{ $values { "alist" sequence }
{ "path" string } }
{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with etags format: its key must be a resource path and its value a vector, containing pairs of words and lines" }
{ $examples
{ $unchecked-example
"USING: kernel etags.ctags ;"
"{ { \"resource:extra/unix/unix.factor\" V{ { dup2 91 } } } } \"ETAGS\" etags-write"
""
}
} ;
HELP: etag-strings ( alist -- seq )
{ $values { "alist" sequence }
{ "seq" sequence } }
{ $description "Converts an " { $snippet "alist" } " with etag format (a path as key and a vector containing word/line pairs) in a " { $snippet "seq" } " of strings." } ;
ABOUT: "etags" ;

72
extra/ctags/etags/etags-tests.factor Normal file
View File

@ -0,0 +1,72 @@
USING: kernel ctags ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ;
IN: ctags.etags.tests
! etag-at
[ t ]
[
V{ }
"path" H{ } clone etag-at =
] unit-test
[ t ]
[
V{ if { "path" 1 } }
"path" H{ { "path" V{ if { "path" 1 } } } } etag-at =
] unit-test
! etag-vector
[ t ]
[
V{ }
{ if { "path" 1 } } H{ } clone etag-vector =
] unit-test
[ t ]
[
V{ if { "path" 1 } }
{ if { "path" 1 } }
{ { "path" V{ if { "path" 1 } } } } >hashtable
etag-vector =
] unit-test
! etag-pair
[ t ]
[
{ if 28 }
{ if { "resource:core/kernel/kernel.factor" 28 } } etag-pair =
] unit-test
! etag-add
[ t ]
[
H{ { "path" V{ { if 1 } } } }
{ if { "path" 1 } } H{ } clone [ etag-add ] keep =
] unit-test
! etag-hash
[ t ]
[
H{ { "path" V{ { if 1 } } } }
{ { if { "path" 1 } } } etag-hash =
] unit-test
! line-bytes (note that for each line implicit \n is counted)
[ t ]
[
17
{ "1234567890" "12345" } 2 lines>bytes =
] unit-test
! etag
[ t ]
[
"if2,11"
{ "1234567890" "12345" } { if 2 } etag =
] unit-test
! etag-length
[ t ]
[
14
V{ "if2,11" "if2,11" } etag-length =
] unit-test

75
extra/ctags/etags/etags.factor Normal file
View File

@ -0,0 +1,75 @@
! Copyright (C) 2008 Alfredo Beaumont
! See http://factorcode.org/license.txt for BSD license.
! Emacs Etags generator
! Alfredo Beaumont <alfredo.beaumont@gmail.com>
USING: kernel sequences sorting assocs words prettyprint ctags
io.encodings.ascii io.files math math.parser namespaces strings locals
shuffle io.backend arrays ;
IN: ctags.etags
: etag-at ( key hash -- vector )
at [ V{ } clone ] unless* ;
: etag-vector ( alist hash -- vector )
[ ctag-path ] dip etag-at ;
: etag-pair ( ctag -- seq )
dup [
first ,
second second ,
] { } make ;
: etag-add ( ctag hash -- )
[ etag-vector ] 2keep [
[ etag-pair ] [ ctag-path ] bi [ suffix ] dip
] dip set-at ;
: etag-hash ( seq -- hash )
H{ } clone swap [ swap [ etag-add ] keep ] each ;
: lines>bytes ( seq n -- bytes )
head 0 [ length 1+ + ] reduce ;
: file>lines ( path -- lines )
ascii file-lines ;
: etag ( lines seq -- str )
[
dup first ?word-name %
1 HEX: 7f <string> %
second dup number>string %
1 CHAR: , <string> %
1- lines>bytes number>string %
] "" make ;
: etag-length ( vector -- n )
0 [ length + ] reduce ;
: (etag-header) ( n path -- str )
[
%
1 CHAR: , <string> %
number>string %
] "" make ;
: etag-header ( vec1 n resource -- vec2 )
normalize-path (etag-header) prefix
1 HEX: 0c <string> prefix ;
: etag-strings ( alist -- seq )
{ } swap [
[
[ first file>lines ]
[ second ] bi
[ etag ] with map
dup etag-length
] keep first
etag-header append
] each ;
: etags-write ( alist path -- )
[ etag-strings ] dip ascii set-file-lines ;
: etags ( path -- )
[ (ctags) sort-values etag-hash >alist ] dip etags-write ;

1
extra/ctags/etags/summary.txt Normal file
View File

@ -0,0 +1 @@
Etags generator

12
extra/delegate/delegate-tests.factor
View File

@ -79,3 +79,15 @@ CONSULT: beta hey value>> 1- ;
[ -1 ] [ 1 <hey> four ] unit-test [ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test [ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
[ f ] [ hey \ one method ] unit-test [ f ] [ hey \ one method ] unit-test
TUPLE: slot-protocol-test-1 a b ;
TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
TUPLE: slot-protocol-test-3 d ;
CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
[ "a" "b" 5 ] [
T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
[ a>> ] [ b>> ] [ c>> ] tri
] unit-test

10
extra/delegate/delegate.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Daniel Ehrenberg ! Copyright (C) 2007, 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions words slots assocs sequences arrays vectors definitions
@ -14,9 +14,11 @@ IN: delegate
GENERIC: group-words ( group -- words ) GENERIC: group-words ( group -- words )
M: tuple-class group-words M: tuple-class group-words
"slot-names" word-prop [ all-slots [
[ reader-word ] [ writer-word ] bi name>>
2array [ 0 2array ] map [ reader-word 0 2array ]
[ writer-word 0 2array ] bi
2array
] map concat ; ] map concat ;
! Consultation ! Consultation

19
extra/generalizations/generalizations-docs.factor
View File

@ -1,9 +1,21 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup kernel sequences quotations USING: help.syntax help.markup kernel sequences quotations
math ; math arrays ;
IN: generalizations IN: generalizations
HELP: narray
{ $values { "n" integer } }
{ $description "A generalization of " { $link 1array } ", "
{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
"that constructs an array from the top " { $snippet "n" } " elements of the stack."
} ;
HELP: firstn
{ $values { "n" integer } }
{ $description "A generalization of " { $link first } ", "
{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
} ;
HELP: npick HELP: npick
{ $values { "n" integer } } { $values { "n" integer } }
{ $description "A generalization of " { $link dup } ", " { $description "A generalization of " { $link dup } ", "
@ -119,6 +131,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"macros where the arity of the input quotations depends on an " "macros where the arity of the input quotations depends on an "
"input parameter." "input parameter."
{ $subsection narray } { $subsection narray }
{ $subsection firstn }
{ $subsection ndup } { $subsection ndup }
{ $subsection npick } { $subsection npick }
{ $subsection nrot } { $subsection nrot }

4
extra/generalizations/generalizations-tests.factor
View File

@ -32,3 +32,7 @@ IN: generalizations.tests
[ [ dup 2^ 2array ] 5 napply ] must-infer [ [ dup 2^ 2array ] 5 napply ] must-infer
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test [ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test

30
extra/generalizations/generalizations.factor
View File

@ -1,14 +1,20 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces math math.ranges USING: kernel sequences sequences.private namespaces math
combinators macros quotations fry locals arrays ; math.ranges combinators macros quotations fry arrays ;
IN: generalizations IN: generalizations
MACRO: narray ( n -- quot ) MACRO: narray ( n -- quot )
dup [ f <array> ] curry [ <reversed> ] [ '[ , f <array> ] ] bi
swap <reversed> [ [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;
[ swap [ set-nth-unsafe ] keep ] curry
] map concat append ; MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ , _ nth-unsafe ] ] map ]
[ 1- '[ , _ bounds-check 2drop ] ]
bi prefix '[ , cleave ]
] if ;
MACRO: npick ( n -- ) MACRO: npick ( n -- )
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
@ -32,7 +38,7 @@ MACRO: ntuck ( n -- )
2 + [ dupd -nrot ] curry ; 2 + [ dupd -nrot ] curry ;
MACRO: nrev ( n -- quot ) MACRO: nrev ( n -- quot )
1 [a,b] [ '[ , -nrot ] ] map concat ; 1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;
MACRO: ndip ( quot n -- ) MACRO: ndip ( quot n -- )
dup saver -rot restorer 3append ; dup saver -rot restorer 3append ;
@ -44,11 +50,11 @@ MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri [ ] [ 1+ ] [ ] tri
'[ [ , ndup ] dip , -nrot , nslip ] ; '[ [ , ndup ] dip , -nrot , nslip ] ;
MACRO: ncurry ( n -- ) [ curry ] n*quot ; MACRO: ncurry ( n -- )
[ curry ] n*quot ;
MACRO:: nwith ( quot n -- ) MACRO: nwith ( n -- )
[let | n' [ n 1+ ] | [ with ] n*quot ;
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
MACRO: napply ( n -- ) MACRO: napply ( n -- )
2 [a,b] 2 [a,b]

4
extra/geo-ip/geo-ip.factor
View File

@ -1,5 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences io.files io.launcher io.encodings.ascii USING: kernel sequences io.files io.launcher io.encodings.ascii
io.streams.string http.client sequences.lib combinators io.streams.string http.client generalizations combinators
math.parser math.vectors math.intervals interval-maps memoize math.parser math.vectors math.intervals interval-maps memoize
csv accessors assocs strings math splitting grouping arrays ; csv accessors assocs strings math splitting grouping arrays ;
IN: geo-ip IN: geo-ip

4
extra/math/ranges/ranges-docs.factor
View File

@ -4,8 +4,8 @@ IN: math.ranges
ARTICLE: "ranges" "Ranges" ARTICLE: "ranges" "Ranges"
"A " { $emphasis "range" } " is a virtual sequence with elements " "A " { $emphasis "range" } " is a virtual sequence with real elements "
"ranging from a to b by step." "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
$nl $nl

7
extra/models/models-docs.factor
View File

@ -134,7 +134,12 @@ $nl
"When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:" "When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:"
{ $subsection activate-model } { $subsection activate-model }
{ $subsection deactivate-model } { $subsection deactivate-model }
{ $subsection "models-impl" } ; { $subsection "models-impl" }
{ $subsection "models-filter" }
{ $subsection "models-compose" }
{ $subsection "models-history" }
{ $subsection "models-range" }
{ $subsection "models-delay" } ;
ARTICLE: "models-impl" "Implementing models" ARTICLE: "models-impl" "Implementing models"
"New types of models can be defined, for example see " { $vocab-link "models.filter" } "." "New types of models can be defined, for example see " { $vocab-link "models.filter" } "."

2
extra/namespaces/lib/lib.factor
View File

@ -2,7 +2,7 @@
! USING: kernel quotations namespaces sequences assocs.lib ; ! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences USING: kernel namespaces namespaces.private quotations sequences
assocs.lib math.parser math sequences.lib locals mirrors ; assocs.lib math.parser math generalizations locals mirrors ;
IN: namespaces.lib IN: namespaces.lib

1
extra/optimizer/debugger/debugger.factor
View File

@ -58,6 +58,7 @@ MATCH-VARS: ?a ?b ?c ;
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] } { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
{ { { ?a ?b } { ?a ?b ?a } } [ over ] } { { { ?a ?b } { ?a ?b ?a } } [ over ] }
{ { { ?b ?a } { ?a ?b } } [ swap ] } { { { ?b ?a } { ?a ?b } } [ swap ] }
{ { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }

5
extra/sequences/lib/lib-tests.factor
View File

@ -67,11 +67,6 @@ IN: sequences.lib.tests
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test [ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test [ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test

5
extra/sequences/lib/lib.factor
View File

@ -20,11 +20,6 @@ IN: sequences.lib
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: firstn ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map
concat >quotation
[ drop ] compose ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- ) : each-percent ( seq quot -- )

12
extra/tuple-arrays/tuple-arrays-docs.factor
View File

@ -1,9 +1,13 @@
USING: help.syntax help.markup splitting kernel ; USING: help.syntax help.markup splitting kernel sequences ;
IN: tuple-arrays IN: tuple-arrays
HELP: tuple-array HELP: tuple-array
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back.." } ; { $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
HELP: <tuple-array> HELP: <tuple-array>
{ $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } { $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ; { $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
HELP: >tuple-array
{ $values { "seq" sequence } { "tuple-array" tuple-array } }
{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;

10
extra/tuple-arrays/tuple-arrays-tests.factor
View File

@ -1,16 +1,20 @@
USING: tuple-arrays sequences tools.test namespaces kernel math ; USING: tuple-arrays sequences tools.test namespaces kernel math accessors ;
IN: tuple-arrays.tests IN: tuple-arrays.tests
SYMBOL: mat SYMBOL: mat
TUPLE: foo bar ; TUPLE: foo bar ;
C: <foo> foo C: <foo> foo
[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test [ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test [ T{ foo } ] [ mat get first ] unit-test
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test [ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ T{ foo f 3 } t ] [ T{ foo f 3 } t ]
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test [ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
[ 2 ] [ 2 T{ foo t } <tuple-array> dup mat set length ] unit-test [ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test [ T{ foo } ] [ mat get first ] unit-test
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test [ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
TUPLE: baz { bing integer } bong ;
[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test

21
extra/tuple-arrays/tuple-arrays.factor
View File

@ -4,27 +4,26 @@ USING: splitting grouping classes.tuple classes math kernel
sequences arrays accessors ; sequences arrays accessors ;
IN: tuple-arrays IN: tuple-arrays
TUPLE: tuple-array seq class ; TUPLE: tuple-array { seq read-only } { class read-only } ;
: <tuple-array> ( length example -- tuple-array ) : <tuple-array> ( length class -- tuple-array )
[ tuple>array length 1- [ * { } new-sequence ] keep <sliced-groups> ] [
[ class ] bi tuple-array boa ; new tuple>array 1 tail
[ <repetition> concat ] [ length ] bi <sliced-groups>
] [ ] bi tuple-array boa ;
M: tuple-array nth M: tuple-array nth
[ seq>> nth ] [ class>> ] bi prefix >tuple ; [ seq>> nth ] [ class>> ] bi prefix >tuple ;
: deconstruct ( tuple -- seq )
tuple>array 1 tail ;
M: tuple-array set-nth ( elt n seq -- ) M: tuple-array set-nth ( elt n seq -- )
>r >r deconstruct r> r> seq>> set-nth ; >r >r tuple>array 1 tail r> r> seq>> set-nth ;
M: tuple-array new-sequence M: tuple-array new-sequence
class>> new <tuple-array> ; class>> <tuple-array> ;
: >tuple-array ( seq -- tuple-array/seq ) : >tuple-array ( seq -- tuple-array )
dup empty? [ dup empty? [
0 over first <tuple-array> clone-like 0 over first class <tuple-array> clone-like
] unless ; ] unless ;
M: tuple-array like M: tuple-array like

2
extra/ui/gadgets/buttons/buttons.factor
View File

@ -230,5 +230,3 @@ M: radio-control model-changed
swap swap
"toolbar" over class command-map commands>> swap "toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ; [ -rot <command-button> add-gadget ] curry assoc-each ;
: toolbar, ( -- ) g <toolbar> f track, ;

10
extra/ui/gadgets/gadgets-docs.factor
View File

@ -186,15 +186,7 @@ HELP: make-gadget
HELP: with-gadget HELP: with-gadget
{ $values { "gadget" gadget } { "quot" quotation } } { $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ; { $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } } ;
HELP: g
{ $values { "gadget" gadget } }
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
HELP: g->
{ $values { "x" object } { "gadget" gadget } }
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
{ control-value set-control-value gadget-model } related-words { control-value set-control-value gadget-model } related-words

4
extra/ui/gadgets/gadgets.factor
View File

@ -357,10 +357,6 @@ M: f request-focus-on 2drop ;
: focus-path ( world -- seq ) : focus-path ( world -- seq )
[ focus>> ] follow ; [ focus>> ] follow ;
: g ( -- gadget ) gadget get ;
: g-> ( x -- x x gadget ) dup g ;
: with-gadget ( gadget quot -- ) : with-gadget ( gadget quot -- )
gadget swap with-variable ; inline gadget swap with-variable ; inline

2
extra/ui/gadgets/grids/grids.factor
View File

@ -24,6 +24,8 @@ grid
>r >r 2dup swap add-gadget drop r> r> >r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ; 3dup grid-child unparent rot grid>> nth set-nth ;
: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
: grid-remove ( grid i j -- ) : grid-remove ( grid i j -- )
>r >r >r <gadget> r> r> r> grid-add ; >r >r >r <gadget> r> r> r> grid-add ;

20
extra/ui/gadgets/labelled/labelled.factor
View File

@ -5,17 +5,16 @@ ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
ui.gadgets.grids io kernel math models namespaces prettyprint ui.gadgets.grids io kernel math models namespaces prettyprint
sequences sequences words classes.tuple ui.gadgets ui.render sequences sequences words classes.tuple ui.gadgets ui.render
colors ; colors accessors ;
IN: ui.gadgets.labelled IN: ui.gadgets.labelled
TUPLE: labelled-gadget < track content ; TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
{ 0 1 } labelled-gadget new-track { 0 1 } labelled-gadget new-track
[ swap <label> reverse-video-theme f track-add*
<label> reverse-video-theme f track, swap >>content
g-> set-labelled-gadget-content 1 track, dup content>> 1 track-add* ;
] make-gadget ;
M: labelled-gadget focusable-child* labelled-gadget-content ; M: labelled-gadget focusable-child* labelled-gadget-content ;
@ -50,10 +49,9 @@ TUPLE: closable-gadget < frame content ;
[ [ closable-gadget? ] is? ] find-parent ; [ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget ) : <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new-frame closable-gadget new-frame
[ -rot <title-bar> @top grid-add*
<title-bar> @top frame, swap >>content
g-> set-closable-gadget-content @center frame, dup content>> @center grid-add* ;
] make-gadget ;
M: closable-gadget focusable-child* closable-gadget-content ; M: closable-gadget focusable-child* closable-gadget-content ;

8
extra/ui/gadgets/labels/labels.factor
View File

@ -64,7 +64,11 @@ M: object >label ;
M: f >label drop <gadget> ; M: f >label drop <gadget> ;
: label-on-left ( gadget label -- button ) : label-on-left ( gadget label -- button )
[ >label f track, 1 track, ] { 1 0 } make-track ; { 1 0 } <track>
swap >label f track-add*
swap 1 track-add* ;
: label-on-right ( label gadget -- button ) : label-on-right ( label gadget -- button )
[ f track, >label 1 track, ] { 1 0 } make-track ; { 1 0 } <track>
swap f track-add*
swap >label 1 track-add* ;

19
extra/ui/gadgets/packs/packs-docs.factor
View File

@ -9,10 +9,6 @@ ARTICLE: "ui-pack-layout" "Pack layouts"
{ $subsection <pack> } { $subsection <pack> }
{ $subsection <pile> } { $subsection <pile> }
{ $subsection <shelf> } { $subsection <shelf> }
"Creating packs using a combinator:"
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
"For more control, custom layouts can reuse portions of pack layout logic:" "For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim } { $subsection pack-pref-dim }
@ -24,9 +20,6 @@ HELP: pack
{ $link <pack> } { $link <pack> }
{ $link <pile> } { $link <pile> }
{ $link <shelf> } { $link <shelf> }
{ $link make-pile }
{ $link make-filled-pile }
{ $link make-shelf }
} }
"Packs have the following slots:" "Packs have the following slots:"
{ $list { $list
@ -64,16 +57,4 @@ HELP: pack-pref-dim
"This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure." "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
} ; } ;
HELP: make-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the gadget, word." } ;
HELP: make-filled-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the gadget, word." } ;
HELP: make-shelf
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the gadget, word." } ;
ABOUT: "ui-pack-layout" ABOUT: "ui-pack-layout"

6
extra/ui/gadgets/packs/packs-tests.factor
View File

@ -5,10 +5,8 @@ kernel namespaces tools.test math.parser sequences math.geometry.rect ;
[ t ] [ [ t ] [
{ 0 0 } { 100 100 } <rect> clip set { 0 0 } { 100 100 } <rect> clip set
[ <pile>
100 [ number>string <label> gadget, ] each 100 [ number>string <label> add-gadget ] each
] make-pile
dup layout dup layout
visible-children [ label? ] all? visible-children [ label? ] all?

9
extra/ui/gadgets/packs/packs.factor
View File

@ -60,12 +60,3 @@ M: pack layout*
M: pack children-on ( rect gadget -- seq ) M: pack children-on ( rect gadget -- seq )
dup gadget-orientation swap gadget-children dup gadget-orientation swap gadget-children
[ fast-children-on ] keep <slice> ; [ fast-children-on ] keep <slice> ;
: make-pile ( quot -- pack )
<pile> swap make-gadget ; inline
: make-filled-pile ( quot -- pack )
<filled-pile> swap make-gadget ; inline
: make-shelf ( quot -- pack )
<shelf> swap make-gadget ; inline

30
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -29,30 +29,22 @@ scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] } { T{ mouse-scroll } [ do-mouse-scroll ] }
} set-gestures } set-gestures
: viewport, ( child -- )
g model>> <viewport>
g-> set-scroller-viewport @center frame, ;
: <scroller-model> ( -- model ) : <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ; 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
: x-model ( -- model ) g model>> dependencies>> first ;
: y-model ( -- model ) g model>> dependencies>> second ;
: new-scroller ( gadget class -- scroller ) : new-scroller ( gadget class -- scroller )
new-frame new-frame
t >>root? t >>root?
<scroller-model> >>model <scroller-model> >>model
faint-boundary faint-boundary
[
x-model <x-slider> g-> set-scroller-x @bottom frame,
y-model <y-slider> g-> set-scroller-y @right frame,
viewport,
] make-gadget ;
: <scroller> ( gadget -- scroller ) dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add*
scroller new-scroller ; dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add*
swap over model>> <viewport> >>viewport
dup viewport>> @center grid-add* ;
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
: scroll ( value scroller -- ) : scroll ( value scroller -- )
[ [

33
extra/ui/gadgets/sliders/sliders.factor
View File

@ -138,10 +138,11 @@ M: elevator layout*
[ swap find-slider slide-by-line ] curry <repeat-button> [ swap find-slider slide-by-line ] curry <repeat-button>
[ set-gadget-orientation ] keep ; [ set-gadget-orientation ] keep ;
: elevator, ( orientation -- ) : elevator, ( gadget orientation -- gadget )
dup <elevator> g-> set-slider-elevator tuck <elevator> >>elevator
swap <thumb> g-> set-slider-thumb add-gadget swap <thumb> >>thumb
@center frame, ; dup elevator>> over thumb>> add-gadget
@center grid-add* ;
: <left-button> ( -- button ) : <left-button> ( -- button )
{ 0 1 } arrow-left -1 <slide-button> ; { 0 1 } arrow-left -1 <slide-button> ;
@ -149,26 +150,12 @@ M: elevator layout*
: <right-button> ( -- button ) : <right-button> ( -- button )
{ 0 1 } arrow-right 1 <slide-button> ; { 0 1 } arrow-right 1 <slide-button> ;
: build-x-slider ( slider -- slider )
[
<left-button> @left frame,
{ 0 1 } elevator,
<right-button> @right frame,
] make-gadget ; inline
: <up-button> ( -- button ) : <up-button> ( -- button )
{ 1 0 } arrow-up -1 <slide-button> ; { 1 0 } arrow-up -1 <slide-button> ;
: <down-button> ( -- button ) : <down-button> ( -- button )
{ 1 0 } arrow-down 1 <slide-button> ; { 1 0 } arrow-down 1 <slide-button> ;
: build-y-slider ( slider -- slider )
[
<up-button> @top frame,
{ 1 0 } elevator,
<down-button> @bottom frame,
] make-gadget ; inline
: <slider> ( range orientation -- slider ) : <slider> ( range orientation -- slider )
slider new-frame slider new-frame
swap >>orientation swap >>orientation
@ -176,10 +163,16 @@ M: elevator layout*
32 >>line ; 32 >>line ;
: <x-slider> ( range -- slider ) : <x-slider> ( range -- slider )
{ 1 0 } <slider> build-x-slider ; { 1 0 } <slider>
<left-button> @left grid-add*
{ 0 1 } elevator,
<right-button> @right grid-add* ;
: <y-slider> ( range -- slider ) : <y-slider> ( range -- slider )
{ 0 1 } <slider> build-y-slider ; { 0 1 } <slider>
<up-button> @top grid-add*
{ 1 0 } elevator,
<down-button> @bottom grid-add* ;
M: slider pref-dim* M: slider pref-dim*
dup call-next-method dup call-next-method

12
extra/ui/gadgets/slots/slots.factor
View File

@ -69,13 +69,11 @@ M: value-ref finish-editing
} define-command } define-command
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track { 0 1 } slot-editor new-track
swap >>ref swap >>ref
[ dup <toolbar> f track-add*
toolbar, <source-editor> >>text
<source-editor> g-> set-slot-editor-text dup text>> <scroller> 1 track-add*
<scroller> 1 track,
] make-gadget
dup revert ; dup revert ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ; M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;

16
extra/ui/gadgets/tabs/tabs.factor
View File

@ -48,9 +48,13 @@ DEFER: (del-page)
[ names>> index ] 2keep (del-page) ; [ names>> index ] 2keep (del-page) ;
: <tabbed> ( assoc -- tabbed ) : <tabbed> ( assoc -- tabbed )
tabbed new-frame tabbed new-frame
[ g 0 <model> >>model 0 <model> >>model
<pile> 1 >>fill [ >>toggler ] keep swap @left grid-add <pile> 1 >>fill >>toggler
[ keys >vector g swap >>names ] dup toggler>> @left grid-add*
[ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi swap
g redo-toggler g ] with-gadget ; [ keys >vector >>names ]
[ values over model>> <book> >>content dup content>> @center grid-add* ]
bi
dup redo-toggler ;

10
extra/ui/tools/browser/browser.factor
View File

@ -20,13 +20,11 @@ TUPLE: browser-gadget < track pane history ;
"handbook" >link <history> >>history drop ; "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track { 0 1 } browser-gadget new-track
dup init-history dup init-history
[ dup <toolbar> f track-add*
toolbar, dup <help-pane> >>pane
g <help-pane> g-> set-browser-gadget-pane dup pane>> <scroller> 1 track-add* ;
<scroller> 1 track,
] make-gadget ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;

29
extra/ui/tools/inspector/inspector.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: ui.tools.workspace inspector kernel ui.commands USING: accessors ui.tools.workspace inspector kernel ui.commands
ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.slots ui.gadgets.tracks ui.gestures ui.gadgets.slots ui.gadgets.tracks ui.gestures
ui.gadgets.buttons namespaces ; ui.gadgets.buttons namespaces ;
@ -9,27 +9,26 @@ IN: ui.tools.inspector
TUPLE: inspector-gadget < track object pane ; TUPLE: inspector-gadget < track object pane ;
: refresh ( inspector -- ) : refresh ( inspector -- )
dup inspector-gadget-object swap inspector-gadget-pane [ [ object>> ] [ pane>> ] bi [
H{ { +editable+ t } { +number-rows+ t } } describe* +editable+ on
+number-rows+ on
describe
] with-pane ; ] with-pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track { 0 1 } inspector-gadget new-track
[ dup <toolbar> f track-add*
toolbar, <pane> >>pane
<pane> g-> set-inspector-gadget-pane <scroller> 1 track, dup pane>> <scroller> 1 track-add* ;
] make-gadget ;
: inspect-object ( obj inspector -- ) : inspect-object ( obj mirror keys inspector -- )
[ set-inspector-gadget-object ] keep refresh ; 2nip swap >>object refresh ;
\ &push H{ { +nullary+ t } { +listener+ t } } define-command \ &push H{ { +nullary+ t } { +listener+ t } } define-command
\ &back H{ { +nullary+ t } { +listener+ t } } define-command \ &back H{ { +nullary+ t } { +listener+ t } } define-command
: globals ( -- ) global inspect ; \ &globals H{ { +nullary+ t } { +listener+ t } } define-command
\ globals H{ { +nullary+ t } { +listener+ t } } define-command
: inspector-help ( -- ) "ui-inspector" help-window ; : inspector-help ( -- ) "ui-inspector" help-window ;
@ -39,7 +38,7 @@ inspector-gadget "toolbar" f {
{ T{ update-object } refresh } { T{ update-object } refresh }
{ f &push } { f &push }
{ f &back } { f &back }
{ f globals } { f &globals }
{ T{ key-down f f "F1" } inspector-help } { T{ key-down f f "F1" } inspector-help }
} define-command-map } define-command-map

34
extra/ui/tools/listener/listener.factor
View File

@ -12,9 +12,9 @@ IN: ui.tools.listener
TUPLE: listener-gadget < track input output stack ; TUPLE: listener-gadget < track input output stack ;
: listener-output, ( -- ) : listener-output, ( listener -- listener )
<scrolling-pane> g-> set-listener-gadget-output <scrolling-pane> >>output
<scroller> "Output" <labelled-gadget> 1 track, ; dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
: listener-streams ( listener -- input output ) : listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ; [ input>> ] [ output>> <pane-stream> ] bi ;
@ -22,10 +22,12 @@ TUPLE: listener-gadget < track input output stack ;
: <listener-input> ( listener -- gadget ) : <listener-input> ( listener -- gadget )
output>> <pane-stream> <interactor> ; output>> <pane-stream> <interactor> ;
: listener-input, ( -- ) : listener-input, ( listener -- listener )
g <listener-input> g-> set-listener-gadget-input dup <listener-input> >>input
dup input>>
{ 0 100 } <limited-scroller> { 0 100 } <limited-scroller>
"Input" <labelled-gadget> f track, ; "Input" <labelled-gadget>
f track-add* ;
: welcome. ( -- ) : welcome. ( -- )
"If this is your first time with Factor, please read the " print "If this is your first time with Factor, please read the " print
@ -120,14 +122,13 @@ M: engine-word word-completion-string
TUPLE: stack-display < track ; TUPLE: stack-display < track ;
: <stack-display> ( -- gadget ) : <stack-display> ( workspace -- gadget )
g workspace-listener listener>>
{ 0 1 } stack-display new-track { 0 1 } stack-display new-track
[ over <toolbar> f track-add*
dup <toolbar> f track, swap
stack>> [ [ stack. ] curry try ] stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
t "Data stack" <labelled-pane> 1 track, 1 track-add* ;
] make-gadget ;
M: stack-display tool-scroller M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ; find-workspace workspace-listener tool-scroller ;
@ -170,9 +171,10 @@ M: stack-display tool-scroller
f <model> swap set-listener-gadget-stack ; f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track { 0 1 } listener-gadget new-track
dup init-listener dup init-listener
[ listener-output, listener-input, ] make-gadget ; listener-output,
listener-input, ;
: listener-help ( -- ) "ui-listener" help-window ; : listener-help ( -- ) "ui-listener" help-window ;

12
extra/ui/tools/profiler/profiler.factor
View File

@ -2,18 +2,16 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: ui.tools.workspace kernel quotations tools.profiler USING: ui.tools.workspace kernel quotations tools.profiler
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.gadgets.buttons ; ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
IN: ui.tools.profiler IN: ui.tools.profiler
TUPLE: profiler-gadget < track pane ; TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track { 0 1 } profiler-gadget new-track
[ dup <toolbar> f track-add*
toolbar, <pane> >>pane
<pane> g-> set-profiler-gadget-pane dup pane>> <scroller> 1 track-add* ;
<scroller> 1 track,
] make-gadget ;
: with-profiler-pane ( gadget quot -- ) : with-profiler-pane ( gadget quot -- )
>r profiler-gadget-pane r> with-pane ; >r profiler-gadget-pane r> with-pane ;

8
extra/ui/tools/tools-tests.factor
View File

@ -5,12 +5,10 @@ ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs tools.test.ui ui ; ui.gadgets.scrollers vocabs tools.test.ui ui ;
IN: ui.tools.tests IN: ui.tools.tests
[ f ]
[ [
[ f ] [ <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
0 <model> <gadget> [ set-gadget-model ] keep gadget set ] unit-test
<workspace-tabs> gadget-children empty?
] unit-test
] with-scope
[ ] [ <workspace> "w" set ] unit-test [ ] [ <workspace> "w" set ] unit-test
[ ] [ "w" get com-scroll-up ] unit-test [ ] [ "w" get com-scroll-up ] unit-test

47
extra/ui/tools/tools.factor
View File

@ -12,31 +12,36 @@ tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
mirrors ; mirrors ;
IN: ui.tools IN: ui.tools
: <workspace-tabs> ( -- tabs ) : <workspace-tabs> ( workspace -- tabs )
g gadget-model model>>
"tool-switching" workspace command-map commands>> "tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist [ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ; <toggle-buttons> ;
: <workspace-book> ( -- gadget ) : <workspace-book> ( workspace -- gadget )
[
<stack-display> , dup
<browser-gadget> , <stack-display>
<inspector-gadget> , <browser-gadget>
<profiler-gadget> , <inspector-gadget>
] { } make g gadget-model <book> ; <profiler-gadget>
4array
swap model>>
<book> ;
: <workspace> ( -- workspace ) : <workspace> ( -- workspace )
{ 0 1 } workspace new-track { 0 1 } workspace new-track
0 <model> >>model
[ 0 <model> >>model
<listener-gadget> g set-workspace-listener <listener-gadget> >>listener
<workspace-book> g set-workspace-book dup <workspace-book> >>book
<workspace-tabs> f track,
g workspace-book 1/5 track, dup <workspace-tabs> f track-add*
g workspace-listener 4/5 track, dup book>> 1/5 track-add*
toolbar, dup listener>> 4/5 track-add*
] make-gadget ; dup <toolbar> f track-add* ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup track-sizes over control-value zero? [ dup track-sizes over control-value zero? [

35
extra/ui/tools/traceback/traceback.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces USING: accessors continuations kernel models namespaces
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
hashtables inspector ; hashtables inspector ;
IN: ui.tools.traceback IN: ui.tools.traceback
: <callstack-display> ( model -- gadget ) : <callstack-display> ( model -- gadget )
@ -24,20 +25,18 @@ TUPLE: traceback-gadget < track ;
M: traceback-gadget pref-dim* drop { 550 600 } ; M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget ) : <traceback-gadget> ( model -- gadget )
{ 0 1 } traceback-gadget new-track { 0 1 } traceback-gadget new-track
swap >>model swap >>model
[
g model>> dup model>>
[ { 1 0 } <track>
[ over <datastack-display> 1/2 track-add*
[ <datastack-display> 1/2 track, ] swap <retainstack-display> 1/2 track-add*
[ <retainstack-display> 1/2 track, ] 1/3 track-add*
bi
] { 1 0 } make-track 1/3 track, dup model>> <callstack-display> 2/3 track-add*
]
[ <callstack-display> 2/3 track, ] bi dup <toolbar> f track-add* ;
toolbar,
] make-gadget ;
: <namestack-display> ( model -- gadget ) : <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ] [ [ continuation-name namestack. ] when* ]

9
extra/ui/tools/walker/walker.factor
View File

@ -61,11 +61,10 @@ M: walker-gadget focusable-child*
swap >>continuation swap >>continuation
swap >>status swap >>status
dup continuation>> <traceback-gadget> >>traceback dup continuation>> <traceback-gadget> >>traceback
[
toolbar, dup <toolbar> f track-add*
g status>> self <thread-status> f track, dup status>> self <thread-status> f track-add*
g traceback>> 1 track, dup traceback>> 1 track-add* ;
] make-gadget ;
: walker-help ( -- ) "ui-walker" help-window ; : walker-help ( -- ) "ui-walker" help-window ;

5
extra/ui/ui-docs.factor
View File

@ -238,10 +238,7 @@ $nl
"Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable." "Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable."
$nl $nl
"A combinator which stores a gadget in the " { $link gadget } " variable:" "A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection with-gadget } { $subsection with-gadget } ;
"The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " to store child gadgets in tuple slots:"
{ $subsection g }
{ $subsection g-> } ;
ARTICLE: "ui-null-layout" "Manual layouts" ARTICLE: "ui-null-layout" "Manual layouts"
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:" "When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"

2
extra/usa-cities/usa-cities.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii sequences sequences.lib USING: io.files io.encodings.ascii sequences generalizations
math.parser combinators kernel memoize csv symbols summary math.parser combinators kernel memoize csv symbols summary
words accessors math.order sorting ; words accessors math.order sorting ;
IN: usa-cities IN: usa-cities

14
vm/cpu-ppc.S
View File

@ -103,20 +103,6 @@ DEF(void,c_to_factor,(CELL quot)):
EPILOGUE EPILOGUE
blr blr
/* We must pass the XT to the quotation in r11. */
DEF(void,primitive_call,(void)):
lwz r3,0(r14) /* load quotation from data stack */
subi r14,r14,4 /* pop quotation from data stack */
JUMP_QUOT
/* We must preserve r4 here in case we're calling a primitive */
DEF(void,primitive_execute,(void)):
lwz r3,0(r14) /* load word from data stack */
lwz r11,29(r3) /* load word-xt slot */
mtctr r11 /* prepare to call XT */
subi r14,r14,4 /* pop word from data stack */
bctr /* go */
/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI /* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
limitation which would otherwise require us to do a bizzaro PC-relative limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */ trampoline to retrieve the function address */