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

db4
Slava Pestov 2008-02-12 12:19:36 -06:00
commit aee498b05d
10 changed files with 109 additions and 211 deletions

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math ;
USING: combinators kernel math sequences ;
IN: dlists
TUPLE: dlist front back length ;
@ -72,6 +72,9 @@ PRIVATE>
: push-front ( obj dlist -- )
push-front* drop ;
: push-all-front ( seq dlist -- )
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
@ -80,11 +83,10 @@ PRIVATE>
inc-length ;
: push-back ( obj dlist -- )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
[ set-dlist-back ] keep
[ set-front-to-back ] keep
inc-length ;
push-back* drop ;
: push-all-back ( seq dlist -- )
[ push-back ] curry each ;
: peek-front ( dlist -- obj )
dlist-front dlist-node-obj ;
@ -156,3 +158,6 @@ PRIVATE>
over dlist-empty?
[ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ;
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

View File

@ -141,37 +141,6 @@ C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
HOOK: library-roots io-backend ( -- seq )
HOOK: binary-roots io-backend ( -- seq )
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
: find-library ( str -- path/f )
library-roots swap find-file ;
: find-binary ( str -- path/f )
binary-roots swap find-file ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] with map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
: file-lines ( path -- seq ) <file-reader> lines ;
: file-contents ( path -- str )

View File

@ -1,6 +1,6 @@
USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
system continuations namespaces sequences splitting math.parser
arrays system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download
combinators.cleave ;
@ -11,21 +11,6 @@ IN: builder
: runtime ( quot -- time ) benchmark nip ;
: log-runtime ( quot file -- )
>r runtime r> <file-writer> [ . ] with-stream ;
: log-object ( object file -- ) <file-writer> [ . ] with-stream ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-recipients
@ -48,23 +33,8 @@ SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-or-notify ( desc message -- )
[ [ try-process ] curry ]
[ [ email-string throw ] curry ]
bi*
recover ;
: run-or-send-file ( desc message file -- )
>r >r [ try-process ] curry
r> r> [ email-file throw ] 2curry
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: factor-binary ( -- name )
os
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
@ -72,12 +42,6 @@ SYMBOL: builder-recipients
[ drop "./factor" ] }
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: stamp
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-pull ( -- desc )
{
"git"
@ -89,16 +53,30 @@ VAR: stamp
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
VAR: stamp
: enter-build-dir ( -- )
datestamp >stamp
"/builds" cd
stamp> make-directory
stamp> cd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
: record-git-id ( -- ) git-id "../git-id" log-object ;
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ;
: make-clean ( -- desc ) { "make" "clean" } ;
@ -110,13 +88,6 @@ VAR: stamp
}
>hashtable ;
: retrieve-boot-image ( -- )
[ my-arch download-image ]
[ ]
[ "builder: image download" email-string ]
cleanup
flush ;
: bootstrap ( -- desc )
`{
{ +arguments+ {
@ -131,129 +102,66 @@ VAR: stamp
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
! : build ( -- )
! enter-build-dir
! git-clone "git clone error" run-or-notify
! "factor" cd
! record-git-id
! make-clean "make clean error" run-or-notify
! make-vm "vm compile error" "../compile-log" run-or-send-file
! retrieve-boot-image
! bootstrap "bootstrap error" "../boot-log" run-or-send-file
! builder-test "builder.test fatal error" run-or-notify
! "../load-everything-log" exists?
! [ "load-everything" "../load-everything-log" email-file ]
! when
! "../failing-tests" exists?
! [ "failing tests" "../failing-tests" email-file ]
! when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: report
: >>>report ( quot -- ) report get swap with-stream* ;
: file>>>report ( file -- ) [ <file-reader> contents write ] curry >>>report ;
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) <file-reader> contents eval ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-or-report ( desc quot -- )
[ [ try-process ] curry ]
[ [ >>>report throw ] curry ]
: cat ( file -- ) <file-reader> contents print ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
[ [ throw ] curry ]
bi*
recover ;
: run-or-report-file ( desc quot file -- )
[ [ try-process ] curry ]
[ [ >>>report ] curry ]
[ [ file>>>report throw ] curry ]
tri*
compose
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ms>minutes ( ms -- minutes ) 1000.0 / 60 / ;
: bootstrap-minutes ( -- )
"../bootstrap-time" <file-reader> contents eval ms>minutes unparse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (build) ( -- )
enter-build-dir
"report" <file-writer> report set
"report" [
[
"Build machine: " write host-name write nl
"Build directory: " write cwd write nl
] >>>report
"Build machine: " write host-name print
"Build directory: " write cwd print
git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report
git-clone [ "git clone failed" print ] run-or-bail
"factor" cd
"factor" cd
record-git-id
record-git-id
make-clean run-process drop
make-clean run-process drop
make-vm
[ "Builder fatal error: vm compile error" write nl ]
"../compile-log"
run-or-report-file
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
[ my-arch download-image ]
[ [ "Builder fatal error: image download" write nl ] >>>report throw ]
recover
[ my-arch download-image ] [ "Image download error" print throw ] recover
bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
builder-test [ "Builder test error" write nl ] run-or-report
[ builder-test try-process ]
[ "Builder test error" print throw ]
recover
[ "Bootstrap time: " write bootstrap-minutes write " minutes" write nl ]
>>>report
"Boot time: " write "../boot-time" eval-file milli-seconds>time print
"Load time: " write "../load-time" eval-file milli-seconds>time print
"Test time: " write "../test-time" eval-file milli-seconds>time print
"../load-everything-vocabs" exists?
[
[ "Did not pass load-everything: " write nl ] >>>report
"../load-everything-vocabs" file>>>report
]
when
"Did not pass load-everything: " print "../load-everything-vocabs" cat
"Did not pass test-all: " print "../test-all-vocabs" cat
"../test-all-vocabs" exists?
[
[ "Did not pass test-all: " write nl ] >>>report
"../test-all-vocabs" file>>>report
]
when ;
: send-report ( -- )
report get dispose
"report" "../report" email-file ;
] with-file-out ;
: build ( -- )
[ (build) ]
[ drop ]
recover
send-report ;
[ (build) ] [ drop ] recover
"report" "../report" email-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -10,28 +10,15 @@ USING: kernel namespaces sequences assocs builder continuations
IN: builder.test
: record-bootstrap-time ( -- )
"../bootstrap-time" <file-writer>
[ bootstrap-time get . ]
with-stream ;
: do-load ( -- )
[ try-everything keys ] "../load-everything-time" log-runtime
dup empty?
[ drop ]
[ "../load-everything-vocabs" log-object ]
if ;
try-everything keys "../load-everything-vocabs" [ . ] with-file-out ;
: do-tests ( -- )
[ run-all-tests keys ] "../test-all-time" log-runtime
dup empty?
[ drop ]
[ "../test-all-vocabs" log-object ]
if ;
run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
: do-all ( -- )
record-bootstrap-time
do-load
do-tests ;
bootstrap-time get "../boot-time" [ . ] with-file-out
[ do-load ] runtime "../load-time" [ . ] with-file-out
[ do-tests ] runtime "../test-time" [ . ] with-file-out ;
MAIN: do-all

View File

@ -1,12 +1,12 @@
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
io.paths strings ;
io.paths strings unicode.case ;
IN: editors.editpadpro
: editpadpro-path
\ editpadpro-path get-global [
program-files "JGsoft" path+ walk-dir
[ >lower "editpadpro.exe" tail? ] find nip
program-files "JGsoft" path+
[ >lower "editpadpro.exe" tail? ] find-file-breadth
] unless* ;
: editpadpro ( file line -- )

View File

@ -4,7 +4,7 @@ IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
program-files "\\EditPlus 2\\editplus.exe" append
program-files "\\EditPlus 2\\editplus.exe" path+
] unless* ;
: editplus ( file line -- )

View File

@ -1,8 +1,9 @@
USING: editors.gvim.backend io.files io.windows kernel namespaces
sequences windows.shell32 ;
sequences windows.shell32 io.paths ;
IN: editors.gvim.windows
M: windows-io gvim-path
\ gvim-path get-global [
program-files walk-dir [ "gvim.exe" tail? ] find nip
program-files "vim" path+
[ "gvim.exe" tail? ] find-file-breadth
] unless* ;

View File

@ -1,10 +1,11 @@
USING: editors hardware-info.windows io.launcher kernel
math.parser namespaces sequences windows.shell32 ;
math.parser namespaces sequences windows.shell32 io.files
arrays ;
IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
program-files "\\Windows NT\\Accessories\\wordpad.exe" append
program-files "\\Windows NT\\Accessories\\wordpad.exe" path+
] unless* ;
: wordpad ( file line -- )

View File

@ -1,24 +1,49 @@
USING: assocs io.files kernel namespaces sequences ;
USING: arrays assocs combinators.lib dlists io.files
kernel namespaces sequences shuffle vectors ;
IN: io.paths
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
! HOOK: library-roots io-backend ( -- seq )
! HOOK: binary-roots io-backend ( -- seq )
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] with map ;
[ >r path+ r> ] with* assoc-map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
dup directory append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
first2 [
get-paths dup keys % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
: walk-dir ( path -- seq )
dup directory? 2array [ (walk-dir) ] { } make ;
GENERIC# find-file* 1 ( obj quot -- path/f )
M: dlist find-file* ( dlist quot -- path/f )
over dlist-empty? [ 2drop f ] [
2dup >r pop-front get-paths dup r> assoc-find
[ drop 3nip ]
[ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if
] if ;
M: vector find-file* ( vector quot -- path/f )
over empty? [ 2drop f ] [
2dup >r pop get-paths dup r> assoc-find
[ drop 3nip ]
[ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if
] if ;
: prepare-find-file ( quot -- quot )
[ drop ] swap compose ;
: find-file-depth ( path quot -- path/f )
prepare-find-file >r 1vector r> find-file* ;
: find-file-breadth ( path quot -- path/f )
prepare-find-file >r 1dlist r> find-file* ;

View File

@ -25,6 +25,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 3nip ( a b c d -- d ) 3 nnip ; inline
: 4nip ( a b c d e -- e ) 4 nnip ; inline
: 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline
: 4drop ( a b c d -- ) 3drop drop ; inline