steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-10-02 08:02:35 -05:00
parent 47d884cf41 b45ee5b8be
commit 668fa4d6f8
30 changed files with 266 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
basis/colors/colors.factor
View File

@ -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> 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

11
basis/colors/gray/gray.factor Normal file
View File

@ -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> ;

26
basis/colors/hsv/hsv-tests.factor Normal file
View File

@ -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

65
basis/colors/hsv/hsv.factor
View File

@ -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
<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 )
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> hsva
<PRIVATE
: Hi ( hsv -- Hi ) hue>> 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 <rgba> ;

15
basis/compiler/tests/optimizer.factor
View File

@ -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

4
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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

14
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -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

24
basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -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

12
basis/compiler/tree/recursive/recursive.factor
View File

@ -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 ;

2
basis/http/client/client-docs.factor
View File

@ -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" }

2
basis/http/client/client.factor
View File

@ -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

4
basis/http/http.factor
View File

@ -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 ;

4
basis/http/parsers/parsers.factor
View File

@ -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 ;

2
basis/http/server/server.factor
View File

@ -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

16
basis/io/sockets/sockets.factor
View File

@ -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>

4
basis/io/unix/sockets/sockets.factor
View File

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

10
basis/io/windows/nt/backend/backend.factor
View File

@ -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 ;

4
basis/io/windows/nt/sockets/sockets.factor
View File

@ -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

55
basis/tools/deploy/shaker/shaker.factor
View File

@ -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

9
basis/tools/deploy/shaker/strip-cocoa.factor
View File

@ -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

10
basis/tools/deploy/shaker/strip-debugger.factor
View File

@ -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

5
basis/ui/gadgets/theme/theme.factor
View File

@ -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 ;

6
basis/urls/secure/secure.factor Normal file
View File

@ -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> ;

10
basis/urls/urls.factor
View File

@ -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 ;

4
core/io/backend/backend.factor
View File

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

14
core/io/streams/c/c.factor
View File

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

16
core/sequences/sequences.factor
View File

@ -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

4
core/system/system.factor
View File

@ -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

7
extra/benchmark/mandel/colors/colors.factor
View File

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

2
extra/color-picker/color-picker.factor
View File

@ -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