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

basis/bootstrap/image/image.factor

@@ -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>
+    bootstrap-cell <groups> native> emit-seq ;
-    big-endian get [ [ be> ] map ] [ [ le> ] map ] if
-    emit-seq ;
 
 : pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
-: check-string ( string -- )
+: extended-part ( str -- str' )
-    [ 127 > ] contains?
+    dup [ 128 < ] all? [ drop f ] [
-    [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+        [ -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
+        [ emit-fixnum ]
-        f ' emit
+        [ emit ]
-        f ' emit
+        [ f ' emit ascii-part pad-bytes emit-bytes ]
-        pad-bytes emit-bytes
+        tri*
     ] emit-object ;
 
 M: string '

basis/cairo/gadgets/gadgets.factor

@@ -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 )
+: render-cairo ( gadget -- alien )
-    dup dim>> first2 over width>stride
+    [
-    [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ] 
+        image-dims
-    [ cairo_image_surface_create_for_data ] 3bi
+        [ image-buffer dup CAIRO_FORMAT_ARGB32 ] 
-    rot '[ _ render-cairo* ] with-cairo-from-surface ; inline
+        [ 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
+        [ dim>> ] [ render-cairo &free ] bi
-    1.0 -1.0 glPixelZoom
+        origin get first2 glRasterPos2i
-    [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
+        1.0 -1.0 glPixelZoom
-    glDrawPixels ;
+        [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
+        glDrawPixels
+    ] with-destructors ;
 
 : copy-surface ( surface -- )
     cr swap 0 0 cairo_set_source_surface

basis/fry/fry-docs.factor

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

basis/furnace/auth/auth-docs.factor

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

basis/furnace/auth/features/recover-password/recover-password.factor

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

basis/html/elements/elements-docs.factor

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

basis/http/http-docs.factor

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

basis/http/server/dispatchers/dispatchers-docs.factor

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

basis/http/server/server.factor

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

basis/io/backend/windows/windows.factor

@@ -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
+USING: alien alien.c-types arrays destructors io io.backend io.buffers
-io.buffers io.files io.ports io.binary io.timeouts
+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 ;

basis/io/directories/directories-docs.factor

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

basis/io/directories/search/search-tests.factor

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

basis/io/files/links/unix/unix-tests.factor

@@ -9,24 +9,30 @@ IN: io.files.links.unix.tests
 
 [ t ] [
     [
-        5 "lol" make-test-links
+        current-temporary-directory get [
-        "lol1" follow-links
+            5 "lol" make-test-links
-        current-directory get "lol5" append-path =
+            "lol1" follow-links
-    ] with-unique-directory
+            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
+            current-temporary-directory get [
-            "laf1" follow-links
+                100 "laf" make-test-links
-            current-directory get "laf100" append-path =
+                "laf1" follow-links
-        ] with-unique-directory
+                current-temporary-directory get "laf100" append-path =
+            ] with-directory
+        ] cleanup-unique-directory
     ] with-variable
 ] unit-test

basis/io/files/unique/unique-docs.factor

@@ -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*
+{ unique-file make-unique-file cleanup-unique-file } related-words
-{ $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." } ;
 
-{ make-unique-file make-unique-file* with-unique-file } related-words
+HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
-
-HELP: with-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." }
+{ $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." } ;
+{ $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"
+HELP: with-unique-directory
-"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
+{ $values
-"Creating temporary files:"
+     { "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* }
+"Creating unique directories:"
-{ $subsection with-unique-file }
+{ $subsection unique-directory }
-"Creating temporary directories:"
+{ $subsection with-unique-directory }
-{ $subsection make-unique-directory }
+{ $subsection cleanup-unique-directory }
-{ $subsection with-unique-directory } ;
+"Default temporary directory:"
+{ $subsection default-temporary-directory } ;
 
 ABOUT: "io.files.unique"

basis/io/files/unique/unique-tests.factor

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

basis/io/files/unique/unique.factor

@@ -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: (touch-unique-file) io-backend ( path -- )
-HOOK: temporary-path 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-name ( -- string )
-    [ random-ch ] "" replicate-as ;
+    unique-length get [ random-ch ] "" replicate-as ;
-
-PRIVATE>
 
 : (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 )
+: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
-    [ current-directory get ] 2dip (make-unique-file) ;
-
-: with-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: ( -- ) -- )
+: with-unique-directory ( quot -- path )
-    [ make-unique-directory ] dip
+    [ unique-directory ] dip
-    '[ _ with-directory ] [ delete-tree ] bi ; inline
+    [ 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

basis/io/files/unique/unix/unix.factor

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

basis/io/files/unique/windows/windows.factor

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

basis/io/monitors/linux/linux-tests.factor

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

basis/io/monitors/monitors-docs.factor

@@ -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" } }
+{ $values { "monitor" "a monitor" } { "change" file-change } }
-{ $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" } "." }
+{ $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"

basis/io/monitors/monitors-tests.factor

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

basis/io/monitors/monitors.factor

@@ -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 )
+: next-change ( monitor -- change )
-    [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
+    [ 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

basis/io/monitors/recursive/recursive.factor

@@ -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>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
-    monitor tget queue>>
+    monitor tget queue-change ;
-    mailbox-put ;
 
 : 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 ] }

basis/io/pipes/pipes-docs.factor

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

basis/io/streams/limited/limited-docs.factor

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

basis/io/streams/limited/limited-tests.factor

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

basis/io/streams/limited/limited.factor

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

basis/locals/locals-docs.factor

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

basis/mime/multipart/multipart-tests.factor

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

basis/mime/multipart/multipart.factor

@@ -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
+mime-parts ;
-form-variables ;
 
 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 >>mime-parts ;
-        H{ } clone >>form-variables ;
 
 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* < [
+    dupd [ length ] bi@ 1- - short cut-slice swap ;
-        drop f
-    ] [
-        length 1- cut-slice swap
-    ] if ;
 
 : 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
+        dup [ bytes>> ] [ current-separator>> ] bi split-bytes mime-write
-        [ mime-write ] when*
         >>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" = [
+    dup bytes>> "--\r\n" sequence= [
-        drop
+        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>> ]
+        [ content-disposition>> "name" swap at unquote ]
-        [ uploaded-files>> set-at ] tri
+        [ 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 ]
+        [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ]
-        [ name>> ]
+        [ name>> unquote ]
-        [ form-variables>> set-at ] tri
+        [ 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 )
+: parse-multipart ( separator -- mime-parts )
-    <multipart> parse-beginning parse-multipart-loop
+    <multipart> parse-beginning fill-bytes parse-multipart-loop
-    [ form-variables>> ] [ uploaded-files>> ] bi ;
+    mime-parts>> ;

basis/prettyprint/prettyprint-docs.factor

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

basis/random/random-docs.factor

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

basis/sorting/human/human-docs.factor

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

basis/sorting/human/human.factor

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

basis/sorting/slots/slots-tests.factor

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

basis/tools/threads/threads-docs.factor

@@ -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"
+        "“running” if the thread is the current thread"
-        "``yield'' if the thread is waiting to run"
+        "“yield” if the thread is waiting to run"
         { "the string given to " { $link suspend } " if the thread is suspended" }
     }
 } ;

basis/tools/vocabs/monitor/monitor.factor

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

basis/unix/debugger/debugger.factor

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

core/assocs/assocs-docs.factor

@@ -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 assoc-map-as } ;
-{ $subsection search-alist }
-"Utility word:"
-{ $subsection assoc-pusher } ;
 
 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 }

core/assocs/assocs-tests.factor

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

core/assocs/assocs.factor

@@ -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 )
+<PRIVATE
-
-GENERIC: >alist ( assoc -- newassoc )
 
 : (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-size 0 = ;
-
-: (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-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 )
-    [
+    >alist hashcode* ;
-        [ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor
-    ] { } assoc>map 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 ;
 

core/classes/tuple/tuple-docs.factor

@@ -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" } ")." } ;

core/continuations/continuations-docs.factor

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

core/io/backend/backend.factor

@@ -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 ]
+    [ console-encoding <decoder> input-stream set-global ]
-    [ utf8 <encoder> output-stream set-global ]
+    [ console-encoding <encoder> output-stream set-global ]
-    [ utf8 <encoder> error-stream set-global ] tri* ;
+    [ console-encoding <encoder> error-stream set-global ] tri* ;
 
 HOOK: io-multiplex io-backend ( us -- )
 

core/kernel/kernel-docs.factor

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

core/math/math-docs.factor

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

core/parser/parser.factor

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

core/syntax/syntax-docs.factor

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

extra/google-tech-talk/google-tech-talk.factor

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

extra/literals/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/literals/literals-docs.factor

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

extra/literals/literals-tests.factor

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

extra/literals/literals.factor

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

extra/literals/summary.txt

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

extra/literals/tags.txt

@@ -0,0 +1 @@
+syntax

extra/log-viewer/log-viewer.factor

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

extra/sequences/n-based/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/sequences/n-based/n-based-docs.factor

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

extra/sequences/n-based/n-based-tests.factor

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

extra/sequences/n-based/n-based.factor

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

extra/sequences/n-based/summary.txt

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

extra/sequences/n-based/tags.txt

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

misc/fuel/fuel-syntax.el

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