Remove some usages of tuck

dharmatech · Jan 24, 2009 · f34c14a · f34c14a
1 parent a2cd1dd
commit f34c14a
Show file tree

Hide file tree

Showing 57 changed files with 135 additions and 113 deletions.
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
@@ -433,7 +433,7 @@ M: quotation '
         array>> '
         quotation type-number object tag-number [
             emit ! array
-            f ' emit ! compiled>>
+            f ' emit ! compiled
             0 emit ! xt
             0 emit ! code
         ] emit-object

diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
@@ -211,7 +211,7 @@ TUPLE: my-tuple ;
     { tuple vector } 3 slot { word } declare
     dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
 
-[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
 
 [ vector ] [ dispatch-alignment-regression ] unit-test
 

diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
@@ -9,7 +9,7 @@ IN: optimizer.tests
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;
 
-[ t ] [ \ xyz compiled>> ] unit-test
+[ t ] [ \ xyz optimized>> ] unit-test
 
 ! Test predicate inlining
 : pred-test-1
@@ -94,7 +94,7 @@ TUPLE: pred-test ;
 ! regression
 GENERIC: void-generic ( obj -- * )
 : breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage compiled>> ] unit-test
+[ t ] [ \ breakage optimized>> ] unit-test
 [ breakage ] must-fail
 
 ! regression
@@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
 ! compiling <tuple> with a non-literal class failed
 : <tuple>-regression ( class -- tuple ) <tuple> ;
 
-[ t ] [ \ <tuple>-regression compiled>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized>> ] unit-test
 
 GENERIC: foozul ( a -- b )
 M: reversed foozul ;
@@ -228,7 +228,7 @@ USE: binary-search.private
 : node-successor-f-bug ( x -- * )
     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
 
-[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
 
 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 
@@ -242,7 +242,7 @@ USE: binary-search.private
         ] if
     ] if ;
 
