From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Tue, 16 Feb 2010 18:35:15 +0000 (-0800)
Subject: Merge to upstream
X-Git-Tag: 0.97~4856^2~18
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=fd1416617ec328fac1c81e5aed7e128f6a0c8ca8

Merge to upstream
---

fd1416617ec328fac1c81e5aed7e128f6a0c8ca8
diff --cc basis/tools/deploy/deploy-tests.factor
index f76ad7a557,8e25afdcfe..4f470af202
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@@ -1,125 -1,129 +1,129 @@@
 -USING: tools.test system io io.encodings.ascii io.pathnames
 -io.files io.files.info io.files.temp kernel tools.deploy.config
 -tools.deploy.config.editor tools.deploy.backend math sequences
 -io.launcher arrays namespaces continuations layouts accessors
 -urls math.parser io.directories tools.deploy.test ;
 -IN: tools.deploy.tests
 -
 -[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
 -
 -[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
 -
 -[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
 -
 -[ "staging.math-threads-compiler-ui.image" ] [
 -    "hello-ui" deploy-config
 -    [ bootstrap-profile staging-image-name file-name ] bind
 -] unit-test
 -
 -[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
 -
 -[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
 -
 -[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
 -
 -[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
 -
 -[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test
 -
 -[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
 -
 -[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test
 -
 -os macosx? [
 -    [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
 -] when
 -
 -[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test
 -
 -{
 -    "tools.deploy.test.1"
 -    "tools.deploy.test.2"
 -    "tools.deploy.test.3"
 -    "tools.deploy.test.4"
 -} [
 -    [ ] swap [
 -        shake-and-bake
 -        run-temp-image
 -    ] curry unit-test
 -] each
 -
 -USING: http.client http.server http.server.dispatchers
 -http.server.responses http.server.static io.servers.connection ;
 -
 -SINGLETON: quit-responder
 -
 -M: quit-responder call-responder*
 -    2drop stop-this-server "Goodbye" "text/html" <content> ;
 -
 -: add-quot-responder ( responder -- responder )
 -    quit-responder "quit" add-responder ;
 -
 -: test-httpd ( responder -- )
 -    [
 -        main-responder set
 -        <http-server>
 -            0 >>insecure
 -            f >>secure
 -        dup start-server*
 -        sockets>> first addr>> port>>
 -        dup number>string "resource:temp/port-number" ascii set-file-contents
 -    ] with-scope
 -    "port" set ;
 -
 -[ ] [
 -    <dispatcher>
 -        add-quot-responder
 -        "vocab:http/test" <static> >>default
 -
 -    test-httpd
 -] unit-test
 -
 -[ ] [
 -    "tools.deploy.test.5" shake-and-bake
 -    run-temp-image
 -] unit-test
 -
 -: add-port ( url -- url' )
 -    >url clone "port" get >>port ;
 -
 -[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
 -
 -{
 -    "tools.deploy.test.6"
 -    "tools.deploy.test.7"
 -    "tools.deploy.test.9"
 -    "tools.deploy.test.10"
 -    "tools.deploy.test.11"
 -    "tools.deploy.test.12"
 -} [
 -    [ ] swap [
 -        shake-and-bake
 -        run-temp-image
 -    ] curry unit-test
 -] each
 -
 -os windows? os macosx? or [
 -    [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
 -] when
 -
 -os macosx? [
 -    [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
 -] when
 -
 -[ { "a" "b" "c" } ] [
 -    "tools.deploy.test.15" shake-and-bake deploy-test-command
 -    { "a" "b" "c" } append
 -    ascii [ lines ] with-process-reader
 -    rest
 -] unit-test
 -
 -[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
 -
 -[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test
 -
 -[ t ] [
 -    "tools.deploy.test.18" shake-and-bake
 -    deploy-test-command ascii [ readln ] with-process-reader
 -    "test.image" temp-file =
 -] unit-test
 +USING: tools.test system io io.encodings.ascii io.pathnames
 +io.files io.files.info io.files.temp kernel tools.deploy.config
 +tools.deploy.config.editor tools.deploy.backend math sequences
 +io.launcher arrays namespaces continuations layouts accessors
 +urls math.parser io.directories tools.deploy.test ;
 +IN: tools.deploy.tests
 +
 +[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
 +
 +[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
 +
 +[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
 +
 +[ "staging.math-threads-compiler-ui.image" ] [
 +    "hello-ui" deploy-config
 +    [ bootstrap-profile staging-image-name file-name ] bind
 +] unit-test
 +
 +[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
 +
 +[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
 +
 +[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
 +
 +[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
 +
++[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test
++
 +[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
 +
++[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test
++
 +os macosx? [
 +    [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
 +] when
 +
 +[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test
 +
 +{
 +    "tools.deploy.test.1"
 +    "tools.deploy.test.2"
 +    "tools.deploy.test.3"
 +    "tools.deploy.test.4"
 +} [
 +    [ ] swap [
 +        shake-and-bake
 +        run-temp-image
 +    ] curry unit-test
 +] each
 +
 +USING: http.client http.server http.server.dispatchers
 +http.server.responses http.server.static io.servers.connection ;
 +
 +SINGLETON: quit-responder
 +
 +M: quit-responder call-responder*
 +    2drop stop-this-server "Goodbye" "text/html" <content> ;
 +
 +: add-quot-responder ( responder -- responder )
 +    quit-responder "quit" add-responder ;
 +
 +: test-httpd ( responder -- )
 +    [
 +        main-responder set
 +        <http-server>
 +            0 >>insecure
 +            f >>secure
 +        dup start-server*
 +        sockets>> first addr>> port>>
 +        dup number>string "resource:temp/port-number" ascii set-file-contents
 +    ] with-scope
 +    "port" set ;
 +
 +[ ] [
 +    <dispatcher>
 +        add-quot-responder
 +        "vocab:http/test" <static> >>default
 +
 +    test-httpd
 +] unit-test
 +
 +[ ] [
 +    "tools.deploy.test.5" shake-and-bake
 +    run-temp-image
 +] unit-test
 +
 +: add-port ( url -- url' )
 +    >url clone "port" get >>port ;
 +
 +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
 +
 +{
 +    "tools.deploy.test.6"
 +    "tools.deploy.test.7"
 +    "tools.deploy.test.9"
 +    "tools.deploy.test.10"
 +    "tools.deploy.test.11"
 +    "tools.deploy.test.12"
 +} [
 +    [ ] swap [
 +        shake-and-bake
 +        run-temp-image
 +    ] curry unit-test
 +] each
 +
 +os windows? os macosx? or [
 +    [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
 +] when
 +
 +os macosx? [
 +    [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
 +] when
 +
 +[ { "a" "b" "c" } ] [
 +    "tools.deploy.test.15" shake-and-bake deploy-test-command
 +    { "a" "b" "c" } append
 +    ascii [ lines ] with-process-reader
 +    rest
 +] unit-test
 +
 +[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
 +
 +[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test
 +
 +[ t ] [
 +    "tools.deploy.test.18" shake-and-bake
 +    deploy-test-command ascii [ readln ] with-process-reader
 +    "test.image" temp-file =
 +] unit-test
diff --cc basis/tools/deploy/windows/ico/ico.factor
index 0000000000,8ea7af348d..46610c487d
mode 000000,100755..100755
--- a/basis/tools/deploy/windows/ico/ico.factor
+++ b/basis/tools/deploy/windows/ico/ico.factor
@@@ -1,0 -1,72 +1,72 @@@
 -USING: accessors alien alien.c-types arrays classes.struct combinators
 -io.backend kernel locals math sequences specialized-arrays
 -tools.deploy.windows windows.kernel32 windows.types ;
 -IN: tools.deploy.windows.ico
 -
 -<PRIVATE
 -
 -STRUCT: ico-header
 -    { Reserved WORD }
 -    { Type WORD }
 -    { ImageCount WORD } ;
 -
 -STRUCT: ico-directory-entry
 -    { Width        BYTE  }
 -    { Height       BYTE  }
 -    { Colors       BYTE  }
 -    { Reserved     BYTE  }
 -    { Planes       WORD  }
 -    { BitsPerPixel WORD  }
 -    { ImageSize    DWORD }
 -    { ImageOffset  DWORD } ;
 -SPECIALIZED-ARRAY: ico-directory-entry
 -
 -STRUCT: group-directory-entry
 -    { Width        BYTE  }
 -    { Height       BYTE  }
 -    { Colors       BYTE  }
 -    { Reserved     BYTE  }
 -    { Planes       WORD  }
 -    { BitsPerPixel WORD  }
 -    { ImageSize    DWORD }
 -    { ImageResourceID WORD } ;
 -
 -: ico>group-directory-entry ( ico i -- group )
 -    [ {
 -        [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
 -        [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
 -    } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
 -
 -: ico-icon ( directory-entry bytes -- subbytes )
 -    [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
 -
 -:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
 -    bytes ico-header memory>struct :> header
 -
 -    ico-header heap-size bytes <displaced-alien> 
 -    header ImageCount>> <direct-ico-directory-entry-array> :> directory
 -
 -    directory dup length iota [ ico>group-directory-entry ] { } 2map-as
 -        :> group-directory
 -    directory [ bytes ico-icon ] { } map-as :> icon-bytes
 -
 -    header clone >c-ptr group-directory concat append
 -    icon-bytes ; inline
 -
 -PRIVATE>
 -
 -:: embed-icon-resource ( exe ico-bytes id -- )
 -    exe normalize-path 1 BeginUpdateResource :> hUpdate
 -    hUpdate [
 -        ico-bytes ico-group-and-icons :> ( group icons )
 -        hUpdate RT_GROUP_ICON id 0 group dup byte-length
 -        UpdateResource drop
 -
 -        icons [| icon i |
 -            hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
 -            UpdateResource drop
 -        ] each-index
 -
 -        hUpdate 0 EndUpdateResource drop
 -    ] when ;
 -
++USING: accessors alien alien.c-types arrays classes.struct combinators
++io.backend kernel locals math sequences specialized-arrays
++tools.deploy.windows windows.kernel32 windows.types ;
++IN: tools.deploy.windows.ico
++
++<PRIVATE
++
++STRUCT: ico-header
++    { Reserved WORD }
++    { Type WORD }
++    { ImageCount WORD } ;
++
++STRUCT: ico-directory-entry
++    { Width        BYTE  }
++    { Height       BYTE  }
++    { Colors       BYTE  }
++    { Reserved     BYTE  }
++    { Planes       WORD  }
++    { BitsPerPixel WORD  }
++    { ImageSize    DWORD }
++    { ImageOffset  DWORD } ;
++SPECIALIZED-ARRAY: ico-directory-entry
++
++STRUCT: group-directory-entry
++    { Width        BYTE  }
++    { Height       BYTE  }
++    { Colors       BYTE  }
++    { Reserved     BYTE  }
++    { Planes       WORD  }
++    { BitsPerPixel WORD  }
++    { ImageSize    DWORD }
++    { ImageResourceID WORD } ;
++
++: ico>group-directory-entry ( ico i -- group )
++    [ {
++        [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
++        [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
++    } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
++
++: ico-icon ( directory-entry bytes -- subbytes )
++    [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
++
++:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
++    bytes ico-header memory>struct :> header
++
++    ico-header heap-size bytes <displaced-alien> 
++    header ImageCount>> <direct-ico-directory-entry-array> :> directory
++
++    directory dup length iota [ ico>group-directory-entry ] { } 2map-as
++        :> group-directory
++    directory [ bytes ico-icon ] { } map-as :> icon-bytes
++
++    header clone >c-ptr group-directory concat append
++    icon-bytes ; inline
++
++PRIVATE>
++
++:: embed-icon-resource ( exe ico-bytes id -- )
++    exe normalize-path 1 BeginUpdateResource :> hUpdate
++    hUpdate [
++        ico-bytes ico-group-and-icons :> ( group icons )
++        hUpdate RT_GROUP_ICON id 0 group dup byte-length
++        UpdateResource drop
++
++        icons [| icon i |
++            hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
++            UpdateResource drop
++        ] each-index
++
++        hUpdate 0 EndUpdateResource drop
++    ] when ;
++