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

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

db4
Slava Pestov 2008-05-10 15:40:20 -05:00
parent a9b4a69e00 2ef23e1fef
commit 1c7b9079a9
15 changed files with 194 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/io/files/files-tests.factor
View File

@ -66,6 +66,9 @@ strings accessors io.encodings.utf8 math ;
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ "" ] [ "" file-name ] unit-test
[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test
[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test
[ ] [
{ "Hello world." }
"test-foo.txt" temp-file ascii set-file-lines

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

@ -142,7 +142,9 @@ PRIVATE>
: file-name ( path -- string )
dup root-directory? [
right-trim-separators
dup last-path-separator [ 1+ tail ] [ drop ] if
dup last-path-separator [ 1+ tail ] [
drop "resource:" ?head [ file-name ] when
] if
] unless ;
! File info

2
extra/io/unix/backend/backend.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs threads unix
io.nonblocking sequences strings structs sbufs threads unix.ffi unix
vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces io.timeouts
io.encodings.utf8 accessors ;

2
extra/io/unix/kqueue/kqueue.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@
USING: alien.c-types kernel math math.bitfields namespaces
locals accessors combinators threads vectors hashtables
sequences assocs continuations sets
unix unix.time unix.kqueue unix.process
unix.ffi unix unix.time unix.kqueue unix.process
io.nonblocking io.unix.backend io.launcher io.unix.launcher
io.monitors ;
IN: io.unix.kqueue

2
extra/io/unix/sockets/sockets.factor
View File

@ -5,7 +5,7 @@ namespaces threads sequences byte-arrays io.nonblocking
io.binary io.unix.backend io.streams.duplex io.sockets.impl
io.backend io.files io.files.private io.encodings.utf8
math.parser continuations libc combinators system accessors
qualified unix ;
qualified unix.ffi unix ;
EXCLUDE: io => read write close ;
EXCLUDE: io.sockets => accept ;

62
extra/math/miller-rabin/miller-rabin.factor
View File

@ -3,21 +3,9 @@ math.functions math.ranges namespaces random sequences
hashtables sets ;
IN: math.miller-rabin
SYMBOL: a
SYMBOL: n
SYMBOL: r
SYMBOL: s
SYMBOL: count
SYMBOL: trials
: >even ( n -- int )
dup even? [ 1- ] unless ; foldable
: >odd ( n -- int )
dup even? [ 1+ ] when ; foldable
: next-odd ( m -- n )
dup even? [ 1+ ] [ 2 + ] if ;
: >even ( n -- int ) dup even? [ 1- ] unless ; foldable
: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
TUPLE: positive-even-expected n ;
@ -28,34 +16,30 @@ TUPLE: positive-even-expected n ;
#! factor an integer into s * 2^r
0 swap (factor-2s) ;
:: (miller-rabin) ( n prime?! -- ? )
n 1- factor-2s s set r set
trials get [
n 1- [1,b] random a set
a get s get n ^mod 1 = [
0 count set
r get [
2^ s get * a get swap n ^mod n - -1 = [
count [ 1+ ] change
r get +
] when
] each
count get zero? [
f prime?!
trials get +
] when
] unless
drop
] each prime? ;
TUPLE: miller-rabin-bounds ;
:: (miller-rabin) ( n trials -- ? )
[let | r [ n 1- factor-2s drop ]
s [ n 1- factor-2s nip ]
prime?! [ t ]
a! [ 0 ]
count! [ 0 ] |
trials [
n 1- [1,b] random a!
a s n ^mod 1 = [
0 count!
r [
2^ s * a swap n ^mod n - -1 =
[ count 1+ count! r + ] when
] each
count zero? [ f prime?! trials + ] when
] unless drop
] each prime? ] ;
: miller-rabin* ( n numtrials -- ? )
over {
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
[ [ drop trials set t (miller-rabin) ] with-scope ]
[ [ drop (miller-rabin) ] with-scope ]
} cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
@ -66,7 +50,11 @@ TUPLE: miller-rabin-bounds ;
: random-prime ( numbits -- p )
random-bits next-prime ;
ERROR: no-relative-prime n ;
: (find-relative-prime) ( n guess -- p )
over 1 <= [ over no-relative-prime ] when
dup 1 <= [ drop 3 ] when
2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
: find-relative-prime* ( n guess -- p )

190
extra/tar/tar.factor
View File

@ -1,99 +1,92 @@
USING: combinators io io.files io.streams.string kernel math
math.parser continuations namespaces pack prettyprint sequences
strings system hexdump io.encodings.binary inspector accessors ;
strings system hexdump io.encodings.binary inspector accessors
io.backend symbols byte-arrays ;
IN: tar
: zero-checksum 256 ;
: zero-checksum 256 ; inline
: block-size 512 ; inline
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
ERROR: checksum-error ;
: <tar-header> ( -- obj ) tar-header new ;
SYMBOLS: base-dir filename ;
: tar-trim ( seq -- newseq )
[ "\0 " member? ] trim ;
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
: read-tar-header ( -- obj )
<tar-header>
100 read-c-string* over set-tar-header-name
8 read-c-string* tar-trim oct> over set-tar-header-mode
8 read-c-string* tar-trim oct> over set-tar-header-uid
8 read-c-string* tar-trim oct> over set-tar-header-gid
12 read-c-string* tar-trim oct> over set-tar-header-size
12 read-c-string* tar-trim oct> over set-tar-header-mtime
8 read-c-string* tar-trim oct> over set-tar-header-checksum
read1 over set-tar-header-typeflag
100 read-c-string* over set-tar-header-linkname
6 read over set-tar-header-magic
2 read over set-tar-header-version
32 read-c-string* over set-tar-header-uname
32 read-c-string* over set-tar-header-gname
8 read tar-trim oct> over set-tar-header-devmajor
8 read tar-trim oct> over set-tar-header-devminor
155 read-c-string* over set-tar-header-prefix ;
\ tar-header new
100 read-c-string* >>name
8 read-c-string* tar-trim oct> >>mode
8 read-c-string* tar-trim oct> >>uid
8 read-c-string* tar-trim oct> >>gid
12 read-c-string* tar-trim oct> >>size
12 read-c-string* tar-trim oct> >>mtime
8 read-c-string* tar-trim oct> >>checksum
read1 >>typeflag
100 read-c-string* >>linkname
6 read >>magic
2 read >>version
32 read-c-string* >>uname
32 read-c-string* >>gname
8 read tar-trim oct> >>devmajor
8 read tar-trim oct> >>devminor
155 read-c-string* >>prefix ;
: header-checksum ( seq -- x )
148 cut-slice 8 tail-slice
[ sum ] bi@ + 256 + ;
TUPLE: checksum-error ;
TUPLE: malformed-block-error ;
SYMBOL: base-dir
SYMBOL: out-stream
SYMBOL: filename
: (read-data-blocks) ( tar-header -- )
512 read [
over tar-header-size dup 512 <= [
head-slice
>string write
drop
: read-data-blocks ( tar-header -- )
dup size>> 0 > [
block-size read [
over size>> dup block-size <= [
head-slice >byte-array write drop
] [
drop write
[ block-size - ] change-size
read-data-blocks
] if
] [
drop
>string write
dup tar-header-size 512 - over set-tar-header-size
(read-data-blocks)
] if
] if*
] [
drop
] if* ;
: read-data-blocks ( tar-header out -- )
[ (read-data-blocks) ] with-output-stream* ;
] if ;
: parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [
2drop
\ tar-header new
0 over set-tar-header-size
0 over set-tar-header-checksum
0 >>size
0 >>checksum
] [
[ read-tar-header ] with-string-reader
[ tar-header-checksum = [
\ checksum-error new throw
] unless
] keep
[ checksum>> = [ checksum-error ] unless ] keep
] if ;
ERROR: unknown-typeflag ch ;
M: unknown-typeflag summary ( obj -- str )
ch>> 1string
"Unknown typeflag: " prepend ;
ch>> 1string "Unknown typeflag: " prepend ;
: tar-append-path ( path -- newpath )
: tar-prepend-path ( path -- newpath )
base-dir get prepend-path ;
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
! Normal file
: typeflag-0
name>> tar-append-path binary <file-writer>
[ read-data-blocks ] keep dispose ;
: typeflag-0 ( header -- )
dup name>> tar-prepend-path read/write-blocks ;
! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ;
! Symlink
: typeflag-2 ( header -- ) unknown-typeflag ;
: typeflag-2 ( header -- )
[ name>> ] [ linkname>> ] bi
[ make-link ] 2curry ignore-errors ;
! character special
: typeflag-3 ( header -- ) unknown-typeflag ;
@ -103,7 +96,7 @@ M: unknown-typeflag summary ( obj -- str )
! Directory
: typeflag-5 ( header -- )
tar-header-name tar-append-path make-directories ;
name>> tar-prepend-path make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
@ -118,7 +111,7 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-9 ( header -- ) unknown-typeflag ;
! Global POSIX header
: typeflag-g ( header -- ) unknown-typeflag ;
: typeflag-g ( header -- ) typeflag-0 ;
! Extended POSIX header
: typeflag-x ( header -- ) unknown-typeflag ;
@ -140,10 +133,10 @@ M: unknown-typeflag summary ( obj -- str )
! Long file name
: typeflag-L ( header -- )
<string-writer> [ read-data-blocks ] keep
>string [ zero? ] right-trim filename set
global [ "long filename: " write filename get . flush ] bind
filename get tar-append-path make-directories ;
drop ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] right-trim filename set
! filename get tar-prepend-path make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
@ -161,56 +154,39 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
512 read
global [ dup hexdump. flush ] bind
[
block-size read dup length 512 = [
parse-tar-header
! global [ dup tar-header-name [ print flush ] when* ] bind
dup tar-header-typeflag
dup typeflag>>
{
{ 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] }
! { CHAR: 1 [ typeflag-1 ] }
{ CHAR: 2 [ typeflag-2 ] }
{ CHAR: 3 [ typeflag-3 ] }
{ CHAR: 4 [ typeflag-4 ] }
! { CHAR: 3 [ typeflag-3 ] }
! { CHAR: 4 [ typeflag-4 ] }
{ CHAR: 5 [ typeflag-5 ] }
{ CHAR: 6 [ typeflag-6 ] }
{ CHAR: 7 [ typeflag-7 ] }
! { CHAR: 6 [ typeflag-6 ] }
! { CHAR: 7 [ typeflag-7 ] }
{ CHAR: g [ typeflag-g ] }
{ CHAR: x [ typeflag-x ] }
{ CHAR: A [ typeflag-A ] }
{ CHAR: D [ typeflag-D ] }
{ CHAR: E [ typeflag-E ] }
{ CHAR: I [ typeflag-I ] }
{ CHAR: K [ typeflag-K ] }
{ CHAR: L [ typeflag-L ] }
{ CHAR: M [ typeflag-M ] }
{ CHAR: N [ typeflag-N ] }
{ CHAR: S [ typeflag-S ] }
{ CHAR: V [ typeflag-V ] }
{ CHAR: X [ typeflag-X ] }
[ unknown-typeflag ]
} case
! dup tar-header-size zero? [
! out-stream get [ dispose ] when
! out-stream off
! drop
! ] [
! dup tar-header-name
! dup parent-dir base-dir prepend-path
! global [ dup [ . flush ] when* ] bind
! make-directories <file-writer>
! out-stream set
! read-tar-blocks
! ] if
(parse-tar)
] when* ;
! { CHAR: x [ typeflag-x ] }
! { CHAR: A [ typeflag-A ] }
! { CHAR: D [ typeflag-D ] }
! { CHAR: E [ typeflag-E ] }
! { CHAR: I [ typeflag-I ] }
! { CHAR: K [ typeflag-K ] }
! { CHAR: L [ typeflag-L ] }
! { CHAR: M [ typeflag-M ] }
! { CHAR: N [ typeflag-N ] }
! { CHAR: S [ typeflag-S ] }
! { CHAR: V [ typeflag-V ] }
! { CHAR: X [ typeflag-X ] }
{ f [ drop ] }
} case (parse-tar)
] [
drop
] if ;
: parse-tar ( path -- obj )
binary [
"resource:tar-test" base-dir set
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar)
] with-file-writer ;
: parse-tar ( path -- )
normalize-path dup parent-directory base-dir [
binary [ (parse-tar) ] with-file-reader
] with-variable ;

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

@ -8,14 +8,14 @@ debugger io.streams.c io.files io.backend
quotations io.launcher words.private tools.deploy.config
bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
[ prepend-path ] dip append vm over copy-file ;
: copy-fonts ( name dir -- )
append-path "fonts/" resource-path swap copy-tree-into ;
: image-name ( vocab bundle-name -- str )
: copy-fonts ( name dir -- )
append-path "resource:fonts/" swap copy-tree-into ;
: image-name ( vocab bundle-name -- str )
prepend-path ".image" append ;
: (copy-lines) ( stream -- )

7
extra/tools/deploy/windows/windows-tests.factor Executable file
View File

@ -0,0 +1,7 @@
IN: tools.deploy.windows.tests
USING: tools.deploy.windows tools.test sequences ;
[ t ] [
"foo" "resource:temp/test-copy-files" create-exe-dir
".exe" tail?
] unit-test

27
extra/tools/deploy/windows/windows.factor
View File

@ -2,12 +2,15 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files kernel namespaces sequences system
tools.deploy.backend tools.deploy.config assocs hashtables
prettyprint windows.shell32 windows.user32 ;
prettyprint combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows
: copy-dlls ( bundle-name -- )
{ "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" }
swap copy-files-into ;
{
"resource:freetype6.dll"
"resource:zlib1.dll"
"resource:factor.dll"
} swap copy-files-into ;
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dlls
@ -15,11 +18,15 @@ IN: tools.deploy.windows
".exe" copy-vm ;
M: winnt deploy*
"." resource-path [
dup deploy-config [
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
[ namespace make-deploy-image ] keep
open-in-explorer
] bind
"resource:" [
deploy-name over deploy-config at
[
{
[ create-exe-dir ]
[ image-name ]
[ drop ]
[ drop deploy-config ]
} 2cleave make-deploy-image
]
[ nip open-in-explorer ] 2bi
] with-directory ;

2
extra/tools/time/time-docs.factor Normal file → Executable file
View File

@ -16,7 +16,7 @@ ABOUT: "timing"
HELP: benchmark
{ $values { "quot" "a quotation" }
{ "runtime" "an integer denoting milliseconds" } }
{ $description "Runs a quotation, measuring the total wall clock time and the total time spent in the garbage collector." }
{ $description "Runs a quotation, measuring the total wall clock time." }
{ $notes "A nicer word for interactive use is " { $link time } "." } ;
HELP: time

5
extra/unix/ffi/ffi.factor
View File

@ -9,4 +9,7 @@ C-STRUCT: utimbuf
{ "time_t" "actime" }
{ "time_t" "modtime" } ;
FUNCTION: int utime ( char* path, utimebuf* buf ) ;
FUNCTION: int utime ( char* path, utimebuf* buf ) ;
FUNCTION: int err_no ( ) ;
FUNCTION: char* strerror ( int errno ) ;

2
extra/unix/stat/macosx/macosx.factor
View File

@ -30,4 +30,4 @@ FUNCTION: int lstat ( char* pathname, stat* buf ) ;
: stat-st_atim stat-st_atimespec ;
: stat-st_mtim stat-st_mtimespec ;
: stat-st_ctim stat-st_ctimespec ;
: stat-st_ctim stat-st_ctimespec ;

15
extra/unix/system-call/system-call.factor Normal file
View File

@ -0,0 +1,15 @@
USING: kernel continuations sequences math accessors inference macros
fry arrays.lib unix.ffi ;
IN: unix.system-call
ERROR: unix-system-call-error word args message ;
MACRO: unix-system-call ( quot -- )
[ ] [ infer in>> ] [ first ] tri
'[
[ @ dup 0 < [ dup throw ] [ ] if ]
[ drop , narray , swap err_no strerror unix-system-call-error ]
recover
] ;

40
extra/unix/unix.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel libc structs
math namespaces system combinators vocabs.loader unix.ffi unix.types
qualified ;
math namespaces system combinators vocabs.loader qualified
unix.ffi unix.types unix.system-call ;
QUALIFIED: unix.ffi
@ -27,9 +27,27 @@ TYPEDEF: ulong size_t
: ESRCH 3 ; inline
: EEXIST 17 ; inline
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }
{ "int" "gr_gid" }
{ "char**" "gr_mem" } ;
C-STRUCT: passwd
{ "char*" "pw_name" }
{ "char*" "pw_passwd" }
{ "uid_t" "pw_uid" }
{ "gid_t" "pw_gid" }
{ "time_t" "pw_change" }
{ "char*" "pw_class" }
{ "char*" "pw_gecos" }
{ "char*" "pw_dir" }
{ "char*" "pw_shell" }
{ "time_t" "pw_expire" }
{ "int" "pw_fields" } ;
! ! ! Unix functions
LIBRARY: factor
FUNCTION: int err_no ( ) ;
FUNCTION: void clear_err_no ( ) ;
LIBRARY: libc
@ -64,6 +82,9 @@ FUNCTION: int getdtablesize ;
FUNCTION: gid_t getegid ;
FUNCTION: uid_t geteuid ;
FUNCTION: gid_t getgid ;
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: uid_t getuid ;
@ -78,19 +99,10 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_
FUNCTION: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: char* strerror ( int errno ) ;
ERROR: open-error path flags prot message ;
: open ( path flags prot -- int ) [ unix.ffi:open ] unix-system-call ;
: open ( path flags prot -- int )
3dup unix.ffi:open
dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ;
ERROR: utime-error path message ;
: utime ( path buf -- )
dupd unix.ffi:utime
0 = [ drop ] [ err_no strerror utime-error ] if ;
: utime ( path buf -- ) [ unix.ffi:utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ;