Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
a0a6f4090f
|
|
@ -151,8 +151,9 @@ M: byte-array byte-length length ;
|
|||
swap dup length memcpy ;
|
||||
|
||||
: (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 )
|
||||
>r "-nth" append r> create ;
|
||||
|
|
|
|||
|
|
@ -44,10 +44,11 @@ ARTICLE: "assocs-protocol" "Associative mapping protocol"
|
|||
{ $subsection set-at }
|
||||
{ $subsection delete-at }
|
||||
{ $subsection clear-assoc }
|
||||
"The following two words are optional:"
|
||||
"The following three words are optional:"
|
||||
{ $subsection value-at* }
|
||||
{ $subsection new-assoc }
|
||||
{ $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-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:"
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@ bootstrapping? on
|
|||
[ [ dup pair? [ first2 create ] when ] map ] map ;
|
||||
|
||||
: define-builtin-slots ( class slots -- )
|
||||
prepare-slots 1 make-slots
|
||||
prepare-slots make-slots 1 finalize-slots
|
||||
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
|
||||
|
||||
: define-builtin ( symbol slotspec -- )
|
||||
|
|
@ -273,18 +273,16 @@ bi
|
|||
{ "echelon" { "fixnum" "math" } read-only }
|
||||
} define-builtin
|
||||
|
||||
"tuple" "kernel" create {
|
||||
[ { } define-builtin ]
|
||||
[ { "delegate" } "slot-names" set-word-prop ]
|
||||
[ define-tuple-layout ]
|
||||
[
|
||||
{ "delegate" }
|
||||
[ drop ] [ generate-tuple-slots ] 2bi
|
||||
[ "slots" set-word-prop ]
|
||||
[ define-accessors ]
|
||||
2bi
|
||||
]
|
||||
} cleave
|
||||
"tuple" "kernel" create
|
||||
[ { } define-builtin ]
|
||||
[ define-tuple-layout ]
|
||||
[
|
||||
{ "delegate" } make-slots
|
||||
[ drop ] [ finalize-tuple-slots ] 2bi
|
||||
[ "slots" set-word-prop ]
|
||||
[ define-accessors ]
|
||||
2bi
|
||||
] tri
|
||||
|
||||
! Create special tombstone values
|
||||
"tombstone" "hashtables.private" create
|
||||
|
|
|
|||
|
|
@ -1,35 +1,44 @@
|
|||
IN: classes.tuple.parser.tests
|
||||
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 ;
|
||||
|
||||
[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
|
||||
[ t ] [ test-1 "slots" word-prop empty? ] unit-test
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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 } ;
|
||||
|
||||
[ { { "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 } ;
|
||||
|
||||
[ 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 } ;
|
||||
|
||||
|
|
@ -39,6 +48,8 @@ TUPLE: test-8 { b integer read-only } ;
|
|||
|
||||
[ 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 ]
|
||||
[ error>> invalid-slot-name? ]
|
||||
must-fail-with
|
||||
|
|
@ -51,17 +62,33 @@ must-fail-with
|
|||
[ error>> unexpected-eof? ]
|
||||
must-fail-with
|
||||
|
||||
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
|
||||
[ error>> no-initial-value? ]
|
||||
2 [
|
||||
[ "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
|
||||
|
||||
[ "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
|
||||
|
||||
[ ] [
|
||||
[
|
||||
{ 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
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -4,10 +4,11 @@ USING: accessors kernel sets namespaces sequences summary parser
|
|||
lexer combinators words classes.parser classes.tuple arrays ;
|
||||
IN: classes.tuple.parser
|
||||
|
||||
: slot-names ( slots -- seq )
|
||||
[ dup array? [ first ] when ] map ;
|
||||
|
||||
: shadowed-slots ( superclass slots -- shadowed )
|
||||
[ all-slots [ name>> ] map ]
|
||||
[ [ dup array? [ first ] when ] map ]
|
||||
bi* intersect ;
|
||||
[ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
|
||||
|
||||
: check-slot-shadowing ( class superclass slots -- )
|
||||
shadowed-slots [
|
||||
|
|
@ -20,11 +21,19 @@ IN: classes.tuple.parser
|
|||
] "" make note.
|
||||
] 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 ;
|
||||
|
||||
M: invalid-slot-name summary
|
||||
drop
|
||||
"Invalid slot name" ;
|
||||
drop "Invalid slot name" ;
|
||||
|
||||
: parse-long-slot-name ( -- )
|
||||
[ scan , \ } parse-until % ] { } make ;
|
||||
|
|
@ -38,7 +47,7 @@ M: invalid-slot-name summary
|
|||
#! : ...
|
||||
{
|
||||
{ [ dup not ] [ unexpected-eof ] }
|
||||
{ [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
|
||||
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
|
||||
{ [ dup ";" = ] [ drop f ] }
|
||||
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
|
||||
} cond ;
|
||||
|
|
@ -52,4 +61,6 @@ M: invalid-slot-name summary
|
|||
{ ";" [ tuple f ] }
|
||||
{ "<" [ scan-word [ parse-tuple-slots ] { } 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 ;
|
||||
|
|
|
|||
|
|
@ -346,11 +346,9 @@ HELP: tuple
|
|||
$nl
|
||||
"Tuple classes have additional word properties:"
|
||||
{ $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 "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
|
||||
{ { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
|
||||
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
|
||||
{ { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
|
||||
} } ;
|
||||
|
||||
HELP: define-tuple-predicate
|
||||
|
|
|
|||
|
|
@ -443,36 +443,36 @@ TUPLE: redefinition-problem-2 ;
|
|||
! Hardcore unit tests
|
||||
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
|
||||
] with-compilation-unit
|
||||
|
||||
[ 1337 sleep ] "Test" spawn drop
|
||||
|
||||
[
|
||||
\ thread tuple "slot-names" get
|
||||
\ thread tuple "slots" get
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
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
|
||||
] with-compilation-unit
|
||||
|
||||
all-words drop
|
||||
|
||||
[
|
||||
\ vocab tuple "slot-names" get
|
||||
\ vocab tuple "slots" get
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -22,18 +22,6 @@ ERROR: not-a-tuple object ;
|
|||
|
||||
<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 )
|
||||
"layout" word-prop ;
|
||||
|
||||
|
|
@ -86,9 +74,6 @@ M: tuple-class slots>tuple
|
|||
: >tuple ( seq -- tuple )
|
||||
unclip slots>tuple ;
|
||||
|
||||
: slot-names ( class -- seq )
|
||||
"slot-names" word-prop ;
|
||||
|
||||
ERROR: bad-superclass class ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -116,7 +101,7 @@ ERROR: bad-superclass class ;
|
|||
|
||||
: superclass-size ( class -- n )
|
||||
superclasses but-last-slice
|
||||
[ slot-names length ] sigma ;
|
||||
[ "slots" word-prop length ] sigma ;
|
||||
|
||||
: (instance-check-quot) ( class -- quot )
|
||||
[
|
||||
|
|
@ -150,19 +135,18 @@ ERROR: bad-superclass class ;
|
|||
: define-tuple-prototype ( class -- )
|
||||
dup tuple-prototype "prototype" set-word-prop ;
|
||||
|
||||
: generate-tuple-slots ( class slots -- slot-specs )
|
||||
over superclass-size 2 + make-slots deprecated-slots ;
|
||||
: finalize-tuple-slots ( class slots -- slots )
|
||||
over superclass-size 2 + finalize-slots deprecated-slots ;
|
||||
|
||||
: define-tuple-slots ( class -- )
|
||||
dup dup "slot-names" word-prop generate-tuple-slots
|
||||
[ "slots" set-word-prop ]
|
||||
dup dup "slots" word-prop finalize-tuple-slots
|
||||
[ define-accessors ] ! new
|
||||
[ define-slots ] ! old
|
||||
2tri ;
|
||||
2bi ;
|
||||
|
||||
: make-tuple-layout ( class -- layout )
|
||||
[ ]
|
||||
[ [ superclass-size ] [ slot-names length ] bi + ]
|
||||
[ [ superclass-size ] [ "slots" word-prop length ] bi + ]
|
||||
[ superclasses dup length 1- ] tri
|
||||
<tuple-layout> ;
|
||||
|
||||
|
|
@ -223,8 +207,9 @@ M: tuple-class update-class
|
|||
} cleave ;
|
||||
|
||||
: define-new-tuple-class ( class superclass slots -- )
|
||||
make-slots
|
||||
[ drop f f tuple-class define-class ]
|
||||
[ nip "slot-names" set-word-prop ]
|
||||
[ nip "slots" set-word-prop ]
|
||||
[ 2drop update-classes ]
|
||||
3tri ;
|
||||
|
||||
|
|
@ -248,7 +233,7 @@ M: tuple-class update-class
|
|||
3bi ;
|
||||
|
||||
: tuple-class-unchanged? ( class superclass slots -- ? )
|
||||
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
|
||||
rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
|
||||
|
||||
: valid-superclass? ( class -- ? )
|
||||
[ tuple-class? ] [ tuple eq? ] bi or ;
|
||||
|
|
@ -293,7 +278,7 @@ M: tuple-class reset-class
|
|||
[ call-next-method ]
|
||||
[
|
||||
{
|
||||
"layout" "slots" "slot-names" "boa-check" "prototype"
|
||||
"layout" "slots" "boa-check" "prototype"
|
||||
} reset-props
|
||||
] bi
|
||||
] bi ;
|
||||
|
|
|
|||
|
|
@ -162,8 +162,6 @@ PREDICATE: small-slot < integer cells small-enough? ;
|
|||
|
||||
PREDICATE: small-tagged < integer v>operand small-enough? ;
|
||||
|
||||
PREDICATE: inline-array < integer 32 < ;
|
||||
|
||||
: if-small-struct ( n size true false -- ? )
|
||||
>r >r over not over struct-small-enough? and
|
||||
[ nip r> call r> drop ] [ r> drop r> call ] if ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
USING: generator.fixup generic kernel memory namespaces
|
||||
words math math.bitfields math.order io.binary ;
|
||||
USING: generator.fixup kernel namespaces words io.binary math
|
||||
math.order cpu.ppc.assembler.backend ;
|
||||
IN: cpu.ppc.assembler
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
|
|
@ -15,215 +15,195 @@ IN: cpu.ppc.assembler
|
|||
!
|
||||
! 14 15 10 STW
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
|
||||
: a-form ( d a b c xo rc -- n ) { 0 1 6 11 16 21 } bitfield ;
|
||||
: b-form ( bo bi bd aa lk -- n ) { 0 1 2 16 21 } bitfield ;
|
||||
: s>u16 ( s -- u ) HEX: ffff bitand ;
|
||||
: d-form ( d a simm -- n ) s>u16 { 0 16 21 } bitfield ;
|
||||
: sd-form ( d a simm -- n ) s>u16 { 0 21 16 } bitfield ;
|
||||
: i-form ( li aa lk -- n ) { 0 1 0 } bitfield ;
|
||||
: x-form ( a s b rc xo -- n ) { 1 0 11 21 16 } bitfield ;
|
||||
: xfx-form ( d spr xo -- n ) { 1 11 21 } bitfield ;
|
||||
: xo-form ( d a b oe rc xo -- n ) { 1 0 10 11 16 21 } bitfield ;
|
||||
! D-form
|
||||
D: ADDI 14
|
||||
D: ADDIC 12
|
||||
D: ADDIC. 13
|
||||
D: ADDIS 15
|
||||
D: CMPI 11
|
||||
D: CMPLI 10
|
||||
D: LBZ 34
|
||||
D: LBZU 35
|
||||
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 ;
|
||||
: ADDIS d-form 15 insn ; : LIS 0 rot ADDIS ;
|
||||
! SD-form
|
||||
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 ;
|
||||
: ADD 0 0 (ADD) ; : ADD. 0 1 (ADD) ;
|
||||
: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ;
|
||||
! Branches
|
||||
: B ( dest -- ) 0 0 (B) ;
|
||||
: 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 ;
|
||||
: ADDC 0 0 (ADDC) ; : ADDC. 0 1 (ADDC) ;
|
||||
: ADDCO 1 0 (ADDC) ; : ADDCO. 1 1 (ADDC) ;
|
||||
! Special registers
|
||||
MFSPR: XER 1
|
||||
MFSPR: LR 8
|
||||
MFSPR: CTR 9
|
||||
MTSPR: XER 1
|
||||
MTSPR: LR 8
|
||||
MTSPR: CTR 9
|
||||
|
||||
: (ADDE) 138 xo-form 31 insn ;
|
||||
: ADDE 0 0 (ADDE) ; : ADDE. 0 1 (ADDE) ;
|
||||
: ADDEO 1 0 (ADDE) ; : ADDEO. 1 1 (ADDE) ;
|
||||
|
||||
: ANDI sd-form 28 insn ;
|
||||
: ANDIS sd-form 29 insn ;
|
||||
|
||||
: (AND) 28 x-form 31 insn ;
|
||||
: AND 0 (AND) ; : AND. 0 (AND) ;
|
||||
|
||||
: (DIVW) 491 xo-form 31 insn ;
|
||||
: DIVW 0 0 (DIVW) ; : DIVW. 0 1 (DIVW) ;
|
||||
: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
|
||||
|
||||
: (DIVWU) 459 xo-form 31 insn ;
|
||||
: DIVWU 0 0 (DIVWU) ; : DIVWU. 0 1 (DIVWU) ;
|
||||
: DIVWUO 1 0 (DIVWU) ; : DIVWUO. 1 1 (DIVWU) ;
|
||||
|
||||
: (EQV) 284 x-form 31 insn ;
|
||||
: 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 ;
|
||||
! Pseudo-instructions
|
||||
: LI 0 rot ADDI ; inline
|
||||
: SUBI neg ADDI ; inline
|
||||
: LIS 0 rot ADDIS ; inline
|
||||
: SUBIC neg ADDIC ; inline
|
||||
: SUBIC. neg ADDIC. ; inline
|
||||
: NOT dup NOR ; inline
|
||||
: NOT. dup NOR. ; inline
|
||||
: MR dup OR ; inline
|
||||
: MR. dup OR. ; inline
|
||||
: (SLWI) 0 31 pick - ; inline
|
||||
: SLWI ( d a b -- ) (SLWI) RLWINM ;
|
||||
: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
|
||||
: (SRWI) 32 over - swap 31 ; inline
|
||||
: SRWI ( d a b -- ) (SRWI) RLWINM ;
|
||||
: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
|
||||
: LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
|
||||
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
|
||||
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.ppc.assembler generator.fixup compiler.units
|
||||
compiler.constants math layouts words vocabs ;
|
||||
USING: bootstrap.image.private kernel kernel.private namespaces
|
||||
system cpu.ppc.assembler generator.fixup compiler.units
|
||||
compiler.constants math math.private layouts words words.private
|
||||
vocabs slots.private ;
|
||||
IN: bootstrap.ppc
|
||||
|
||||
4 \ cell set
|
||||
|
|
@ -11,9 +12,7 @@ big-endian on
|
|||
4 jit-code-format set
|
||||
|
||||
: ds-reg 14 ;
|
||||
: quot-reg 3 ;
|
||||
: temp-reg 6 ;
|
||||
: aux-reg 11 ;
|
||||
: rs-reg 15 ;
|
||||
|
||||
: factor-area-size 4 bootstrap-cells ;
|
||||
|
||||
|
|
@ -24,86 +23,286 @@ big-endian on
|
|||
: xt-save stack-frame 2 bootstrap-cells - ;
|
||||
|
||||
[
|
||||
! Load word
|
||||
0 temp-reg LOAD32
|
||||
temp-reg dup 0 LWZ
|
||||
! Bump profiling counter
|
||||
aux-reg temp-reg profile-count-offset LWZ
|
||||
aux-reg dup 1 tag-fixnum ADDI
|
||||
aux-reg temp-reg profile-count-offset STW
|
||||
! Load word->code
|
||||
aux-reg temp-reg word-code-offset LWZ
|
||||
! Compute word XT
|
||||
aux-reg dup compiled-header-size ADDI
|
||||
! Jump to XT
|
||||
aux-reg MTCTR
|
||||
0 6 LOAD32
|
||||
6 dup 0 LWZ
|
||||
11 6 profile-count-offset LWZ
|
||||
11 11 1 tag-fixnum ADDI
|
||||
11 6 profile-count-offset STW
|
||||
11 6 word-code-offset LWZ
|
||||
11 11 compiled-header-size ADDI
|
||||
11 MTCTR
|
||||
BCTR
|
||||
] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define
|
||||
|
||||
[
|
||||
0 temp-reg LOAD32 ! load XT
|
||||
0 MFLR ! load return address
|
||||
1 1 stack-frame neg ADDI ! create stack frame
|
||||
temp-reg 1 xt-save STW ! save XT
|
||||
stack-frame temp-reg LI ! load frame size
|
||||
temp-reg 1 next-save STW ! save frame size
|
||||
0 1 lr-save stack-frame + STW ! save return address
|
||||
0 6 LOAD32
|
||||
0 MFLR
|
||||
1 1 stack-frame SUBI
|
||||
6 1 xt-save STW
|
||||
stack-frame 6 LI
|
||||
6 1 next-save STW
|
||||
0 1 lr-save stack-frame + STW
|
||||
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
|
||||
|
||||
[
|
||||
0 temp-reg LOAD32 ! load literal
|
||||
temp-reg dup 0 LWZ ! indirection
|
||||
temp-reg ds-reg 4 STWU ! push literal
|
||||
0 6 LOAD32
|
||||
6 dup 0 LWZ
|
||||
6 ds-reg 4 STWU
|
||||
] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define
|
||||
|
||||
[
|
||||
0 temp-reg LOAD32 ! load primitive address
|
||||
4 1 MR ! pass stack pointer to primitive
|
||||
temp-reg MTCTR ! jump to primitive
|
||||
0 6 LOAD32
|
||||
6 ds-reg 4 STWU
|
||||
] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32
|
||||
4 1 MR
|
||||
6 MTCTR
|
||||
BCTR
|
||||
] 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 ( -- )
|
||||
temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt
|
||||
temp-reg MTCTR ! jump to quotation-xt
|
||||
4 3 quot-xt-offset LWZ
|
||||
4 MTCTR
|
||||
BCTR ;
|
||||
|
||||
[
|
||||
0 quot-reg LOAD32 ! point quot-reg at false branch
|
||||
temp-reg ds-reg 0 LWZ ! load boolean
|
||||
0 temp-reg \ f tag-number CMPI ! compare it with f
|
||||
2 BNE ! skip next insn if its not f
|
||||
quot-reg dup 4 ADDI ! point quot-reg at true branch
|
||||
quot-reg dup 0 LWZ ! load the branch
|
||||
ds-reg dup 4 SUBI ! pop boolean
|
||||
0 3 LOAD32
|
||||
6 ds-reg 0 LWZ
|
||||
0 6 \ f tag-number CMPI
|
||||
2 BNE
|
||||
3 3 4 ADDI
|
||||
3 3 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
jit-call-quot
|
||||
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
|
||||
|
||||
[
|
||||
0 quot-reg LOAD32 ! load dispatch array
|
||||
quot-reg dup 0 LWZ ! indirection
|
||||
temp-reg ds-reg 0 LWZ ! load index
|
||||
temp-reg dup 1 SRAWI ! turn it into an array offset
|
||||
quot-reg dup temp-reg ADD ! compute quotation location
|
||||
quot-reg dup array-start-offset LWZ ! load quotation
|
||||
ds-reg dup 4 SUBI ! pop index
|
||||
0 3 LOAD32
|
||||
3 3 0 LWZ
|
||||
6 ds-reg 0 LWZ
|
||||
6 6 1 SRAWI
|
||||
3 3 6 ADD
|
||||
3 3 array-start-offset LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
jit-call-quot
|
||||
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
|
||||
|
||||
[
|
||||
0 1 lr-save stack-frame + LWZ ! load return address
|
||||
1 1 stack-frame ADDI ! pop stack frame
|
||||
0 MTLR ! get ready to return
|
||||
0 1 lr-save stack-frame + LWZ
|
||||
1 1 stack-frame ADDI
|
||||
0 MTLR
|
||||
] f f f jit-epilog 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
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler
|
||||
cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
|
||||
kernel.private math math.private namespaces sequences words
|
||||
generic quotations byte-arrays hashtables hashtables.private
|
||||
generator generator.registers generator.fixup sequences.private
|
||||
sbufs vectors system layouts math.floats.private
|
||||
classes classes.tuple classes.tuple.private sbufs.private
|
||||
vectors.private strings.private slots.private combinators
|
||||
compiler.constants ;
|
||||
USING: accessors alien alien.accessors alien.c-types arrays
|
||||
cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
|
||||
cpu.architecture kernel kernel.private math math.private
|
||||
namespaces sequences words generic quotations byte-arrays
|
||||
hashtables hashtables.private generator generator.registers
|
||||
generator.fixup sequences.private sbufs vectors system layouts
|
||||
math.floats.private classes slots.private combinators
|
||||
compiler.constants optimizer.allot ;
|
||||
IN: cpu.ppc.intrinsics
|
||||
|
||||
: %slot-literal-known-tag
|
||||
|
|
@ -445,38 +444,33 @@ IN: cpu.ppc.intrinsics
|
|||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] H{
|
||||
{ +input+ { { [ tuple-layout? ] "layout" } } }
|
||||
{ +input+ { { [ ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <array> [
|
||||
\ (array) [
|
||||
array "n" get 2 + cells %allot
|
||||
! Store length
|
||||
"n" operand 12 LI
|
||||
12 11 cell STW
|
||||
! Store initial element
|
||||
"n" get [ "initial" operand 11 rot 2 + cells STW ] each
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { [ inline-array? ] "n" } { f "initial" } } }
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <byte-array> [
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + %allot
|
||||
! Store length
|
||||
"n" operand 12 LI
|
||||
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
|
||||
"array" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { [ inline-array? ] "n" } } }
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
|
|
|||
|
|
@ -6,8 +6,7 @@ kernel.private math math.private namespaces quotations sequences
|
|||
words generic byte-arrays hashtables hashtables.private
|
||||
generator generator.registers generator.fixup sequences.private
|
||||
sbufs sbufs.private vectors vectors.private layouts system
|
||||
classes.tuple.private strings.private slots.private
|
||||
compiler.constants ;
|
||||
strings.private slots.private compiler.constants optimizer.allot ;
|
||||
IN: cpu.x86.intrinsics
|
||||
|
||||
! Type checks
|
||||
|
|
@ -298,37 +297,33 @@ IN: cpu.x86.intrinsics
|
|||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ tuple-layout? ] "layout" } } }
|
||||
{ +input+ { { [ ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <array> [
|
||||
\ (array) [
|
||||
array "n" get 2 + cells [
|
||||
! Store length
|
||||
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
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ inline-array? ] "n" } { f "initial" } } }
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <byte-array> [
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store initial element
|
||||
"n" get cell align cell /i [ 2 + object@ 0 MOV ] each
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ inline-array? ] "n" } } }
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
|
|
|||
|
|
@ -212,6 +212,12 @@ M: not-a-tuple summary
|
|||
M: bad-superclass summary
|
||||
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
|
||||
drop "Fall-through in cond" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -93,11 +93,6 @@ HELP: hash-deleted+
|
|||
{ $description "Called to increment the deleted entry counter when an entry is removed with " { $link delete-at } }
|
||||
{ $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
|
||||
{ $values { "hash" hashtable } }
|
||||
{ $description "Enlarges the capacity of a hashtable. User code does not need to call this word directly." }
|
||||
|
|
|
|||
|
|
@ -164,3 +164,16 @@ H{ } "x" set
|
|||
[ { "one" "two" 3 } ] [
|
||||
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
|
||||
] 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
|
||||
|
|
|
|||
|
|
@ -20,15 +20,18 @@ TUPLE: hashtable
|
|||
: probe ( array i -- array i )
|
||||
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
|
||||
dup ((empty)) eq?
|
||||
[ 3drop nip f f ] [
|
||||
[ 3drop no-key ] [
|
||||
= [ rot drop t ] [ probe (key@) ] if
|
||||
] if ; inline
|
||||
|
||||
: 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 )
|
||||
1+ next-power-of-2 4 * ((empty)) <array> ; inline
|
||||
|
|
@ -63,25 +66,20 @@ TUPLE: hashtable
|
|||
: hash-deleted+ ( hash -- )
|
||||
[ 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 -- )
|
||||
swap [ swapd (set-hash) drop ] curry assoc-each ;
|
||||
swap [ swapd set-at ] curry assoc-each ; inline
|
||||
|
||||
: hash-large? ( hash -- ? )
|
||||
[ count>> 3 fixnum*fast ]
|
||||
[ array>> array-capacity ] bi > ;
|
||||
[ count>> 3 fixnum*fast 1 fixnum+fast ]
|
||||
[ array>> array-capacity ] bi fixnum> ; inline
|
||||
|
||||
: hash-stale? ( hash -- ? )
|
||||
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ;
|
||||
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
|
||||
|
||||
: grow-hash ( hash -- )
|
||||
[ dup >alist swap assoc-size 1+ ] keep
|
||||
[ reset-hash ] keep
|
||||
swap (rehash) ;
|
||||
swap (rehash) ; inline
|
||||
|
||||
: ?grow-hash ( hash -- )
|
||||
dup hash-large? [
|
||||
|
|
@ -122,7 +120,10 @@ M: hashtable assoc-size ( hash -- n )
|
|||
r> (rehash) ;
|
||||
|
||||
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 )
|
||||
2 <hashtable> [ set-at ] keep ;
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@ USING: kernel math sequences arrays assocs sequences.private
|
|||
growable accessors math.order ;
|
||||
IN: heaps
|
||||
|
||||
MIXIN: priority-queue
|
||||
|
||||
GENERIC: heap-push* ( value key heap -- entry )
|
||||
GENERIC: heap-peek ( heap -- value key )
|
||||
GENERIC: heap-pop* ( heap -- )
|
||||
|
|
@ -36,13 +34,10 @@ TUPLE: max-heap < heap ;
|
|||
|
||||
: <max-heap> ( -- max-heap ) max-heap <heap> ;
|
||||
|
||||
INSTANCE: min-heap priority-queue
|
||||
INSTANCE: max-heap priority-queue
|
||||
|
||||
M: priority-queue heap-empty? ( heap -- ? )
|
||||
M: heap heap-empty? ( heap -- ? )
|
||||
data>> empty? ;
|
||||
|
||||
M: priority-queue heap-size ( heap -- n )
|
||||
M: heap heap-size ( heap -- n )
|
||||
data>> length ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -152,7 +147,7 @@ DEFER: down-heap
|
|||
|
||||
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 ;
|
||||
|
||||
: 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 )
|
||||
[ value>> ] [ key>> ] bi ;
|
||||
|
||||
M: priority-queue heap-peek ( heap -- value key )
|
||||
M: heap heap-peek ( heap -- value key )
|
||||
data-first >entry< ;
|
||||
|
||||
: entry>index ( entry heap -- n )
|
||||
|
|
@ -172,7 +167,7 @@ M: priority-queue heap-peek ( heap -- value key )
|
|||
] unless
|
||||
entry-index ;
|
||||
|
||||
M: priority-queue heap-delete ( entry heap -- )
|
||||
M: heap heap-delete ( entry heap -- )
|
||||
[ entry>index ] keep
|
||||
2dup heap-size 1- = [
|
||||
nip data-pop*
|
||||
|
|
@ -182,10 +177,10 @@ M: priority-queue heap-delete ( entry heap -- )
|
|||
down-heap
|
||||
] if ;
|
||||
|
||||
M: priority-queue heap-pop* ( heap -- )
|
||||
M: heap heap-pop* ( heap -- )
|
||||
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< ;
|
||||
|
||||
: heap-pop-all ( heap -- alist )
|
||||
|
|
|
|||
|
|
@ -540,9 +540,6 @@ set-primitive-effect
|
|||
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
|
||||
\ <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> make-foldable
|
||||
|
||||
|
|
|
|||
|
|
@ -33,10 +33,10 @@ SYMBOL: +editable+
|
|||
: write-value ( mirror key -- )
|
||||
<value-ref> write-slot-editor ;
|
||||
|
||||
: describe-row ( obj key n -- )
|
||||
: describe-row ( mirror key n -- )
|
||||
[
|
||||
+number-rows+ get [ pprint-cell ] [ drop ] if
|
||||
2dup write-key write-value
|
||||
[ write-key ] [ write-value ] 2bi
|
||||
] with-row ;
|
||||
|
||||
: summary. ( obj -- ) [ summary ] keep write-object nl ;
|
||||
|
|
@ -48,21 +48,19 @@ SYMBOL: +editable+
|
|||
sort-keys values
|
||||
] [ keys ] if ;
|
||||
|
||||
: describe* ( obj flags -- )
|
||||
clone [
|
||||
dup summary.
|
||||
make-mirror dup sorted-keys dup empty? [
|
||||
2drop
|
||||
] [
|
||||
dup enum? [ +sequence+ on ] when
|
||||
standard-table-style [
|
||||
dup length
|
||||
rot [ -rot describe-row ] curry 2each
|
||||
] tabular-output
|
||||
] if
|
||||
] bind ;
|
||||
: describe* ( obj mirror keys -- )
|
||||
rot summary.
|
||||
dup empty? [
|
||||
2drop
|
||||
] [
|
||||
dup enum? [ +sequence+ on ] when
|
||||
standard-table-style [
|
||||
swap [ -rot describe-row ] curry each-index
|
||||
] tabular-output
|
||||
] if ;
|
||||
|
||||
: describe ( obj -- ) H{ } describe* ;
|
||||
: describe ( obj -- )
|
||||
dup make-mirror dup sorted-keys describe* ;
|
||||
|
||||
M: tuple error. describe ;
|
||||
|
||||
|
|
@ -78,19 +76,21 @@ M: tuple error. describe ;
|
|||
|
||||
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: me
|
||||
|
||||
: reinspect ( obj -- )
|
||||
dup me set
|
||||
dup make-mirror dup mirror set keys \ keys set
|
||||
inspector-hook get call ;
|
||||
[ me set ]
|
||||
[
|
||||
dup make-mirror dup mirror set dup sorted-keys dup \ keys set
|
||||
inspector-hook get call
|
||||
] bi ;
|
||||
|
||||
: (inspect) ( obj -- )
|
||||
dup inspector-stack get push reinspect ;
|
||||
[ inspector-stack get push ] [ reinspect ] bi ;
|
||||
|
||||
: key@ ( n -- key ) \ keys get nth ;
|
||||
|
||||
|
|
@ -123,6 +123,7 @@ SYMBOL: me
|
|||
"&add ( value key -- ) add new slot" print
|
||||
"&delete ( n -- ) remove a slot" print
|
||||
"&rename ( key n -- ) change a slot's key" print
|
||||
"&globals ( -- ) inspect global namespace" print
|
||||
"&help -- display this message" print
|
||||
nl ;
|
||||
|
||||
|
|
@ -133,3 +134,5 @@ SYMBOL: me
|
|||
|
||||
: inspect ( obj -- )
|
||||
inspector-stack get [ (inspect) ] [ inspector ] if ;
|
||||
|
||||
: &globals ( -- ) global inspect ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -9,7 +9,7 @@ classes.tuple classes.predicate classes.tuple.private classes
|
|||
classes.algebra sequences.private combinators byte-arrays
|
||||
byte-vectors slots.private inference.dataflow inference.state
|
||||
inference.class optimizer.def-use optimizer.backend
|
||||
optimizer.pattern-match optimizer.inlining ;
|
||||
optimizer.pattern-match optimizer.inlining optimizer.allot ;
|
||||
IN: optimizer.known-words
|
||||
|
||||
{ <tuple> <tuple-boa> (tuple) } [
|
||||
|
|
@ -25,37 +25,6 @@ IN: optimizer.known-words
|
|||
dup class? [ drop tuple ] unless 1array f
|
||||
] "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
|
||||
{ clone (clone) } [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -406,7 +406,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
|
||||
: convert-mod-to-and ( #call -- node )
|
||||
dup
|
||||
dup node-in-d second node-literal 1-
|
||||
dup in-d>> second node-literal 1-
|
||||
[ nip bitand ] curry f splice-quot ;
|
||||
|
||||
\ mod [
|
||||
|
|
@ -438,6 +438,19 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
}
|
||||
} 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
|
||||
|
||||
|
|
|
|||
|
|
@ -384,3 +384,10 @@ PREDICATE: list < improper-list
|
|||
[ 1 [ "hi" + 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
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math optimizer.control
|
||||
optimizer.collect optimizer.inlining inference.class ;
|
||||
optimizer.known-words optimizer.math optimizer.allot
|
||||
optimizer.control optimizer.collect optimizer.inlining
|
||||
inference.class ;
|
||||
IN: optimizer
|
||||
|
||||
: optimize-1 ( node -- newnode ? )
|
||||
|
|
|
|||
|
|
@ -277,13 +277,32 @@ M: array pprint-slot-name
|
|||
f <inset unclip text pprint-elements 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*
|
||||
<colon \ TUPLE: pprint-word
|
||||
dup pprint-word
|
||||
dup superclass tuple eq? [
|
||||
"<" text dup superclass pprint-word
|
||||
] unless
|
||||
<block slot-names [ pprint-slot-name ] each block>
|
||||
<block "slots" word-prop [ pprint-slot ] each block>
|
||||
pprint-; block> ;
|
||||
|
||||
M: word see-class* drop ;
|
||||
|
|
|
|||
|
|
@ -124,16 +124,28 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
|
|||
{ $subsection each }
|
||||
{ $subsection reduce }
|
||||
{ $subsection interleave }
|
||||
{ $subsection 2each }
|
||||
{ $subsection 2reduce }
|
||||
"Mapping:"
|
||||
{ $subsection map }
|
||||
{ $subsection 2map }
|
||||
{ $subsection map-as }
|
||||
{ $subsection accumulate }
|
||||
{ $subsection produce }
|
||||
"Filtering:"
|
||||
{ $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"
|
||||
"Testing for an empty sequence:"
|
||||
|
|
@ -147,12 +159,7 @@ ARTICLE: "sequences-tests" "Testing sequences"
|
|||
{ $subsection head? }
|
||||
{ $subsection tail? }
|
||||
{ $subsection subseq? }
|
||||
"Testing if a sequence contains elements satisfying a predicate:"
|
||||
{ $subsection contains? }
|
||||
{ $subsection all? }
|
||||
{ $subsection 2all? }
|
||||
"Testing how elements are related:"
|
||||
{ $subsection monotonic? }
|
||||
{ $subsection all-eq? }
|
||||
{ $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" } }
|
||||
{ $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
|
||||
{ $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." }
|
||||
|
|
@ -478,8 +494,7 @@ HELP: max-length
|
|||
|
||||
HELP: 2each
|
||||
{ $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" } "." }
|
||||
{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
|
||||
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
|
||||
|
||||
HELP: 2reduce
|
||||
{ $values { "seq1" sequence }
|
||||
|
|
@ -488,18 +503,19 @@ HELP: 2reduce
|
|||
{ "quot" "a quotation with stack effect "
|
||||
{ $snippet "( prev elt1 elt2 -- next )" } }
|
||||
{ "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" } "." }
|
||||
{ $notes "If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." } ;
|
||||
{ $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" } "." } ;
|
||||
|
||||
HELP: 2map
|
||||
{ $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" } "." }
|
||||
{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
|
||||
{ $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" } "." } ;
|
||||
|
||||
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?
|
||||
{ $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" } "." }
|
||||
{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
|
||||
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
|
||||
|
||||
HELP: find
|
||||
{ $values { "seq" sequence }
|
||||
|
|
|
|||
|
|
@ -383,10 +383,13 @@ PRIVATE>
|
|||
: 2reduce ( seq1 seq2 identity quot -- result )
|
||||
>r -rot r> 2each ; inline
|
||||
|
||||
: 2map ( seq1 seq2 quot -- newseq )
|
||||
pick >r (2each) over r>
|
||||
: 2map-as ( seq1 seq2 quot exemplar -- newseq )
|
||||
>r (2each) over r>
|
||||
[ [ collect ] keep ] new-like ; inline
|
||||
|
||||
: 2map ( seq1 seq2 quot -- newseq )
|
||||
pick 2map-as ; inline
|
||||
|
||||
: 2all? ( seq1 seq2 quot -- ? )
|
||||
(2each) all-integers? ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ $nl
|
|||
{ $subsection prune }
|
||||
"Test for duplicates:"
|
||||
{ $subsection all-unique? }
|
||||
{ $subsection duplicates }
|
||||
"Set operations on sequences:"
|
||||
{ $subsection diff }
|
||||
{ $subsection intersect }
|
||||
|
|
@ -64,6 +65,13 @@ HELP: prune
|
|||
{ $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?
|
||||
{ $values { "seq" sequence } { "?" "a boolean" } }
|
||||
{ $description "Tests whether a sequence contains any repeated elements." }
|
||||
|
|
|
|||
|
|
@ -16,6 +16,9 @@ IN: sets
|
|||
[ ] [ length <hashtable> ] [ length <vector> ] tri
|
||||
[ [ (prune) ] 2curry each ] keep ;
|
||||
|
||||
: duplicates ( seq -- newseq )
|
||||
H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ;
|
||||
|
||||
: gather ( seq quot -- newseq )
|
||||
map concat prune ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -188,9 +188,14 @@ M: array make-slot
|
|||
[ dup empty? not ] [ peel-off-attributes ] [ ] while drop
|
||||
check-initial-value ;
|
||||
|
||||
: make-slots ( slots base -- specs )
|
||||
over length [ + ] with map
|
||||
[ [ make-slot ] dip >>offset ] 2map ;
|
||||
M: slot-spec make-slot
|
||||
check-initial-value ;
|
||||
|
||||
: 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-spec-name = ] with find nip ;
|
||||
[ name>> = ] with find nip ;
|
||||
|
|
|
|||
|
|
@ -140,8 +140,6 @@ $nl
|
|||
|
||||
{ { $snippet "\"constructor\"" } { $link "tuple-constructors" } }
|
||||
|
||||
{ { $snippet "\"slot-names\"" } { $link "tuples" } }
|
||||
|
||||
{ { $snippet "\"type\"" } { $link "builtin-classes" } }
|
||||
|
||||
{ { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } }
|
||||
|
|
|
|||
|
|
@ -94,4 +94,4 @@ MACRO: bake ( seq -- quot ) [bake] ;
|
|||
|
||||
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
|
||||
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
|
||||
: `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing
|
||||
: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.parser models
|
||||
models.filter models.range models.compose sequences ui
|
||||
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
|
||||
ui.gadgets.sliders ui.render math.geometry.rect ;
|
||||
models.filter models.range models.compose sequences ui
|
||||
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
|
||||
ui.gadgets.sliders ui.render math.geometry.rect accessors ;
|
||||
IN: color-picker
|
||||
|
||||
! Simple example demonstrating the use of models.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
ARTICLE: "ctags" "Ctags file"
|
||||
|
|
@ -6,7 +6,10 @@ ARTICLE: "ctags" "Ctags file"
|
|||
{ $subsection ctags }
|
||||
{ $subsection ctags-write }
|
||||
{ $subsection ctag-strings }
|
||||
{ $subsection ctag } ;
|
||||
{ $subsection ctag }
|
||||
{ $subsection ctag-word }
|
||||
{ $subsection ctag-path }
|
||||
{ $subsection ctag-lineno } ;
|
||||
|
||||
HELP: ctags ( path -- )
|
||||
{ $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"
|
||||
|
|
@ -1,6 +1,21 @@
|
|||
USING: kernel ctags tools.test io.backend sequences arrays prettyprint ;
|
||||
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 ] [
|
||||
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append
|
||||
{ if { "resource:extra/unix/unix.factor" 91 } } ctag =
|
||||
|
|
@ -9,4 +24,5 @@ IN: ctags.tests
|
|||
[ t ] [
|
||||
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array
|
||||
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings =
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -9,29 +9,36 @@ io.encodings.ascii math.parser vocabs definitions
|
|||
namespaces words sorting ;
|
||||
IN: ctags
|
||||
|
||||
: ctag-word ( ctag -- word )
|
||||
first ;
|
||||
|
||||
: ctag-path ( ctag -- path )
|
||||
second first ;
|
||||
|
||||
: ctag-lineno ( ctag -- n )
|
||||
second second ;
|
||||
|
||||
: ctag ( seq -- str )
|
||||
[
|
||||
dup first ?word-name %
|
||||
dup ctag-word ?word-name %
|
||||
"\t" %
|
||||
second dup first normalize-path %
|
||||
dup ctag-path normalize-path %
|
||||
"\t" %
|
||||
second number>string %
|
||||
ctag-lineno number>string %
|
||||
] "" make ;
|
||||
|
||||
: ctag-strings ( seq1 -- seq2 )
|
||||
{ } swap [ ctag suffix ] each ;
|
||||
[ ctag ] map ;
|
||||
|
||||
: ctags-write ( seq path -- )
|
||||
[ ctag-strings ] dip ascii set-file-lines ;
|
||||
|
||||
: (ctags) ( -- seq )
|
||||
{ } all-words [
|
||||
all-words [
|
||||
dup where [
|
||||
2array suffix
|
||||
] [
|
||||
drop
|
||||
] if*
|
||||
] each ;
|
||||
2array
|
||||
] when*
|
||||
] map [ sequence? ] filter ;
|
||||
|
||||
: ctags ( path -- )
|
||||
(ctags) sort-keys swap ctags-write ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Alfredo Beaumont
|
||||
|
|
@ -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" ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Etags generator
|
||||
|
|
@ -79,3 +79,15 @@ CONSULT: beta hey value>> 1- ;
|
|||
[ -1 ] [ 1 <hey> four ] unit-test
|
||||
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] 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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Daniel Ehrenberg
|
||||
! Copyright (C) 2007, 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors parser generic kernel classes classes.tuple
|
||||
words slots assocs sequences arrays vectors definitions
|
||||
|
|
@ -14,9 +14,11 @@ IN: delegate
|
|||
GENERIC: group-words ( group -- words )
|
||||
|
||||
M: tuple-class group-words
|
||||
"slot-names" word-prop [
|
||||
[ reader-word ] [ writer-word ] bi
|
||||
2array [ 0 2array ] map
|
||||
all-slots [
|
||||
name>>
|
||||
[ reader-word 0 2array ]
|
||||
[ writer-word 0 2array ] bi
|
||||
2array
|
||||
] map concat ;
|
||||
|
||||
! Consultation
|
||||
|
|
|
|||
|
|
@ -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
|
||||
math ;
|
||||
math arrays ;
|
||||
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
|
||||
{ $values { "n" integer } }
|
||||
{ $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 "
|
||||
"input parameter."
|
||||
{ $subsection narray }
|
||||
{ $subsection firstn }
|
||||
{ $subsection ndup }
|
||||
{ $subsection npick }
|
||||
{ $subsection nrot }
|
||||
|
|
|
|||
|
|
@ -32,3 +32,7 @@ IN: generalizations.tests
|
|||
[ [ dup 2^ 2array ] 5 napply ] must-infer
|
||||
|
||||
[ { "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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
USING: kernel sequences sequences.private namespaces math math.ranges
|
||||
combinators macros quotations fry locals arrays ;
|
||||
USING: kernel sequences sequences.private namespaces math
|
||||
math.ranges combinators macros quotations fry arrays ;
|
||||
IN: generalizations
|
||||
|
||||
MACRO: narray ( n -- quot )
|
||||
dup [ f <array> ] curry
|
||||
swap <reversed> [
|
||||
[ swap [ set-nth-unsafe ] keep ] curry
|
||||
] map concat append ;
|
||||
[ <reversed> ] [ '[ , f <array> ] ] bi
|
||||
[ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
[ [ '[ , _ nth-unsafe ] ] map ]
|
||||
[ 1- '[ , _ bounds-check 2drop ] ]
|
||||
bi prefix '[ , cleave ]
|
||||
] if ;
|
||||
|
||||
MACRO: npick ( n -- )
|
||||
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
|
||||
|
|
@ -32,7 +38,7 @@ MACRO: ntuck ( n -- )
|
|||
2 + [ dupd -nrot ] curry ;
|
||||
|
||||
MACRO: nrev ( n -- quot )
|
||||
1 [a,b] [ '[ , -nrot ] ] map concat ;
|
||||
1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;
|
||||
|
||||
MACRO: ndip ( quot n -- )
|
||||
dup saver -rot restorer 3append ;
|
||||
|
|
@ -44,11 +50,11 @@ MACRO: nkeep ( n -- )
|
|||
[ ] [ 1+ ] [ ] tri
|
||||
'[ [ , ndup ] dip , -nrot , nslip ] ;
|
||||
|
||||
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
|
||||
MACRO: ncurry ( n -- )
|
||||
[ curry ] n*quot ;
|
||||
|
||||
MACRO:: nwith ( quot n -- )
|
||||
[let | n' [ n 1+ ] |
|
||||
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
|
||||
MACRO: nwith ( n -- )
|
||||
[ with ] n*quot ;
|
||||
|
||||
MACRO: napply ( n -- )
|
||||
2 [a,b]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
io.streams.string http.client sequences.lib combinators
|
||||
io.streams.string http.client generalizations combinators
|
||||
math.parser math.vectors math.intervals interval-maps memoize
|
||||
csv accessors assocs strings math splitting grouping arrays ;
|
||||
IN: geo-ip
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@ IN: math.ranges
|
|||
|
||||
ARTICLE: "ranges" "Ranges"
|
||||
|
||||
"A " { $emphasis "range" } " is a virtual sequence with elements "
|
||||
"ranging from a to b by step."
|
||||
"A " { $emphasis "range" } " is a virtual sequence with real elements "
|
||||
"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
|
||||
|
||||
$nl
|
||||
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
{ $subsection activate-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"
|
||||
"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! USING: kernel quotations namespaces sequences assocs.lib ;
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -58,6 +58,7 @@ MATCH-VARS: ?a ?b ?c ;
|
|||
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
|
||||
{ { { ?a ?b } { ?a ?b ?a } } [ over ] }
|
||||
{ { { ?b ?a } { ?a ?b } } [ swap ] }
|
||||
{ { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
|
||||
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
|
||||
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
|
||||
|
|
|
|||
|
|
@ -67,11 +67,6 @@ IN: sequences.lib.tests
|
|||
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] 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
|
||||
[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -20,11 +20,6 @@ IN: sequences.lib
|
|||
|
||||
: 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 -- )
|
||||
|
|
|
|||
|
|
@ -1,9 +1,13 @@
|
|||
USING: help.syntax help.markup splitting kernel ;
|
||||
USING: help.syntax help.markup splitting kernel sequences ;
|
||||
IN: tuple-arrays
|
||||
|
||||
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>
|
||||
{ $values { "example" tuple } { "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 } "." } ;
|
||||
{ $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." } ;
|
||||
|
||||
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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
SYMBOL: mat
|
||||
TUPLE: foo bar ;
|
||||
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 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{ foo f 3 } t ]
|
||||
[ 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 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
|
||||
|
|
|
|||
|
|
@ -4,27 +4,26 @@ USING: splitting grouping classes.tuple classes math kernel
|
|||
sequences arrays accessors ;
|
||||
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 1- [ * { } new-sequence ] keep <sliced-groups> ]
|
||||
[ class ] bi tuple-array boa ;
|
||||
: <tuple-array> ( length class -- tuple-array )
|
||||
[
|
||||
new tuple>array 1 tail
|
||||
[ <repetition> concat ] [ length ] bi <sliced-groups>
|
||||
] [ ] bi tuple-array boa ;
|
||||
|
||||
M: tuple-array nth
|
||||
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
|
||||
|
||||
: deconstruct ( tuple -- seq )
|
||||
tuple>array 1 tail ;
|
||||
|
||||
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
|
||||
class>> new <tuple-array> ;
|
||||
class>> <tuple-array> ;
|
||||
|
||||
: >tuple-array ( seq -- tuple-array/seq )
|
||||
: >tuple-array ( seq -- tuple-array )
|
||||
dup empty? [
|
||||
0 over first <tuple-array> clone-like
|
||||
0 over first class <tuple-array> clone-like
|
||||
] unless ;
|
||||
|
||||
M: tuple-array like
|
||||
|
|
|
|||
|
|
@ -230,5 +230,3 @@ M: radio-control model-changed
|
|||
swap
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> add-gadget ] curry assoc-each ;
|
||||
|
||||
: toolbar, ( -- ) g <toolbar> f track, ;
|
||||
|
|
|
|||
|
|
@ -185,16 +185,8 @@ HELP: make-gadget
|
|||
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
|
||||
|
||||
HELP: with-gadget
|
||||
{ $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." } ;
|
||||
|
||||
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 } "." } ;
|
||||
{ $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" } } ;
|
||||
|
||||
{ control-value set-control-value gadget-model } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -357,10 +357,6 @@ M: f request-focus-on 2drop ;
|
|||
: focus-path ( world -- seq )
|
||||
[ focus>> ] follow ;
|
||||
|
||||
: g ( -- gadget ) gadget get ;
|
||||
|
||||
: g-> ( x -- x x gadget ) dup g ;
|
||||
|
||||
: with-gadget ( gadget quot -- )
|
||||
gadget swap with-variable ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -24,6 +24,8 @@ grid
|
|||
>r >r 2dup swap add-gadget drop r> r>
|
||||
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 -- )
|
||||
>r >r >r <gadget> r> r> r> grid-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,17 +5,16 @@ ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
|
|||
ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
|
||||
ui.gadgets.grids io kernel math models namespaces prettyprint
|
||||
sequences sequences words classes.tuple ui.gadgets ui.render
|
||||
colors ;
|
||||
colors accessors ;
|
||||
IN: ui.gadgets.labelled
|
||||
|
||||
TUPLE: labelled-gadget < track content ;
|
||||
|
||||
: <labelled-gadget> ( gadget title -- newgadget )
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
[
|
||||
<label> reverse-video-theme f track,
|
||||
g-> set-labelled-gadget-content 1 track,
|
||||
] make-gadget ;
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
swap <label> reverse-video-theme f track-add*
|
||||
swap >>content
|
||||
dup content>> 1 track-add* ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
|
||||
|
|
@ -50,10 +49,9 @@ TUPLE: closable-gadget < frame content ;
|
|||
[ [ closable-gadget? ] is? ] find-parent ;
|
||||
|
||||
: <closable-gadget> ( gadget title quot -- gadget )
|
||||
closable-gadget new-frame
|
||||
[
|
||||
<title-bar> @top frame,
|
||||
g-> set-closable-gadget-content @center frame,
|
||||
] make-gadget ;
|
||||
|
||||
closable-gadget new-frame
|
||||
-rot <title-bar> @top grid-add*
|
||||
swap >>content
|
||||
dup content>> @center grid-add* ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
|
|
|
|||
|
|
@ -64,7 +64,11 @@ M: object >label ;
|
|||
M: f >label drop <gadget> ;
|
||||
|
||||
: 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 )
|
||||
[ f track, >label 1 track, ] { 1 0 } make-track ;
|
||||
{ 1 0 } <track>
|
||||
swap f track-add*
|
||||
swap >label 1 track-add* ;
|
||||
|
|
|
|||
|
|
@ -9,10 +9,6 @@ ARTICLE: "ui-pack-layout" "Pack layouts"
|
|||
{ $subsection <pack> }
|
||||
{ $subsection <pile> }
|
||||
{ $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:"
|
||||
{ $subsection pack-pref-dim }
|
||||
|
|
@ -24,9 +20,6 @@ HELP: pack
|
|||
{ $link <pack> }
|
||||
{ $link <pile> }
|
||||
{ $link <shelf> }
|
||||
{ $link make-pile }
|
||||
{ $link make-filled-pile }
|
||||
{ $link make-shelf }
|
||||
}
|
||||
"Packs have the following slots:"
|
||||
{ $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."
|
||||
} ;
|
||||
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -5,10 +5,8 @@ kernel namespaces tools.test math.parser sequences math.geometry.rect ;
|
|||
[ t ] [
|
||||
{ 0 0 } { 100 100 } <rect> clip set
|
||||
|
||||
[
|
||||
100 [ number>string <label> gadget, ] each
|
||||
] make-pile
|
||||
|
||||
<pile>
|
||||
100 [ number>string <label> add-gadget ] each
|
||||
dup layout
|
||||
|
||||
visible-children [ label? ] all?
|
||||
|
|
|
|||
|
|
@ -60,12 +60,3 @@ M: pack layout*
|
|||
M: pack children-on ( rect gadget -- seq )
|
||||
dup gadget-orientation swap gadget-children
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -29,30 +29,22 @@ scroller H{
|
|||
{ T{ mouse-scroll } [ do-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: viewport, ( child -- )
|
||||
g model>> <viewport>
|
||||
g-> set-scroller-viewport @center frame, ;
|
||||
|
||||
: <scroller-model> ( -- model )
|
||||
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-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
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 ;
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
|
||||
: <scroller> ( gadget -- scroller )
|
||||
scroller new-scroller ;
|
||||
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add*
|
||||
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 -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -138,10 +138,11 @@ M: elevator layout*
|
|||
[ swap find-slider slide-by-line ] curry <repeat-button>
|
||||
[ set-gadget-orientation ] keep ;
|
||||
|
||||
: elevator, ( orientation -- )
|
||||
dup <elevator> g-> set-slider-elevator
|
||||
swap <thumb> g-> set-slider-thumb add-gadget
|
||||
@center frame, ;
|
||||
: elevator, ( gadget orientation -- gadget )
|
||||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
@center grid-add* ;
|
||||
|
||||
: <left-button> ( -- button )
|
||||
{ 0 1 } arrow-left -1 <slide-button> ;
|
||||
|
|
@ -149,26 +150,12 @@ M: elevator layout*
|
|||
: <right-button> ( -- 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 )
|
||||
{ 1 0 } arrow-up -1 <slide-button> ;
|
||||
|
||||
: <down-button> ( -- 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 new-frame
|
||||
swap >>orientation
|
||||
|
|
@ -176,10 +163,16 @@ M: elevator layout*
|
|||
32 >>line ;
|
||||
|
||||
: <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 )
|
||||
{ 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*
|
||||
dup call-next-method
|
||||
|
|
|
|||
|
|
@ -69,15 +69,13 @@ M: value-ref finish-editing
|
|||
} define-command
|
||||
|
||||
: <slot-editor> ( ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
[
|
||||
toolbar,
|
||||
<source-editor> g-> set-slot-editor-text
|
||||
<scroller> 1 track,
|
||||
] make-gadget
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add*
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add*
|
||||
dup revert ;
|
||||
|
||||
|
||||
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
||||
|
||||
M: slot-editor focusable-child* text>> ;
|
||||
|
|
|
|||
|
|
@ -48,9 +48,13 @@ DEFER: (del-page)
|
|||
[ names>> index ] 2keep (del-page) ;
|
||||
|
||||
: <tabbed> ( assoc -- tabbed )
|
||||
tabbed new-frame
|
||||
[ g 0 <model> >>model
|
||||
<pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
|
||||
[ keys >vector g swap >>names ]
|
||||
[ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
|
||||
g redo-toggler g ] with-gadget ;
|
||||
tabbed new-frame
|
||||
0 <model> >>model
|
||||
<pile> 1 >>fill >>toggler
|
||||
dup toggler>> @left grid-add*
|
||||
swap
|
||||
[ keys >vector >>names ]
|
||||
[ values over model>> <book> >>content dup content>> @center grid-add* ]
|
||||
bi
|
||||
dup redo-toggler ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,13 +20,11 @@ TUPLE: browser-gadget < track pane history ;
|
|||
"handbook" >link <history> >>history drop ;
|
||||
|
||||
: <browser-gadget> ( -- gadget )
|
||||
{ 0 1 } browser-gadget new-track
|
||||
{ 0 1 } browser-gadget new-track
|
||||
dup init-history
|
||||
[
|
||||
toolbar,
|
||||
g <help-pane> g-> set-browser-gadget-pane
|
||||
<scroller> 1 track,
|
||||
] make-gadget ;
|
||||
dup <toolbar> f track-add*
|
||||
dup <help-pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
|
||||
M: browser-gadget call-tool* show-help ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
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.slots ui.gadgets.tracks ui.gestures
|
||||
ui.gadgets.buttons namespaces ;
|
||||
|
|
@ -9,27 +9,26 @@ IN: ui.tools.inspector
|
|||
TUPLE: inspector-gadget < track object pane ;
|
||||
|
||||
: refresh ( inspector -- )
|
||||
dup inspector-gadget-object swap inspector-gadget-pane [
|
||||
H{ { +editable+ t } { +number-rows+ t } } describe*
|
||||
[ object>> ] [ pane>> ] bi [
|
||||
+editable+ on
|
||||
+number-rows+ on
|
||||
describe
|
||||
] with-pane ;
|
||||
|
||||
: <inspector-gadget> ( -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
[
|
||||
toolbar,
|
||||
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
: inspect-object ( obj inspector -- )
|
||||
[ set-inspector-gadget-object ] keep refresh ;
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
dup <toolbar> f track-add*
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
|
||||
: inspect-object ( obj mirror keys inspector -- )
|
||||
2nip swap >>object refresh ;
|
||||
|
||||
\ &push 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 ;
|
||||
|
||||
|
|
@ -39,7 +38,7 @@ inspector-gadget "toolbar" f {
|
|||
{ T{ update-object } refresh }
|
||||
{ f &push }
|
||||
{ f &back }
|
||||
{ f globals }
|
||||
{ f &globals }
|
||||
{ T{ key-down f f "F1" } inspector-help }
|
||||
} define-command-map
|
||||
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ IN: ui.tools.listener
|
|||
|
||||
TUPLE: listener-gadget < track input output stack ;
|
||||
|
||||
: listener-output, ( -- )
|
||||
<scrolling-pane> g-> set-listener-gadget-output
|
||||
<scroller> "Output" <labelled-gadget> 1 track, ;
|
||||
: listener-output, ( listener -- listener )
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
|
@ -22,10 +22,12 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
: <listener-input> ( listener -- gadget )
|
||||
output>> <pane-stream> <interactor> ;
|
||||
|
||||
: listener-input, ( -- )
|
||||
g <listener-input> g-> set-listener-gadget-input
|
||||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
{ 0 100 } <limited-scroller>
|
||||
"Input" <labelled-gadget> f track, ;
|
||||
"Input" <labelled-gadget>
|
||||
f track-add* ;
|
||||
|
||||
: welcome. ( -- )
|
||||
"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 ;
|
||||
|
||||
: <stack-display> ( -- gadget )
|
||||
g workspace-listener
|
||||
{ 0 1 } stack-display new-track
|
||||
[
|
||||
dup <toolbar> f track,
|
||||
stack>> [ [ stack. ] curry try ]
|
||||
t "Data stack" <labelled-pane> 1 track,
|
||||
] make-gadget ;
|
||||
: <stack-display> ( workspace -- gadget )
|
||||
listener>>
|
||||
{ 0 1 } stack-display new-track
|
||||
over <toolbar> f track-add*
|
||||
swap
|
||||
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
|
||||
1 track-add* ;
|
||||
|
||||
M: stack-display tool-scroller
|
||||
find-workspace workspace-listener tool-scroller ;
|
||||
|
|
@ -170,10 +171,11 @@ M: stack-display tool-scroller
|
|||
f <model> swap set-listener-gadget-stack ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
{ 0 1 } listener-gadget new-track
|
||||
dup init-listener
|
||||
[ listener-output, listener-input, ] make-gadget ;
|
||||
|
||||
listener-output,
|
||||
listener-input, ;
|
||||
|
||||
: listener-help ( -- ) "ui-listener" help-window ;
|
||||
|
||||
\ listener-help H{ { +nullary+ t } } define-command
|
||||
|
|
|
|||
|
|
@ -2,19 +2,17 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.tools.workspace kernel quotations tools.profiler
|
||||
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
|
||||
|
||||
TUPLE: profiler-gadget < track pane ;
|
||||
|
||||
: <profiler-gadget> ( -- gadget )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
[
|
||||
toolbar,
|
||||
<pane> g-> set-profiler-gadget-pane
|
||||
<scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
dup <toolbar> f track-add*
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
|
||||
: with-profiler-pane ( gadget quot -- )
|
||||
>r profiler-gadget-pane r> with-pane ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,12 +5,10 @@ ui.gadgets.labelled ui.gadgets.presentations
|
|||
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
||||
IN: ui.tools.tests
|
||||
|
||||
[ f ]
|
||||
[
|
||||
[ f ] [
|
||||
0 <model> <gadget> [ set-gadget-model ] keep gadget set
|
||||
<workspace-tabs> gadget-children empty?
|
||||
] unit-test
|
||||
] with-scope
|
||||
<gadget> 0 <model> >>model <workspace-tabs> children>> empty?
|
||||
] unit-test
|
||||
|
||||
[ ] [ <workspace> "w" set ] unit-test
|
||||
[ ] [ "w" get com-scroll-up ] unit-test
|
||||
|
|
|
|||
|
|
@ -12,31 +12,36 @@ tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
|
|||
mirrors ;
|
||||
IN: ui.tools
|
||||
|
||||
: <workspace-tabs> ( -- tabs )
|
||||
g gadget-model
|
||||
"tool-switching" workspace command-map commands>>
|
||||
: <workspace-tabs> ( workspace -- tabs )
|
||||
model>>
|
||||
"tool-switching" workspace command-map commands>>
|
||||
[ command-string ] { } assoc>map <enum> >alist
|
||||
<toggle-buttons> ;
|
||||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( -- gadget )
|
||||
[
|
||||
<stack-display> ,
|
||||
<browser-gadget> ,
|
||||
<inspector-gadget> ,
|
||||
<profiler-gadget> ,
|
||||
] { } make g gadget-model <book> ;
|
||||
: <workspace-book> ( workspace -- gadget )
|
||||
|
||||
dup
|
||||
<stack-display>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<profiler-gadget>
|
||||
4array
|
||||
|
||||
swap model>>
|
||||
|
||||
<book> ;
|
||||
|
||||
: <workspace> ( -- workspace )
|
||||
{ 0 1 } workspace new-track
|
||||
0 <model> >>model
|
||||
[
|
||||
<listener-gadget> g set-workspace-listener
|
||||
<workspace-book> g set-workspace-book
|
||||
<workspace-tabs> f track,
|
||||
g workspace-book 1/5 track,
|
||||
g workspace-listener 4/5 track,
|
||||
toolbar,
|
||||
] make-gadget ;
|
||||
{ 0 1 } workspace new-track
|
||||
|
||||
0 <model> >>model
|
||||
<listener-gadget> >>listener
|
||||
dup <workspace-book> >>book
|
||||
|
||||
dup <workspace-tabs> f track-add*
|
||||
dup book>> 1/5 track-add*
|
||||
dup listener>> 4/5 track-add*
|
||||
dup <toolbar> f track-add* ;
|
||||
|
||||
: resize-workspace ( workspace -- )
|
||||
dup track-sizes over control-value zero? [
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors continuations kernel models namespaces
|
||||
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
|
||||
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
|
||||
ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
|
||||
hashtables inspector ;
|
||||
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
|
||||
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
|
||||
ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
|
||||
hashtables inspector ;
|
||||
|
||||
IN: ui.tools.traceback
|
||||
|
||||
: <callstack-display> ( model -- gadget )
|
||||
|
|
@ -24,20 +25,18 @@ TUPLE: traceback-gadget < track ;
|
|||
M: traceback-gadget pref-dim* drop { 550 600 } ;
|
||||
|
||||
: <traceback-gadget> ( model -- gadget )
|
||||
{ 0 1 } traceback-gadget new-track
|
||||
swap >>model
|
||||
[
|
||||
g model>>
|
||||
[
|
||||
[
|
||||
[ <datastack-display> 1/2 track, ]
|
||||
[ <retainstack-display> 1/2 track, ]
|
||||
bi
|
||||
] { 1 0 } make-track 1/3 track,
|
||||
]
|
||||
[ <callstack-display> 2/3 track, ] bi
|
||||
toolbar,
|
||||
] make-gadget ;
|
||||
{ 0 1 } traceback-gadget new-track
|
||||
swap >>model
|
||||
|
||||
dup model>>
|
||||
{ 1 0 } <track>
|
||||
over <datastack-display> 1/2 track-add*
|
||||
swap <retainstack-display> 1/2 track-add*
|
||||
1/3 track-add*
|
||||
|
||||
dup model>> <callstack-display> 2/3 track-add*
|
||||
|
||||
dup <toolbar> f track-add* ;
|
||||
|
||||
: <namestack-display> ( model -- gadget )
|
||||
[ [ continuation-name namestack. ] when* ]
|
||||
|
|
|
|||
|
|
@ -61,12 +61,11 @@ M: walker-gadget focusable-child*
|
|||
swap >>continuation
|
||||
swap >>status
|
||||
dup continuation>> <traceback-gadget> >>traceback
|
||||
[
|
||||
toolbar,
|
||||
g status>> self <thread-status> f track,
|
||||
g traceback>> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
dup <toolbar> f track-add*
|
||||
dup status>> self <thread-status> f track-add*
|
||||
dup traceback>> 1 track-add* ;
|
||||
|
||||
: walker-help ( -- ) "ui-walker" help-window ;
|
||||
|
||||
\ walker-help H{ { +nullary+ t } } define-command
|
||||
|
|
|
|||
|
|
@ -238,10 +238,7 @@ $nl
|
|||
"Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable."
|
||||
$nl
|
||||
"A combinator which stores a gadget in the " { $link gadget } " variable:"
|
||||
{ $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-> } ;
|
||||
{ $subsection with-gadget } ;
|
||||
|
||||
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:"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! 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
|
||||
words accessors math.order sorting ;
|
||||
IN: usa-cities
|
||||
|
|
|
|||
14
vm/cpu-ppc.S
14
vm/cpu-ppc.S
|
|
@ -103,20 +103,6 @@ DEF(void,c_to_factor,(CELL quot)):
|
|||
EPILOGUE
|
||||
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
|
||||
limitation which would otherwise require us to do a bizzaro PC-relative
|
||||
trampoline to retrieve the function address */
|
||||
|
|
|
|||
Loading…
Reference in New Issue