diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index ec76156775..9a73e575a2 100644 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -31,7 +31,7 @@ ERROR: file-delete-failed path error ; : (delete-file) ( path -- ) dup DeleteFile 0 = [ GetLastError ERROR_ACCESS_DENIED = - [ delete-read-only-file ] [ throw-win32-error ] if + [ delete-read-only-file ] [ drop win32-error ] if ] [ drop ] if ; M: windows delete-file ( path -- ) diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index f5c45881b6..57546b6ca9 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel system sequences combinators -vocabs vocabs.loader io.files io.files.types math ; +USING: accessors assocs combinators io.files io.files.types +io.pathnames kernel math system vocabs ; IN: io.files.info ! File info @@ -34,6 +34,22 @@ HOOK: file-readable? os ( path -- ? ) HOOK: file-writable? os ( path -- ? ) HOOK: file-executable? os ( path -- ? ) +HOOK: mount-points os ( -- assoc ) + +M: object mount-points + file-systems [ [ mount-point>> ] keep ] H{ } map>assoc ; + +: (find-mount-point) ( path assoc -- object ) + [ resolve-symlinks canonicalize-path-full ] dip + 2dup at* [ + 2nip + ] [ + drop [ parent-directory ] dip (find-mount-point) + ] if ; + +: find-mount-point ( path -- object ) + mount-points (find-mount-point) ; + { { [ os unix? ] [ "io.files.info.unix" ] } { [ os windows? ] [ "io.files.info.windows" ] } diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 56e722bf21..ce99f23ac4 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -68,9 +68,15 @@ frequency pass-number ; char: \s [ "/etc/mtab" utf8 file>csv ] with-delimiter [ mtab-csv>mtab-entry ] map ; +: (file-system-info) ( path -- file-system-info ) + [ new-file-system-info ] dip + [ file-system-statfs statfs>file-system-info ] + [ file-system-statvfs statvfs>file-system-info ] bi + file-system-calculations ; inline + : mtab-entry>file-system-info ( mtab-entry -- file-system-info/f ) '[ - _ [ mount-point>> file-system-info ] keep + _ [ mount-point>> (file-system-info) ] [ ] bi { [ file-system-name>> >>device-name ] [ mount-point>> >>mount-point ] @@ -78,28 +84,14 @@ frequency pass-number ; } cleave ] [ { [ libc-error? ] [ errno>> EACCES = ] } 1&& ] ignore-error/f ; +M: linux mount-points + parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc ; + M: linux file-systems parse-mtab [ mtab-entry>file-system-info ] map sift ; -: (find-mount-point) ( path mtab-paths -- mtab-entry ) - 2dup at* [ - 2nip - ] [ - drop [ parent-directory ] dip (find-mount-point) - ] if ; - -: find-mount-point ( path -- mtab-entry ) - resolve-symlinks - parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; - M: linux file-system-info ( path -- file-system-info ) - normalize-path - [ - [ new-file-system-info ] dip - [ file-system-statfs statfs>file-system-info ] - [ file-system-statvfs statvfs>file-system-info ] bi - file-system-calculations - ] keep + normalize-path [ (file-system-info) ] [ ] bi find-mount-point { [ file-system-name>> >>device-name drop ] diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index fac0f8b041..81e8e25ee3 100644 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -1,4 +1,3 @@ -! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.data alien.strings ascii calendar classes.struct combinators combinators.short-circuit @@ -19,7 +18,7 @@ TUPLE: windows-file-info < file-info-tuple attributes ; : get-compressed-file-size ( path -- n ) { DWORD } [ GetCompressedFileSize ] with-out-parameters - over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ; + over INVALID_FILE_SIZE = [ win32-error ] when >64bit ; : set-windows-size-on-disk ( file-info path -- file-info ) over attributes>> +compressed+ swap member? [ diff --git a/basis/io/files/temp/macosx/macosx.factor b/basis/io/files/temp/macosx/macosx.factor index 991fbcfdee..4df518f4d7 100644 --- a/basis/io/files/temp/macosx/macosx.factor +++ b/basis/io/files/temp/macosx/macosx.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2012 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax cocoa.plists cocoa.runtime -cocoa.types core-foundation.strings io.directories io.files -io.files.temp io.pathnames kernel sequences system ; +cocoa.types core-foundation.strings io.files io.files.temp +io.pathnames kernel sequences system ; IN: io.files.temp.macosx file-size ( handle -- n/f ) (handle>file-size) [ GetLastError ERROR_INVALID_FUNCTION = - [ f ] [ throw-win32-error ] if + [ win32-error ] unless f ] unless* ; ERROR: seek-before-start n ; @@ -346,6 +346,11 @@ PRIVATE> M: windows canonicalize-path remove-unicode-prefix canonicalize-path* ; +M: windows canonicalize-drive + dup windows-absolute-path? [ ":" split1 [ >upper ] dip ":" glue ] when ; + +M: windows canonicalize-path-full canonicalize-path canonicalize-drive >windows-path ; + M: windows root-path remove-unicode-prefix root-path* ; M: windows relative-path remove-unicode-prefix relative-path* ; @@ -399,8 +404,8 @@ M: windows home WIN32_FIND_STREAM_DATA 0 [ FindFirstStream ] keepd - over -1 = [ - 2drop throw-win32-error + over INVALID_HANDLE_VALUE = [ + 2drop win32-error f ] [ 1vector swap file-streams-rest ] if ; diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 3d8fde7ee6..ff6a3f4937 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors destructors io.backend.unix io.mmap -io.mmap.private kernel libc literals locals system unix -unix.ffi ; +io.mmap.private kernel libc literals locals system unix unix.ffi ; IN: io.mmap.unix :: mmap-open ( path length prot flags open-mode -- alien fd ) diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index f37eb23a6c..8ec490bab0 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2010 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien byte-arrays combinators destructors hints -io io.backend io.buffers io.encodings io.files io.timeouts -kernel kernel.private libc locals math math.order math.private +USING: accessors alien combinators destructors hints io +io.backend io.buffers io.encodings io.files io.timeouts kernel +kernel.private libc locals math math.order math.private namespaces sequences strings system ; IN: io.ports diff --git a/basis/io/sockets/secure/windows/windows.factor b/basis/io/sockets/secure/windows/windows.factor index 59eccfed19..815200c11b 100644 --- a/basis/io/sockets/secure/windows/windows.factor +++ b/basis/io/sockets/secure/windows/windows.factor @@ -14,7 +14,7 @@ M: openssl ssl-certificate-verification-supported? f ; : load-windows-cert-store ( string -- HCERTSTORE ) [ f ] dip CertOpenSystemStore - [ win32-error-string throw ] when-zero ; + [ win32-error f ] when-zero ; : X509-NAME. ( X509_NAME -- ) f 0 X509_NAME_oneline diff --git a/basis/timers/timers.factor b/basis/timers/timers.factor index 57006c1bd9..65064adb29 100644 --- a/basis/timers/timers.factor +++ b/basis/timers/timers.factor @@ -29,11 +29,7 @@ M: duration >nanoseconds duration>nanoseconds >integer ; [ dupd [ mod ] [ swap - ] bi + + ] [ 2drop f ] if* ; : next-nanos ( timer -- timer n/f ) - dup thread>> self eq? [ - dup next-nanos>> dup t eq? [ - drop dup delay-nanos [ >>next-nanos ] keep - ] when - ] [ f ] if ; + dup thread>> self eq? [ dup next-nanos>> ] [ f ] if ; : run-timer ( timer -- timer ) dup interval-nanos >>next-nanos @@ -65,7 +61,7 @@ ERROR: timer-already-started timer ; : start-timer ( timer -- ) dup thread>> [ timer-already-started ] when - t >>next-nanos + dup delay-nanos >>next-nanos dup '[ _ timer-loop ] "Timer" [ >>thread drop ] [ (spawn) ] bi ; @@ -74,7 +70,8 @@ ERROR: timer-already-started timer ; : restart-timer ( timer -- ) dup thread>> [ - t >>next-nanos [ thread>> ] [ ?interrupt ] bi + dup delay-nanos >>next-nanos + [ thread>> ] [ ?interrupt ] bi ] [ start-timer ] if ; diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 4e6dac91bd..c79f433079 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -34,7 +34,7 @@ delete-staging-images { } [ "sudoku" shake-and-bake 800000 small-enough? ] long-unit-test ! [ ] [ "hello-ui" shake-and-bake 1605000 small-enough? ] long-unit-test -{ } [ "hello-ui" shake-and-bake 2762000 small-enough? ] long-unit-test +{ } [ "hello-ui" shake-and-bake 2764000 small-enough? ] long-unit-test { "math-threads-compiler-io-ui" } [ "hello-ui" deploy-config config>profile @@ -42,24 +42,24 @@ delete-staging-images ] long-unit-test ! [ ] [ "maze" shake-and-bake 1520000 small-enough? ] long-unit-test -{ } [ "maze" shake-and-bake 2800000 small-enough? ] long-unit-test +{ } [ "maze" shake-and-bake 2801000 small-enough? ] long-unit-test ! [ ] [ "tetris" shake-and-bake 1734000 small-enough? ] long-unit-test { } [ "tetris" shake-and-bake 2850000 small-enough? ] long-unit-test ! [ ] [ "spheres" shake-and-bake 1557000 small-enough? ] long-unit-test -{ } [ "spheres" shake-and-bake 2820000 small-enough? ] long-unit-test +{ } [ "spheres" shake-and-bake 2850000 small-enough? ] long-unit-test ! [ ] [ "terrain" shake-and-bake 2053000 small-enough? ] long-unit-test -{ } [ "terrain" shake-and-bake 2685300 small-enough? ] long-unit-test +{ } [ "terrain" shake-and-bake 3385300 small-enough? ] long-unit-test ! [ ] [ "gpu.demos.raytrace" shake-and-bake 2764000 small-enough? ] long-unit-test -{ } [ "gpu.demos.raytrace" shake-and-bake 3557800 small-enough? ] long-unit-test +{ } [ "gpu.demos.raytrace" shake-and-bake 4157800 small-enough? ] long-unit-test ! { } [ "bunny" shake-and-bake 2559640 small-enough? ] long-unit-test -{ } [ "bunny" shake-and-bake 2700000 small-enough? ] long-unit-test +{ } [ "bunny" shake-and-bake 3400000 small-enough? ] long-unit-test -{ } [ "gpu.demos.bunny" shake-and-bake 3750000 small-enough? ] long-unit-test +{ } [ "gpu.demos.bunny" shake-and-bake 4200000 small-enough? ] long-unit-test os macosx? [ [ ] [ "webkit-demo" shake-and-bake 600000 small-enough? ] long-unit-test diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 83a8df0148..09b32ee3fa 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -733,16 +733,6 @@ ERROR: windows-error n string ; : win32-error<0 ( n -- ) 0 < [ win32-error ] when ; : win32-error<>0 ( n -- ) zero? [ win32-error ] unless ; -: n>win32-error-check ( n -- ) - dup ERROR_SUCCESS = [ - drop - ] [ - dup n>win32-error-string windows-error - ] if ; - -: throw-win32-error ( -- * ) - win32-error-string throw ; - : check-invalid-handle ( handle -- handle ) dup INVALID_HANDLE_VALUE = [ throw-win32-error ] when ; diff --git a/build.cmd b/build.cmd index 6d964ec660..eb8cd39990 100644 --- a/build.cmd +++ b/build.cmd @@ -39,7 +39,7 @@ echo Deleting staging images from temp/... del temp\staging.*.image echo Updating working copy from %GIT_BRANCH%... -call git pull git://factorcode.org/git/factor.git %GIT_BRANCH% +call git pull https://github.com/factor/factor %GIT_BRANCH% if errorlevel 1 goto fail echo Building vm... diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6725481cb1..e96dbc8ab5 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings init io io.backend io.encodings io.pathnames -kernel kernel.private namespaces sequences splitting system ; +USING: alien.strings init io io.backend io.encodings +io.pathnames kernel kernel.private namespaces sequences +splitting system ; IN: io.files : absolute-path? ( path -- ? ) { - { [ dup empty? ] [ f ] } - { [ dup special-path? nip ] [ t ] } + { [ dup empty? ] [ drop f ] } + { [ dup special-path? nip ] [ drop t ] } { [ os windows? ] [ windows-absolute-path? ] } - { [ dup first path-separator? ] [ t ] } - [ f ] - } cond nip ; + { [ dup first path-separator? ] [ drop t ] } + [ drop f ] + } cond ; : append-relative-path ( path1 path2 -- path ) [ trim-tail-separators ] @@ -213,6 +213,16 @@ HOOK: canonicalize-path io-backend ( path -- path' ) M: object canonicalize-path canonicalize-path* ; +HOOK: canonicalize-drive io-backend ( path -- path' ) + +M: object canonicalize-drive ; + +HOOK: canonicalize-path-full io-backend ( path -- path' ) + +M: object canonicalize-path-full canonicalize-path canonicalize-drive ; + +: >windows-path ( path -- path' ) H{ { CHAR: / CHAR: \\ } } substitute ; + TUPLE: pathname string ; C: pathname diff --git a/extra/bencode/bencode-tests.factor b/extra/bencode/bencode-tests.factor index 1d18c6c205..2ef6796681 100644 --- a/extra/bencode/bencode-tests.factor +++ b/extra/bencode/bencode-tests.factor @@ -1,4 +1,4 @@ -USING: bencode tools.test ; +USING: bencode linked-assocs tools.test ; { "i42e" } [ 42 >bencode ] unit-test { "i0e" } [ 0 >bencode ] unit-test @@ -8,6 +8,6 @@ USING: bencode tools.test ; { { "spam" 42 } } [ "l4:spami42ee" bencode> ] unit-test -{ H{ { "bar" "spam" } { "foo" 42 } } } [ +{ LH{ { "bar" "spam" } { "foo" 42 } } } [ "d3:bar4:spam3:fooi42ee" bencode> ] unit-test diff --git a/extra/bencode/bencode.factor b/extra/bencode/bencode.factor index 1e4ad130f3..174833aa08 100644 --- a/extra/bencode/bencode.factor +++ b/extra/bencode/bencode.factor @@ -1,6 +1,6 @@ -USING: arrays assocs combinators hashtables io -io.encodings.ascii io.encodings.string io.streams.string kernel -math math.parser sequences strings ; +USING: arrays assocs combinators io io.encodings.ascii +io.encodings.string io.streams.string kernel linked-assocs math +math.parser sequences strings ; IN: bencode GENERIC: >bencode ( obj -- bencode ) @@ -18,10 +18,10 @@ M: assoc >bencode [ [ >bencode ] bi@ append ] { } assoc>map concat "d" "e" surround ; -number ; @@ -31,11 +31,13 @@ DEFER: read-bencode : read-dictionary ( -- obj ) [ read-bencode [ read-bencode 2array ] [ f ] if* dup - ] [ ] produce nip >hashtable ; + ] [ ] produce nip >linked-hash ; : read-string ( prefix -- obj ) ":" read-until char: \: assert= swap prefix - string>number read ascii decode ; + string>number read "" like ; + +PRIVATE> : read-bencode ( -- obj ) read1 { @@ -46,7 +48,5 @@ DEFER: read-bencode [ read-string ] } case ; -PRIVATE> - : bencode> ( bencode -- obj ) [ read-bencode ] with-string-reader ; diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor index 9c28023194..121176089b 100644 --- a/extra/game/loop/loop.factor +++ b/extra/game/loop/loop.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2009 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors timers alien.c-types calendar classes.struct -continuations destructors fry kernel math math.order memory -namespaces sequences system ui ui.gadgets.worlds vm -vocabs.loader arrays locals ; +USING: accessors calendar continuations destructors fry kernel +locals math math.order system timers ui ui.gadgets.worlds +vocabs.loader ; IN: game.loop TUPLE: game-loop @@ -36,8 +35,9 @@ TUPLE: game-loop-error-state error game-loop ; > iteration-start-nanos>> nano-count swap - ] - [ tick-interval-nanos>> ] bi /f 1.0 min ; + [ draw-timer>> next-nanos>> nano-count - ] + [ tick-interval-nanos>> ] bi /f 1.0 swap - + 0.0 1.0 clamp ; GENERIC#: record-benchmarking 1 ( loop quot -- ) diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index 74093a2e44..cf70c44bd2 100644 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -104,7 +104,7 @@ UNIFORM-TUPLE: loading-uniforms V{ } clone swap (read-line-tokens) ; : each-line-tokens ( quot -- ) - input-stream get [ stream-read-line-tokens ] curry each-morsel ; inline + [ input-stream get [ stream-read-line-tokens ] curry ] dip while* ; inline : (parse-bunny-model) ( vs is -- vs is ) [ diff --git a/extra/llvm/ffi/ffi.factor b/extra/llvm/ffi/ffi.factor index 9709dc21c6..272bc2cb10 100644 --- a/extra/llvm/ffi/ffi.factor +++ b/extra/llvm/ffi/ffi.factor @@ -7,8 +7,8 @@ IN: llvm.ffi << "llvm" { { [ os linux? ] [ "LLVM-3.9" find-so ] } { [ os macosx? ] [ "/usr/local/opt/llvm/lib/libLLVM.dylib" ] } - [ drop ] -} cond [ cdecl add-library ] when* + [ f ] +} cond [ cdecl add-library ] [ drop ] if* >> LIBRARY: llvm diff --git a/extra/mason/disk/disk.factor b/extra/mason/disk/disk.factor index 214b8f13fe..a80556cd16 100644 --- a/extra/mason/disk/disk.factor +++ b/extra/mason/disk/disk.factor @@ -1,26 +1,28 @@ -! Copyright (C) 2010 Slava Pestov. +! Copyright (C) 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.files.info io.pathnames kernel mason.config -math math.parser namespaces sequences ; +USING: accessors formatting io.files.info io.pathnames kernel +mason.config math namespaces ; IN: mason.disk -: gb ( -- n ) 30 2^ ; inline +: Gi ( n -- gibibits ) 30 2^ * ; inline : sufficient-disk-space? ( -- ? ) - ! We want at least 300Mb to be available before starting - ! a build. - "." file-system-info available-space>> gb > ; + current-directory get find-mount-point mount-point>> + file-system-info available-space>> 1 Gi > ; : check-disk-space ( -- ) sufficient-disk-space? [ - "Less than 1 Gb free disk space." throw + "Less than 1 Gi free disk space." throw ] unless ; -: mb-str ( n -- string ) gb /i number>string ; +: Gi-str ( n -- string ) 1 Gi /f ; + +: path>disk-usage ( path -- string ) + find-mount-point mount-point>> file-system-info + [ used-space>> ] [ available-space>> ] [ total-space>> ] tri + 2dup /f 100 * + [ [ Gi-str ] tri@ ] dip + "%0.2fGi used, %0.2fGi avail, %0.2fGi total, %0.2f%% free" sprintf ; : disk-usage ( -- string ) - builds-dir get file-system-info - [ used-space>> ] [ total-space>> ] bi - [ [ mb-str ] bi@ " / " glue " Gb used" append ] - [ [ 100 * ] dip /i number>string "(" "%)" surround ] 2bi - " " glue ; + builds-dir get path>disk-usage ; diff --git a/extra/tensors/tensor-slice/tensor-slice.factor b/extra/tensors/tensor-slice/tensor-slice.factor index 86eeab8a37..275d62600e 100644 --- a/extra/tensors/tensor-slice/tensor-slice.factor +++ b/extra/tensors/tensor-slice/tensor-slice.factor @@ -1,7 +1,12 @@ USING: accessors kernel locals math math.order sequences ; IN: tensors.tensor-slice -TUPLE: step-slice < slice { step integer read-only } ; +TUPLE: step-slice + { from integer read-only initial: 0 } + { to integer read-only initial: 0 } + { seq read-only } + { step integer read-only } ; + :: ( from to step seq -- step-slice ) step zero? [ "can't be zero" throw ] when seq length :> len @@ -17,10 +22,14 @@ TUPLE: step-slice < slice { step integer read-only } ; seq dup slice? [ collapse-slice ] when step step-slice boa ; +M: step-slice virtual-exemplar seq>> ; inline + M: step-slice virtual@ - [ step>> * ] [ from>> + ] [ seq>> ] tri ; + [ step>> * ] [ from>> + ] [ seq>> ] tri ; inline M: step-slice length [ to>> ] [ from>> - ] [ step>> ] tri dup 0 < [ [ neg 0 max ] dip neg ] when /mod - zero? [ 1 + ] unless ; + zero? [ 1 + ] unless ; inline + +INSTANCE: step-slice virtual-sequence