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-02-07 17:54:25 -06:00
parent 3a989db973 6187a1e5e1
commit 0836e4ed54
15 changed files with 102 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
core/bootstrap/image/image.factor
View File

@ -10,6 +10,23 @@ definitions debugger float-arrays quotations.private
combinators.private combinators ;
IN: bootstrap.image
: my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
: my-boot-image-name ( -- string )
my-arch boot-image-name ;
: images ( -- seq )
{
"x86.32"
"x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} ;
<PRIVATE
! Constants
@ -394,9 +411,6 @@ M: curry '
[ >le write ] curry each
] if ;
: image-name
"boot." architecture get ".image" 3append resource-path ;
: write-image ( image filename -- )
"Writing image to " write dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ;
@ -415,16 +429,10 @@ PRIVATE>
begin-image
"resource:/core/bootstrap/stage1.factor" run-file
end-image
image get image-name write-image
image get
architecture get boot-image-name resource-path
write-image
] with-variable ;
: my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ;
: make-images ( -- )
{
"x86.32"
"x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} [ make-image ] each ;
images [ make-image ] each ;

4
extra/benchmark/bootstrap2/bootstrap2.factor
View File

@ -1,4 +1,4 @@
USING: io.files io.launcher system tools.deploy.backend
USING: io.files io.launcher system bootstrap.image
namespaces sequences kernel ;
IN: benchmark.bootstrap2
@ -6,7 +6,7 @@ IN: benchmark.bootstrap2
"." resource-path cd
[
vm ,
"-i=" boot-image-name append ,
"-i=" my-boot-image-name append ,
"-output-image=foo.image" ,
"-no-user-init" ,
] { } make run-process drop ;

1
extra/bootstrap/image/download/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

25
extra/bootstrap/image/download/download.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
USING: http.client crypto.md5 splitting assocs kernel io.files
bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
: download-checksums ( -- alist )
url "checksums.txt" append http-get
string-lines [ " " split1 ] { } map>assoc ;
: need-new-image? ( image -- ? )
dup exists?
[ dup file>md5str swap download-checksums at = not ]
[ drop t ] if ;
: download-image ( arch -- )
boot-image-name dup need-new-image? [
"Downloading " write dup write "..." print
url swap append download
] [
"Boot image up to date" print
drop
] if ;

1
extra/bootstrap/image/download/summary.txt Normal file
View File

@ -0,0 +1 @@
Smart image downloader utility which first checks MD5 checksum

1
extra/bootstrap/image/upload/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/bootstrap/image/upload/summary.txt Normal file
View File

@ -0,0 +1 @@
Image upload utility

25
extra/bootstrap/image/upload/upload.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.upload
USING: http.client crypto.md5 splitting assocs kernel io.files
bootstrap.image sequences io namespaces io.launcher math ;
: destination "slava@factorcode.org:www/images/latest/" ;
: boot-image-names images [ boot-image-name ] map ;
: compute-checksums ( -- )
"checksums.txt" [
boot-image-names [ dup write bl file>md5str print ] each
] with-file-out ;
: upload-images ( -- )
[
"scp" , boot-image-names % "checksums.txt" , destination ,
] { } make run-process
wait-for-process zero? [ "Upload failed" throw ] unless ;
: new-images ( -- )
make-images compute-checksums upload-images ;
MAIN: new-images

11
extra/crypto/sha1/sha1.factor
View File

@ -48,14 +48,13 @@ SYMBOL: K
! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
: sha1-f ( B C D t -- f_tbcd )
#! Maybe use dispatch
20 /i
{
{ [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] }
{ [ dup 1 = ] [ drop bitxor bitxor ] }
{ [ dup 2 = ] [ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
{ [ dup 3 = ] [ drop bitxor bitxor ] }
} cond ;
{ 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
{ 1 [ bitxor bitxor ] }
{ 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
{ 3 [ bitxor bitxor ] }
} case ;
: make-w ( str -- )
#! compute w, steps a-b of RFC 3174, section 6.1

27
extra/http/client/client.factor
View File

@ -47,32 +47,31 @@ DEFER: http-get-stream
dispose "location" swap peek-at nip http-get-stream
] when ;
: default-timeout 60 1000 * over set-timeout ;
: http-get-stream ( url -- code headers stream )
#! Opens a stream for reading from an HTTP URL.
parse-url over parse-host <inet> <client> [
[ [ get-request read-response ] with-stream* ] keep
default-timeout
] [ ] [ dispose ] cleanup do-redirect ;
: http-get ( url -- code headers string )
#! Opens a stream for reading from an HTTP URL.
[
http-get-stream [ stdio get contents ] with-stream
] with-scope ;
: success? ( code -- ? ) 200 = ;
: check-response ( code headers stream -- stream )
nip swap success?
[ dispose "HTTP download failed" throw ] unless ;
: http-get ( url -- string )
http-get-stream check-response contents ;
: download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ;
: default-timeout 60 1000 * over set-timeout ;
: success? ( code -- ? ) 200 = ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
>r http-get-stream nip default-timeout swap success? [
r> <file-writer> stream-copy
] [
r> drop dispose "HTTP download failed" throw
] if ;
>r http-get-stream check-response
r> <file-writer> stream-copy ;
: download ( url -- )
dup download-name download-to ;

3
extra/io/server/server.factor
View File

@ -19,7 +19,8 @@ LOG: accepted-connection NOTICE
: accept-loop ( server quot -- )
[
>r accept r> [ with-client ] 2curry concurrency:spawn
>r accept r> [ with-client ] 2curry
concurrency:spawn drop
] 2keep accept-loop ; inline
: server-loop ( server quot -- )

2
extra/rss/rss.factor
View File

@ -78,7 +78,7 @@ C: <entry> entry
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
http-get-stream rot 200 = [
http-get-stream rot success? [
nip read-feed
] [
2drop "Error retrieving newsfeed file" throw

7
extra/tools/deploy/backend/backend.factor
View File

@ -24,12 +24,9 @@ IN: tools.deploy.backend
dup duplex-stream-out dispose
copy-lines ;
: boot-image-name ( -- string )
"boot." my-arch ".image" 3append ;
: make-boot-image ( -- )
#! If stage1 image doesn't exist, create one.
boot-image-name resource-path exists?
my-boot-image-name resource-path exists?
[ my-arch make-image ] unless ;
: ?, [ , ] [ drop ] if ;
@ -49,7 +46,7 @@ IN: tools.deploy.backend
: staging-command-line ( config -- flags )
[
"-i=" boot-image-name append ,
"-i=" my-boot-image-name append ,
"-output-image=" over staging-image-name append ,

2
extra/webapps/fjsc/fjsc.factor
View File

@ -25,7 +25,7 @@ IN: webapps.fjsc
: compile-url ( url -- )
#! Compile the factor code at the given url, return the javascript.
dup "http:" head? [ "Unable to access remote sites." throw ] when
"http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ;
"http://" "Host" header-param rot 3append http-get compile "();" write flush ;
\ compile-url {
{ "url" v-required }

4
extra/yahoo/yahoo.factor
View File

@ -26,6 +26,4 @@ C: <result> result
] "" make ;
: search-yahoo ( search num -- seq )
query http-get 2nip
[ "Search failed" throw ] unless*
string>xml parse-yahoo ;
query http-get string>xml parse-yahoo ;