Merge commit 'origin/master' into emacs

basis/alien/remote-control/remote-control.factor

@@ -15,7 +15,7 @@ IN: alien.remote-control
     "void" { "long" } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
-    dup compiled>> [ execute ] [ drop f ] if ; inline
+    dup optimized>> [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
     \ eval-callback ?callback 16 setenv

basis/bootstrap/compiler/compiler.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors compiler cpu.architecture vocabs.loader system
 sequences namespaces parser kernel kernel.private classes
@@ -25,8 +25,8 @@ IN: bootstrap.compiler
 
 enable-compiler
 
-: compile-uncompiled ( words -- )
+: compile-unoptimized ( words -- )
-    [ compiled>> not ] filter compile ;
+    [ optimized>> not ] filter compile ;
 
 nl
 "Compiling..." write flush
@@ -48,70 +48,70 @@ nl
     wrap probe
 
     namestack*
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     bitand bitor bitxor bitnot
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     + 1+ 1- 2/ < <= > >= shift
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     new-sequence nth push pop peek flip
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     hashcode* = get set
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     memq? split harvest sift cut cut-slice start index clone
     set-at reverse push-all class number>string string>number
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     lines prefix suffix unclip new-assoc update
     word-prop set-word-prop 1array 2array 3array ?nth
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
-{ build-tree } compile-uncompiled
+{ build-tree } compile-unoptimized
 
 "." write flush
 
-{ optimize-tree } compile-uncompiled
+{ optimize-tree } compile-unoptimized
 
 "." write flush
 
-{ optimize-cfg } compile-uncompiled
+{ optimize-cfg } compile-unoptimized
 
 "." write flush
 
-{ (compile) } compile-uncompiled
+{ (compile) } compile-unoptimized
 
 "." write flush
 
-vocabs [ words compile-uncompiled "." write flush ] each
+vocabs [ words compile-unoptimized "." write flush ] each
 
 " done" print flush

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

basis/bootstrap/stage2.factor

@@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
     "Core bootstrap completed in " write core-bootstrap-time get print-time
     "Bootstrap completed in "      write bootstrap-time      get print-time
 
-    [ compiled>> ] count-words " compiled words" print
+    [ optimized>> ] count-words " compiled words" print
     [ symbol? ] count-words " symbol words" print
     [ ] count-words " words total" print
 

basis/compiler/compiler.factor

@@ -24,7 +24,7 @@ SYMBOL: compiled
     } cond drop ;
 
 : maybe-compile ( word -- )
-    dup compiled>> [ drop ] [ queue-compile ] if ;
+    dup optimized>> [ drop ] [ queue-compile ] if ;
 
 SYMBOL: +failed+
 

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
 

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
 

basis/compiler/tests/peg-regression.factor

@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
 
 USE: tools.test
 
-[ t ] [ \ expr compiled>> ] unit-test
+[ t ] [ \ expr optimized>> ] unit-test
-[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test

basis/compiler/tests/redefine1.factor

@@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
 : hey ( -- ) ;
 : there ( -- ) hey ;
 
-[ t ] [ \ hey compiled>> ] unit-test
+[ t ] [ \ hey optimized>> ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
 [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey compiled>> ] unit-test
+[ f ] [ \ hey optimized>> ] unit-test
-[ f ] [ \ there compiled>> ] 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 ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly compiled>> ] 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 ] [ \ good optimized>> ] unit-test
-[ f ] [ \ bad compiled>> ] unit-test
+[ f ] [ \ bad optimized>> ] unit-test
-[ f ] [ \ ugly compiled>> ] 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 ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test

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

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

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
 

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 ] 2dip 72 0 63 x-insn ;
-: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
-: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
+: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
-: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
 
 ! XO-form
 XO: ADD 0 0 266 31

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: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
-M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
+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 ;

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>>
+    [ nip ] [
-    [ postgresql-bind-conversion ] with map
+        in-params>>
+        [ postgresql-bind-conversion ] with map
+    ] 2bi
     >>bind-params drop ;
 
 M: postgresql-result-set #rows ( result-set -- n )

basis/db/tuples/tuples.factor

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

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 ;
 

basis/http/client/client.factor

@@ -7,7 +7,7 @@ io io.sockets io.streams.string io.files io.timeouts
 io.pathnames io.encodings io.encodings.string io.encodings.ascii
 io.encodings.utf8 io.encodings.8-bit io.encodings.binary
 io.streams.duplex fry ascii urls urls.encoding present
-http http.parsers ;
+http http.parsers http.client.post-data ;
 IN: http.client
 
 ERROR: too-many-redirects ;
@@ -27,14 +27,6 @@ CONSTANT: max-redirects 10
     [ host>> ] [ port>> ] bi dup "http" protocol-port =
     [ drop ] [ ":" swap number>string 3append ] if ;
 
