diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 9cd9050ea8..4da06ec4c9 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/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 diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index f0d9e8e131..617073bbc4 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/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 -- ) - [ compiled>> not ] filter compile ; +: compile-unoptimized ( words -- ) + [ 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 diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index bbd7df9108..3e3c4a93aa 100644 --- 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/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index f0622726f5..13f943898c 100644 --- a/basis/bootstrap/stage2.factor +++ b/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 diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 2fa234e381..84797981d1 100644 --- a/basis/compiler/compiler.factor +++ b/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+ diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 3d17009e31..8ee120012d 100644 --- 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 index bb1cb2eab5..c5bbe4a6c3 100644 --- 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 with a non-literal class failed : -regression ( class -- tuple ) ; -[ t ] [ \ -regression compiled>> ] unit-test +[ t ] [ \ -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 index a0262fdc81..56a4021eed 100644 --- 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 index 1b349d2296..b5835de5fd 100644 --- 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 index 941d086312..b25b5a1a5e 100644 --- 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 index c1e23c3e1e..a6d6c5dfb9 100644 --- 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 index ee8c2f056a..4092352fd5 100644 --- 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 index 0bb0d70ee0..fbb878a888 100644 --- 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 index a2c3a6c8d5..c6a3a94194 100644 --- 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 index a094fbc542..1f55dcf769 100644 --- 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 ] [ ] 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 index d2116058d8..219116aefd 100644 --- 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 index 33b8923347..2d4a6ff5fb 100644 --- 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/client/client.factor b/basis/http/client/client.factor index cce9f07967..edfc6e312b 100644 --- a/basis/http/client/client.factor +++ b/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" - swap >>data ; - -M: assoc >post-data - "application/x-www-form-urlencoded" - swap >>params ; - -M: object >post-data - "application/octet-stream" - swap >>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 diff --git a/basis/http/client/post-data/authors.txt b/basis/http/client/post-data/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/http/client/post-data/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/http/client/post-data/post-data-tests.factor b/basis/http/client/post-data/post-data-tests.factor new file mode 100644 index 0000000000..2704ce169f --- /dev/null +++ b/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 diff --git a/basis/http/client/post-data/post-data.factor b/basis/http/client/post-data/post-data.factor new file mode 100644 index 0000000000..b7551d86b9 --- /dev/null +++ b/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 + +> "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 ; + +> [ [ 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" + swap >>data ; + +M: assoc >post-data + "application/x-www-form-urlencoded" + swap >>params ; + +M: object >post-data + "application/octet-stream" + swap >>data ; + +: pathname>measured-stream ( pathname -- stream ) + string>> + [ binary &dispose ] + [ file-info size>> ] bi + ; + +: 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* ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 73a6b208d8..8a5e695a70 100755 --- 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 index 34e43ddc75..4fd4592ee1 100644 --- 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 index c2955d3977..a6dacc1841 100755 --- 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" tuck - FindFirstFile + "WIN32_FIND_DATA" + [ nip ] [ FindFirstFile ] 2bi [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ; : find-next-file ( path -- WIN32_FIND_DATA/f ) - "WIN32_FIND_DATA" tuck - FindNextFile 0 = [ + "WIN32_FIND_DATA" + [ 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 index 0803ba3871..d971cf2e60 100644 --- 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 index 11025e14e6..61d7a1d921 100644 --- 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" tuck statfs io-error ; + "statfs" [ 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" tuck statvfs io-error ; + "statvfs" [ 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 index b447b6e54f..5dddca4f9d 100644 --- 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" tuck statfs64 io-error ; + "statfs64" [ 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" tuck statvfs64 io-error ; + "statvfs64" [ 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 index 53992bcb95..cfc13ba015 100644 --- 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" tuck statfs64 io-error ; + "statfs64" [ statfs64 io-error ] keep ; M: macosx file-system-statvfs ( normalized-path -- statvfs ) - "statvfs" tuck statvfs io-error ; + "statvfs" [ 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 index 6dc0bb3f87..4f284b5f44 100644 --- 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" tuck statvfs io-error ; + "statvfs" [ 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 index 62783a968b..0fe4c4bec0 100644 --- 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" tuck statfs io-error ; + "statfs" [ 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" tuck statvfs io-error ; + "statvfs" [ 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 index 6eb61a24a7..1fe717d5ee 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ; output-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 index f6a1bcfcb0..49a1b2ae63 100644 --- 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 ; diff --git a/basis/match/match.factor b/basis/match/match.factor index fee06686b8..3846dea3be 100644 --- a/basis/match/match.factor +++ b/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* ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index ff52c17047..85b4d711ac 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -122,11 +122,9 @@ PRIVATE> [ * ] 2keep gcd nip /i ; foldable : mod-inv ( x n -- y ) - tuck gcd 1 = [ - dup 0 < [ + ] [ nip ] if - ] [ - "Non-trivial divisor found" throw - ] if ; foldable + [ nip ] [ gcd 1 = ] 2bi + [ dup 0 < [ + ] [ nip ] if ] + [ "Non-trivial divisor found" throw ] if ; foldable : ^mod ( x y n -- z ) over 0 < [ diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 13090b6486..5783dfdf41 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/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> diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 15914e7b05..e44dbd1a75 100644 --- a/basis/math/ratios/ratios.factor +++ b/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* diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 10ddb926dd..1cea707862 100755 --- a/basis/mime/multipart/multipart.factor +++ b/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* diff --git a/basis/persistent/hashtables/nodes/leaf/leaf.factor b/basis/persistent/hashtables/nodes/leaf/leaf.factor index 3419e8387f..94174d5667 100644 --- a/basis/persistent/hashtables/nodes/leaf/leaf.factor +++ b/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 ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index b3800babe8..95f05c21ff 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/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. { diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index c3e98ae1ec..549669cab7 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/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 -- ) diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 2f397538a0..377535eccd 100644 --- a/basis/regexp/parser/parser.factor +++ b/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 ; : ( obj -- kleene ) possessive-kleene-star boa ; : ( obj -- kleene ) reluctant-kleene-star boa ; diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 5375d813e1..e5c31a54e0 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/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 diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 3ec1e96c72..4a0d3777b8 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -221,8 +221,7 @@ SYMBOL: deserialized (deserialize) (deserialize) 2dup lookup dup [ 2nip ] [ drop - "Unknown word: " -rot - 2array unparse append throw + 2array unparse "Unknown word: " prepend throw ] if ; : deserialize-gensym ( -- word ) diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index c82fe4006d..9d0419a818 100644 --- a/basis/syndication/syndication.factor +++ b/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 ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 67386c1807..dc2cedfef8 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/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 diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index baf025d116..e5a2b53096 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/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 - [ graft ] - [ drop ] - if ; + tuck graft-state>> second [ 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* ; diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index af249bbdc8..2b33d2bfe1 100644 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/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* diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 336d99657e..6bcf8b50cc 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/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+ ; : 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 ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index c2b5ad4ea4..42444261e2 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -155,8 +155,8 @@ FUNCTION: int utime ( char* path, utimebuf* buf ) ; : change-file-times ( filename access modification -- ) "utimebuf" - tuck set-utimbuf-modtime - tuck set-utimbuf-actime + [ set-utimbuf-modtime ] keep + [ set-utimbuf-actime ] keep [ utime ] unix-system-call drop ; FUNCTION: int pclose ( void* file ) ; diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 472488ddc2..d3fe0a8447 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/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 -- ) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 67ece9d1c7..be9f8cf7a9 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -37,7 +37,7 @@ IN: x11.windows : set-size-hints ( window -- ) "XSizeHints" USPosition over set-XSizeHints-flags - dpy get -rot XSetWMNormalHints ; + [ dpy get ] 2dip XSetWMNormalHints ; : auto-position ( window loc -- ) { 0 0 } = [ drop ] [ set-size-hints ] if ; diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 8c024d938e..9d84791c1f 100644 --- a/basis/xml/data/data.factor +++ b/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 ; diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index 3e632cc5af..798807f198 100644 --- a/basis/xmode/marker/marker.factor +++ b/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 -- ) diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor index b5a2f6eb98..871767ccf5 100644 --- a/basis/xmode/utilities/utilities.factor +++ b/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 diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 7f34c3b19d..a2eb2d25ec 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -188,7 +188,7 @@ M: sequence new-assoc drop ; 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 ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 61d178ccf8..f1e8b8b65e 100644 --- a/core/bootstrap/primitives.factor +++ b/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 -H{ } clone dictionary set -H{ } clone new-classes set -H{ } clone changed-definitions set -H{ } clone changed-generics set -H{ } clone remake-generics set -H{ } clone forgotten-definitions set -H{ } clone root-cache set -H{ } clone source-files set -H{ } clone update-map set -H{ } clone implementors-map set +"syntax" vocab vocab-words bootstrap-syntax set { + dictionary + new-classes + changed-definitions changed-generics + remake-generics forgotten-definitions + root-cache source-files update-map implementors-map +} [ H{ } clone swap set ] each + 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 diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 4625c665bf..e71379ac1a 100644 --- a/core/classes/algebra/algebra.factor +++ b/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 -- ) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index acff3d57e5..8145730f40 100644 --- a/core/classes/classes.factor +++ b/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 ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 2470c00875..1261d44a69 100644 --- a/core/classes/mixin/mixin.factor +++ b/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 diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 884207b901..ba990b4247 100644 --- a/core/compiler/units/units-tests.factor +++ b/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" [ [ 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 \ No newline at end of file diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 77bcd7cad6..6b7e953b6c 100644 --- a/core/effects/parser/parser.factor +++ b/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 { diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4eb39291a0..c16b6a52a1 100644 --- a/core/generic/generic.factor +++ b/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 ) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 9268340c79..8aa13a5f5e 100644 --- a/core/hashtables/hashtables.factor +++ b/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+ ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 81ed91290c..3c915cb07d 100644 --- a/core/parser/parser.factor +++ b/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 ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 061da05669..2a5c0c674c 100644 --- a/core/sequences/sequences.factor +++ b/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 - tuck 0 swap set-nth-unsafe ; inline + [ 1 swap set-nth-unsafe ] keep + [ 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 ) diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index 643fc3ae05..5a10e7af37 100755 --- a/extra/math/text/english/english.factor +++ b/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 - sequences ; +USING: combinators.short-circuit grouping kernel math math.parser +math.text.utils namespaces sequences ; IN: math.text.english ] [ 1000 /mod ] [ ] produce nip ; - : hundreds-place ( n -- str ) 100 /mod over 0 = [ 2drop "" diff --git a/extra/math/text/french/authors.txt b/extra/math/text/french/authors.txt new file mode 100644 index 0000000000..f3b0233f74 --- /dev/null +++ b/extra/math/text/french/authors.txt @@ -0,0 +1 @@ +Samuel Tardieu diff --git a/extra/math/text/french/french-docs.factor b/extra/math/text/french/french-docs.factor new file mode 100644 index 0000000000..702a963e05 --- /dev/null +++ b/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." } ; diff --git a/extra/math/text/french/french-tests.factor b/extra/math/text/french/french-tests.factor new file mode 100644 index 0000000000..fd8438718d --- /dev/null +++ b/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 diff --git a/extra/math/text/french/french.factor b/extra/math/text/french/french.factor new file mode 100644 index 0000000000..f8b97103eb --- /dev/null +++ b/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 + + + +: number>text ( n -- str ) + dup abs 10 102 ^ >= [ number>string ] [ basic ] if ; diff --git a/extra/math/text/french/summary.txt b/extra/math/text/french/summary.txt new file mode 100644 index 0000000000..c4c89dcdc4 --- /dev/null +++ b/extra/math/text/french/summary.txt @@ -0,0 +1 @@ +Convert integers to French text diff --git a/extra/math/text/utils/authors.txt b/extra/math/text/utils/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/math/text/utils/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/math/text/utils/summary.txt b/extra/math/text/utils/summary.txt new file mode 100644 index 0000000000..b2d8744879 --- /dev/null +++ b/extra/math/text/utils/summary.txt @@ -0,0 +1 @@ +Number to text conversion utilities diff --git a/extra/math/text/utils/utils-docs.factor b/extra/math/text/utils/utils-docs.factor new file mode 100644 index 0000000000..e1d1a005d3 --- /dev/null +++ b/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." } ; diff --git a/extra/math/text/utils/utils-tests.factor b/extra/math/text/utils/utils-tests.factor new file mode 100644 index 0000000000..d14bb06a2a --- /dev/null +++ b/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 diff --git a/extra/math/text/utils/utils.factor b/extra/math/text/utils/utils.factor new file mode 100644 index 0000000000..73326de273 --- /dev/null +++ b/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 ; diff --git a/vm/code_heap.c b/vm/code_heap.c index 9a1c45c7df..99db189356 100755 --- a/vm/code_heap.c +++ b/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) diff --git a/vm/layouts.h b/vm/layouts.h index 74a4c0475e..ad7e4c0f65 100755 --- a/vm/layouts.h +++ b/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 */ - CELL compiledp; + /* TAGGED t or f, t means its compiled with the optimizing compiler, + f means its compiled with the non-optimizing compiler */ + CELL optimizedp; /* TAGGED call count for profiling */ CELL counter; /* TAGGED machine code for sub-primitive */ diff --git a/vm/quotations.c b/vm/quotations.c index 86952a32e8..2d7818a307 100755 --- a/vm/quotations.c +++ b/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); diff --git a/vm/types.c b/vm/types.c index c9e657f8ee..983c238943 100755 --- a/vm/types.c +++ b/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;