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

Merge branch 'master' of factorcode.org:/git/factor into cuda-changes

db4
Joe Groff 2010-05-04 17:34:31 -07:00
parent 67b991dbe3 de8e0ccd5c
commit 0778923d98
13 changed files with 148 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
basis/alien/c-types/c-types.factor
View File

@ -164,17 +164,12 @@ M: c-type stack-size size>> cell align ;
MIXIN: value-type
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
] unless* ;
: c-type-getter-boxer ( name -- quot )
[ c-getter ] [ c-type-boxer-quot ] bi append ;
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
: c-setter ( name -- quot )
c-type-setter [
[ "Cannot write struct fields with this type" throw ]
] unless* ;
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
[ c-type-setter ]
bi append ;
: array-accessor ( c-type quot -- def )
[
@ -295,7 +290,7 @@ M: pointer c-type
c-ptr >>class
c-ptr >>boxed-class
[ alien-cell ] >>getter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
@ -304,30 +299,6 @@ M: pointer c-type
"alien_offset" >>unboxer
\ void* define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_signed_4" >>boxer
"to_fixnum" >>unboxer
\ int define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_unsigned_4" >>boxer
"to_cell" >>unboxer
\ uint define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
@ -338,6 +309,7 @@ M: pointer c-type
2 >>align-first
"from_signed_2" >>boxer
"to_fixnum" >>unboxer
[ >fixnum ] >>unboxer-quot
\ short define-primitive-type
<c-type>
@ -350,6 +322,7 @@ M: pointer c-type
2 >>align-first
"from_unsigned_2" >>boxer
"to_cell" >>unboxer
[ >fixnum ] >>unboxer-quot
\ ushort define-primitive-type
<c-type>
@ -362,6 +335,7 @@ M: pointer c-type
1 >>align-first
"from_signed_1" >>boxer
"to_fixnum" >>unboxer
[ >fixnum ] >>unboxer-quot
\ char define-primitive-type
<c-type>
@ -374,34 +348,14 @@ M: pointer c-type
1 >>align-first
"from_unsigned_1" >>boxer
"to_cell" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uchar define-primitive-type
cpu ppc? [
<c-type>
[ alien-unsigned-4 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
] [
<c-type>
[ alien-unsigned-1 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
1 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
] if
\ bool define-primitive-type
<c-type>
math:float >>class
math:float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
[ set-alien-float ] >>setter
4 >>size
4 >>align
4 >>align-first
@ -415,7 +369,7 @@ M: pointer c-type
math:float >>class
math:float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
[ set-alien-double ] >>setter
8 >>size
8-byte-alignment
"from_double" >>boxer
@ -425,14 +379,40 @@ M: pointer c-type
\ double define-primitive-type
cell 8 = [
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_signed_4" >>boxer
"to_fixnum" >>unboxer
[ >fixnum ] >>unboxer-quot
\ int define-primitive-type
<c-type>
fixnum >>class
fixnum >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_unsigned_4" >>boxer
"to_cell" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uint define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
8 >>size
8 >>align
8 >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
\ longlong define-primitive-type
@ -442,9 +422,9 @@ M: pointer c-type
integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
8 >>size
8 >>align
8 >>align-first
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
\ ulonglong define-primitive-type
@ -463,6 +443,30 @@ M: pointer c-type
\ ulonglong c-type \ uintptr_t typedef
\ ulonglong c-type \ size_t typedef
] [
<c-type>
integer >>class
integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
\ int define-primitive-type
<c-type>
integer >>class
integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
4 >>size
4 >>align
4 >>align-first
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
\ uint define-primitive-type
<long-long-type>
integer >>class
integer >>boxed-class
@ -495,6 +499,12 @@ M: pointer c-type
\ uint c-type \ size_t typedef
] if
cpu ppc? \ uint \ uchar ? c-type clone
[ >c-bool ] >>unboxer-quot
[ c-bool> ] >>boxer-quot
object >>boxed-class
\ bool define-primitive-type
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;

3
basis/alien/data/data.factor
View File

@ -68,8 +68,7 @@ M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
[ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
M: array c-type-boxer-quot
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;

2
basis/alien/parser/parser.factor
View File

@ -169,7 +169,7 @@ PREDICATE: alien-callback-type-word < typedef-word
: global-quot ( type word -- quot )
name>> current-library get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
swap c-getter append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

12
basis/bootstrap/compiler/timing/timing.factor
View File

@ -1,12 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel make sequences tools.annotations tools.crossref ;
QUALIFIED: compiler.cfg.builder
QUALIFIED: compiler.cfg.linear-scan
QUALIFIED: compiler.cfg.mr
QUALIFIED: compiler.cfg.optimizer
QUALIFIED: compiler.cfg.stacks.finalize
QUALIFIED: compiler.cfg.stacks.global
QUALIFIED: compiler.cfg.finalization
QUALIFIED: compiler.codegen
QUALIFIED: compiler.tree.builder
QUALIFIED: compiler.tree.optimizer
@ -19,7 +17,7 @@ IN: bootstrap.compiler.timing
: low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
: machine-passes ( -- seq ) \ compiler.cfg.finalization:finalize-cfg passes ;
: linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
@ -29,11 +27,9 @@ IN: bootstrap.compiler.timing
\ compiler.tree.optimizer:optimize-tree ,
high-level-passes %
\ compiler.cfg.builder:build-cfg ,
\ compiler.cfg.stacks.global:compute-global-sets ,
\ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
\ compiler.cfg.optimizer:optimize-cfg ,
low-level-passes %
\ compiler.cfg.mr:build-mr ,
\ compiler.cfg.finalization:finalize-cfg ,
machine-passes %
linear-scan-passes %
\ compiler.codegen:generate ,

4
basis/classes/struct/struct-tests.factor
View File

@ -211,7 +211,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ name "y" }
{ offset 4 }
{ initial 123 }
{ class integer }
{ class $[ cell 4 = integer fixnum ? ] }
{ type int }
}
T{ struct-slot-spec
@ -235,7 +235,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ name "bits" }
{ offset 0 }
{ type uint }
{ class integer }
{ class $[ cell 4 = integer fixnum ? ] }
{ initial 0 }
}
} ] [ struct-test-float-and-bits c-type fields>> ] unit-test

2
basis/classes/struct/struct.factor
View File

@ -101,7 +101,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
GENERIC: (reader-quot) ( slot -- quot )
M: struct-slot-spec (reader-quot)
[ type>> c-type-getter-boxer ]
[ type>> c-getter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
M: struct-bit-slot-spec (reader-quot)

2
basis/specialized-arrays/specialized-arrays.factor
View File

@ -45,7 +45,7 @@ byte-array>A DEFINES byte-array>${A}
A{ DEFINES ${A}{
A@ DEFINES ${A}@
NTH [ T dup c-type-getter-boxer array-accessor ]
NTH [ T dup c-getter array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
WHERE

6
basis/vm/vm.factor
View File

@ -19,10 +19,10 @@ STRUCT: context
: context-field-offset ( field -- offset ) context offset-of ; inline
STRUCT: zone
{ start cell }
{ here cell }
{ size cell }
{ end cell } ;
{ start cell }
{ end cell }
{ size cell } ;
STRUCT: vm
{ ctx context* }

19
extra/mason/release/tidy/tidy.factor
View File

@ -6,17 +6,14 @@ kernel mason.common namespaces sequences ;
FROM: mason.config => target-os ;
IN: mason.release.tidy
: common-files ( -- seq )
: useless-files ( -- seq )
"build-support/cleanup" ascii file-lines
images [ boot-image-name ] map
append ;
: remove-common-files ( -- )
common-files [ really-delete-tree ] each ;
: remove-factor-app ( -- )
target-os get "macosx" =
[ "Factor.app" really-delete-tree ] unless ;
images [ boot-image-name ] map append
target-os get "macosx" = [ "Factor.app" suffix ] unless ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;
"factor" [
useless-files
[ exists? ] filter
[ really-delete-tree ] each
] with-directory ;

2
extra/trees/avl/avl-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel tools.test trees trees.avl math random sequences
assocs accessors ;
assocs accessors trees.avl.private trees.private ;
IN: trees.avl.tests
[ "key1" 0 "key2" 0 ] [

18
extra/trees/avl/avl.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel generic math math.functions
math.parser namespaces io sequences trees shuffle
assocs parser accessors math.order prettyprint.custom ;
assocs parser accessors math.order prettyprint.custom
trees.private ;
IN: trees.avl
TUPLE: avl < tree ;
@ -10,6 +11,8 @@ TUPLE: avl < tree ;
: <avl> ( -- tree )
avl new-tree ;
<PRIVATE
TUPLE: avl-node < node balance ;
: <avl-node> ( key value -- node )
@ -20,11 +23,14 @@ TUPLE: avl-node < node balance ;
swap [ + ] change-balance drop ;
: rotate ( node -- node )
dup node+link dup node-link pick set-node+link
tuck set-node-link ;
dup node+link
dup node-link
pick set-node+link
[ set-node-link ] keep ;
: single-rotate ( node -- node )
0 over (>>balance) 0 over node+link
0 >>balance
0 over node+link
(>>balance) rotate ;
: pick-balances ( a node -- balance balance )
@ -61,7 +67,7 @@ DEFER: avl-set
: avl-insert ( value key node -- node taller? )
2dup key>> before? left right ? [
[ node-link avl-set ] keep swap
[ tuck set-node-link ] dip
[ [ set-node-link ] keep ] dip
[ dup current-side get increase-balance balance-insert ]
[ f ] if
] with-side ;
@ -146,6 +152,8 @@ M: avl delete-at ( key node -- )
M: avl new-assoc 2drop <avl> ;
PRIVATE>
: >avl ( assoc -- avl )
T{ avl f f 0 } assoc-clone-like ;

38
extra/trees/splay/splay.factor
View File

@ -1,7 +1,8 @@
! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences assocs parser
trees generic math.order accessors prettyprint.custom shuffle ;
trees generic math.order accessors prettyprint.custom
trees.private combinators ;
IN: trees.splay
TUPLE: splay < tree ;
@ -9,6 +10,8 @@ TUPLE: splay < tree ;
: <splay> ( -- tree )
\ splay new-tree ;
<PRIVATE
: rotate-right ( node -- node )
dup left>>
[ right>> swap (>>left) ] 2keep
@ -27,32 +30,35 @@ TUPLE: splay < tree ;
swap [ rot [ (>>right) ] 2keep
drop dup right>> swapd ] dip swap ;
: cmp ( key node -- obj node -1/0/1 )
2dup key>> key-side ;
: cmp ( key node -- obj node <=> )
2dup key>> <=> ;
: lcmp ( key node -- obj node -1/0/1 )
2dup left>> key>> key-side ;
: lcmp ( key node -- obj node <=> )
2dup left>> key>> <=> ;
: rcmp ( key node -- obj node -1/0/1 )
2dup right>> key>> key-side ;
: rcmp ( key node -- obj node <=> )
2dup right>> key>> <=> ;
DEFER: (splay)
: splay-left ( left right key node -- left right key node )
dup left>> [
lcmp 0 < [ rotate-right ] when
lcmp +lt+ = [ rotate-right ] when
dup left>> [ link-right (splay) ] when
] when ;
: splay-right ( left right key node -- left right key node )
dup right>> [
rcmp 0 > [ rotate-left ] when
rcmp +gt+ = [ rotate-left ] when
dup right>> [ link-left (splay) ] when
] when ;
: (splay) ( left right key node -- left right key node )
cmp dup 0 <
[ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
cmp {
{ +lt+ [ splay-left ] }
{ +gt+ [ splay-right ] }
{ +eq+ [ ] }
} case ;
: assemble ( head left right node -- root )
[ right>> swap (>>left) ] keep
@ -64,18 +70,18 @@ DEFER: (splay)
[ T{ node } clone dup dup ] 2dip
(splay) nip assemble ;
: splay ( key tree -- )
: do-splay ( key tree -- )
[ root>> splay-at ] keep (>>root) ;
: splay-split ( key tree -- node node )
2dup splay root>> cmp 0 < [
2dup do-splay root>> cmp +lt+ = [
nip dup left>> swap f over (>>left)
] [
nip dup right>> swap f over (>>right) swap
] if ;
: get-splay ( key tree -- node ? )
2dup splay root>> cmp 0 = [
2dup do-splay root>> cmp +eq+ = [
nip t
] [
2drop f f
@ -95,7 +101,7 @@ DEFER: (splay)
] if* ;
: remove-splay ( key tree -- )
tuck get-splay nip [
[ get-splay nip ] keep [
dup dec-count
dup right>> swap left>> splay-join
swap (>>root)
@ -128,6 +134,8 @@ M: splay delete-at ( key tree -- )
M: splay new-assoc
2drop <splay> ;
PRIVATE>
: >splay ( assoc -- tree )
T{ splay f f 0 } assoc-clone-like ;

23
extra/trees/trees.factor
View File

@ -2,22 +2,27 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic math sequences arrays io namespaces
prettyprint.private kernel.private assocs random combinators
parser math.order accessors deques make prettyprint.custom
shuffle ;
parser math.order accessors deques make prettyprint.custom ;
IN: trees
TUPLE: tree root count ;
<PRIVATE
: new-tree ( class -- tree )
new
f >>root
0 >>count ; inline
PRIVATE>
: <tree> ( -- tree )
tree new-tree ;
INSTANCE: tree assoc
<PRIVATE
TUPLE: node key value left right ;
: new-node ( key value class -- node )
@ -61,7 +66,7 @@ CONSTANT: right 1
: set-node+link ( child node -- ) t set-node-link@ ;
: with-side ( side quot -- )
[ swap current-side set call ] with-scope ; inline
[ current-side ] dip with-variable ; inline
: with-other-side ( quot -- )
current-side get neg swap with-side ; inline
@ -137,9 +142,9 @@ DEFER: delete-node
: (prune-extremity) ( parent node -- new-extremity )
dup node-link [
rot drop (prune-extremity)
[ nip ] dip (prune-extremity)
] [
tuck delete-node swap set-node-link
[ delete-node ] [ set-node-link ] bi
] if* ;
: prune-extremity ( node -- new-extremity )
@ -183,9 +188,15 @@ DEFER: delete-node
2dup key>> key-side dup 0 eq? [
drop nip delete-node
] [
[ tuck node-link delete-bst-node over set-node-link ] with-side
[
[ node-link delete-bst-node ]
[ set-node-link ]
[ ] tri
] with-side
] if ;
PRIVATE>
M: tree delete-at
[ delete-bst-node ] change-root drop ;