-: set-post-data-headers ( header post-data -- header )
-    [
-        data>> dup sequence?
-        [ length "content-length" ]
-        [ drop "chunked" "transfer-encoding" ] if
-        pick set-at
-    ] [ content-type>> "content-type" pick set-at ] bi ;
-
 : set-host-header ( request header -- request header )
     over url>> url-host "host" pick set-at ;
 
@@ -48,53 +40,6 @@ CONSTANT: max-redirects 10
     over cookies>> [ set-cookie-header ] unless-empty
     write-header ;
 
-PRIVATE>
-
-GENERIC: >post-data ( object -- post-data )
-
-M: f >post-data ;
-
-M: post-data >post-data ;
-
-M: string >post-data
-    utf8 encode
-    "application/octet-stream" <post-data>
-        swap >>data ;
-
-M: assoc >post-data
-    "application/x-www-form-urlencoded" <post-data>
-        swap >>params ;
-
-M: object >post-data
-    "application/octet-stream" <post-data>
-        swap >>data ;
-
-<PRIVATE
-    
-: normalize-post-data ( request -- request )
-    dup post-data>> [
-        dup params>> [
-            assoc>query ascii encode >>data
-        ] when* drop
-    ] when* ;
-
-: unparse-post-data ( request -- request )
-    [ >post-data ] change-post-data
-    normalize-post-data ;
-
-: write-chunk ( chunk -- )
-    [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
-
-: write-chunked ( stream -- )
-    [ [ write-chunk ] each-block ] with-input-stream
-    "0;\r\n" ascii encode write ;
-
-: write-post-data ( request -- request )
-    dup method>> { "POST" "PUT" } member?  [
-        dup post-data>> data>> dup sequence?
-        [ write ] [ write-chunked ] if
-    ] when ;
-
 : write-request ( request -- )
     unparse-post-data
     write-request-line
@@ -197,7 +142,7 @@ ERROR: download-failed response ;
     dup code>> success? [ download-failed ] unless ;
 
 : with-http-request ( request quot -- response )
-    (with-http-request) check-response ; inline
+    [ (with-http-request) check-response ] with-destructors ; inline
 
 : http-request ( request -- response data )
     [ [ % ] with-http-request ] B{ } make

basis/http/client/post-data/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/http/client/post-data/post-data-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test http.client.post-data ;
+IN: http.client.post-data.tests

basis/http/client/post-data/post-data.factor

@@ -0,0 +1,91 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs destructors http io io.encodings.ascii
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.files io.files.info io.pathnames kernel math.parser
+namespaces sequences strings urls.encoding ;
+IN: http.client.post-data
+
+TUPLE: measured-stream stream size ;
+
+C: <measured-stream> measured-stream
+
+<PRIVATE
+
+GENERIC: (set-post-data-headers) ( header data -- header )
+
+M: sequence (set-post-data-headers)
+    length "content-length" pick set-at ;
+
+M: measured-stream (set-post-data-headers)
+    size>> "content-length" pick set-at ;
+
+M: object (set-post-data-headers)
+    drop "chunked" "transfer-encoding" pick set-at ;
+
+PRIVATE>
+
+: set-post-data-headers ( header post-data -- header )
+    [ data>> (set-post-data-headers) ]
+    [ content-type>> "content-type" pick set-at ] bi ;
+
+<PRIVATE
+
+GENERIC: (write-post-data) ( data -- )
+
+M: sequence (write-post-data) write ;
+
+M: measured-stream (write-post-data)
+    stream>> [ [ write ] each-block ] with-input-stream ;
+
+: write-chunk ( chunk -- )
+    [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
+
+M: object (write-post-data)
+    [ [ write-chunk ] each-block ] with-input-stream
+    "0;\r\n" ascii encode write ;
+
+GENERIC: >post-data ( object -- post-data )
+
+M: f >post-data ;
+
+M: post-data >post-data ;
+
+M: string >post-data
+    utf8 encode
+    "application/octet-stream" <post-data>
+        swap >>data ;
+
+M: assoc >post-data
+    "application/x-www-form-urlencoded" <post-data>
+        swap >>params ;
+
+M: object >post-data
+    "application/octet-stream" <post-data>
+        swap >>data ;
+
+: pathname>measured-stream ( pathname -- stream )
+    string>>
+    [ binary <file-reader> &dispose ]
+    [ file-info size>> ] bi
+    <measured-stream> ;
+
+: normalize-post-data ( request -- request )
+    dup post-data>> [
+        dup params>> [
+            assoc>query ascii encode >>data
+        ] when*
+        dup data>> pathname? [
+            [ pathname>measured-stream ] change-data
+        ] when
+        drop
+    ] when* ;
+
+PRIVATE>
+
+: unparse-post-data ( request -- request )
+    [ >post-data ] change-post-data
+    normalize-post-data ;
+
+: write-post-data ( request -- request )
+    dup post-data>> [ data>> (write-post-data) ] when* ;

basis/http/server/server.factor

@@ -196,8 +196,8 @@ LOG: httpd-hit NOTICE
 
 LOG: httpd-header NOTICE
 
-: log-header ( headers name -- )
+: log-header ( request name -- )
-    tuck header 2array httpd-header ;
+    [ nip ] [ header ] 2bi 2array httpd-header ;
 
 : log-request ( request -- )
     [ [ method>> ] [ url>> ] bi 2array httpd-hit ]

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 ;
 

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
+    "WIN32_FIND_DATA" <c-object>
-    FindFirstFile
+    [ 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
+    "WIN32_FIND_DATA" <c-object>
-    FindNextFile 0 = [
+    [ nip ] [ FindNextFile ] 2bi 0 = [
         GetLastError ERROR_NO_MORE_FILES = [
             win32-error
         ] unless drop f

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

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

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

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' )
     {

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' )
     {

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' )
     {

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

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 ;

basis/match/match.factor

@@ -80,7 +80,7 @@ MACRO: match-cond ( assoc -- )
     (match-first) drop ;
 
 : (match-all) ( seq pattern-seq -- )
-    tuck (match-first) swap 
+    [ nip ] [ (match-first) swap ] 2bi
     [ 
         , [ swap (match-all) ] [ drop ] if* 
     ] [ 2drop ] if* ;

basis/math/functions/functions.factor

@@ -122,11 +122,9 @@ PRIVATE>
     [ * ] 2keep gcd nip /i ; foldable
 
 : mod-inv ( x n -- y )
-    tuck gcd 1 = [
+    [ nip ] [ gcd 1 = ] 2bi
-        dup 0 < [ + ] [ nip ] if
+    [ dup 0 < [ + ] [ nip ] if ]
-    ] [
+    [ "Non-trivial divisor found" throw ] if ; foldable
-        "Non-trivial divisor found" throw
-    ] if ; foldable
 
 : ^mod ( x y n -- z )
     over 0 < [

basis/math/polynomials/polynomials.factor

@@ -68,7 +68,8 @@ PRIVATE>
     dup V{ 0 } clone p= [
         drop nip
     ] [
-        tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
+        [ nip ] [ p/mod ] 2bi
+        [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
     ] if ;
 
 PRIVATE>

basis/math/ratios/ratios.factor

@@ -24,7 +24,7 @@ M: integer /
         "Division by zero" throw
     ] [
         dup 0 < [ [ neg ] bi@ ] when
-        2dup gcd nip tuck /i [ /i ] dip fraction>
+        2dup gcd nip tuck [ /i ] 2bi@ fraction>
     ] if ;
 
 M: ratio hashcode*

basis/mime/multipart/multipart.factor

@@ -54,7 +54,9 @@ ERROR: end-of-stream multipart ;
     ] if ;
 
 : dump-until-separator ( multipart -- multipart )
-    dup [ current-separator>> ] [ bytes>> ] bi tuck start [
+    dup
+    [ current-separator>> ] [ bytes>> ] bi
+    [ nip ] [ start ] 2bi [
         cut-slice
         [ mime-write ]
         [ over current-separator>> length tail-slice >>bytes ] bi*

basis/persistent/hashtables/nodes/leaf/leaf.factor

@@ -6,7 +6,8 @@ persistent.hashtables.nodes ;
 IN: persistent.hashtables.nodes.leaf
 
 : matching-key? ( key hashcode leaf-node -- ? )
-    tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
+    [ nip ] [ hashcode>> eq? ] 2bi
+    [ key>> = ] [ 2drop f ] if ; inline
 
 M: leaf-node (entry-at) [ matching-key? ] keep and ;
 

basis/prettyprint/prettyprint.factor

@@ -248,7 +248,8 @@ GENERIC: declarations. ( obj -- )
 M: object declarations. drop ;
 
 : declaration. ( word prop -- )
-    tuck name>> word-prop [ pprint-word ] [ drop ] if ;
+    [ nip ] [ name>> word-prop ] 2bi
+    [ pprint-word ] [ drop ] if ;
 
 M: word declarations.
     {

basis/regexp/dfa/dfa.factor

@@ -72,7 +72,7 @@ IN: regexp.dfa
     dup
     [ nfa-traversal-flags>> ]
     [ dfa-table>> transitions>> keys ] bi
-    [ tuck [ swap at ] with map concat ] with H{ } map>assoc
+    [ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
     >>dfa-traversal-flags drop ;
 
 : construct-dfa ( regexp -- )

basis/regexp/parser/parser.factor

@@ -63,7 +63,7 @@ left-parenthesis pipe caret dash ;
 : cut-out ( vector n -- vector' vector ) cut rest ;
 ERROR: cut-stack-error ;
 : cut-stack ( obj vector -- vector' vector )
-    tuck last-index [ cut-stack-error ] unless* cut-out swap ;
+    [ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
 
 : <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
 : <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;

basis/regexp/transition-tables/transition-tables.factor

@@ -35,7 +35,7 @@ TUPLE: transition-table transitions start-state final-states ;
         H{ } clone >>final-states ;
 
 : maybe-initialize-key ( key hashtable -- )
-    2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
+    2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
 
 : set-transition ( transition hash -- )
     #! set the state as a key

basis/serialize/serialize.factor

@@ -221,8 +221,7 @@ SYMBOL: deserialized
     (deserialize) (deserialize) 2dup lookup
     dup [ 2nip ] [
         drop
-        "Unknown word: " -rot
+        2array unparse "Unknown word: " prepend throw
-        2array unparse append throw
     ] if ;
 
 : deserialize-gensym ( -- word )

basis/syndication/syndication.factor

@@ -9,7 +9,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
 IN: syndication
 
 : any-tag-named ( tag names -- tag-inside )
-    f -rot [ tag-named nip dup ] with find 2drop ;
+    [ f ] 2dip [ tag-named nip dup ] with find 2drop ;
 
 TUPLE: feed title url entries ;
 

basis/ui/gadgets/editors/editors.factor

@@ -350,7 +350,7 @@ M: editor gadget-text* editor-string % ;
     dupd editor-select-next mark>caret ;
 
 : editor-select ( from to editor -- )
-    tuck caret>> set-model mark>> set-model ;
+    tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
 
 : select-elt ( editor elt -- )
     [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi

basis/ui/gadgets/gadgets.factor

@@ -165,7 +165,9 @@ M: gadget dim-changed
     in-layout? get [ invalidate ] [ invalidate* ] if ;
 
 M: gadget (>>dim) ( dim gadget -- )
-    2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
+    2dup dim>> =
+    [ 2drop ]
+    [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
 
 GENERIC: pref-dim* ( gadget -- dim )
 
@@ -250,7 +252,7 @@ M: gadget ungraft* drop ;
     f >>parent drop ;
 
 : unfocus-gadget ( child gadget -- )
-    tuck focus>> eq? [ f >>focus ] when drop ;
+    [ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
 
 SYMBOL: in-layout?
 
@@ -286,10 +288,7 @@ SYMBOL: in-layout?
     dup unparent
     over >>parent
     tuck ((add-gadget))
-    tuck graft-state>> second
+    tuck graft-state>> second [ graft ] [ drop  ] if ;
-        [ graft ]
-        [ drop  ]
-    if ;
 
 : add-gadget ( parent child -- parent )
     not-in-layout
@@ -316,7 +315,7 @@ SYMBOL: in-layout?
 : (screen-rect) ( gadget -- loc ext )
     dup parent>> [
         [ rect-extent ] dip (screen-rect)
-        [ tuck v+ ] dip vmin [ v+ ] dip
+        [ [ nip ] [ v+ ] 2bi ] dip [ vmin ] [ v+ ] 2bi*
     ] [
         rect-extent
     ] if* ;

basis/ui/gadgets/incremental/incremental.factor

@@ -23,7 +23,7 @@ M: incremental pref-dim*
     ] keep orientation>> set-axis ;
 
 : update-cursor ( gadget incremental -- )
-    tuck next-cursor >>cursor drop ;
+    [ nip ] [ next-cursor ] 2bi >>cursor drop ;
 
 : incremental-loc ( gadget incremental -- )
     [ cursor>> ] [ orientation>> ] bi v*

basis/unicode/breaks/breaks.factor

@@ -96,7 +96,7 @@ PRIVATE>
 
 : first-grapheme ( str -- i )
     unclip-slice grapheme-class over
-    [ grapheme-class tuck grapheme-break? ] find drop
+    [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
     nip swap length or 1+ ;
 
 <PRIVATE

basis/unicode/collation/collation.factor

@@ -125,7 +125,7 @@ PRIVATE>
 
 : filter-ignorable ( weights -- weights' )
     f swap [
-        tuck primary>> zero? and
+        [ nip ] [ primary>> zero? and ] 2bi
         [ swap ignorable?>> or ]
         [ swap completely-ignorable? or not ] 2bi
     ] filter nip ;

basis/unix/unix.factor

@@ -155,8 +155,8 @@ FUNCTION: int utime ( char* path, utimebuf* buf ) ;
 
 : change-file-times ( filename access modification -- )
     "utimebuf" <c-object>
-    tuck set-utimbuf-modtime
+    [ set-utimbuf-modtime ] keep
-    tuck set-utimbuf-actime
+    [ set-utimbuf-actime ] keep
     [ utime ] unix-system-call drop ;
 
 FUNCTION: int pclose ( void* file ) ;

basis/x11/clipboard/clipboard.factor

@@ -41,7 +41,7 @@ TUPLE: x-clipboard atom contents ;
     ] if ;
 
 : own-selection ( prop win -- )
-    dpy get -rot CurrentTime XSetSelectionOwner drop
+    [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
     flush-dpy ;
 
 : set-targets-prop ( evt -- )

basis/x11/windows/windows.factor

@@ -37,7 +37,7 @@ IN: x11.windows
 : set-size-hints ( window -- )
     "XSizeHints" <c-object>
     USPosition over set-XSizeHints-flags
-    dpy get -rot XSetWMNormalHints ;
+    [ dpy get ] 2dip XSetWMNormalHints ;
 
 : auto-position ( window loc -- )
     { 0 0 } = [ drop ] [ set-size-hints ] if ;

basis/xml/data/data.factor

@@ -62,7 +62,8 @@ M: attrs assoc-like
 M: attrs clear-assoc
     f >>alist drop ;
 M: attrs delete-at
-    tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
+    [ nip ] [ attr@ drop ] 2bi
+    [ swap alist>> delete-nth ] [ drop ] if* ;
 
 M: attrs clone
     alist>> clone <attrs> ;

basis/xmode/marker/marker.factor

@@ -100,7 +100,7 @@ DEFER: get-rules
     [ ch>upper ] dip rules>> at ?push-all ;
 
 : get-rules ( char ruleset -- seq )
-    f -rot [ get-char-rules ] keep get-always-rules ;
+    [ f ] 2dip [ get-char-rules ] keep get-always-rules ;
 
 GENERIC: handle-rule-start ( match-count rule -- )
 

basis/xmode/utilities/utilities.factor

@@ -7,7 +7,7 @@ IN: xmode.utilities
 : child-tags ( tag -- seq ) children>> [ tag? ] filter ;
 
 : map-find ( seq quot -- result elt )
-    f -rot
+    [ f ] 2dip
     '[ nip @ dup ] find
     [ [ drop f ] unless ] dip ; inline
 

core/assocs/assocs.factor

@@ -188,7 +188,7 @@ M: sequence new-assoc drop <vector> ;
 M: sequence clear-assoc delete-all ;
 
 M: sequence delete-at
-    tuck search-alist nip
+    [ nip ] [ search-alist nip ] 2bi
     [ swap delete-nth ] [ drop ] if* ;
 
 M: sequence assoc-size length ;

core/bootstrap/primitives.factor

@@ -32,17 +32,14 @@ H{ } clone sub-primitives set
 ! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
 
 ! Bring up a bare cross-compiling vocabulary.
-"syntax" vocab vocab-words bootstrap-syntax set
+"syntax" vocab vocab-words bootstrap-syntax set {
-H{ } clone dictionary set
+    dictionary
-H{ } clone new-classes set
+    new-classes
-H{ } clone changed-definitions set
+    changed-definitions changed-generics
-H{ } clone changed-generics set
+    remake-generics forgotten-definitions
-H{ } clone remake-generics set
+    root-cache source-files update-map implementors-map
-H{ } clone forgotten-definitions set
+} [ H{ } clone swap set ] each
-H{ } clone root-cache set
+
-H{ } clone source-files set
-H{ } clone update-map set
-H{ } clone implementors-map set
 init-caches
 
 ! Vocabulary for slot accessors
@@ -264,7 +261,7 @@ bi
     "vocabulary"
     { "def" { "quotation" "quotations" } initial: [ ] }
     "props"
-    { "compiled" read-only }
+    { "optimized" read-only }
     { "counter" { "fixnum" "math" } }
     { "sub-primitive" read-only }
 } define-builtin

core/classes/algebra/algebra.factor

@@ -215,7 +215,7 @@ M: anonymous-complement (classes-intersect?)
 : min-class ( class seq -- class/f )
     over [ classes-intersect? ] curry filter
     [ drop f ] [
-        tuck [ class<= ] with all? [ peek ] [ drop f ] if
+        [ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if
     ] if-empty ;
 
 GENERIC: (flatten-class) ( class -- )

core/classes/classes.factor

@@ -162,7 +162,7 @@ GENERIC: update-methods ( class seq -- )
     dup "predicate" word-prop
     dup length 1 = [
         first
-        tuck "predicating" word-prop =
+        [ nip ] [ "predicating" word-prop = ] 2bi
         [ forget ] [ drop ] if
     ] [ 2drop ] if ;
 

core/classes/mixin/mixin.factor

@@ -54,7 +54,7 @@ TUPLE: check-mixin-class class ;
     #! class-usages of the member, now that it's been added.
     [ 2drop ] [
         [ [ suffix ] change-mixin-class ] 2keep
-        tuck [ new-class? ] either? [
+        [ nip ] [ [ new-class? ] either? ] 2bi [
             update-classes/new
         ] [
             update-classes

core/compiler/units/units-tests.factor

@@ -1,6 +1,6 @@
 IN: compiler.units.tests
 USING: definitions compiler.units tools.test arrays sequences words kernel
-accessors ;
+accessors namespaces fry ;
 
 [ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
 [ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
@@ -9,8 +9,22 @@ accessors ;
 [ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
 [ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
 
-! Non-optimizing compiler bug
+! Non-optimizing compiler bugs
 [ 1 1 ] [
     "A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array f modify-code-heap
     1 swap execute
+] unit-test
+
+[ "A" "B" ] [
+    gensym "a" set
+    gensym "b" set
+    [
+        "a" get [ "A" ] define
+        "b" get "a" get '[ _ execute ] define
+    ] with-compilation-unit
+    "b" get execute
+    [
+        "a" get [ "B" ] define
+    ] with-compilation-unit
+    "b" get execute
 ] unit-test

core/effects/parser/parser.factor

@@ -9,7 +9,7 @@ DEFER: parse-effect
 ERROR: bad-effect ;
 
 : parse-effect-token ( end -- token/f )
-    scan tuck = [ drop f ] [
+    scan [ nip ] [ = ] 2bi [ drop f ] [
         dup { f "(" "((" } member? [ bad-effect ] [
             ":" ?tail [
                 scan-word {

core/generic/generic.factor

@@ -36,7 +36,8 @@ PREDICATE: method-spec < pair
     "methods" word-prop keys sort-classes ;
 
 : specific-method ( class generic -- method/f )
-    tuck order min-class dup [ swap method ] [ 2drop f ] if ;
+    [ nip ] [ order min-class ] 2bi
+    dup [ swap method ] [ 2drop f ] if ;
 
 GENERIC: effective-method ( generic -- method )
 

core/hashtables/hashtables.factor

@@ -104,7 +104,7 @@ M: hashtable clear-assoc ( hash -- )
     [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
 
 M: hashtable delete-at ( key hash -- )
-    tuck key@ [
+    [ nip ] [ key@ ] 2bi [
         [ ((tombstone)) dup ] 2dip set-nth-pair
         hash-deleted+
     ] [

core/parser/parser.factor

@@ -254,7 +254,7 @@ print-use-hook global [ [ ] or ] change-at
     [
         [
             lines dup parse-fresh
-            tuck finish-parsing
+            [ nip ] [ finish-parsing ] 2bi
             forget-smudged
         ] with-source-file
     ] with-compilation-unit ;

core/sequences/sequences.factor

@@ -138,15 +138,15 @@ INSTANCE: iota immutable-sequence
 : from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
 
 : (2sequence) ( obj1 obj2 seq -- seq )
-    tuck 1 swap set-nth-unsafe
+    [ 1 swap set-nth-unsafe ] keep
-    tuck 0 swap set-nth-unsafe ; inline
+    [ 0 swap set-nth-unsafe ] keep ; inline
 
 : (3sequence) ( obj1 obj2 obj3 seq -- seq )
-    tuck 2 swap set-nth-unsafe
+    [ 2 swap set-nth-unsafe ] keep
     (2sequence) ; inline
 
 : (4sequence) ( obj1 obj2 obj3 obj4 seq -- seq )
-    tuck 3 swap set-nth-unsafe
+    [ 3 swap set-nth-unsafe ] keep
     (3sequence) ; inline
 
 PRIVATE>
@@ -723,14 +723,14 @@ PRIVATE>
     2dup shorter? [
         2drop f
     ] [
-        tuck length head-slice sequence=
+        [ nip ] [ length head-slice ] 2bi sequence=
     ] if ;
 
 : tail? ( seq end -- ? )
     2dup shorter? [
         2drop f
     ] [
-        tuck length tail-slice* sequence=
+        [ nip ] [ length tail-slice* ] 2bi sequence=
     ] if ;
 
 : cut-slice ( seq n -- before-slice after-slice )

extra/math/text/english/english.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit grouping kernel math math.parser namespaces
+USING: combinators.short-circuit grouping kernel math math.parser
-    sequences ;
+math.text.utils namespaces sequences ;
 IN: math.text.english
 
 <PRIVATE
@@ -31,9 +31,6 @@ SYMBOL: and-needed?
 : negative-text ( n -- str )
     0 < "Negative " "" ? ;
 
-: 3digit-groups ( n -- seq )
-    [ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;
-
 : hundreds-place ( n -- str )
     100 /mod over 0 = [
         2drop ""

extra/math/text/french/authors.txt

@@ -0,0 +1 @@
+Samuel Tardieu

extra/math/text/french/french-docs.factor

@@ -0,0 +1,6 @@
+USING: help.markup help.syntax ;
+IN: math.text.french
+
+HELP: number>text
+{ $values { "n" "an integer" } { "str" "a string" } }
+{ $description "Return the a string describing " { $snippet "n" } " in French. Numbers with absolute value equal to or greater than 10^12 will be returned using their numeric representation." } ;

extra/math/text/french/french-tests.factor

@@ -0,0 +1,22 @@
+USING: math math.functions math.parser math.text.french sequences tools.test ;
+
+[ "zéro" ] [ 0 number>text ] unit-test
+[ "vingt et un" ] [ 21 number>text ] unit-test
+[ "vingt-deux" ] [ 22 number>text ] unit-test
+[ "deux mille" ] [ 2000 number>text ] unit-test
+[ "soixante et un" ] [ 61 number>text ] unit-test
+[ "soixante-deux" ] [ 62 number>text ] unit-test
+[ "quatre-vingts" ] [ 80 number>text ] unit-test
+[ "quatre-vingt-un" ] [ 81 number>text ] unit-test
+[ "quatre-vingt-onze" ] [ 91 number>text ] unit-test
+[ "deux cents" ] [ 200 number>text ] unit-test
+[ "mille deux cents" ] [ 1200 number>text ] unit-test
+[ "mille deux cent quatre-vingts" ] [ 1280 number>text ] unit-test
+[ "mille deux cent quatre-vingt-un" ] [ 1281 number>text ] unit-test
+[ "un billion deux cent vingt milliards quatre-vingts millions trois cent quatre-vingt mille deux cents" ] [ 1220080380200 number>text ] unit-test
+[ "un million" ] [ 1000000 number>text ] unit-test
+[ "un million un" ] [ 1000001 number>text ] unit-test
+[ "moins vingt" ] [ -20 number>text ] unit-test
+[ 104 ] [ -1 10 102 ^ - number>text length ] unit-test
+! Check that we do not exhaust stack
+[ 1484 ] [ 10 100 ^ 1 - number>text length ] unit-test

extra/math/text/french/french.factor

@@ -0,0 +1,97 @@
+! Copyright (c) 2009 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators kernel math math.functions
+math.parser math.text.utils memoize sequences ;
+IN: math.text.french
+
+<PRIVATE
+
+DEFER: basic ( n -- str )
+
+CONSTANT: literals
+    H{ { 0 "zéro" } { 1 "un" } { 2 "deux" } { 3 "trois" } { 4 "quatre" }
+       { 5 "cinq" } { 6 "six" } { 7 "sept" } { 8 "huit" } { 9 "neuf" }
+       { 10 "dix" } { 11 "onze" } { 12 "douze" } { 13 "treize" }
+       { 14 "quatorze" } { 15 "quinze" } { 16 "seize" } { 17 "dix-sept" }
+       { 18 "dix-huit" } { 19 "dix-neuf" } { 20 "vingt" } { 30 "trente" }
+       { 40 "quarante" } { 50 "cinquante" } { 60 "soixante" }
+       { 71 "soixante et onze" } { 80 "quatre-vingts" }
+       { 81 "quatre-vingt-un" }
+       { 100 "cent" } { 1000 "mille" } }
+
+MEMO: units ( -- seq ) ! up to 10^99
+    { "m" "b" "tr" "quadr" "quint" "sext" "sept" "oct"
+      "non" "déc" "unodéc" "duodéc" "trédéc" "quattuordéc"
+      "quindéc" "sexdéc" }
+      [ [ "illion" append ] [ "illiard" append ] bi 2array ] map concat
+      "mille" prefix ;
+
+! The only plurals we have to remove are "quatre-vingts" and "cents",
+! which are also the only strings ending with "ts".
+: unpluralize ( str -- newstr ) dup "ts" tail? [ but-last ] when ;
+: pluralize ( str -- newstr ) CHAR: s suffix ;
+
+: space-append ( str1 str2 -- str ) " " glue ;
+
+! Small numbers (below 100) use dashes between them unless they are
+! separated with "et". Pluralized prefixes must be unpluralized.
+: complete-small ( str n -- str )
+    { { 0 [ ] }
+      { 1 [ " et un" append ] }
+      [ [ unpluralize ] dip basic "-" glue ] } case ;
+
+: smaller-than-60 ( n -- str )
+    dup 10 mod [ - ] keep [ basic ] dip complete-small ;
+
+: base-onto ( n b -- str ) [ nip literals at ] [ - ] 2bi complete-small ;
+
+: smaller-than-80 ( n -- str ) 60 base-onto ;
+
+: smaller-than-100 ( n -- str ) 80 base-onto ;
+
+: if-zero ( n quot quot -- )
+    [ dup zero? ] 2dip [ [ drop ] prepose ] dip if ; inline
+
+: complete ( str n -- newstr )
+    [ ] [ basic space-append ] if-zero ;
+
+: smaller-than-1000 ( n -- str )
+    100 /mod
+    [ "cent" swap dup 1 = [ drop ] [ basic swap space-append ] if ]
+    [ [ pluralize ] [ basic space-append ] if-zero ] bi* ;
+
+: smaller-than-2000 ( n -- str ) "mille" swap 1000 - complete ;
+
+: smaller-than-1000000 ( n -- str )
+    1000 /mod [ basic unpluralize " mille" append ] dip complete ;
+
+: n-units ( n unit -- str/f )
+    {
+        { [ over zero? ] [ 2drop f ] }
+        { [ over 1 = ] [ [ basic ] dip space-append ] }
+        [ [ basic ] dip space-append pluralize ]
+    } cond ;
+
+: over-1000000 ( n -- str )
+    3digit-groups [ 1+ units nth n-units ] map-index sift
+    reverse " " join ;
+
+: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
+
+: basic ( n -- str )
+    {
+        { [ dup literals key? ] [ literals at ] }
+        { [ dup 0 < ] [ abs basic "moins " swap append ] }
+        { [ dup 60 < ] [ smaller-than-60 ] }
+        { [ dup 80 < ] [ smaller-than-80 ] }
+        { [ dup 100 < ] [ smaller-than-100 ] }
+        { [ dup 1000 < ] [ smaller-than-1000 ] }
+        { [ dup 2000 < ] [ smaller-than-2000 ] }
+        { [ dup 1000000 < ] [ smaller-than-1000000 ] }
+        [ decompose ]
+    } cond ;
+
+PRIVATE>
+
+: number>text ( n -- str )
+    dup abs 10 102 ^ >= [ number>string ] [ basic ] if ;

extra/math/text/french/summary.txt

@@ -0,0 +1 @@
+Convert integers to French text

extra/math/text/utils/authors.txt

@@ -0,0 +1 @@
+Aaron Schaefer

extra/math/text/utils/summary.txt

@@ -0,0 +1 @@
+Number to text conversion utilities

extra/math/text/utils/utils-docs.factor

@@ -0,0 +1,6 @@
+USING: help.markup help.syntax ;
+IN: math.text.utils
+
+HELP: 3digit-groups
+{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
+{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ;

extra/math/text/utils/utils-tests.factor

@@ -0,0 +1,3 @@
+USING: math.text.utils tools.test ;
+
+[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test

extra/math/text/utils/utils.factor

@@ -0,0 +1,7 @@
+! Copyright (c) 2007, 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: math.text.utils
+
+: 3digit-groups ( n -- seq )
+    [ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;

vm/code_heap.c

@@ -315,7 +315,7 @@ void set_word_code(F_WORD *word, F_COMPILED *compiled)
 		critical_error("bad param to set_word_xt",(CELL)compiled);
 
 	word->code = compiled;
-	word->compiledp = T;
+	word->optimizedp = T;
 }
 
 /* Allocates memory */
@@ -326,7 +326,7 @@ void default_word_code(F_WORD *word, bool relocate)
 	UNREGISTER_UNTAGGED(word);
 
 	word->code = untag_quotation(word->def)->code;
-	word->compiledp = F;
+	word->optimizedp = F;
 }
 
 void primitive_modify_code_heap(void)

vm/layouts.h

@@ -125,8 +125,9 @@ typedef struct {
 	CELL def;
 	/* TAGGED property assoc for library code */
 	CELL props;
-	/* TAGGED t or f, depending on if the word is compiled or not */
+	/* TAGGED t or f, t means its compiled with the optimizing compiler,
-	CELL compiledp;
+	f means its compiled with the non-optimizing compiler */
+	CELL optimizedp;
 	/* TAGGED call count for profiling */
 	CELL counter;
 	/* TAGGED machine code for sub-primitive */

vm/quotations.c

@@ -535,7 +535,7 @@ void compile_all_words(void)
 	{
 		F_WORD *word = untag_word(array_nth(untag_array(words),i));
 		REGISTER_UNTAGGED(word);
-		if(word->compiledp == F)
+		if(word->optimizedp == F)
 			default_word_code(word,false);
 		UNREGISTER_UNTAGGED(word);
 		update_word_xt(word);

vm/types.c

@@ -48,7 +48,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
 	word->def = userenv[UNDEFINED_ENV];
 	word->props = F;
 	word->counter = tag_fixnum(0);
-	word->compiledp = F;
+	word->optimizedp = F;
 	word->subprimitive = F;
 	word->profiling = NULL;
 	word->code = NULL;