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

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

db4
Daniel Ehrenberg 2009-01-27 00:30:43 -06:00
parent f8fa984bae 043adcf0f6
commit b4fe2f0ad0
63 changed files with 623 additions and 260 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
basis/bootstrap/image/image.factor
View File

@ -344,25 +344,37 @@ M: wrapper '
[ emit ] emit-object ;
! Strings
: native> ( object -- object )
big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
: emit-bytes ( seq -- )
bootstrap-cell <groups>
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ;
bootstrap-cell <groups> native> emit-seq ;
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
: check-string ( string -- )
[ 127 > ] contains?
[ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
: extended-part ( str -- str' )
dup [ 128 < ] all? [ drop f ] [
[ -7 shift 1 bitxor ] { } map-as
big-endian get
[ [ 2 >be ] { } map-as ]
[ [ 2 >le ] { } map-as ] if
B{ } join
] if ;
: ascii-part ( str -- str' )
[
[ 128 mod ] [ 128 >= ] bi
[ 128 bitor ] when
] B{ } map-as ;
: emit-string ( string -- ptr )
dup check-string
[ length ] [ extended-part ' ] [ ] tri
string type-number object tag-number [
dup length emit-fixnum
f ' emit
f ' emit
pad-bytes emit-bytes
[ emit-fixnum ]
[ emit ]
[ f ' emit ascii-part pad-bytes emit-bytes ]
tri*
] emit-object ;
M: string '

33
basis/cairo/gadgets/gadgets.factor
View File

@ -2,19 +2,26 @@
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math kernel byte-arrays cairo.ffi cairo
io.backend ui.gadgets accessors opengl.gl arrays fry
classes ui.render namespaces ;
classes ui.render namespaces destructors libc ;
IN: cairo.gadgets
<PRIVATE
: width>stride ( width -- stride ) 4 * ;
: image-dims ( gadget -- width height stride )
dim>> first2 over width>stride ; inline
: image-buffer ( width height stride -- alien )
* nip malloc ; inline
PRIVATE>
GENERIC: render-cairo* ( gadget -- )
: render-cairo ( gadget -- byte-array )
dup dim>> first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
rot '[ _ render-cairo* ] with-cairo-from-surface ; inline
: render-cairo ( gadget -- alien )
[
image-dims
[ image-buffer dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
TUPLE: cairo-gadget < gadget ;
@ -23,11 +30,13 @@ TUPLE: cairo-gadget < gadget ;
swap >>dim ;
M: cairo-gadget draw-gadget*
[ dim>> ] [ render-cairo ] bi
origin get first2 glRasterPos2i
1.0 -1.0 glPixelZoom
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
glDrawPixels ;
[
[ dim>> ] [ render-cairo &free ] bi
origin get first2 glRasterPos2i
1.0 -1.0 glPixelZoom
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
glDrawPixels
] with-destructors ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface

6
basis/fry/fry-docs.factor
View File

@ -69,18 +69,18 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"'[ [ _ key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter"
}
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let” form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
{ $code
"'[ 3 _ + 4 _ / ]"
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
} ;
ARTICLE: "fry" "Fried quotations"
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
$nl
"Fried quotations are started by a special parsing word:"
{ $subsection POSTPONE: '[ }
"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"
{ $subsection _ }
{ $subsection @ }
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."

2
basis/furnace/auth/auth-docs.factor
View File

@ -148,7 +148,7 @@ ARTICLE: "furnace.auth.users" "User profiles"
"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
ARTICLE: "furnace.auth.example" "Furnace authentication example"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:"
{ $code
<" <protected>
"view your todo list" >>description">

2
basis/furnace/auth/features/recover-password/recover-password.factor
View File

@ -27,7 +27,7 @@ SYMBOL: lost-password-from
over email>> 1array >>to
[
"This e-mail was sent by the application server on " % current-host % "\n" %
"because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
"because somebody, maybe you, clicked on a “recover password” link in the\n" %
"login form, and requested a new password for the user named ``" %
over username>> % "''.\n" %
"\n" %

2
basis/html/elements/elements-docs.factor
View File

@ -14,7 +14,7 @@ $nl
{ $code "<a =href a> \"Click me\" write </a>" }
{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
"Tags that have no ``closing'' equivalent have a trailing " { $snippet "tag/>" } " form:"
"Tags that have no “closing” equivalent have a trailing " { $snippet "tag/>" } " form:"
{ $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
"For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
$nl

6
basis/http/http-docs.factor
View File

@ -30,7 +30,7 @@ $nl
{ $table
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Success”, for example." } }
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
{ { $slot "content-type" } { "an HTTP content type" } }
@ -49,7 +49,7 @@ $nl
{ $table
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Success”, for example." } }
{ { $slot "body" } { "an HTTP response body" } }
} } ;
@ -110,7 +110,7 @@ $nl
HELP: set-header
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "value" object } { "key" string } }
{ $description "Stores a value into the HTTP header of a request or response. The value can be any object supported by " { $link present } "." }
{ $notes "This word always returns the same object that was input. This allows for a ``pipeline'' coding style, where several header parameters are set in a row." }
{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
{ $side-effects "request/response" } ;
ARTICLE: "http.cookies" "HTTP cookies"

2
basis/http/server/dispatchers/dispatchers-docs.factor
View File

@ -41,7 +41,7 @@ main-responder set-global">
}
"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
{ $heading "Another pathname dispatcher" }
"On the other hand, suppose we wanted to route all unrecognized paths to a ``view'' action:"
"On the other hand, suppose we wanted to route all unrecognized paths to a “view” action:"
{ $code
<" <dispatcher>
<new-action> "new" add-responder

4
basis/http/server/server.factor
View File

@ -42,7 +42,7 @@ ERROR: no-boundary ;
";" split1 nip
"=" split1 nip [ no-boundary ] unless* ;
: read-multipart-data ( request -- form-variables uploaded-files )
: read-multipart-data ( request -- mime-parts )
[ "content-type" header ]
[ "content-length" header string>number ] bi
unlimit-input
@ -55,7 +55,7 @@ ERROR: no-boundary ;
: parse-content ( request content-type -- post-data )
[ <post-data> swap ] keep {
{ "multipart/form-data" [ read-multipart-data assoc-union >>params ] }
{ "multipart/form-data" [ read-multipart-data >>params ] }
{ "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
[ drop read-content >>data ]
} case ;

6
basis/io/backend/windows/windows.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.binary io.timeouts
USING: alien alien.c-types arrays destructors io io.backend io.buffers
io.files io.ports io.binary io.timeouts io.encodings.8-bit
windows.errors strings kernel math namespaces sequences windows
windows.kernel32 windows.shell32 windows.types windows.winsock
splitting continuations math.bitwise system accessors ;
@ -52,3 +52,5 @@ HOOK: add-completion io-backend ( port -- )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size
over set-SECURITY_ATTRIBUTES-nLength ;
M: windows console-encoding windows-1252 ;

6
basis/io/directories/directories-docs.factor
View File

@ -5,13 +5,13 @@ IN: io.directories
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
{ $errors "Windows CE has no concept of “current directory”, so this word throws an error there." }
{ $notes "User code should use the value of the " { $link current-directory } " variable instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
{ $errors "Windows CE has no concept of “current directory”, so this word throws an error there." }
{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
{ cd cwd current-directory set-current-directory with-directory } related-words
@ -116,7 +116,7 @@ ARTICLE: "current-directory" "Current working directory"
"This variable can be changed with a pair of words:"
{ $subsection set-current-directory }
{ $subsection with-directory }
"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
"This variable is independent of the operating system notion of “current working directory”. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
{ $subsection (normalize-path) }
"The second is to change the working directory of the current process:"
{ $subsection cd }

7
basis/io/directories/search/search-tests.factor
View File

@ -4,8 +4,7 @@ IN: io.directories.search.tests
[ t ] [
[
10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate
current-directory get t [ ] find-all-files
] with-unique-directory
[ natural-sort ] bi@ =
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
current-temporary-directory get t [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test

24
basis/io/files/links/unix/unix-tests.factor
View File

@ -9,24 +9,30 @@ IN: io.files.links.unix.tests
[ t ] [
[
5 "lol" make-test-links
"lol1" follow-links
current-directory get "lol5" append-path =
] with-unique-directory
current-temporary-directory get [
5 "lol" make-test-links
"lol1" follow-links
current-temporary-directory get "lol5" append-path =
] with-directory
] cleanup-unique-directory
] unit-test
[
[
100 "laf" make-test-links "laf1" follow-links
current-temporary-directory get [
100 "laf" make-test-links "laf1" follow-links
] with-directory
] with-unique-directory
] [ too-many-symlinks? ] must-fail-with
[ t ] [
110 symlink-depth [
[
100 "laf" make-test-links
"laf1" follow-links
current-directory get "laf100" append-path =
] with-unique-directory
current-temporary-directory get [
100 "laf" make-test-links
"laf1" follow-links
current-temporary-directory get "laf100" append-path =
] with-directory
] cleanup-unique-directory
] with-variable
] unit-test

75
basis/io/files/unique/unique-docs.factor
View File

@ -1,8 +1,9 @@
USING: help.markup help.syntax io io.ports kernel math
io.pathnames io.directories math.parser io.files strings ;
io.pathnames io.directories math.parser io.files strings
quotations io.files.unique.private ;
IN: io.files.unique
HELP: temporary-path
HELP: default-temporary-directory
{ $values
{ "path" "a pathname string" }
}
@ -25,42 +26,66 @@ HELP: unique-retries
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." }
{ $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-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. The most likely error is incorrect directory permissions on the temporary directory." } ;
HELP: make-unique-file*
{ $values
{ "prefix" string } { "suffix" string }
{ "path" "a pathname string" }
}
{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
{ unique-file make-unique-file cleanup-unique-file } related-words
{ make-unique-file make-unique-file* with-unique-file } related-words
HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- )
HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
{ $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: make-unique-directory ( -- path )
HELP: 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." }
{ $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." }
{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
HELP: with-unique-directory ( quot -- )
HELP: cleanup-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 using the " { $link with-directory } " combinator. The quotation can access the " { $link current-directory } " symbol for the name of the temporary directory." }
{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation." } ;
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." }
{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ;
ARTICLE: "io.files.unique" "Temporary files"
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
"Creating temporary files:"
HELP: with-unique-directory
{ $values
{ "quot" quotation }
{ "path" "a pathname string" }
}
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } ;
HELP: current-temporary-directory
{ $values
{ "value" "a path" }
}
{ $description "The temporary directory used for creating unique files and directories." } ;
HELP: unique-file
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;
HELP: with-temporary-directory
{ $values
{ "path" "a pathname string" } { "quot" quotation }
}
{ $description "Sets " { $link current-temporary-directory } " to " { $snippet "path" } " and calls the quotation, restoring the previous temporary path after execution completes." } ;
ARTICLE: "io.files.unique" "Unique files"
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in temporary directories in a high-level and secure way." $nl
"Changing the temporary path:"
{ $subsection current-temporary-directory }
"Creating unique files:"
{ $subsection unique-file }
{ $subsection cleanup-unique-file }
{ $subsection make-unique-file }
{ $subsection make-unique-file* }
{ $subsection with-unique-file }
"Creating temporary directories:"
{ $subsection make-unique-directory }
{ $subsection with-unique-directory } ;
"Creating unique directories:"
{ $subsection unique-directory }
{ $subsection with-unique-directory }
{ $subsection cleanup-unique-directory }
"Default temporary directory:"
{ $subsection default-temporary-directory } ;
ABOUT: "io.files.unique"

28
basis/io/files/unique/unique-tests.factor
View File

@ -1,21 +1,41 @@
USING: io.encodings.ascii sequences strings io io.files accessors
tools.test kernel io.files.unique namespaces continuations
io.files.info io.pathnames ;
io.files.info io.pathnames io.directories ;
IN: io.files.unique.tests
[ 123 ] [
"core" ".test" [
[ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
[ file-info size>> ] bi
] with-unique-file
] cleanup-unique-file
] unit-test
[ t ] [
[ current-directory get file-info directory? ] with-unique-directory
[ current-directory get file-info directory? ] cleanup-unique-directory
] unit-test
[ t ] [
current-directory get
[ [ "FAILDOG" throw ] with-unique-directory ] [ drop ] recover
[ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover
current-directory get =
] unit-test
[ t ] [
[
"asdf" unique-file drop
"asdf2" unique-file drop
current-temporary-directory get directory-files length 2 =
] cleanup-unique-directory
] unit-test
[ t ] [
[ ] with-unique-directory >boolean
] unit-test
[ t ] [
[
"asdf" unique-file drop
"asdf" unique-file drop
current-temporary-directory get directory-files length 2 =
] with-unique-directory drop
] unit-test

49
basis/io/files/unique/unique.factor
View File

@ -6,8 +6,13 @@ kernel math math.bitwise math.parser namespaces random
sequences system vocabs.loader ;
IN: io.files.unique
HOOK: touch-unique-file io-backend ( path -- )
HOOK: temporary-path io-backend ( -- path )
HOOK: (touch-unique-file) io-backend ( path -- )
: touch-unique-file ( path -- )
normalize-path (touch-unique-file) ;
HOOK: default-temporary-directory io-backend ( -- path )
SYMBOL: current-temporary-directory
SYMBOL: unique-length
SYMBOL: unique-retries
@ -15,6 +20,9 @@ SYMBOL: unique-retries
10 unique-length set-global
10 unique-retries set-global
: with-temporary-directory ( path quot -- )
[ current-temporary-directory ] dip with-variable ; inline
<PRIVATE
: random-letter ( -- ch )
@ -24,37 +32,44 @@ SYMBOL: unique-retries
{ t f } random
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string )
[ random-ch ] "" replicate-as ;
PRIVATE>
: random-name ( -- string )
unique-length get [ random-ch ] "" replicate-as ;
: (make-unique-file) ( path prefix suffix -- path )
'[
_ _ _ unique-length get random-name glue append-path
_ _ _ random-name glue append-path
dup touch-unique-file
] unique-retries get retry ;
PRIVATE>
: make-unique-file ( prefix suffix -- path )
[ temporary-path ] 2dip (make-unique-file) ;
[ current-temporary-directory get ] 2dip (make-unique-file) ;
: make-unique-file* ( prefix suffix -- path )
[ current-directory get ] 2dip (make-unique-file) ;
: with-unique-file ( prefix suffix quot: ( path -- ) -- )
: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
[ make-unique-file ] dip [ delete-file ] bi ; inline
: make-unique-directory ( -- path )
: unique-directory ( -- path )
[
temporary-path unique-length get random-name append-path
current-temporary-directory get
random-name append-path
dup make-directory
] unique-retries get retry ;
: with-unique-directory ( quot: ( -- ) -- )
[ make-unique-directory ] dip
'[ _ with-directory ] [ delete-tree ] bi ; inline
: with-unique-directory ( quot -- path )
[ unique-directory ] dip
[ with-temporary-directory ] [ drop ] 2bi ; inline
: cleanup-unique-directory ( quot: ( -- ) -- )
[ unique-directory ] dip
'[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
: unique-file ( path -- path' )
"" make-unique-file ;
{
{ [ os unix? ] [ "io.files.unique.unix" ] }
{ [ os windows? ] [ "io.files.unique.windows" ] }
} cond require
default-temporary-directory current-temporary-directory set-global

4
basis/io/files/unique/unix/unix.factor
View File

@ -7,7 +7,7 @@ IN: io.files.unique.unix
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
M: unix touch-unique-file ( path -- )
M: unix (touch-unique-file) ( path -- )
open-unique-flags file-mode open-file close-file ;
M: unix temporary-path ( -- path ) "/tmp" ;
M: unix default-temporary-directory ( -- path ) "/tmp" ;

4
basis/io/files/unique/windows/windows.factor
View File

@ -3,8 +3,8 @@ io.files.windows io.ports windows destructors environment
io.files.unique ;
IN: io.files.unique.windows
M: windows touch-unique-file ( path -- )
M: windows (touch-unique-file) ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
M: windows temporary-path ( -- path )
M: windows default-temporary-directory ( -- path )
"TEMP" os-env ;

4
basis/io/monitors/linux/linux-tests.factor
View File

@ -16,7 +16,7 @@ destructors io.timeouts ;
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
[ t ] [
"m" get next-change drop
"m" get next-change path>>
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
] unit-test
@ -29,7 +29,7 @@ destructors io.timeouts ;
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
[ t ] [
"m" get next-change drop
"m" get next-change path>>
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
] unit-test

17
basis/io/monitors/monitors-docs.factor
View File

@ -17,9 +17,12 @@ HELP: (monitor)
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
HELP: file-change
{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
HELP: next-change
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }
{ $values { "monitor" "a monitor" } { "change" file-change } }
{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." }
{ $errors "Throws an error if the monitor is closed from another thread." } ;
HELP: with-monitor
@ -46,7 +49,9 @@ HELP: +rename-file+
{ $description "Indicates that a file has been renamed." } ;
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
"Change descriptors output by " { $link next-change } ":"
"The " { $link next-change } " word outputs instances of a class:"
{ $subsection file-change }
"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:"
{ $subsection +add-file+ }
{ $subsection +remove-file+ }
{ $subsection +modify-file+ }
@ -55,7 +60,7 @@ ARTICLE: "io.monitors.descriptors" "File system change descriptors"
{ $subsection +rename-file+ } ;
ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
$nl
"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below."
{ $heading "Mac OS X" }
@ -63,7 +68,7 @@ $nl
$nl
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
$nl
"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
$nl
"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
{ $heading "Windows" }
@ -107,7 +112,7 @@ $nl
{ $code
"USE: io.monitors"
": watch-loop ( monitor -- )"
" dup next-change . . nl nl flush watch-loop ;"
" dup next-change . nl nl flush watch-loop ;"
""
": watch-directory ( path -- )"
" [ t [ watch-loop ] with-monitor ] with-monitors"

10
basis/io/monitors/monitors-tests.factor
View File

@ -3,7 +3,7 @@ USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors io.timeouts
io.files.temp io.directories io.directories.hierarchy
io.pathnames ;
io.pathnames accessors ;
os { winnt linux macosx } member? [
[
@ -53,7 +53,7 @@ os { winnt linux macosx } member? [
"b" get count-down
[
"m" get next-change drop
"m" get next-change path>>
dup print flush
dup parent-directory
[ trim-right-separators "xyz" tail? ] either? not
@ -62,7 +62,7 @@ os { winnt linux macosx } member? [
"c1" get count-down
[
"m" get next-change drop
"m" get next-change path>>
dup print flush
dup parent-directory
[ trim-right-separators "yxy" tail? ] either? not
@ -101,13 +101,13 @@ os { winnt linux macosx } member? [
! Non-recursive
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
! Recursive
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
] with-monitors
] when

20
basis/io/monitors/monitors.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend kernel continuations destructors namespaces
sequences assocs hashtables sorting arrays threads boxes
io.timeouts accessors concurrency.mailboxes
io.timeouts accessors concurrency.mailboxes fry
system vocabs.loader combinators ;
IN: io.monitors
@ -33,17 +33,19 @@ M: monitor set-timeout (>>timeout) ;
swap >>queue
swap >>path ; inline
TUPLE: file-change path changed monitor ;
: queue-change ( path changes monitor -- )
3dup and and
[ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
[ [ file-change boa ] keep queue>> mailbox-put ] [ 3drop ] if ;
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
: <monitor> ( path recursive? -- monitor )
<mailbox> (monitor) ;
: next-change ( monitor -- path changed )
[ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
: next-change ( monitor -- change )
[ queue>> ] [ timeout ] bi mailbox-get-timeout ;
SYMBOL: +add-file+
SYMBOL: +remove-file+
@ -55,9 +57,15 @@ SYMBOL: +rename-file+
: with-monitor ( path recursive? quot -- )
[ <monitor> ] dip with-disposal ; inline
: run-monitor ( path recursive? quot -- )
'[ [ @ t ] loop ] with-monitor ; inline
: spawn-monitor ( path recursive? quot -- )
[ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi
spawn drop ;
{
{ [ os macosx? ] [ "io.monitors.macosx" require ] }
{ [ os linux? ] [ "io.monitors.linux" require ] }
{ [ os winnt? ] [ "io.monitors.windows.nt" require ] }
[ ]
{ [ os bsd? ] [ ] }
} cond

11
basis/io/monitors/recursive/recursive.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences assocs arrays continuations
destructors combinators kernel threads concurrency.messaging
@ -45,12 +45,11 @@ M: recursive-monitor dispose*
bi ;
: stop-pump ( -- )
monitor tget children>> [ nip dispose ] assoc-each ;
monitor tget children>> values dispose-each ;
: pump-step ( msg -- )
first3 path>> swap [ prepend-path ] dip monitor tget 3array
monitor tget queue>>
mailbox-put ;
[ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
monitor tget queue-change ;
: child-added ( path monitor -- )
path>> prepend-path add-child-monitor ;
@ -59,7 +58,7 @@ M: recursive-monitor dispose*
path>> prepend-path remove-child-monitor ;
: update-hierarchy ( msg -- )
first3 swap [
[ path>> ] [ monitor>> ] [ changed>> ] tri [
{
{ +add-file+ [ child-added ] }
{ +remove-file+ [ child-removed ] }

2
basis/io/pipes/pipes-docs.factor
View File

@ -29,7 +29,7 @@ HELP: run-pipeline
}
}
{ $examples
"Print the lines of a log file which contain the string ``error'', sort them and filter out duplicates, using Unix shell commands only:"
"Print the lines of a log file which contain the string “error”, sort them and filter out duplicates, using Unix shell commands only:"
{ $code "{ \"cat log.txt\" \"grep error\" \"sort\" \"uniq\" } run-pipeline" }
} ;

2
basis/io/streams/limited/limited-docs.factor
View File

@ -81,7 +81,7 @@ ARTICLE: "io.streams.limited" "Limited input streams"
"Unlimits a limited stream:"
{ $subsection unlimit }
"Unlimits the current " { $link input-stream } ":"
{ $subsection limit-input }
{ $subsection unlimit-input }
"Make a limited stream throw an exception on exhaustion:"
{ $subsection stream-throws }
"Make a limited stream return " { $link f } " on exhaustion:"

19
basis/io/streams/limited/limited-tests.factor
View File

@ -1,6 +1,7 @@
USING: io io.streams.limited io.encodings io.encodings.string
io.encodings.ascii io.encodings.binary io.streams.byte-array
namespaces tools.test strings kernel io.streams.string accessors ;
namespaces tools.test strings kernel io.streams.string accessors
io.encodings.utf8 io.files destructors ;
IN: io.streams.limited.tests
[ ] [
@ -59,3 +60,19 @@ IN: io.streams.limited.tests
"abc" <string-reader> 3 stream-eofs limit unlimit
"abc" <string-reader> =
] unit-test
[ t ]
[
"abc" <string-reader> 3 stream-eofs limit unlimit
"abc" <string-reader> =
] unit-test
[ t ]
[
[
"resource:license.txt" utf8 <file-reader> &dispose
3 stream-eofs limit unlimit
"resource:license.txt" utf8 <file-reader> &dispose
[ decoder? ] both?
] with-destructors
] unit-test

15
basis/io/streams/limited/limited.factor
View File

@ -5,7 +5,7 @@ USING: kernel math io io.encodings destructors accessors
sequences namespaces byte-vectors fry combinators ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit mode ;
TUPLE: limited-stream stream count limit mode stack ;
SINGLETONS: stream-throws stream-eofs ;
@ -24,13 +24,24 @@ M: decoder limit ( stream limit mode -- stream' )
M: object limit ( stream limit mode -- stream' )
<limited-stream> ;
: unlimit ( stream -- stream' )
GENERIC: unlimit ( stream -- stream' )
M: decoder unlimit ( stream -- stream' )
[ stream>> ] change-stream ;
M: object unlimit ( stream -- stream' )
stream>> stream>> ;
: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
: unlimit-input ( -- ) input-stream [ unlimit ] change ;
: with-unlimited-stream ( stream quot -- )
[ clone unlimit ] dip call ; inline
: with-limited-stream ( stream limit mode quot -- )
[ limit ] dip call ; inline
ERROR: limit-exceeded ;
ERROR: bad-stream-mode mode ;

4
basis/locals/locals-docs.factor
View File

@ -166,7 +166,7 @@ $nl
"Recall that the following two code snippets are equivalent:"
{ $code "'[ sq _ + ]" }
{ $code "[ [ sq ] dip + ] curry" }
"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as ``inserted'' in the ``hole'' in the quotation's second element."
"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as “inserted” in the “hole” in the quotation's second element."
$nl
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
{ $code "3 [ - ] curry" }
@ -179,7 +179,7 @@ $nl
{ $code "'[ [| a | a - ] curry ] call" }
"Instead, the first line above expands into something like the following:"
{ $code "[ [ swap [| a | a - ] ] curry call ]" }
"This ensures that the fried value appears ``underneath'' the local variable " { $snippet "a" } " when the quotation calls."
"This ensures that the fried value appears “underneath” the local variable " { $snippet "a" } " when the quotation calls."
$nl
"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;

11
basis/mime/multipart/multipart-tests.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.ascii io.files io.files.unique kernel
mime.multipart tools.test io.streams.duplex io multiline
assocs ;
assocs accessors ;
IN: mime.multipart.tests
: upload-separator ( -- seq )
@ -20,11 +20,16 @@ IN: mime.multipart.tests
[ t ] [
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
nip "\"up.txt\"" swap key?
"file1" swap key?
] unit-test
[ t ] [
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
drop "\"text1\"" swap key?
"file1" swap key?
] unit-test
[ t ] [
mime-test-stream [ upload-separator parse-multipart ] with-input-stream
"file1" swap at filename>> "up.txt" =
] unit-test

58
basis/mime/multipart/multipart.factor
View File

@ -3,7 +3,7 @@
USING: multiline kernel sequences io splitting fry namespaces
http.parsers hashtables assocs combinators ascii io.files.unique
accessors io.encodings.binary io.files byte-arrays math
io.streams.string combinators.short-circuit strings ;
io.streams.string combinators.short-circuit strings math.order ;
IN: mime.multipart
CONSTANT: buffer-size 65536
@ -16,8 +16,7 @@ header
content-disposition bytes
filename temp-file
name name-content
uploaded-files
form-variables ;
mime-parts ;
TUPLE: mime-file headers filename temporary-path ;
TUPLE: mime-variable headers key value ;
@ -25,8 +24,7 @@ TUPLE: mime-variable headers key value ;
: <multipart> ( mime-separator -- multipart )
multipart new
swap >>mime-separator
H{ } clone >>uploaded-files
H{ } clone >>form-variables ;
H{ } clone >>mime-parts ;
ERROR: bad-header bytes ;
@ -47,11 +45,7 @@ ERROR: end-of-stream multipart ;
dup bytes>> [ fill-bytes ] unless ;
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
2dup [ length ] [ length 1- ] bi* < [
drop f
] [
length 1- cut-slice swap
] if ;
dupd [ length ] bi@ 1- - short cut-slice swap ;
: dump-until-separator ( multipart -- multipart )
dup
@ -59,11 +53,10 @@ ERROR: end-of-stream multipart ;
[ nip ] [ start ] 2bi [
cut-slice
[ mime-write ]
[ over current-separator>> length tail-slice >>bytes ] bi*
[ over current-separator>> length short tail-slice >>bytes ] bi*
] [
drop
dup [ bytes>> ] [ current-separator>> ] bi split-bytes
[ mime-write ] when*
dup [ bytes>> ] [ current-separator>> ] bi split-bytes mime-write
>>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
] if* ;
@ -72,31 +65,43 @@ ERROR: end-of-stream multipart ;
[ dump-until-separator ] with-string-writer ;
: read-header ( multipart -- multipart )
"\r\n\r\n" dump-string dup "--\r" = [
drop
dup bytes>> "--\r\n" sequence= [
t >>end-of-stream?
] [
parse-headers >>header
"\r\n\r\n" dump-string parse-headers >>header
] if ;
: empty-name? ( string -- ? )
{ "''" "\"\"" "" f } member? ;
: quote? ( ch -- ? ) "'\"" member? ;
: quoted? ( str -- ? )
{
[ length 1 > ]
[ first quote? ]
[ [ first ] [ peek ] bi = ]
} 1&& ;
: unquote ( str -- newstr )
dup quoted? [ but-last-slice rest-slice >string ] when ;
: save-uploaded-file ( multipart -- )
dup filename>> empty-name? [
drop
] [
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
[ filename>> ]
[ uploaded-files>> set-at ] tri
[ content-disposition>> "name" swap at unquote ]
[ mime-parts>> set-at ] tri
] if ;
: save-form-variable ( multipart -- )
: save-mime-part ( multipart -- )
dup name>> empty-name? [
drop
] [
[ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
[ name>> ]
[ form-variables>> set-at ] tri
[ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ]
[ name>> unquote ]
[ mime-parts>> set-at ] tri
] if ;
: dump-mime-file ( multipart filename -- multipart )
@ -119,12 +124,13 @@ ERROR: unknown-content-disposition multipart ;
: parse-form-data ( multipart -- multipart )
"filename" lookup-disposition [
unquote
>>filename
[ dump-file ] [ save-uploaded-file ] bi
] [
"name" lookup-disposition [
[ dup mime-separator>> dump-string >>name-content ] dip
>>name dup save-form-variable
>>name dup save-mime-part
] [
unknown-content-disposition
] if*
@ -157,6 +163,6 @@ ERROR: no-content-disposition multipart ;
read-header
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
: parse-multipart ( separator -- form-variables uploaded-files )
<multipart> parse-beginning parse-multipart-loop
[ form-variables>> ] [ uploaded-files>> ] bi ;
: parse-multipart ( separator -- mime-parts )
<multipart> parse-beginning fill-bytes parse-multipart-loop
mime-parts>> ;

4
basis/prettyprint/prettyprint-docs.factor
View File

@ -193,11 +193,11 @@ HELP: unparse
HELP: pprint-short
{ $values { "obj" object } }
{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce “shorter” output. See " { $link "prettyprint-variables" } "." } ;
HELP: short.
{ $values { "obj" object } }
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce “shorter” output." } ;
HELP: .b
{ $values { "n" "an integer" } }

2
basis/random/random-docs.factor
View File

@ -73,7 +73,7 @@ ARTICLE: "random-protocol" "Random protocol"
ARTICLE: "random" "Generating random integers"
"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers."
$nl
"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
"The “Mersenne Twister” pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
$nl
"Generate a random object:"
{ $subsection random }

14
basis/sorting/human/human-docs.factor
View File

@ -11,19 +11,19 @@ HELP: find-numbers
}
{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
HELP: human-<=>
HELP: human<=>
{ $values
{ "obj1" object } { "obj2" object }
{ "<=>" "an ordering specifier" }
}
{ $description "Compares two objects after converting numbers in the string into integers." } ;
HELP: human->=<
HELP: human>=<
{ $values
{ "obj1" object } { "obj2" object }
{ ">=<" "an ordering specifier" }
}
{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ;
{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
HELP: human-compare
{ $values
@ -44,22 +44,22 @@ HELP: human-sort-keys
{ "seq" "an alist" }
{ "sortedseq" "a new sorted sequence" }
}
{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ;
{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
HELP: human-sort-values
{ $values
{ "seq" "an alist" }
{ "sortedseq" "a new sorted sequence" }
}
{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ;
{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
ARTICLE: "sorting.human" "sorting.human"
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
"Comparing two objects:"
{ $subsection human-<=> }
{ $subsection human->=< }
{ $subsection human<=> }
{ $subsection human>=< }
{ $subsection human-compare }
"Sort a sequence:"
{ $subsection human-sort }

8
basis/sorting/human/human.factor
View File

@ -7,13 +7,13 @@ IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline
: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ;
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
: human-sort ( seq -- seq' ) [ human-<=> ] sort ;
: human-sort ( seq -- seq' ) [ human<=> ] sort ;
: human-sort-keys ( seq -- sortedseq )
[ [ first ] human-compare ] sort ;

4
basis/sorting/slots/slots-tests.factor
View File

@ -41,7 +41,7 @@ TUPLE: tuple2 d ;
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
} { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots
} { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots
] unit-test
[
@ -64,7 +64,7 @@ TUPLE: tuple2 d ;
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
}
{ { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep
{ { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep
[ but-last-slice ] map split-by-slots [ >array ] map
] unit-test

6
basis/tools/threads/threads-docs.factor
View File

@ -2,10 +2,10 @@ IN: tools.threads
USING: help.markup help.syntax threads ;
HELP: threads.
{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:"
{ $description "Prints a list of running threads and their state. The “Waiting on” column displays one of the following:"
{ $list
"``running'' if the thread is the current thread"
"``yield'' if the thread is waiting to run"
"“running” if the thread is the current thread"
"“yield” if the thread is waiting to run"
{ "the string given to " { $link suspend } " if the thread is suspended" }
}
} ;

6
basis/tools/vocabs/monitor/monitor.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: threads io.files io.pathnames io.monitors init kernel
vocabs vocabs.loader tools.vocabs namespaces continuations
sequences splitting assocs command-line concurrency.messaging
io.backend sets tr ;
io.backend sets tr accessors ;
IN: tools.vocabs.monitor
TR: convert-separators "/\\" ".." ;
@ -29,7 +29,7 @@ TR: convert-separators "/\\" ".." ;
: monitor-loop ( -- )
#! On OS X, monitors give us the full path, so we chop it
#! off if its there.
receive first path>vocab changed-vocab
receive path>> path>vocab changed-vocab
reset-cache
monitor-loop ;

2
basis/unix/debugger/debugger.factor
View File

@ -9,7 +9,7 @@ M: unix-error error.
dup message>> write " (" write errno>> pprint ")" print ;
M: unix-system-call-error error.
"Unix system call ``" write dup word>> pprint "'' failed:" print
"Unix system call “" write dup word>> pprint "” failed:" print
nl
dup message>> write " (" write dup errno>> pprint ")" print
nl

26
core/assocs/assocs-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
sequences.private namespaces math quotations ;
sequences.private namespaces math quotations assocs.private ;
IN: assocs
ARTICLE: "alists" "Association lists"
@ -113,7 +113,6 @@ $nl
{ $subsection assoc-each }
{ $subsection assoc-find }
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-filter }
{ $subsection assoc-filter-as }
{ $subsection assoc-contains? }
@ -122,10 +121,7 @@ $nl
{ $subsection cache }
{ $subsection map>assoc }
{ $subsection assoc>map }
{ $subsection assoc-map-as }
{ $subsection search-alist }
"Utility word:"
{ $subsection assoc-pusher } ;
{ $subsection assoc-map-as } ;
ARTICLE: "assocs" "Associative mapping operations"
"An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key."
@ -225,10 +221,6 @@ HELP: assoc-map
{ assoc-map assoc-map-as } related-words
HELP: assoc-push-if
{ $values { "accum" "a resizable mutable sequence" } { "quot" { $quotation "( key value -- ? )" } } { "key" object } { "value" object } }
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
HELP: assoc-filter
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
@ -388,18 +380,6 @@ HELP: assoc-map-as
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
HELP: assoc-pusher
{ $values
{ "quot" "a predicate quotation" }
{ "quot'" quotation } { "accum" assoc } }
{ $description "Creates a new " { $snippet "assoc" } " to accumulate the key/value pairs which return true for a predicate. Returns a new quotation which accepts a pair of object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
{ $example "! Find only the pairs that sum to 5:" "USING: prettyprint assocs math kernel ;"
"{ { 1 2 } { 2 3 } { 3 4 } } [ + 5 = ] assoc-pusher [ assoc-each ] dip ."
"V{ { 2 3 } }"
}
{ $notes "Used to implement the " { $link assoc-filter } " word." } ;
HELP: extract-keys
{ $values
{ "seq" sequence } { "assoc" assoc }

9
core/assocs/assocs-tests.factor
View File

@ -129,4 +129,13 @@ unit-test
[ "x" ] [
"a" H{ { "a" "x" } } at-default
] unit-test
[ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [
H{
{ "a" [ 1 ] }
{ "b" [ 2 ] }
{ "c" [ 3 ] }
{ "d" [ 4 ] }
} [ nip first even? ] assoc-partition
] unit-test

59
core/assocs/assocs.factor
View File

@ -7,22 +7,39 @@ IN: assocs
MIXIN: assoc
GENERIC: at* ( key assoc -- value/f ? )
GENERIC: value-at* ( value assoc -- key/f ? )
GENERIC: set-at ( value key assoc -- )
GENERIC: new-assoc ( capacity exemplar -- newassoc )
GENERIC: delete-at ( key assoc -- )
GENERIC: clear-assoc ( assoc -- )
GENERIC: assoc-size ( assoc -- n )
GENERIC: assoc-like ( assoc exemplar -- newassoc )
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
M: assoc assoc-like drop ;
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
<PRIVATE
: (assoc-each) ( assoc quot -- seq quot' )
[ >alist ] dip [ first2 ] prepose ; inline
: (assoc-stack) ( key i seq -- value )
over 0 < [
3drop f
] [
3dup nth-unsafe at*
[ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
] if ; inline recursive
: search-alist ( key alist -- pair/f i/f )
[ first = ] with find swap ; inline
: substituter ( assoc -- quot )
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
PRIVATE>
: assoc-find ( assoc quot -- key value ? )
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
@ -40,18 +57,16 @@ GENERIC: >alist ( assoc -- newassoc )
: assoc-map ( assoc quot -- newassoc )
over assoc-map-as ; inline
: assoc-push-if ( key value quot accum -- )
[ 2keep ] dip [ [ 2array ] dip push ] 3curry when ; inline
: assoc-pusher ( quot -- quot' accum )
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
: assoc-filter-as ( assoc quot exemplar -- subassoc )
[ assoc-pusher [ assoc-each ] dip ] dip assoc-like ; inline
[ (assoc-each) filter ] dip assoc-like ; inline
: assoc-filter ( assoc quot -- subassoc )
over assoc-filter-as ; inline
: assoc-partition ( assoc quot -- true-assoc false-assoc )
[ (assoc-each) partition ] [ drop ] 2bi
tuck [ assoc-like ] 2bi@ ; inline
: assoc-contains? ( assoc quot -- ? )
assoc-find 2nip ; inline
@ -65,7 +80,7 @@ GENERIC: >alist ( assoc -- newassoc )
2dup at* [ 2nip ] [ 2drop ] if ; inline
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
over assoc-size swap new-assoc
[ dup assoc-size ] dip new-assoc
[ [ swapd set-at ] curry assoc-each ] keep ;
: keys ( assoc -- keys )
@ -81,15 +96,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ delete-at* ] keep [ swapd set-at ] curry [ 2drop ] if ;
: assoc-empty? ( assoc -- ? )
assoc-size zero? ;
: (assoc-stack) ( key i seq -- value )
over 0 < [
3drop f
] [
3dup nth-unsafe at*
[ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
] if ; inline recursive
assoc-size 0 = ;
: assoc-stack ( key seq -- value )
[ length 1- ] keep (assoc-stack) ; flushable
@ -101,9 +108,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
: assoc-hashcode ( n assoc -- code )
[
[ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor
] { } assoc>map hashcode* ;
>alist hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-filter ;
@ -124,9 +129,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry filter ;
: substituter ( assoc -- quot )
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
: substitute-here ( seq assoc -- )
substituter change-each ;
@ -155,8 +157,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
GENERIC: value-at* ( value assoc -- key/f ? )
M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
: value-at ( value assoc -- key/f ) value-at* drop ;
@ -172,9 +172,6 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
: unzip ( assoc -- keys values )
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
: search-alist ( key alist -- pair/f i/f )
[ first = ] with find swap ; inline
M: sequence at*
search-alist [ second t ] [ f ] if ;

4
core/classes/tuple/tuple-docs.factor
View File

@ -172,7 +172,7 @@ $nl
$nl
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of “monkey patching” methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
{ $see-also "parametrized-constructors" } ;
ARTICLE: "tuple-subclassing" "Tuple subclassing"
@ -428,5 +428,5 @@ HELP: new
HELP: boa
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." }
{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." }
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;

3
core/continuations/continuations-docs.factor
View File

@ -245,8 +245,9 @@ HELP: retry
}
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
{ $examples
"Try to get a 0 as a random number:"
{ $unchecked-example "USING: continuations math prettyprint ;"
"[ 5 random 0 = ] retry t"
"[ 5 random 0 = ] 5 retry t"
"t"
}
} ;

12
core/io/backend/backend.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
io.encodings.utf8 init assocs splitting alien ;
@ -14,11 +14,15 @@ HOOK: init-io io-backend ( -- )
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
HOOK: console-encoding os ( -- encoding )
M: object console-encoding utf8 ;
: init-stdio ( -- )
(init-stdio)
[ utf8 <decoder> input-stream set-global ]
[ utf8 <encoder> output-stream set-global ]
[ utf8 <encoder> error-stream set-global ] tri* ;
[ console-encoding <decoder> input-stream set-global ]
[ console-encoding <encoder> output-stream set-global ]
[ console-encoding <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( us -- )

2
core/kernel/kernel-docs.factor
View File

@ -929,7 +929,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality"
"There are two distinct notions of ``sameness'' when it comes to objects."
"There are two distinct notions of “sameness” when it comes to objects."
$nl
"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
{ $subsection eq? }

2
core/math/math-docs.factor
View File

@ -143,7 +143,7 @@ HELP: bitxor
HELP: shift
{ $values { "x" integer } { "n" integer } { "y" integer } }
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits “falling off” the right hand side and being discarded." }
{ $examples { $example "USING: math prettyprint ;" "BIN: 101 5 shift .b" "10100000" } { $example "USING: math prettyprint ;" "BIN: 11111 -2 shift .b" "111" } } ;
HELP: bitnot

2
core/parser/parser.factor
View File

@ -57,7 +57,7 @@ SYMBOL: auto-use?
dup vocabulary>>
[ (use+) ]
[ amended-use get dup [ push ] [ 2drop ] if ]
[ "Added ``" "'' vocabulary to search path" surround note. ]
[ "Added “" "” vocabulary to search path" surround note. ]
tri
] [ create-in ] if ;

6
core/syntax/syntax-docs.factor
View File

@ -69,7 +69,7 @@ ARTICLE: "syntax-floats" "Float syntax"
"More information on floats can be found in " { $link "floats" } "." ;
ARTICLE: "syntax-complex-numbers" "Complex number syntax"
"A complex number is given by two components, a ``real'' part and ''imaginary'' part. The components must either be integers, ratios or floats."
"A complex number is given by two components, a “real” part and “imaginary” part. The components must either be integers, ratios or floats."
{ $code
"C{ 1/2 1/3 } ! the complex number 1/2+1/3i"
"C{ 0 1 } ! the imaginary unit"
@ -149,7 +149,7 @@ ARTICLE: "syntax-pathnames" "Pathname syntax"
ARTICLE: "syntax-literals" "Literals"
"Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words."
$nl
"If a quotation contains a literal object, the same literal object instance is used each time the quotation executes; that is, literals are ``live''."
"If a quotation contains a literal object, the same literal object instance is used each time the quotation executes; that is, literals are “live”."
$nl
"Using mutable object literals in word definitions requires care, since if those objects are mutated, the actual word definition will be changed, which is in most cases not what you would expect. Literals should be " { $link clone } "d before being passed to word which may potentially mutate them."
{ $subsection "syntax-numbers" }
@ -604,7 +604,7 @@ HELP: MIXIN:
HELP: INSTANCE:
{ $syntax "INSTANCE: instance mixin" }
{ $values { "instance" "a class word" } { "instance" "a class word" } }
{ $values { "instance" "a class word" } { "mixin" "a mixin class word" } }
{ $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ;
HELP: PREDICATE:

2
extra/google-tech-talk/google-tech-talk.factor
View File

@ -354,7 +354,7 @@ IN: google-tech-talk
": forever ( quot -- ) '[ @ t ] loop ; inline"
""
"\"/tmp\" t <monitor>"
"'[ _ next-change . . ] forever"
"'[ _ next-change . ] forever"
}
}
{ $slide "Example: time server"

1
extra/literals/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

61
extra/literals/literals-docs.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax multiline ;
IN: literals
HELP: $
{ $syntax "$ word" }
{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." }
{ $examples
{ $example <"
USING: kernel literals prettyprint ;
IN: scratchpad
<< : five 5 ; >>
{ $ five } .
"> "{ 5 }" }
{ $example <"
USING: kernel literals prettyprint ;
IN: scratchpad
<< : seven-eleven 7 11 ; >>
{ $ seven-eleven } .
"> "{ 7 11 }" }
} ;
HELP: $[
{ $syntax "$[ code ]" }
{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." }
{ $examples
{ $example <"
USING: kernel literals math prettyprint ;
IN: scratchpad
<< : five 5 ; >>
{ $[ five dup 1+ dup 2 + ] } .
"> "{ 5 6 8 }" }
} ;
{ POSTPONE: $ POSTPONE: $[ } related-words
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
{ $example <"
USING: kernel literals math prettyprint ;
IN: scratchpad
<< : five 5 ; >>
{ $ five $[ five dup 1+ dup 2 + ] } .
"> "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
;
ABOUT: "literals"

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

@ -1,4 +1,4 @@
USING: kernel literals tools.test ;
USING: kernel literals math tools.test ;
IN: literals.tests
<<
@ -10,3 +10,5 @@ IN: literals.tests
[ { 5 } ] [ { $ five } ] unit-test
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test

4
extra/literals/literals.factor
View File

@ -1,4 +1,6 @@
USING: continuations kernel parser words ;
! (c) Joe Groff, see license for details
USING: continuations kernel parser words quotations ;
IN: literals
: $ scan-word [ execute ] curry with-datastack ; parsing
: $[ \ ] parse-until >quotation with-datastack ; parsing

1
extra/literals/summary.txt Normal file
View File

@ -0,0 +1 @@
Expression interpolation into sequence literals

1
extra/literals/tags.txt Normal file
View File

@ -0,0 +1 @@
syntax

2
extra/log-viewer/log-viewer.factor
View File

@ -6,7 +6,7 @@ IN: log-viewer
[ print read-lines ] [ 2drop flush ] if ;
: tail-file-loop ( stream monitor -- )
dup next-change 2drop over read-lines tail-file-loop ;
dup next-change drop over read-lines tail-file-loop ;
: tail-file ( file -- )
dup utf8 <file-reader> dup read-lines

1
extra/sequences/n-based/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

66
extra/sequences/n-based/n-based-docs.factor Normal file
View File

@ -0,0 +1,66 @@
! (c)2008 Joe Groff, see BSD license etc.
USING: help.markup help.syntax kernel math multiline sequences ;
IN: sequences.n-based
HELP: <n-based-assoc>
{ $values { "seq" sequence } { "base" integer } { "n-based-assoc" n-based-assoc } }
{ $description "Wraps " { $snippet "seq" } " in an " { $link n-based-assoc } " wrapper." }
{ $examples
{ $example <"
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
: months
{
"January"
"February"
"March"
"April"
"May"
"June"
"July"
"August"
"September"
"October"
"November"
"December"
} 1 <n-based-assoc> ;
10 months at .
"> "\"October\"" } } ;
HELP: n-based-assoc
{ $class-description "An adaptor class that allows a sequence to be treated as an assoc with non-zero-based keys." }
{ $examples
{ $example <"
USING: assocs prettyprint kernel sequences.n-based ;
IN: scratchpad
: months
{
"January"
"February"
"March"
"April"
"May"
"June"
"July"
"August"
"September"
"October"
"November"
"December"
} 1 <n-based-assoc> ;
10 months at .
"> "\"October\"" } } ;
{ n-based-assoc <n-based-assoc> } related-words
ARTICLE: "sequences.n-based" "sequences.n-based"
"The " { $vocab-link "sequences.n-based" } " vocabulary provides a sequence adaptor that allows a sequence to be treated as an assoc with non-zero-based keys."
{ $subsection n-based-assoc }
{ $subsection <n-based-assoc> }
;
ABOUT: "sequences.n-based"

64
extra/sequences/n-based/n-based-tests.factor Normal file
View File

@ -0,0 +1,64 @@
! (c)2008 Joe Groff, see BSD license etc.
USING: kernel accessors assocs
sequences sequences.n-based tools.test ;
IN: sequences.n-based.tests
: months
V{
"January"
"February"
"March"
"April"
"May"
"June"
"July"
"August"
"September"
"October"
"November"
"December"
} clone 1 <n-based-assoc> ; inline
[ "December" t ]
[ 12 months at* ] unit-test
[ f f ]
[ 13 months at* ] unit-test
[ f f ]
[ 0 months at* ] unit-test
[ 12 ] [ months assoc-size ] unit-test
[ {
{ 1 "January" }
{ 2 "February" }
{ 3 "March" }
{ 4 "April" }
{ 5 "May" }
{ 6 "June" }
{ 7 "July" }
{ 8 "August" }
{ 9 "September" }
{ 10 "October" }
{ 11 "November" }
{ 12 "December" }
} ] [ months >alist ] unit-test
[ V{
"January"
"February"
"March"
"April"
"May"
"June"
"July"
"August"
"September"
"October"
"November"
"December"
"Smarch"
} ] [ "Smarch" 13 months [ set-at ] keep seq>> ] unit-test
[ V{ } ] [ months [ clear-assoc ] keep seq>> ] unit-test

31
extra/sequences/n-based/n-based.factor Normal file
View File

@ -0,0 +1,31 @@
! (c)2008 Joe Groff, see BSD license etc.
USING: accessors assocs kernel math math.ranges sequences
sequences.private ;
IN: sequences.n-based
TUPLE: n-based-assoc seq base ;
C: <n-based-assoc> n-based-assoc
<PRIVATE
: n-based@ ( key assoc -- n seq )
[ base>> - ] [ nip seq>> ] 2bi ;
: n-based-keys ( assoc -- range )
[ base>> ] [ assoc-size ] bi 1 <range> ;
PRIVATE>
INSTANCE: n-based-assoc assoc
M: n-based-assoc at* ( key assoc -- value ? )
n-based@ 2dup bounds-check?
[ nth-unsafe t ] [ 2drop f f ] if ;
M: n-based-assoc assoc-size ( assoc -- size )
seq>> length ;
M: n-based-assoc >alist ( assoc -- alist )
[ n-based-keys ] [ seq>> ] bi zip ;
M: n-based-assoc set-at ( value key assoc -- )
n-based@ set-nth ;
M: n-based-assoc delete-at ( key assoc -- )
[ f ] 2dip n-based@ set-nth ;
M: n-based-assoc clear-assoc ( assoc -- )
seq>> delete-all ;

1
extra/sequences/n-based/summary.txt Normal file
View File

@ -0,0 +1 @@
Sequence adaptor to treat a sequence as an n-based assoc

2
extra/sequences/n-based/tags.txt Normal file
View File

@ -0,0 +1,2 @@
sequences
assocs

4
misc/fuel/fuel-syntax.el
View File

@ -254,9 +254,9 @@
(" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
(" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
;; Strings
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)"
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\)"
(3 "\"") (4 "\""))
("\\( \\|^\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)" (2 "\"") (3 "\""))
("\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\|$\\)" (1 "\"") (2 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
;; Multiline constructs