-[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
 [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
 
@@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ;
 : recursive-inline-hang-1 ( -- a )
     { } recursive-inline-hang ;
 
-[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
 
 DEFER: recursive-inline-hang-3
 

diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor
@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
 
 USE: tools.test
 
-[ t ] [ \ expr compiled>> ] unit-test
-[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
+[ t ] [ \ expr optimized>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor
@@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
 : hey ( -- ) ;
 : there ( -- ) hey ;
 
-[ t ] [ \ hey compiled>> ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ hey optimized>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
 [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey compiled>> ] unit-test
-[ f ] [ \ there compiled>> ] unit-test
+[ f ] [ \ hey optimized>> ] unit-test
+[ f ] [ \ there optimized>> ] unit-test
 [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
 
 : good ( -- ) ;
 : bad ( -- ) good ;
 : ugly ( -- ) bad ;
 
-[ t ] [ \ good compiled>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
 
 [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
 
-[ f ] [ \ good compiled>> ] unit-test
-[ f ] [ \ bad compiled>> ] unit-test
-[ f ] [ \ ugly compiled>> ] unit-test
+[ f ] [ \ good optimized>> ] unit-test
+[ f ] [ \ bad optimized>> ] unit-test
+[ f ] [ \ ugly optimized>> ] unit-test
 
 [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
 
 [ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
 
-[ t ] [ \ good compiled>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor
@@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
 : sheeple-test ( -- string ) { } sheeple ;
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 
@@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor
@@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
 10 [
     [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
     [ t ] [
-        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
+        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
     ] unit-test
 ] times
diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor
@@ -47,7 +47,7 @@ IN: compiler.tests
 [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
 [ 1.0 float-spill-bug ] unit-test
 
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-spill-bug optimized>> ] unit-test
 
 : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
     {
@@ -132,7 +132,7 @@ IN: compiler.tests
 [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
 [ 1.0 float-fixnum-spill-bug ] unit-test
 
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
 
 : resolve-spill-bug ( a b -- c )
     [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@@ -159,7 +159,7 @@ IN: compiler.tests
         16 narray
     ] if ;
 
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
 
 [ 4 ] [ 1 1 resolve-spill-bug ] unit-test
 

diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor
@@ -97,10 +97,10 @@ 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 ;
+: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
+: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
 
 ! XO-form
 XO: ADD 0 0 266 31

diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor
@@ -74,8 +74,8 @@ IN: cpu.ppc.assembler.backend
 
 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 ;
+M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
 
 GENERIC: BC ( a b c -- )
 M: integer BC 0 0 16 b-insn ;

diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor
@@ -55,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
     [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
 
 M: postgresql-statement bind-tuple ( tuple statement -- )
-    tuck in-params>>
-    [ postgresql-bind-conversion ] with map
+    [ nip ] [
+        in-params>>
+        [ postgresql-bind-conversion ] with map
+    ] 2bi
     >>bind-params drop ;
 
 M: postgresql-result-set #rows ( result-set -- n )

diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
@@ -73,9 +73,10 @@ PRIVATE>
 ! High level
 ERROR: no-slots-named class seq ;
 : check-columns ( class columns -- )
-    tuck
-    [ [ first ] map ]
-    [ all-slots [ name>> ] map ] bi* diff
+    [ nip ] [
+        [ [ first ] map ]
+        [ all-slots [ name>> ] map ] bi* diff
+    ] 2bi
     [ drop ] [ no-slots-named ] if-empty ;
 
 : define-persistent ( class table columns -- )

diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor
@@ -42,10 +42,10 @@ ERROR: no-slot ;
     slot-named dup [ no-slot ] unless offset>> ;
 
 : get-slot-named ( name tuple -- value )
-    tuck offset-of-slot slot ;
+    [ nip ] [ offset-of-slot ] 2bi slot ;
 
 : set-slot-named ( value name obj -- )
-    tuck offset-of-slot set-slot ;
+    [ nip ] [ offset-of-slot ] 2bi set-slot ;
 
 ERROR: not-persistent class ;
 

diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor
@@ -196,8 +196,8 @@ LOG: httpd-hit NOTICE
 
 LOG: httpd-header NOTICE
 
-: log-header ( headers name -- )
-    tuck header 2array httpd-header ;
+: log-header ( request name -- )
+    [ nip ] [ header ] 2bi 2array httpd-header ;
 
 : log-request ( request -- )
     [ [ method>> ] [ url>> ] bi 2array httpd-hit ]

diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor
@@ -31,7 +31,8 @@ PRIVATE>
 
 : interval-at* ( key map -- value ? )
     [ drop ] [ array>> find-interval ] 2bi
-    tuck interval-contains? [ third t ] [ drop f f ] if ;
+    [ nip ] [ interval-contains? ] 2bi
+    [ third t ] [ drop f f ] if ;
 
 : interval-at ( key map -- value ) interval-at* drop ;
 

diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor
@@ -33,13 +33,13 @@ M: windows delete-directory ( path -- )
     RemoveDirectory win32-error=0/f ;
 
 : find-first-file ( path -- WIN32_FIND_DATA handle )
-    "WIN32_FIND_DATA" <c-object> tuck
-    FindFirstFile
+    "WIN32_FIND_DATA" <c-object>
+    [ nip ] [ FindFirstFile ] 2bi
     [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
 
 : find-next-file ( path -- WIN32_FIND_DATA/f )
-    "WIN32_FIND_DATA" <c-object> tuck
-    FindNextFile 0 = [
+    "WIN32_FIND_DATA" <c-object>
+    [ nip ] [ FindNextFile ] 2bi 0 = [
         GetLastError ERROR_NO_MORE_FILES = [
             win32-error
         ] unless drop f

diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor
@@ -9,7 +9,8 @@ IN: io.encodings.ascii
 
 : decode-if< ( stream encoding max -- character )
     nip swap stream-read1 dup
-    [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
+    [ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
+    [ 2drop f ] if ; inline
 PRIVATE>
 
 SINGLETON: ascii

diff --git a/basis/io/files/info/unix/freebsd/freebsd.factor b/basis/io/files/info/unix/freebsd/freebsd.factor
@@ -13,7 +13,7 @@ version io-size owner syncreads syncwrites asyncreads asyncwrites ;
 M: freebsd new-file-system-info freebsd-file-system-info new ;
 
 M: freebsd file-system-statfs ( path -- byte-array )
-    "statfs" <c-object> tuck statfs io-error ;
+    "statfs" <c-object> [ statfs io-error ] keep ;
 
 M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
     {
@@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
     } cleave ;
 
 M: freebsd file-system-statvfs ( path -- byte-array )
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
     {

diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor
@@ -14,7 +14,7 @@ namelen ;
 M: linux new-file-system-info linux-file-system-info new ;
 
 M: linux file-system-statfs ( path -- byte-array )
-    "statfs64" <c-object> tuck statfs64 io-error ;
+    "statfs64" <c-object> [ statfs64 io-error ] keep ;
 
 M: linux statfs>file-system-info ( struct -- statfs )
     {
@@ -32,7 +32,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
     } cleave ;
 
 M: linux file-system-statvfs ( path -- byte-array )
-    "statvfs64" <c-object> tuck statvfs64 io-error ;
+    "statvfs64" <c-object> [ statvfs64 io-error ] keep ;
 
 M: linux statvfs>file-system-info ( struct -- statfs )
     {

diff --git a/basis/io/files/info/unix/macosx/macosx.factor b/basis/io/files/info/unix/macosx/macosx.factor
@@ -20,10 +20,10 @@ M: macosx file-systems ( -- array )
 M: macosx new-file-system-info macosx-file-system-info new ;
 
 M: macosx file-system-statfs ( normalized-path -- statfs )
-    "statfs64" <c-object> tuck statfs64 io-error ;
+    "statfs64" <c-object> [ statfs64 io-error ] keep ;
 
 M: macosx file-system-statvfs ( normalized-path -- statvfs )
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
     {

diff --git a/basis/io/files/info/unix/netbsd/netbsd.factor b/basis/io/files/info/unix/netbsd/netbsd.factor
@@ -16,7 +16,7 @@ idx mount-from ;
 M: netbsd new-file-system-info netbsd-file-system-info new ;
 
 M: netbsd file-system-statvfs
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
     {

diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor
@@ -14,7 +14,7 @@ owner ;
 M: openbsd new-file-system-info freebsd-file-system-info new ;
 
 M: openbsd file-system-statfs
-    "statfs" <c-object> tuck statfs io-error ;
+    "statfs" <c-object> [ statfs io-error ] keep ;
 
 M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
     {
@@ -41,7 +41,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
     } cleave ;
 
 M: openbsd file-system-statvfs ( normalized-path -- statvfs )
-    "statvfs" <c-object> tuck statvfs io-error ;
+    "statvfs" <c-object> [ statvfs io-error ] keep ;
 
 M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
     {

diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor
@@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ;
     output-port <buffered-port> ;
 
 : wait-to-write ( len port -- )
-    tuck buffer>> buffer-capacity <=
+    [ nip ] [ buffer>> buffer-capacity <= ] 2bi
     [ drop ] [ stream-flush ] if ; inline
 
 M: output-port stream-write1

diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor
@@ -6,7 +6,7 @@ libc math sequences threads system combinators accessors ;
 IN: io.sockets.windows.nt
 
 : malloc-int ( object -- object )
-    "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
+    "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
 
 M: winnt WSASocket-flags ( -- DWORD )
     WSA_FLAG_OVERLAPPED ;