diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor index 77a1f46c87..1183c2e46c 100644 --- a/basis/colors/colors.factor +++ b/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 combinators sequences arrays classes.tuple accessors colors.hsv ; - +USING: kernel accessors ; IN: colors -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TUPLE: color ; TUPLE: rgba < color red green blue alpha ; -TUPLE: hsva < color hue saturation value alpha ; - -TUPLE: gray < color gray alpha ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +C: rgba 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 } ; -: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; -: cyan T{ rgba f 0 0.941 0.941 1 } ; -: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; -: green T{ rgba f 0.0 1.0 0.0 1.0 } ; -: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; -: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; -: magenta T{ rgba f 0.941 0 0.941 1 } ; -: orange T{ rgba f 0.941 0.627 0 1 } ; -: purple T{ rgba f 0.627 0 0.941 1 } ; -: red T{ rgba f 1.0 0.0 0.0 1.0 } ; -: white T{ rgba f 1.0 1.0 1.0 1.0 } ; -: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; +: 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 +: cyan T{ rgba f 0 0.941 0.941 1 } ; inline +: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; inline +: green T{ rgba f 0.0 1.0 0.0 1.0 } ; inline +: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; inline +: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; inline +: magenta T{ rgba f 0.941 0 0.941 1 } ; inline +: orange T{ rgba f 0.941 0.627 0 1 } ; inline +: purple T{ rgba f 0.627 0 0.941 1 } ; inline +: red T{ rgba f 1.0 0.0 0.0 1.0 } ; inline +: white T{ rgba f 1.0 1.0 1.0 1.0 } ; inline +: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; inline diff --git a/basis/colors/gray/gray.factor b/basis/colors/gray/gray.factor new file mode 100644 index 0000000000..26ec1177b6 --- /dev/null +++ b/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 + +M: gray >rgba ( gray -- rgba ) + [ gray>> dup dup ] [ alpha>> ] bi ; diff --git a/basis/colors/hsv/hsv-tests.factor b/basis/colors/hsv/hsv-tests.factor new file mode 100644 index 0000000000..8a736553bb --- /dev/null +++ b/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 >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 diff --git a/basis/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor index dd2811822b..6f658818a1 100644 --- a/basis/colors/hsv/hsv.factor +++ b/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: kernel combinators arrays sequences math math.functions ; - +USING: colors kernel combinators math math.functions accessors ; IN: colors.hsv - - ! h [0,360) ! s [0,1] ! v [0,1] +TUPLE: hsva < color hue saturation value alpha ; -: hsv>rgb ( hsv -- rgb ) -dup Hi -{ { 0 [ [ V ] [ t ] [ p ] tri ] } - { 1 [ [ q ] [ V ] [ p ] tri ] } - { 2 [ [ p ] [ V ] [ t ] tri ] } - { 3 [ [ p ] [ q ] [ V ] tri ] } - { 4 [ [ t ] [ p ] [ V ] tri ] } - { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ; +C: hsva + +> 60 / floor 6 mod ; inline + +: f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline + +: 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 ; diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 4c39da0479..f1b3e32eed 100755 --- a/basis/compiler/tests/optimizer.factor +++ b/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 diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index d73e8b7db1..19ee051ac6 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/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 diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 7fc38239f1..d586ff398f 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/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? ] + [ drop object-info ] + recover ; + +: predicate-output-infos/class ( info class -- info ) [ class>> ] dip { { [ 2dup class<= ] [ t ] } { [ 2dup classes-intersect? not ] [ f ] } [ 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 diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index c66c182869..b1f9406092 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/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 diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index d1e4c7c70e..d257cd6600 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/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 ; diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index a762d1a5ef..d4f277a7c3 100644 --- a/basis/http/client/client-docs.factor +++ b/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" } diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index aa1e0771ba..9260f15a7b 100755 --- a/basis/http/client/client.factor +++ b/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 diff --git a/basis/http/http.factor b/basis/http/http.factor index cfc205dbb5..c90a1872ce 100755 --- a/basis/http/http.factor +++ b/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 ; diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index ce8257dec5..8e8e7358d1 100644 --- a/basis/http/parsers/parsers.factor +++ b/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 ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 547e1b69fb..697dec24ce 100755 --- a/basis/http/server/server.factor +++ b/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 diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 9bfcc7e310..c704382dd4 100755 --- a/basis/io/sockets/sockets.factor +++ b/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 [ ] [ 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" ; M: inet4 make-sockaddr ( inet -- sockaddr ) "sockaddr-in" @@ -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" ; M: inet6 make-sockaddr ( inet -- sockaddr ) "sockaddr-in6" diff --git a/basis/io/unix/sockets/sockets.factor b/basis/io/unix/sockets/sockets.factor index 50952dd217..8f9ff4f066 100755 --- a/basis/io/unix/sockets/sockets.factor +++ b/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" ; M: local make-sockaddr path>> (normalize-path) diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor index 7fbc1dbcf9..73b77508b7 100755 --- a/basis/io/windows/nt/backend/backend.factor +++ b/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 -sequences threads windows windows.errors windows.kernel32 -strings splitting io.files io.buffers qualified ascii system -accessors locals ; +io.windows io.windows.files io.files io.buffers io.streams.c +libc kernel math namespaces sequences threads windows +windows.errors windows.kernel32 strings splitting qualified +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 ; diff --git a/basis/io/windows/nt/sockets/sockets.factor b/basis/io/windows/nt/sockets/sockets.factor index 41c5e88f5f..5d94cf2d4a 100755 --- a/basis/io/windows/nt/sockets/sockets.factor +++ b/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 diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index f8b0862c9d..7c02e87209 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/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 -assocs kernel parser lexer strings.parser tools.deploy.config -vocabs sequences words words.private memory kernel.private -continuations io prettyprint vocabs.loader debugger system -strings sets vectors quotations byte-arrays sorting ; +USING: accessors qualified io.backend io.streams.c init fry +namespaces make assocs kernel parser lexer strings.parser +tools.deploy.config vocabs sequences words words.private memory +kernel.private continuations io prettyprint vocabs.loader +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 - [ props>> keys ] gather . + "Remaining word properties:\n" show + [ 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 - compiler.units:update-tuples-hook - compiler.units:definition-observers + recompile-hook + update-tuples-hook + 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 diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index 2cf803e270..d5249dc20c 100755 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/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 diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor index 2302b61715..bdcc6c237e 100755 --- a/basis/tools/deploy/shaker/strip-debugger.factor +++ b/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 diff --git a/basis/ui/gadgets/theme/theme.factor b/basis/ui/gadgets/theme/theme.factor index 46fa0105a3..5e4a2fbf4c 100644 --- a/basis/ui/gadgets/theme/theme.factor +++ b/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 >>boundary ; inline : faint-boundary ( gadget -- gadget ) - gray solid-boundary ; inline + colors:gray solid-boundary ; inline : selection-color ( -- color ) light-purple ; diff --git a/basis/urls/secure/secure.factor b/basis/urls/secure/secure.factor new file mode 100644 index 0000000000..d2fa55f7f3 --- /dev/null +++ b/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 ; diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index 5cc8c9693b..30e8c68f9d 100644 --- a/basis/urls/urls.factor +++ b/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" = ; +secure-addr ( addrspec -- addrspec' ) + +PRIVATE> + : url-addr ( url -- addr ) [ [ host>> ] @@ -166,7 +172,7 @@ PRIVATE> [ protocol>> protocol-port ] tri or ] [ protocol>> ] bi - secure-protocol? [ ] when ; + secure-protocol? [ >secure-addr ] when ; : ensure-port ( url -- url ) dup protocol>> '[ _ protocol-port or ] change-port ; diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 0760063f0d..0c13277106 100755 --- a/core/io/backend/backend.factor +++ b/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 ) diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 780d892d2e..1e12d7e956 100755 --- a/core/io/streams/c/c.factor +++ b/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 stdout-handle stderr-handle ; -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 ; -M: object (file-writer) +M: c-io-backend (file-writer) "wb" fopen ; -M: object (file-appender) +M: c-io-backend (file-appender) "ab" fopen ; : show ( msg -- ) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 267238a502..63cc14d1d7 100755 --- a/core/sequences/sequences.factor +++ b/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 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 [ ] curry ] dip compose if ; inline diff --git a/core/system/system.factor b/core/system/system.factor index 3c207c4ab5..6c9d838fa4 100755 --- a/core/system/system.factor +++ b/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 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 : ( nb-cols -- map ) dup [ 360 * swap 1+ / sat val - 3array hsv>rgb first3 scale-rgb + 1 >rgba scale-rgb ] with map ; : color-map ( -- map ) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 4a0c148145..6ed8c1220c 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -23,7 +23,7 @@ M: color-preview model-changed swap value>> >>interior relayout-1 ; : ( model -- model ) - [ [ 256 /f ] map 1 suffix first4 rgba boa ] ; + [ first3 [ 256 /f ] tri@ 1 ] ; : ( -- model gadget ) 3 [ 0 0 0 255 ] replicate