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

basis/alien/c-types/c-types.factor

@@ -164,17 +164,12 @@ M: c-type stack-size size>> cell align ;
 MIXIN: value-type
 
 : c-getter ( name -- quot )
-    c-type-getter [
+    [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
-        [ "Cannot read struct fields with this type" throw ]
-    ] unless* ;
-
-: c-type-getter-boxer ( name -- quot )
-    [ c-getter ] [ c-type-boxer-quot ] bi append ;
 
 : c-setter ( name -- quot )
-    c-type-setter [
+    [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
-        [ "Cannot write struct fields with this type" throw ]
+    [ c-type-setter ]
-    ] unless* ;
+    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
+            8 >>size
-            bootstrap-cell >>align
+            8 >>align
-            bootstrap-cell >>align-first
+            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
+            8 >>size
-            bootstrap-cell >>align
+            8 >>align
-            bootstrap-cell >>align-first
+            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 ;

basis/alien/data/data.factor

@@ -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
+    [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
-    '[ @ swap @ _ memcpy ] ;
 
 M: array c-type-boxer-quot
     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;

basis/alien/parser/parser.factor

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

basis/bootstrap/compiler/timing/timing.factor

@@ -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.finalization
-QUALIFIED: compiler.cfg.stacks.global
 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 ,

basis/classes/struct/struct-tests.factor

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

basis/classes/struct/struct.factor

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

basis/specialized-arrays/specialized-arrays.factor

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

basis/vm/vm.factor

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

extra/mason/release/tidy/tidy.factor

@@ -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
+    images [ boot-image-name ] map append
-    append ;
+    target-os get "macosx" = [ "Factor.app" suffix ] unless ;
-
-: remove-common-files ( -- )
-    common-files [ really-delete-tree ] each ;
-
-: remove-factor-app ( -- )
-    target-os get "macosx" =
-    [ "Factor.app" really-delete-tree ] unless ;
 
 : tidy ( -- )
-    "factor" [ remove-factor-app remove-common-files ] with-directory ;
+    "factor" [
+        useless-files
+        [ exists? ] filter
+        [ really-delete-tree ] each
+    ] with-directory ;

extra/trees/avl/avl-tests.factor

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

extra/trees/avl/avl.factor

@@ -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
+    dup node+link
-    tuck set-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 ;
 

extra/trees/splay/splay.factor

@@ -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 )
+: cmp ( key node -- obj node <=> )
-    2dup key>> key-side ;
+    2dup key>> <=> ;
 
-: lcmp ( key node -- obj node -1/0/1 ) 
+: lcmp ( key node -- obj node <=> ) 
-    2dup left>> key>> key-side ;
+    2dup left>> key>> <=> ;
 
-: rcmp ( key node -- obj node -1/0/1 ) 
+: rcmp ( key node -- obj node <=> ) 
-    2dup right>> key>> key-side ;
+    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 <
+    cmp {
-    [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
+        { +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 ;
 

extra/trees/trees.factor

@@ -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 
+parser math.order accessors deques make prettyprint.custom ;
-shuffle ;
 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 ;