Merge branch 'master' of git://factorcode.org/git/factor

basis/colors/colors.factor

@@ -1,48 +1,33 @@
-! Copyright (C) 2003, 2007, 2008 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: kernel accessors ;
-USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
-
 IN: colors
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 TUPLE: color ;
 
 TUPLE: rgba < color red green blue alpha ;
 
-TUPLE: hsva < color hue saturation value alpha ;
+C: <rgba> rgba
-
-TUPLE: gray < color gray alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 GENERIC: >rgba ( object -- rgba )
 
 M: rgba >rgba ( rgba -- rgba ) ;
 
-M: hsva >rgba ( hsva -- rgba )
-  { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
-  [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
-
-M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-
 M: color red>>   ( color -- red   ) >rgba red>>   ;
 M: color green>> ( color -- green ) >rgba green>> ;
 M: color blue>>  ( color -- blue  ) >rgba blue>>  ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: black        T{ rgba f 0.0   0.0   0.0   1.0  } ; inline
-
+: blue         T{ rgba f 0.0   0.0   1.0   1.0  } ; inline
-: black        T{ rgba f 0.0   0.0   0.0   1.0  } ;
+: cyan         T{ rgba f 0     0.941 0.941 1    } ; inline
-: blue         T{ rgba f 0.0   0.0   1.0   1.0  } ;
+: gray         T{ rgba f 0.6   0.6   0.6   1.0  } ; inline
-: cyan         T{ rgba f 0     0.941 0.941 1    } ;
+: green        T{ rgba f 0.0   1.0   0.0   1.0  } ; inline
-: gray         T{ rgba f 0.6   0.6   0.6   1.0  } ;
+: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ; inline
-: green        T{ rgba f 0.0   1.0   0.0   1.0  } ;
+: light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ; inline
-: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ;
+: magenta      T{ rgba f 0.941 0     0.941 1    } ; inline
-: light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ;
+: orange       T{ rgba f 0.941 0.627 0     1    } ; inline
-: magenta      T{ rgba f 0.941 0     0.941 1    } ;
+: purple       T{ rgba f 0.627 0     0.941 1    } ; inline
-: orange       T{ rgba f 0.941 0.627 0     1    } ;
+: red          T{ rgba f 1.0   0.0   0.0   1.0  } ; inline
-: purple       T{ rgba f 0.627 0     0.941 1    } ;
+: white        T{ rgba f 1.0   1.0   1.0   1.0  } ; inline
-: red          T{ rgba f 1.0   0.0   0.0   1.0  } ;
+: yellow       T{ rgba f 1.0   1.0   0.0   1.0  } ; inline
-: white        T{ rgba f 1.0   1.0   1.0   1.0  } ;
-: yellow       T{ rgba f 1.0   1.0   0.0   1.0  } ;

basis/colors/gray/gray.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors kernel accessors ;
+IN: colors.gray
+
+TUPLE: gray < color gray alpha ;
+
+C: <gray> gray
+
+M: gray >rgba ( gray -- rgba )
+    [ gray>> dup dup ] [ alpha>> ] bi <rgba> ;

basis/colors/hsv/hsv-tests.factor

@@ -0,0 +1,26 @@
+IN: colors.hsv.tests
+USING: accessors kernel colors colors.hsv tools.test math ;
+
+: hsv>rgb ( h s v -- r g b )
+    [ 360 * ] 2dip
+    1 <hsva> >rgba [ red>> ] [ green>> ] [ blue>> ] tri ;
+
+[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
+
+[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
+[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
+
+[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
+[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
+
+[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
+[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
+
+[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
+[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
+
+[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
+[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
+
+[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
+[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test

basis/colors/hsv/hsv.factor

@@ -1,41 +1,38 @@
-! Copyright (C) 2007 Eduardo Cavazos
+! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: colors kernel combinators math math.functions accessors ;
-USING: kernel combinators arrays sequences math math.functions ;
-
 IN: colors.hsv
 
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
-
-: V ( hsv -- V ) third ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
-
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
-
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
-
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-PRIVATE>
-
 ! h [0,360)
 ! s [0,1]
 ! v [0,1]
+TUPLE: hsva < color hue saturation value alpha ;
 
-: hsv>rgb ( hsv -- rgb )
+C: <hsva> hsva
-dup Hi
+
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
+<PRIVATE
-  { 1 [ [ q ] [ V ] [ p ] tri ] }
+
-  { 2 [ [ p ] [ V ] [ t ] tri ] }
+: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
-  { 3 [ [ p ] [ q ] [ V ] tri ] }
+
-  { 4 [ [ t ] [ p ] [ V ] tri ] }
+: f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
-  { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
+
+: p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
+
+: q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+: t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+PRIVATE>
+
+M: hsva >rgba ( hsva -- rgba )
+    [
+        dup Hi
+        {
+            { 0 [ [ value>> ] [ t ] [ p ] tri ] }
+            { 1 [ [ q ] [ value>> ] [ p ] tri ] }
+            { 2 [ [ p ] [ value>> ] [ t ] tri ] }
+            { 3 [ [ p ] [ q ] [ value>> ] tri ] }
+            { 4 [ [ t ] [ p ] [ value>> ] tri ] }
+            { 5 [ [ value>> ] [ p ] [ q ] tri ] }
+        } case
+    ] [ alpha>> ] bi <rgba> ;

basis/compiler/tests/optimizer.factor

@@ -362,3 +362,18 @@ TUPLE: some-tuple x ;
 [ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
 
 [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
+
+! Loop detection problem found by doublec
+SYMBOL: counter
+
+DEFER: loop-bbb
+
+: loop-aaa ( -- )
+    counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
+
+: loop-bbb ( -- )
+    [ loop-aaa ] with-scope ; inline recursive
+
+: loop-ccc ( -- ) loop-bbb ;
+
+[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test

basis/compiler/tree/propagation/propagation-tests.factor

@@ -8,7 +8,7 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays ;
+float-arrays system ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -590,6 +590,8 @@ MIXIN: empty-mixin
 
 [ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
 
+[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -76,13 +76,25 @@ M: #declare propagate-before
 : fold-call ( #call word -- )
     [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
 
-: predicate-output-infos ( info class -- info )
+: predicate-output-infos/literal ( info class -- info )
+    [ literal>> ] dip
+    '[ _ _ instance? <literal-info> ]
+    [ drop object-info ]
+    recover ;
+
+: predicate-output-infos/class ( info class -- info )
     [ class>> ] dip {
         { [ 2dup class<= ] [ t <literal-info> ] }
         { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
         [ object-info ]
     } cond 2nip ;
 
+: predicate-output-infos ( info class -- info )
+    over literal?>>
+    [ predicate-output-infos/literal ]
+    [ predicate-output-infos/class ]
+    if ;
+
 : propagate-predicate ( #call word -- infos )
     #! We need to force the caller word to recompile when the class
     #! is redefined, since now we're making assumptions but the

basis/compiler/tree/recursive/recursive-tests.factor

@@ -148,3 +148,27 @@ DEFER: a'
     [ a' ] build-tree analyze-recursive
     \ b' label-is-loop?
 ] unit-test
+
+DEFER: a''
+
+: b'' ( -- )
+    a'' ; inline recursive
+
+: a'' ( -- )
+    b'' a'' ; inline recursive
+
+[ t ] [
+    [ a'' ] build-tree analyze-recursive
+    \ a'' label-is-not-loop?
+] unit-test
+
+: loop-in-non-loop ( x quot: ( i -- ) -- )
+    over 0 > [
+        [ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
+    ] [ 2drop ] if ; inline recursive
+
+[ t ] [
+    [ 10 [ [ drop ] each-integer ] loop-in-non-loop ]
+    build-tree analyze-recursive
+    \ (each-integer) label-is-loop?
+] unit-test

basis/compiler/tree/recursive/recursive.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces accessors sequences deques
+USING: kernel assocs arrays namespaces accessors sequences deques
 search-deques compiler.tree compiler.tree.combinators ;
 IN: compiler.tree.recursive
 
@@ -50,11 +50,10 @@ GENERIC: collect-loop-info* ( tail? node -- )
     loop-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
-    nip
     [
         [
             label>>
-            [ loop-stack [ swap suffix ] change ]
+            [ swap 2array loop-stack [ swap suffix ] change ]
             [ remember-loop-info ]
             [ t >>loop? drop ]
             tri
@@ -62,7 +61,7 @@ M: #recursive collect-loop-info*
         [ t swap child>> (collect-loop-info) ] bi
     ] with-scope ;
 
-: current-loop-nesting ( label -- labels )
+: current-loop-nesting ( label -- alist )
     loop-stack get swap loop-heights get at tail ;
 
 : disqualify-loop ( label -- )
@@ -71,7 +70,10 @@ M: #recursive collect-loop-info*
 M: #call-recursive collect-loop-info*
     label>>
     swap [ dup disqualify-loop ] unless
-    dup current-loop-nesting [ loop-calls get push-at ] with each ;
+    dup current-loop-nesting
+    [ keys [ loop-calls get push-at ] with each ]
+    [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
+    bi ;
 
 M: #if collect-loop-info*
     children>> [ (collect-loop-info) ] with each ;

basis/http/client/client-docs.factor

@@ -95,6 +95,8 @@ ARTICLE: "http.client.errors" "HTTP client errors"
 ARTICLE: "http.client" "HTTP client"
 "The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
 $nl
+"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't load it, HTTPS will not load and images generated by " { $vocab-link "tools.deploy" } " will be smaller as a result."
+$nl
 "There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
 { $subsection "http.client.get" }
 { $subsection "http.client.post" }

basis/http/client/client.factor

@@ -120,7 +120,7 @@ SYMBOL: redirects
     ] if ; inline recursive
 
 : read-unchunked ( quot: ( chunk -- ) -- )
-    8192 read dup [
+    8192 read-partial dup [
         [ swap call ] [ drop read-unchunked ] 2bi
     ] [ 2drop ] if ; inline recursive
 

basis/http/http.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel combinators math namespaces make
 assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format present urls logging
+math.parser calendar calendar.format present urls
 
 io io.encodings io.encodings.iana io.encodings.binary
 io.encodings.8-bit
@@ -96,8 +96,6 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
         drop
     ] { } make ;
 
-\ parse-cookie DEBUG add-input-logging
-
 : check-cookie-string ( string -- string' )
     dup "=;'\"\r\n" intersect empty?
     [ "Bad cookie name or value" throw ] unless ;

basis/http/parsers/parsers.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.short-circuit math math.order math.parser
 kernel sequences sequences.deep peg peg.parsers assocs arrays
-hashtables strings unicode.case namespaces make ascii logging ;
+hashtables strings unicode.case namespaces make ascii ;
 IN: http.parsers
 
 : except ( quot -- parser )
@@ -61,8 +61,6 @@ PEG: parse-request-line ( string -- triple )
         'space' ,
     ] seq* just ;
 
-\ parse-request-line DEBUG add-input-logging
-
 : 'text' ( -- parser )
     [ ctl? ] except ;
 

basis/http/server/server.factor

@@ -24,6 +24,8 @@ html.elements
 html.streams ;
 IN: http.server
 
+\ parse-cookie DEBUG add-input-logging
+
 : check-absolute ( url -- url )
     dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
 

basis/io/sockets/sockets.factor

@@ -17,10 +17,12 @@ IN: io.sockets
 ! Addressing
 GENERIC: protocol-family ( addrspec -- af )
 
-GENERIC: sockaddr-type ( addrspec -- type )
+GENERIC: sockaddr-size ( addrspec -- n )
 
 GENERIC: make-sockaddr ( addrspec -- sockaddr )
 
+GENERIC: empty-sockaddr ( addrspec -- sockaddr )
+
 GENERIC: address-size ( addrspec -- n )
 
 GENERIC: inet-ntop ( data addrspec -- str )
@@ -28,10 +30,10 @@ GENERIC: inet-ntop ( data addrspec -- str )
 GENERIC: inet-pton ( str addrspec -- data )
 
 : make-sockaddr/size ( addrspec -- sockaddr size )
-    [ make-sockaddr ] [ sockaddr-type heap-size ] bi ;
+    [ make-sockaddr ] [ sockaddr-size ] bi ;
 
 : empty-sockaddr/size ( addrspec -- sockaddr size )
-    sockaddr-type [ <c-object> ] [ heap-size ] bi ;
+    [ empty-sockaddr ] [ sockaddr-size ] bi ;
 
 GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
 
@@ -74,7 +76,9 @@ M: inet4 address-size drop 4 ;
 
 M: inet4 protocol-family drop PF_INET ;
 
-M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
+M: inet4 sockaddr-size drop "sockaddr-in" heap-size ;
+
+M: inet4 empty-sockaddr drop "sockaddr-in" <c-object> ;
 
 M: inet4 make-sockaddr ( inet -- sockaddr )
     "sockaddr-in" <c-object>
@@ -128,7 +132,9 @@ M: inet6 address-size drop 16 ;
 
 M: inet6 protocol-family drop PF_INET6 ;
 
-M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
+M: inet6 sockaddr-size drop "sockaddr-in6" heap-size ;
+
+M: inet6 empty-sockaddr drop "sockaddr-in6" <c-object> ;
 
 M: inet6 make-sockaddr ( inet -- sockaddr )
     "sockaddr-in6" <c-object>

basis/io/unix/sockets/sockets.factor

@@ -139,7 +139,9 @@ M: unix (send) ( packet addrspec datagram -- )
 ! Unix domain sockets
 M: local protocol-family drop PF_UNIX ;
 
-M: local sockaddr-type drop "sockaddr-un" c-type ;
+M: local sockaddr-size drop "sockaddr-un" heap-size ;
+
+M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
 
 M: local make-sockaddr
     path>> (normalize-path)

basis/io/windows/nt/backend/backend.factor

@@ -1,9 +1,9 @@
 USING: alien alien.c-types arrays assocs combinators
 continuations destructors io io.backend io.ports io.timeouts
-io.windows io.windows.files libc kernel math namespaces
+io.windows io.windows.files io.files io.buffers io.streams.c
-sequences threads windows windows.errors windows.kernel32
+libc kernel math namespaces sequences threads windows
-strings splitting io.files io.buffers qualified ascii system
+windows.errors windows.kernel32 strings splitting qualified
-accessors locals ;
+ascii system accessors locals ;
 QUALIFIED: windows.winsock
 IN: io.windows.nt.backend
 
@@ -120,3 +120,5 @@ M: winnt (wait-to-read) ( port -- )
         [ finish-read ]
         tri
     ] with-destructors ;
+
+M: winnt (init-stdio) init-c-stdio ;

basis/io/windows/nt/sockets/sockets.factor

@@ -71,7 +71,7 @@ TUPLE: AcceptEx-args port
     dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
 
 : init-accept-buffer ( addr AcceptEx -- )
-    swap sockaddr-type heap-size 16 +
+    swap sockaddr-size 16 +
         [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
         dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
         drop ; inline
@@ -135,7 +135,7 @@ TUPLE: WSARecvFrom-args port
     WSARecvFrom-args new
         swap >>port
         dup port>> handle>> handle>> >>s
-        dup port>> addr>> sockaddr-type heap-size
+        dup port>> addr>> sockaddr-size
             [ malloc &free >>lpFrom ]
             [ malloc-int &free >>lpFromLen ] bi
         make-receive-buffer >>lpBuffers

basis/tools/deploy/shaker/shaker.factor

@@ -1,20 +1,18 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors qualified io.streams.c init fry namespaces make
+USING: accessors qualified io.backend io.streams.c init fry
-assocs kernel parser lexer strings.parser tools.deploy.config
+namespaces make assocs kernel parser lexer strings.parser
-vocabs sequences words words.private memory kernel.private
+tools.deploy.config vocabs sequences words words.private memory
-continuations io prettyprint vocabs.loader debugger system
+kernel.private continuations io prettyprint vocabs.loader
-strings sets vectors quotations byte-arrays sorting ;
+debugger system strings sets vectors quotations byte-arrays
+sorting compiler.units definitions ;
 QUALIFIED: bootstrap.stage2
 QUALIFIED: classes
 QUALIFIED: command-line
 QUALIFIED: compiler.errors.private
-QUALIFIED: compiler.units
 QUALIFIED: continuations
 QUALIFIED: definitions
 QUALIFIED: init
-QUALIFIED: io.backend
-QUALIFIED: io.thread
 QUALIFIED: layouts
 QUALIFIED: listener
 QUALIFIED: prettyprint.config
@@ -87,8 +85,8 @@ IN: tools.deploy.shaker
             ] change-props drop
         ] each
     ] [
-        "Remaining word properties:" print
+        "Remaining word properties:\n" show
-        [ props>> keys ] gather .
+        [ props>> keys ] gather unparse show
     ] [
         H{ } clone '[
             [ [ _ [ ] cache ] map ] change-props drop
@@ -198,11 +196,6 @@ IN: tools.deploy.shaker
     strip-word-names? [ dup strip-word-names ] when
     2drop ;
 
-: strip-recompile-hook ( -- )
-    [ [ f ] { } map>assoc ]
-    compiler.units:recompile-hook
-    set-global ;
-
 : strip-vocab-globals ( except names -- words )
     [ child-vocabs [ words ] map concat ] map concat swap diff ;
 
@@ -220,20 +213,21 @@ IN: tools.deploy.shaker
             continuations:restarts
             listener:error-hook
             init:init-hooks
-            io.thread:io-thread
             source-files:source-files
             input-stream
             output-stream
             error-stream
         } %
 
+        "io-thread" "io.thread" lookup ,
+
         "mallocs" "libc.private" lookup ,
 
         deploy-threads? [
             "initial-thread" "threads" lookup ,
         ] unless
 
-        strip-io? [ io.backend:io-backend , ] when
+        strip-io? [ io-backend , ] when
 
         { } {
             "alarms"
@@ -260,9 +254,9 @@ IN: tools.deploy.shaker
                 command-line:main-vocab-hook
                 compiled-crossref
                 compiled-generic-crossref
-                compiler.units:recompile-hook
+                recompile-hook
-                compiler.units:update-tuples-hook
+                update-tuples-hook
-                compiler.units:definition-observers
+                definition-observers
                 definitions:crossref
                 interactive-vocabs
                 layouts:num-tags
@@ -326,6 +320,14 @@ IN: tools.deploy.shaker
         21 setenv
     ] [ drop ] if ;
 
+: strip-c-io ( -- )
+    deploy-io get 2 = [
+        [
+            c-io-backend forget
+            "io.streams.c" forget-vocab
+        ] with-compilation-unit
+    ] unless ;
+
 : compress ( pred string -- )
     "Compressing " prepend show
     instances
@@ -358,22 +360,29 @@ SYMBOL: deploy-vocab
         init-hooks get values concat %
         ,
         strip-io? [ \ flush , ] unless
-    ] [ ] make "Boot quotation: " write dup . flush
+    ] [ ] make "Boot quotation: " show dup unparse show
     set-boot-quot ;
 
+: init-stripper ( -- )
+    t "quiet" set-global
+    f output-stream set-global ;
+
 : strip ( -- )
+    init-stripper
     strip-libc
     strip-cocoa
     strip-debugger
-    strip-recompile-hook
     strip-init-hooks
+    strip-c-io
+    f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
     deploy-vocab get vocab-main set-boot-quot*
     stripped-word-props >r
     stripped-globals strip-globals
     r> strip-words
     compress-byte-arrays
     compress-quotations
-    compress-strings ;
+    compress-strings
+    H{ } clone classes:next-method-quot-cache set-global ;
 
 : (deploy) ( final-image vocab config -- )
     #! Does the actual work of a deployment in the slave

basis/tools/deploy/shaker/strip-cocoa.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
 namespaces kernel kernel.private words compiler.units sequences
-ui ui.cocoa init ;
+init vocabs ;
 IN: tools.deploy.shaker.cocoa
 
 : pool ( obj -- obj' ) \ pool get [ ] cache ;
@@ -23,9 +23,12 @@ IN: cocoa.application
 
 H{ } clone \ pool [
     global [
-        stop-after-last-window? set
+        "stop-after-last-window?" "ui" lookup set
 
-        [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
+        "ui.cocoa" vocab [
+            [ "MiniFactor.nib" load-nib ]
+            "cocoa-init-hook" "ui.cocoa" lookup set-global
+        ] when
 
         ! Only keeps those methods that we actually call
         sent-messages get super-sent-messages get assoc-union

basis/tools/deploy/shaker/strip-debugger.factor

@@ -1,8 +1,14 @@
-USING: kernel threads threads.private ;
+USING: compiler.units words vocabs kernel threads.private ;
 IN: debugger
 
 : print-error ( error -- ) die drop ;
 
 : error. ( error -- ) die drop ;
 
-M: thread error-in-thread ( error thread -- ) die 2drop ;
+"threads" vocab [
+    [
+        "error-in-thread" "threads" lookup
+        [ die 2drop ]
+        define
+    ] with-compilation-unit
+] when

basis/ui/gadgets/theme/theme.factor

@@ -2,7 +2,8 @@
 ! Copyright (C) 2006, 2007 Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors accessors ;
+colors colors.gray qualified accessors ;
+QUALIFIED: colors
 IN: ui.gadgets.theme
 
 : solid-interior ( gadget color -- gadget )
@@ -12,7 +13,7 @@ IN: ui.gadgets.theme
     <solid> >>boundary ; inline
 
 : faint-boundary ( gadget -- gadget )
-    gray solid-boundary ; inline
+    colors:gray solid-boundary ; inline
 
 : selection-color ( -- color ) light-purple ;
 

basis/urls/secure/secure.factor

@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: urls urls.private io.sockets io.sockets.secure ;
+IN: urls.secure
+
+M: abstract-inet >secure-addr <secure> ;

basis/urls/urls.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel ascii combinators combinators.short-circuit
 sequences splitting fry namespaces make assocs arrays strings
-io.sockets io.sockets.secure io.encodings.string
+io.sockets io.encodings.string
 io.encodings.utf8 math math.parser accessors parser
 strings.parser lexer prettyprint.backend hashtables present
 peg.ebnf urls.encoding ;
@@ -159,6 +159,12 @@ PRIVATE>
 : secure-protocol? ( protocol -- ? )
     "https" = ;
 
+<PRIVATE
+
+GENERIC: >secure-addr ( addrspec -- addrspec' )
+
+PRIVATE>
+
 : url-addr ( url -- addr )
     [
         [ host>> ]
@@ -166,7 +172,7 @@ PRIVATE>
         [ protocol>> protocol-port ]
         tri or <inet>
     ] [ protocol>> ] bi
-    secure-protocol? [ <secure> ] when ;
+    secure-protocol? [ >secure-addr ] when ;
 
 : ensure-port ( url -- url )
     dup protocol>> '[ _ protocol-port or ] change-port ;

core/io/backend/backend.factor

@@ -6,6 +6,10 @@ IN: io.backend
 
 SYMBOL: io-backend
 
+SINGLETON: c-io-backend
+
+c-io-backend io-backend set-global
+
 HOOK: init-io io-backend ( -- )
 
 HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )

core/io/streams/c/c.factor

@@ -54,26 +54,28 @@ M: c-reader stream-read-until
 M: c-reader dispose*
     handle>> fclose ;
 
-M: object init-io ;
+M: c-io-backend init-io ;
 
 : stdin-handle 11 getenv ;
 : stdout-handle 12 getenv ;
 : stderr-handle 61 getenv ;
 
-M: object (init-stdio)
+: init-c-stdio ( -- stdin stdout stderr )
     stdin-handle <c-reader>
     stdout-handle <c-writer>
     stderr-handle <c-writer> ;
 
-M: object io-multiplex 60 60 * 1000 * or (sleep) ;
+M: c-io-backend (init-stdio) init-c-stdio ;
 
-M: object (file-reader)
+M: c-io-backend io-multiplex 60 60 * 1000 * or (sleep) ;
+
+M: c-io-backend (file-reader)
     "rb" fopen <c-reader> ;
 
-M: object (file-writer)
+M: c-io-backend (file-writer)
     "wb" fopen <c-writer> ;
 
-M: object (file-appender)
+M: c-io-backend (file-appender)
     "ab" fopen <c-writer> ;
 
 : show ( msg -- )

core/sequences/sequences.factor

@@ -27,7 +27,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 
 M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
 
-: empty? ( seq -- ? ) length zero? ; inline
+: empty? ( seq -- ? ) length 0 = ; inline
 
 : if-empty ( seq quot1 quot2 -- )
     [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
@@ -362,7 +362,7 @@ PRIVATE>
     prepose curry ; inline
 
 : (interleave) ( n elt between quot -- )
-    roll zero? [ nip ] [ swapd 2slip ] if call ; inline
+    roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
 
 PRIVATE>
 
@@ -530,7 +530,7 @@ M: sequence <=>
     [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
 
 : sequence= ( seq1 seq2 -- ? )
-    2dup [ length ] bi@ number=
+    2dup [ length ] bi@ =
     [ mismatch not ] [ 2drop f ] if ; inline
 
 : sequence-hashcode-step ( oldhash newpart -- newhash )
@@ -547,7 +547,7 @@ M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
 M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 
 : move ( to from seq -- )
-    2over number=
+    2over =
     [ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
 
 <PRIVATE
@@ -582,7 +582,7 @@ PRIVATE>
 <PRIVATE
 
 : move-backward ( shift from to seq -- )
-    2over number= [
+    2over = [
         2drop 2drop
     ] [
         [ >r 2over + pick r> move >r 1+ r> ] keep
@@ -590,7 +590,7 @@ PRIVATE>
     ] if ;
 
 : move-forward ( shift from to seq -- )
-    2over number= [
+    2over = [
         2drop 2drop
     ] [
         [ >r pick >r dup dup r> + swap r> move 1- ] keep
@@ -607,7 +607,7 @@ PRIVATE>
 PRIVATE>
 
 : open-slice ( shift from seq -- )
-    pick zero? [
+    pick 0 = [
         3drop
     ] [
         pick over length + over >r >r
@@ -680,7 +680,7 @@ PRIVATE>
 
 : padding ( seq n elt quot -- newseq )
     [
-        [ over length [-] dup zero? [ drop ] ] dip
+        [ over length [-] dup 0 = [ drop ] ] dip
         [ <repetition> ] curry
     ] dip compose if ; inline
 

core/system/system.factor

@@ -11,7 +11,7 @@ SINGLETON: ppc
 
 UNION: x86 x86.32 x86.64 ;
 
-: cpu ( -- class ) \ cpu get ;
+: cpu ( -- class ) \ cpu get-global ; foldable
 
 SINGLETON: winnt
 SINGLETON: wince
@@ -29,7 +29,7 @@ UNION: bsd freebsd netbsd openbsd macosx ;
 
 UNION: unix bsd solaris linux ;
 
-: os ( -- class ) \ os get ;
+: os ( -- class ) \ os get-global ; foldable
 
 <PRIVATE
 

extra/benchmark/mandel/colors/colors.factor

@@ -1,10 +1,11 @@
 USING: math math.order kernel arrays byte-arrays sequences
-colors.hsv benchmark.mandel.params ;
+colors.hsv benchmark.mandel.params accessors colors ;
 IN: benchmark.mandel.colors
 
 : scale 255 * >fixnum ; inline
 
-: scale-rgb ( r g b -- n ) [ scale ] tri@ 3byte-array ;
+: scale-rgb ( rgba -- n )
+    [ red>> scale ] [ green>> scale ] [ blue>> scale ] tri 3byte-array ;
 
 : sat 0.85 ; inline
 : val 0.85 ; inline
@@ -12,7 +13,7 @@ IN: benchmark.mandel.colors
 : <color-map> ( nb-cols -- map )
     dup [
         360 * swap 1+ / sat val
-        3array hsv>rgb first3 scale-rgb
+        1 <hsva> >rgba scale-rgb
     ] with map ;
 
 : color-map ( -- map )

extra/color-picker/color-picker.factor

@@ -23,7 +23,7 @@ M: color-preview model-changed
     swap value>> >>interior relayout-1 ;
 
 : <color-model> ( model -- model )
-    [ [ 256 /f ] map 1 suffix first4 rgba boa <solid> ] <filter> ;
+    [ first3 [ 256 /f ] tri@ 1 <rgba> <solid> ] <filter> ;
 
 : <color-sliders> ( -- model gadget )
     3 [ 0 0 0 255 <range> ] replicate