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

Merge remote-tracking branch 'origin/master' into modern-harvey3

modern-harvey3
Doug Coleman 2020-01-08 22:09:41 -06:00
parent 94dbc90f0f 4acb08d905
commit ae15ed674e
22 changed files with 134 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/io/directories/windows/windows.factor
View File

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

20
basis/io/files/info/info.factor
View File

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

30
basis/io/files/info/unix/linux/linux.factor
View File

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

3
basis/io/files/info/windows/windows.factor
View File

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

4
basis/io/files/temp/macosx/macosx.factor
View File

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

19
basis/io/files/windows/windows.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.strings
alien.syntax arrays assocs classes.struct combinators
alien.syntax arrays ascii assocs classes.struct combinators
combinators.short-circuit continuations destructors environment io
io.backend io.binary io.buffers io.files io.files.private
io.files.types io.pathnames io.ports io.streams.c io.streams.null
io.timeouts kernel libc literals locals math math.bitwise namespaces
sequences specialized-arrays system threads tr vectors windows
io.files.types io.pathnames io.pathnames.private io.ports io.streams.c
io.streams.null io.timeouts kernel libc literals locals math math.bitwise
namespaces sequences specialized-arrays system threads tr vectors windows
windows.errors windows.handles windows.kernel32 windows.shell32
windows.time windows.types windows.winsock splitting ;
SPECIALIZED-ARRAY: ushort
@ -117,7 +117,7 @@ M: windows init-io ( -- )
: handle>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 <struct>
0
[ FindFirstStream ] keepd
over -1 <alien> = [
2drop throw-win32-error
over INVALID_HANDLE_VALUE = [
2drop win32-error f
] [
1vector swap file-streams-rest
] if ;

3
basis/io/mmap/unix/unix.factor
View File

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

6
basis/io/ports/ports.factor
View File

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

2
basis/io/sockets/secure/windows/windows.factor
View File

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

11
basis/timers/timers.factor
View File

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

14
basis/tools/deploy/deploy-tests.factor
View File

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

10
basis/windows/errors/errors.factor
View File

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

2
build.cmd
View File

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

9
core/io/files/files.factor
View File

@ -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
<PRIVATE
@ -55,14 +56,14 @@ HOOK: (file-appender) io-backend ( path -- stream )
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
: change-file-lines ( path encoding quot -- )
: change-file-lines ( ..a path encoding quot: ( ..a seq -- ..b seq' ) -- ..b )
[ [ file-lines ] dip call ]
[ drop set-file-lines ] 3bi ; inline
: set-file-contents ( seq path encoding -- )
[ write ] with-file-writer ;
: change-file-contents ( path encoding quot -- )
: change-file-contents ( ..a path encoding quot: ( ..a seq -- ..b seq' ) -- ..b )
[ [ file-contents ] dip call ]
[ drop set-file-contents ] 3bi ; inline

28
core/io/pathnames/pathnames.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io.backend kernel math math.order
namespaces sequences splitting strings system ;
USING: accessors assocs combinators io.backend kernel math
math.order namespaces sequences splitting strings system ;
IN: io.pathnames
SYMBOL: current-directory
@ -61,13 +61,13 @@ ERROR: no-parent-directory path ;
[ nip ]
} cond ;
: windows-absolute-path? ( path -- path ? )
: windows-absolute-path? ( path -- ? )
{
{ [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second char: \: = ] [ t ] }
[ f ]
} cond ;
} cond nip ;
: special-path? ( path -- rest ? )
{
@ -80,12 +80,12 @@ PRIVATE>
: 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> pathname

4
extra/bencode/bencode-tests.factor
View File

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

18
extra/bencode/bencode.factor
View File

@ -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 ;
<PRIVATE
DEFER: read-bencode
<PRIVATE
: read-integer ( -- obj )
"e" read-until char: e assert= string>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 ;

12
extra/game/loop/loop.factor
View File

@ -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 ;
<PRIVATE
: last-tick-percent-offset ( loop -- float )
[ draw-timer>> 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 -- )

2
extra/gpu/demos/bunny/bunny.factor
View File

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

4
extra/llvm/ffi/ffi.factor
View File

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

30
extra/mason/disk/disk.factor
View File

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

15
extra/tensors/tensor-slice/tensor-slice.factor
View File

@ -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 } ;
:: <step-slice> ( 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