Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
aee498b05d
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue