+++ /dev/null
-USING: io.backend ;
-IN: io.files.unique.backend
-
-HOOK: (make-unique-file) io-backend ( path -- )
-HOOK: temporary-path io-backend ( -- path )
+++ /dev/null
-USING: help.markup help.syntax io io.ports kernel math
-io.files.unique.private math.parser io.files ;
-IN: io.files.unique
-
-ARTICLE: "unique" "Making and using unique files"
-"Files:"
-{ $subsection make-unique-file }
-{ $subsection with-unique-file }
-"Directories:"
-{ $subsection make-unique-directory }
-{ $subsection with-unique-directory } ;
-
-ABOUT: "unique"
-
-HELP: make-unique-file ( prefix suffix -- path )
-{ $values { "prefix" "a string" } { "suffix" "a string" }
-{ "path" "a pathname string" } }
-{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
-{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
-{ $see-also with-unique-file } ;
-
-HELP: make-unique-directory ( -- path )
-{ $values { "path" "a pathname string" } }
-{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
-{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
-{ $see-also with-unique-directory } ;
-
-HELP: with-unique-file ( prefix suffix quot -- )
-{ $values { "prefix" "a string" } { "suffix" "a string" }
-{ "quot" "a quotation" } }
-{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
-{ $notes "The unique file will be deleted after calling this word." } ;
-
-HELP: with-unique-directory ( quot -- )
-{ $values { "quot" "a quotation" } }
-{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack." }
-{ $notes "The directory will be deleted after calling this word." } ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.bitfields combinators.lib math.parser
-random sequences sequences.lib continuations namespaces
-io.files io arrays io.files.unique.backend system
-combinators vocabs.loader ;
-IN: io.files.unique
-
-<PRIVATE
-: random-letter ( -- ch )
- 26 random { CHAR: a CHAR: A } random + ;
-
-: random-ch ( -- ch )
- { t f } random
- [ 10 random CHAR: 0 + ] [ random-letter ] if ;
-
-: random-name ( n -- string )
- [ random-ch ] "" replicate-as ;
-
-: unique-length ( -- n ) 10 ; inline
-: unique-retries ( -- n ) 10 ; inline
-PRIVATE>
-
-: make-unique-file ( prefix suffix -- path )
- temporary-path -rot
- [
- unique-length random-name swap 3append append-path
- dup (make-unique-file)
- ] 3curry unique-retries retry ;
-
-: with-unique-file ( prefix suffix quot -- )
- >r make-unique-file r> keep delete-file ; inline
-
-: make-unique-directory ( -- path )
- [
- temporary-path unique-length random-name append-path
- dup make-directory
- ] unique-retries retry ;
-
-: with-unique-directory ( quot -- )
- >r make-unique-directory r>
- [ with-directory ] curry keep delete-tree ; inline
-
-{
- { [ os unix? ] [ "io.unix.files.unique" ] }
- { [ os windows? ] [ "io.windows.files.unique" ] }
-} cond require
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io.files kernel sequences accessors
-dlists dequeues arrays sequences.lib ;
-IN: io.paths
-
-TUPLE: directory-iterator path bfs queue ;
-
-: qualified-directory ( path -- seq )
- dup directory [ first2 >r append-path r> 2array ] with map ;
-
-: push-directory ( path iter -- )
- >r qualified-directory r> [
- dup queue>> swap bfs>>
- [ push-front ] [ push-back ] if
- ] curry each ;
-
-: <directory-iterator> ( path bfs? -- iterator )
- <dlist> directory-iterator boa
- dup path>> over push-directory ;
-
-: next-file ( iter -- file/f )
- dup queue>> dequeue-empty? [ drop f ] [
- dup queue>> pop-back first2
- [ over push-directory next-file ] [ nip ] if
- ] if ;
-
-: iterate-directory ( iter quot -- obj )
- 2dup >r >r >r next-file dup [
- r> call dup [
- r> r> 2drop
- ] [
- drop r> r> iterate-directory
- ] if
- ] [
- drop r> r> r> 3drop f
- ] if ; inline
-
-: find-file ( path bfs? quot -- path/f )
- >r <directory-iterator> r>
- [ keep and ] curry iterate-directory ; inline
-
-: each-file ( path bfs? quot -- )
- >r <directory-iterator> r>
- [ f ] compose iterate-directory drop ; inline
-
-: find-all-files ( path bfs? quot -- paths )
- >r <directory-iterator> r>
- pusher >r [ f ] compose iterate-directory drop r> ; inline
-
-: recursive-directory ( path bfs? -- paths )
- [ ] accumulator >r each-file r> ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: help.markup help.syntax ;
-IN: promises
-
-HELP: promise
-{ $values { "quot" "a quotation with stack effect ( -- X )" } { "promise" "a promise object" } }
-{ $description "Creates a promise to return a value. When forced this quotation is called and the value returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
-{ $see-also force promise-with promise-with2 } ;
-
-HELP: promise-with
-{ $values { "value" "an object" } { "quot" "a quotation with stack effect ( value -- X )" } { "promise" "a promise object" } }
-{ $description "Creates a promise to return a value. When forced this quotation is called with the given value on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
-{ $see-also force promise promise-with2 } ;
-
-HELP: promise-with2
-{ $values { "value1" "an object" } { "value2" "an object" } { "quot" "a quotation with stack effect ( value1 value2 -- X )" } { "promise" "a promise object" } }
-{ $description "Creates a promise to return a value. When forced this quotation is called with the given values on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
-{ $see-also force promise promise-with2 } ;
-
-HELP: force
-{ $values { "promise" "a promise object" } { "value" "a factor object" } }
-{ $description "Calls the quotation associated with the promise if it has not been called before, and returns the value. If the promise has been forced previously, returns the value from the previous call." }
-{ $see-also promise promise-with promise-with2 } ;
-
-HELP: LAZY:
-{ $syntax "LAZY: word definition... ;" }
-{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
-{ $description "Creates a lazy word in the current vocabulary. When executed the word will return a " { $link promise } " that when forced, executes the word definition. Any values on the stack that are required by the word definition are captured along with the promise." }
-{ $examples
- { $example "USING: arrays sequences prettyprint promises ;" "IN: scratchpad" "LAZY: zeroes ( -- pair ) 0 zeroes 2array ;" "zeroes force second force first ." "0" }
-}
-{ $see-also force promise-with promise-with2 } ;
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-
-USING: arrays kernel sequences math vectors arrays namespaces
-quotations parser effects inference words ;
-IN: promises
-
-TUPLE: promise quot forced? value ;
-
-: promise ( quot -- promise )
- f f \ promise boa ;
-
-: promise-with ( value quot -- promise )
- curry promise ;
-
-: promise-with2 ( value1 value2 quot -- promise )
- 2curry promise ;
-
-: force ( promise -- value )
- #! Force the given promise leaving the value of calling the
- #! promises quotation on the stack. Re-forcing the promise
- #! will return the same value and not recall the quotation.
- dup promise-forced? [
- dup promise-quot call over set-promise-value
- t over set-promise-forced?
- ] unless
- promise-value ;
-
-: stack-effect-in ( quot word -- n )
- stack-effect [ ] [ infer ] ?if effect-in length ;
-
-: make-lazy-quot ( word quot -- quot )
- [
- dup ,
- swap stack-effect-in \ curry <repetition> %
- \ promise ,
- ] [ ] make ;
-
-: LAZY:
- CREATE-WORD
- dup parse-definition
- make-lazy-quot define ; parsing
+++ /dev/null
-Lazy thunks
+++ /dev/null
-extensions
+++ /dev/null
-USING: kernel math tools.test namespaces random
-random.blum-blum-shub alien.c-types sequences splitting
-grouping ;
-IN: blum-blum-shub.tests
-
-[ 887708070 ] [
- T{ blum-blum-shub f 590695557939 811977232793 } clone random-32*
-] unit-test
-
-
-[ 887708070 ] [
- T{ blum-blum-shub f 590695557939 811977232793 } clone [
- 32 random-bits
- little-endian? [ <uint> reverse *uint ] unless
- ] with-random
-] unit-test
-
-[ 5726770047455156646 ] [
- T{ blum-blum-shub f 590695557939 811977232793 } clone [
- 64 random-bits
- little-endian? [ <ulonglong> 4 group [ reverse ] map concat *ulonglong ] unless
- ] with-random
-] unit-test
-
-[ 3716213681 ]
-[
- 100 T{ blum-blum-shub f 200352954495 846054538649 } clone tuck [
- random-32* drop
- ] curry times
- random-32*
-] unit-test
+++ /dev/null
-USING: kernel math sequences namespaces
-math.miller-rabin combinators.lib
-math.functions accessors random ;
-IN: random.blum-blum-shub
-
-! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
-! return low bit of x+1
-TUPLE: blum-blum-shub x n ;
-
-<PRIVATE
-
-: generate-bbs-primes ( numbits -- p q )
- [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
-
-: next-bbs-bit ( bbs -- bit )
- [ [ x>> 2 ] [ n>> ] bi ^mod dup ] keep (>>x) 1 bitand ;
-
-PRIVATE>
-
-: <blum-blum-shub> ( numbits -- blum-blum-shub )
- generate-bbs-primes *
- [ find-relative-prime ] keep
- blum-blum-shub boa ;
-
-M: blum-blum-shub random-32* ( bbs -- r )
- 0 32 rot
- [ next-bbs-bit swap 1 shift bitor ] curry times ;
--- /dev/null
+USING: io.backend ;
+IN: io.files.unique.backend
+
+HOOK: (make-unique-file) io-backend ( path -- )
+HOOK: temporary-path io-backend ( -- path )
--- /dev/null
+USING: help.markup help.syntax io io.ports kernel math
+io.files.unique.private math.parser io.files ;
+IN: io.files.unique
+
+ARTICLE: "unique" "Making and using unique files"
+"Files:"
+{ $subsection make-unique-file }
+{ $subsection with-unique-file }
+"Directories:"
+{ $subsection make-unique-directory }
+{ $subsection with-unique-directory } ;
+
+ABOUT: "unique"
+
+HELP: make-unique-file ( prefix suffix -- path )
+{ $values { "prefix" "a string" } { "suffix" "a string" }
+{ "path" "a pathname string" } }
+{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
+{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
+{ $see-also with-unique-file } ;
+
+HELP: make-unique-directory ( -- path )
+{ $values { "path" "a pathname string" } }
+{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
+{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
+{ $see-also with-unique-directory } ;
+
+HELP: with-unique-file ( prefix suffix quot -- )
+{ $values { "prefix" "a string" } { "suffix" "a string" }
+{ "quot" "a quotation" } }
+{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
+{ $notes "The unique file will be deleted after calling this word." } ;
+
+HELP: with-unique-directory ( quot -- )
+{ $values { "quot" "a quotation" } }
+{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack." }
+{ $notes "The directory will be deleted after calling this word." } ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.bitfields combinators.lib math.parser
+random sequences sequences.lib continuations namespaces
+io.files io arrays io.files.unique.backend system
+combinators vocabs.loader ;
+IN: io.files.unique
+
+<PRIVATE
+: random-letter ( -- ch )
+ 26 random { CHAR: a CHAR: A } random + ;
+
+: random-ch ( -- ch )
+ { t f } random
+ [ 10 random CHAR: 0 + ] [ random-letter ] if ;
+
+: random-name ( n -- string )
+ [ random-ch ] "" replicate-as ;
+
+: unique-length ( -- n ) 10 ; inline
+: unique-retries ( -- n ) 10 ; inline
+PRIVATE>
+
+: make-unique-file ( prefix suffix -- path )
+ temporary-path -rot
+ [
+ unique-length random-name swap 3append append-path
+ dup (make-unique-file)
+ ] 3curry unique-retries retry ;
+
+: with-unique-file ( prefix suffix quot -- )
+ >r make-unique-file r> keep delete-file ; inline
+
+: make-unique-directory ( -- path )
+ [
+ temporary-path unique-length random-name append-path
+ dup make-directory
+ ] unique-retries retry ;
+
+: with-unique-directory ( quot -- )
+ >r make-unique-directory r>
+ [ with-directory ] curry keep delete-tree ; inline
+
+{
+ { [ os unix? ] [ "io.unix.files.unique" ] }
+ { [ os windows? ] [ "io.windows.files.unique" ] }
+} cond require
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io.files kernel sequences accessors
+dlists dequeues arrays sequences.lib ;
+IN: io.paths
+
+TUPLE: directory-iterator path bfs queue ;
+
+: qualified-directory ( path -- seq )
+ dup directory [ first2 >r append-path r> 2array ] with map ;
+
+: push-directory ( path iter -- )
+ >r qualified-directory r> [
+ dup queue>> swap bfs>>
+ [ push-front ] [ push-back ] if
+ ] curry each ;
+
+: <directory-iterator> ( path bfs? -- iterator )
+ <dlist> directory-iterator boa
+ dup path>> over push-directory ;
+
+: next-file ( iter -- file/f )
+ dup queue>> dequeue-empty? [ drop f ] [
+ dup queue>> pop-back first2
+ [ over push-directory next-file ] [ nip ] if
+ ] if ;
+
+: iterate-directory ( iter quot -- obj )
+ 2dup >r >r >r next-file dup [
+ r> call dup [
+ r> r> 2drop
+ ] [
+ drop r> r> iterate-directory
+ ] if
+ ] [
+ drop r> r> r> 3drop f
+ ] if ; inline
+
+: find-file ( path bfs? quot -- path/f )
+ >r <directory-iterator> r>
+ [ keep and ] curry iterate-directory ; inline
+
+: each-file ( path bfs? quot -- )
+ >r <directory-iterator> r>
+ [ f ] compose iterate-directory drop ; inline
+
+: find-all-files ( path bfs? quot -- paths )
+ >r <directory-iterator> r>
+ pusher >r [ f ] compose iterate-directory drop r> ; inline
+
+: recursive-directory ( path bfs? -- paths )
+ [ ] accumulator >r each-file r> ;
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: help.markup help.syntax ;
+IN: promises
+
+HELP: promise
+{ $values { "quot" "a quotation with stack effect ( -- X )" } { "promise" "a promise object" } }
+{ $description "Creates a promise to return a value. When forced this quotation is called and the value returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
+{ $see-also force promise-with promise-with2 } ;
+
+HELP: promise-with
+{ $values { "value" "an object" } { "quot" "a quotation with stack effect ( value -- X )" } { "promise" "a promise object" } }
+{ $description "Creates a promise to return a value. When forced this quotation is called with the given value on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
+{ $see-also force promise promise-with2 } ;
+
+HELP: promise-with2
+{ $values { "value1" "an object" } { "value2" "an object" } { "quot" "a quotation with stack effect ( value1 value2 -- X )" } { "promise" "a promise object" } }
+{ $description "Creates a promise to return a value. When forced this quotation is called with the given values on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
+{ $see-also force promise promise-with2 } ;
+
+HELP: force
+{ $values { "promise" "a promise object" } { "value" "a factor object" } }
+{ $description "Calls the quotation associated with the promise if it has not been called before, and returns the value. If the promise has been forced previously, returns the value from the previous call." }
+{ $see-also promise promise-with promise-with2 } ;
+
+HELP: LAZY:
+{ $syntax "LAZY: word definition... ;" }
+{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
+{ $description "Creates a lazy word in the current vocabulary. When executed the word will return a " { $link promise } " that when forced, executes the word definition. Any values on the stack that are required by the word definition are captured along with the promise." }
+{ $examples
+ { $example "USING: arrays sequences prettyprint promises ;" "IN: scratchpad" "LAZY: zeroes ( -- pair ) 0 zeroes 2array ;" "zeroes force second force first ." "0" }
+}
+{ $see-also force promise-with promise-with2 } ;
--- /dev/null
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Updated by Matthew Willis, July 2006
+! Updated by Chris Double, September 2006
+
+USING: arrays kernel sequences math vectors arrays namespaces
+quotations parser effects inference words ;
+IN: promises
+
+TUPLE: promise quot forced? value ;
+
+: promise ( quot -- promise )
+ f f \ promise boa ;
+
+: promise-with ( value quot -- promise )
+ curry promise ;
+
+: promise-with2 ( value1 value2 quot -- promise )
+ 2curry promise ;
+
+: force ( promise -- value )
+ #! Force the given promise leaving the value of calling the
+ #! promises quotation on the stack. Re-forcing the promise
+ #! will return the same value and not recall the quotation.
+ dup promise-forced? [
+ dup promise-quot call over set-promise-value
+ t over set-promise-forced?
+ ] unless
+ promise-value ;
+
+: stack-effect-in ( quot word -- n )
+ stack-effect [ ] [ infer ] ?if effect-in length ;
+
+: make-lazy-quot ( word quot -- quot )
+ [
+ dup ,
+ swap stack-effect-in \ curry <repetition> %
+ \ promise ,
+ ] [ ] make ;
+
+: LAZY:
+ CREATE-WORD
+ dup parse-definition
+ make-lazy-quot define ; parsing
--- /dev/null
+Lazy thunks
--- /dev/null
+extensions
--- /dev/null
+USING: kernel math tools.test namespaces random
+random.blum-blum-shub alien.c-types sequences splitting
+grouping ;
+IN: blum-blum-shub.tests
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone random-32*
+] unit-test
+
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
+ 32 random-bits
+ little-endian? [ <uint> reverse *uint ] unless
+ ] with-random
+] unit-test
+
+[ 5726770047455156646 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
+ 64 random-bits
+ little-endian? [ <ulonglong> 4 group [ reverse ] map concat *ulonglong ] unless
+ ] with-random
+] unit-test
+
+[ 3716213681 ]
+[
+ 100 T{ blum-blum-shub f 200352954495 846054538649 } clone tuck [
+ random-32* drop
+ ] curry times
+ random-32*
+] unit-test
--- /dev/null
+USING: kernel math sequences namespaces
+math.miller-rabin combinators.lib
+math.functions accessors random ;
+IN: random.blum-blum-shub
+
+! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
+! return low bit of x+1
+TUPLE: blum-blum-shub x n ;
+
+<PRIVATE
+
+: generate-bbs-primes ( numbits -- p q )
+ [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
+
+: next-bbs-bit ( bbs -- bit )
+ [ [ x>> 2 ] [ n>> ] bi ^mod dup ] keep (>>x) 1 bitand ;
+
+PRIVATE>
+
+: <blum-blum-shub> ( numbits -- blum-blum-shub )
+ generate-bbs-primes *
+ [ find-relative-prime ] keep
+ blum-blum-shub boa ;
+
+M: blum-blum-shub random-32* ( bbs -- r )
+ 0 32 rot
+ [ next-bbs-bit swap 1 shift bitor ] curry times ;
projects / factor.git / commitdiff