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

basis/alien/c-types/c-types-tests.factor

@@ -56,3 +56,7 @@ TYPEDEF: uchar* MyLPBYTE
 ] must-fail
 
 [ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
+
+os windows? cpu x86.64? and [
+    [ -2147467259 ] [ 2147500037 <long> *long  ] unit-test
+] when

basis/checksums/common/common.factor

@@ -18,4 +18,4 @@ SYMBOL: bytes-read
     ] "" make 64 group ;
 
 : update-old-new ( old new -- )
-    [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
+    [ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline

basis/checksums/md5/md5.factor

@@ -14,7 +14,7 @@ IN: checksums.md5
 SYMBOLS: a b c d old-a old-b old-c old-d ;
 
 : T ( N -- Y )
-    sin abs 4294967296 * >bignum ; foldable
+    sin abs 4294967296 * >integer ; foldable
 
 : initialize-md5 ( -- )
     0 bytes-read set

basis/combinators/short-circuit/short-circuit.factor

@@ -3,9 +3,13 @@ locals generalizations macros fry ;
 IN: combinators.short-circuit
 
 MACRO:: n&& ( quots n -- quot )
-    [ f ]
+    [ f ] quots [| q |
-    quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
+        n
-    [ n nnip ] suffix 1array
+        [ q '[ drop _ ndup @ dup not ] ]
+        [ '[ drop _ ndrop f ] ]
+        bi 2array
+    ] map
+    n '[ _ nnip ] suffix 1array
     [ cond ] 3append ;
 
 MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
@@ -14,10 +18,13 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
 MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
 
 MACRO:: n|| ( quots n -- quot )
-    [ f ]
+    [ f ] quots [| q |
-    quots
+        n
-    [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
+        [ q '[ drop _ ndup @ dup ] ]
-    { [ drop n ndrop t ] [ f ] } suffix 1array
+        [ '[ _ nnip ] ]
+        bi 2array
+    ] map
+    n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
     [ cond ] 3append ;
 
 MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;

basis/cpu/x86/64/winnt/winnt.factor

@@ -23,6 +23,6 @@ M: x86.64 dummy-fp-params? t ;
 <<
 "longlong" "ptrdiff_t" typedef
 "longlong" "intptr_t" typedef
-"int" "long" typedef
+"int" c-type "long" define-primitive-type
-"uint" "ulong" typedef
+"uint" c-type "ulong" define-primitive-type
 >>

basis/delegate/delegate.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors parser generic kernel classes classes.tuple
 words slots assocs sequences arrays vectors definitions
-prettyprint math hashtables sets macros namespaces make ;
+prettyprint math hashtables sets generalizations namespaces make ;
 IN: delegate
 
 : protocol-words ( protocol -- words )
@@ -25,15 +25,7 @@ M: tuple-class group-words
 
 : consult-method ( word class quot -- )
     [ drop swap first create-method ]
-    [
+    [ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi
-        nip
-        [
-            over second saver %
-            %
-            dup second restorer %
-            first ,
-        ] [ ] make
-    ] 3bi
     define ;
 
 : change-word-prop ( word prop quot -- )

basis/furnace/actions/actions.factor

@@ -6,7 +6,7 @@ io arrays math boxes splitting urls
 xml.entities
 http.server
 http.server.responses
-furnace
+furnace.utilities
 furnace.redirection
 furnace.conversations
 html.forms

basis/furnace/asides/asides.factor

@@ -4,9 +4,9 @@ USING: namespaces assocs kernel sequences accessors hashtables
 urls db.types db.tuples math.parser fry logging combinators
 html.templates.chloe.syntax
 http http.server http.server.filters http.server.redirection
-furnace
 furnace.cache
 furnace.sessions
+furnace.utilities
 furnace.redirection ;
 IN: furnace.asides
 

basis/furnace/auth/auth.factor

@@ -8,8 +8,8 @@ html.forms
 http.server
 http.server.filters
 http.server.dispatchers
-furnace
 furnace.actions
+furnace.utilities
 furnace.redirection
 furnace.boilerplate
 furnace.auth.providers

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

@@ -1,11 +1,10 @@
 ! Copyright (c) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make accessors kernel assocs arrays io.sockets
-threads fry urls smtp validators html.forms present
+threads fry urls smtp validators html.forms present http
-http http.server.responses http.server.redirection
+http.server.responses http.server.redirection
-http.server.dispatchers
+http.server.dispatchers furnace.actions furnace.auth
-furnace furnace.actions furnace.auth furnace.auth.providers
+furnace.auth.providers furnace.redirection furnace.utilities ;
-furnace.redirection ;
 IN: furnace.auth.features.recover-password
 
 SYMBOL: lost-password-from

basis/furnace/auth/features/registration/registration.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel namespaces validators html.forms urls
 http.server.dispatchers
-furnace furnace.auth furnace.auth.providers furnace.actions
+furnace.auth furnace.auth.providers furnace.actions
 furnace.redirection ;
 IN: furnace.auth.features.registration
 

basis/furnace/auth/login/login.factor

@@ -3,7 +3,6 @@
 USING: kernel accessors namespaces sequences math.parser
 calendar validators urls logging html.forms
 http http.server http.server.dispatchers
-furnace
 furnace.auth
 furnace.asides
 furnace.actions

basis/furnace/boilerplate/boilerplate.factor

@@ -1,12 +1,13 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.order namespaces furnace combinators.short-circuit
+USING: accessors kernel math.order namespaces combinators.short-circuit
 html.forms
 html.templates
 html.templates.chloe
 locals
 http.server
-http.server.filters ;
+http.server.filters
+furnace.utilities ;
 IN: furnace.boilerplate
 
 TUPLE: boilerplate < filter-responder template init ;

basis/furnace/chloe-tags/chloe-tags.factor

@@ -19,7 +19,7 @@ http
 http.server
 http.server.redirection
 http.server.responses
-furnace ;
+furnace.utilities ;
 QUALIFIED-WITH: assocs a
 IN: furnace.chloe-tags
 

basis/furnace/conversations/conversations.factor

@@ -4,10 +4,10 @@ USING: namespaces assocs kernel sequences accessors hashtables
 urls db.types db.tuples math.parser fry logging combinators
 html.templates.chloe.syntax
 http http.server http.server.filters http.server.redirection
-furnace
 furnace.cache
 furnace.scopes
 furnace.sessions
+furnace.utilities
 furnace.redirection ;
 IN: furnace.conversations
 

basis/furnace/furnace-docs.factor

@@ -2,129 +2,6 @@ USING: assocs help.markup help.syntax kernel
 quotations sequences strings urls xml.data http ;
 IN: furnace
 
-HELP: adjust-redirect-url
-{ $values { "url" url } { "url'" url } }
-{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
-
-HELP: adjust-url
-{ $values { "url" url } { "url'" url } }
-{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
-
-HELP: client-state
-{ $values { "key" string } { "value/f" { $maybe string } } }
-{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
-{ $notes "This word is used by session management, conversation scope and asides." } ;
-
-HELP: each-responder
-{ $values { "quot" { $quotation "( responder -- )" } } }
-{ $description "Applies the quotation to each responder involved in processing the current request." } ;
-
-HELP: hidden-form-field
-{ $values { "value" string } { "name" string } }
-{ $description "Renders an HTML hidden form field tag." }
-{ $notes "This word is used by session management, conversation scope and asides." }
-{ $examples
-    { $example
-        "USING: furnace io ;"
-        "\"bar\" \"foo\" hidden-form-field nl"
-        "<input type='hidden' name='foo' value='bar'/>"
-    }
-} ;
-
-HELP: link-attr
-{ $values { "tag" tag } { "responder" "a responder" } }
-{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
-{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
-{ $examples "Conversation scope adds attributes to link tags." } ;
-
-HELP: modify-form
-{ $values { "responder" "a responder" } }
-{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
-{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
-{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
-
-HELP: modify-query
-{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
-{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
-{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
-{ $examples "Asides add query parameters to URLs." } ;
-
-HELP: modify-redirect-query
-{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
-{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
-{ $notes "This word is called by " { $link "furnace.redirection" } "." }
-{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
-
-HELP: nested-responders
-{ $values { "seq" "a sequence of responders" } }
-{ $description "" } ;
-
-HELP: referrer
-{ $values { "referrer/f" { $maybe string } } }
-{ $description "Outputs the current request's referrer URL." } ;
-
-HELP: request-params
-{ $values { "request" request } { "assoc" assoc } }
-{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
-
-HELP: resolve-base-path
-{ $values { "string" string } { "string'" string } }
-{ $description "" } ;
-
-HELP: resolve-template-path
-{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
-{ $description "" } ;
-
-HELP: same-host?
-{ $values { "url" url } { "?" "a boolean" } }
-{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
-
-HELP: user-agent
-{ $values { "user-agent" { $maybe string } } }
-{ $description "Outputs the user agent reported by the client for the current request." } ;
-
-HELP: vocab-path
-{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
-{ $description "" } ;
-
-HELP: exit-with
-{ $values { "value" object } }
-{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
-
-HELP: with-exit-continuation
-{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
-{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
-{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
-
-ARTICLE: "furnace.extension-points" "Furnace extension points"
-"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
-$nl
-"Responders can implement methods on the following generic words:"
-{ $subsection modify-query }
-{ $subsection modify-redirect-query }
-{ $subsection link-attr }
-{ $subsection modify-form }
-"Presentation-level code can call the following words:"
-{ $subsection adjust-url }
-{ $subsection adjust-redirect-url } ;
-
-ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
-"Inspecting the chain of responders handling the current request:"
-{ $subsection nested-responders }
-{ $subsection each-responder }
-{ $subsection resolve-base-path }
-"Vocabulary root-relative resources:"
-{ $subsection vocab-path }
-{ $subsection resolve-template-path }
-"Early return from a responder:"
-{ $subsection with-exit-continuation }
-{ $subsection exit-with }
-"Other useful words:"
-{ $subsection hidden-form-field }
-{ $subsection request-params }
-{ $subsection client-state }
-{ $subsection user-agent } ;
-
 ARTICLE: "furnace.persistence" "Furnace persistence layer"
 { $subsection "furnace.db" }
 "Server-side state:"

basis/furnace/furnace-tests.factor

@@ -1,7 +1,7 @@
 IN: furnace.tests
 USING: http http.server.dispatchers http.server.responses
-http.server furnace tools.test kernel namespaces accessors
+http.server furnace furnace.utilities tools.test kernel
-io.streams.string urls ;
+namespaces accessors io.streams.string urls ;
 TUPLE: funny-dispatcher < dispatcher ;
 
 : <funny-dispatcher> funny-dispatcher new-dispatcher ;

basis/furnace/furnace.factor

@@ -1,133 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make assocs sequences kernel classes splitting
-vocabs.loader accessors strings combinators arrays
-continuations present fry
-urls html.elements
-http http.server http.server.redirection http.server.remapping ;
 IN: furnace
 
-: nested-responders ( -- seq )
-    responder-nesting get values ;
-
-: each-responder ( quot -- )
-   nested-responders swap each ; inline
-
-: base-path ( string -- pair )
-    dup responder-nesting get
-    [ second class superclasses [ name>> = ] with contains? ] with find nip
-    [ first ] [ "No such responder: " swap append throw ] ?if ;
-
-: resolve-base-path ( string -- string' )
-    "$" ?head [
-        [
-            "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
-        ] "" make
-    ] when ;
-
-: vocab-path ( vocab -- path )
-    dup vocab-dir vocab-append-path ;
-
-: resolve-template-path ( pair -- path )
-    [
-        first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
-    ] "" make ;
-
-GENERIC: modify-query ( query responder -- query' )
-
-M: object modify-query drop ;
-
-GENERIC: modify-redirect-query ( query responder -- query' )
-
-M: object modify-redirect-query drop ;
-
-GENERIC: adjust-url ( url -- url' )
-
-M: url adjust-url
-    clone
-        [ [ modify-query ] each-responder ] change-query
-        [ resolve-base-path ] change-path
-    relative-to-request ;
-
-M: string adjust-url ;
-
-GENERIC: adjust-redirect-url ( url -- url' )
-
-M: url adjust-redirect-url
-    adjust-url
-    [ [ modify-redirect-query ] each-responder ] change-query ;
-
-M: string adjust-redirect-url ;
-
-GENERIC: link-attr ( tag responder -- )
-
-M: object link-attr 2drop ;
-
-GENERIC: modify-form ( responder -- )
-
-M: object modify-form drop ;
-
-: hidden-form-field ( value name -- )
-    over [
-        <input
-            "hidden" =type
-            =name
-            present =value
-        input/>
-    ] [ 2drop ] if ;
-
-: nested-forms-key "__n" ;
-
-: request-params ( request -- assoc )
-    dup method>> {
-        { "GET" [ url>> query>> ] }
-        { "HEAD" [ url>> query>> ] }
-        { "POST" [
-            post-data>>
-            dup content-type>> "application/x-www-form-urlencoded" =
-            [ content>> ] [ drop f ] if
-        ] }
-    } case ;
-
-: referrer ( -- referrer/f )
-    #! Typo is intentional, it's in the HTTP spec!
-    "referer" request get header>> at
-    dup [ >url ensure-port [ remap-port ] change-port ] when ;
-
-: user-agent ( -- user-agent )
-    "user-agent" request get header>> at "" or ;
-
-: same-host? ( url -- ? )
-    dup [
-        url get [
-            [ protocol>> ]
-            [ host>> ]
-            [ port>> remap-port ]
-            tri 3array
-        ] bi@ =
-    ] when ;
-
-: cookie-client-state ( key request -- value/f )
-    swap get-cookie dup [ value>> ] when ;
-
-: post-client-state ( key request -- value/f )
-    request-params at ;
-
-: client-state ( key -- value/f )
-    request get dup method>> {
-        { "GET" [ cookie-client-state ] }
-        { "HEAD" [ cookie-client-state ] }
-        { "POST" [ post-client-state ] }
-    } case ;
-
-SYMBOL: exit-continuation
-
-: exit-with ( value -- )
-    exit-continuation get continue-with ;
-
-: with-exit-continuation ( quot -- value )
-    '[ exit-continuation set @ ] callcc1 exit-continuation off ;
-
 USE: vocabs.loader
 "furnace.actions" require
 "furnace.alloy" require

basis/furnace/redirection/redirection.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors combinators namespaces fry urls http
 http.server http.server.redirection http.server.responses
-http.server.remapping http.server.filters furnace ;
+http.server.remapping http.server.filters furnace.utilities ;
 IN: furnace.redirection
 
 : <redirect> ( url -- response )

basis/furnace/referrer/referrer-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax io.streams.string
-furnace ;
+furnace.utilities ;
 IN: furnace.referrer
 
 HELP: <check-form-submissions>

basis/furnace/referrer/referrer.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel http.server http.server.filters
-http.server.responses furnace ;
+http.server.responses furnace.utilities ;
 IN: furnace.referrer
 
 TUPLE: referrer-check < filter-responder quot ;

basis/furnace/sessions/sessions-tests.factor

@@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions
 http.server http.server.responses math namespaces make kernel
 accessors io.sockets io.servers.connection prettyprint
 io.streams.string io.files splitting destructors sequences db
-db.tuples db.sqlite continuations urls math.parser furnace ;
+db.tuples db.sqlite continuations urls math.parser furnace
+furnace.utilities ;
 
 : with-session
     [

basis/furnace/sessions/sessions.factor

@@ -1,13 +1,11 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel math.intervals math.parser namespaces
-strings random accessors quotations hashtables sequences continuations
+strings random accessors quotations hashtables sequences
-fry calendar combinators combinators.short-circuit destructors alarms
+continuations fry calendar combinators combinators.short-circuit
-io.servers.connection
+destructors alarms io.servers.connection db db.tuples db.types
-db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
-html.elements
+html.elements furnace.cache furnace.scopes furnace.utilities ;
-furnace furnace.cache furnace.scopes ;
 IN: furnace.sessions
 
 TUPLE: session < scope user-agent client ;

basis/furnace/syndication/syndication.factor

@@ -1,9 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences fry
+USING: accessors kernel sequences fry combinators syndication
-combinators syndication
+http.server.responses http.server.redirection furnace.actions
-http.server.responses http.server.redirection
+furnace.utilities ;
-furnace furnace.actions ;
 IN: furnace.syndication
 
 GENERIC: feed-entry-title ( object -- string )

basis/furnace/utilities/utilities-docs.factor

@@ -0,0 +1,126 @@
+USING: assocs help.markup help.syntax kernel
+quotations sequences strings urls xml.data http ;
+IN: furnace.utilities
+
+HELP: adjust-redirect-url
+{ $values { "url" url } { "url'" url } }
+{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
+
+HELP: adjust-url
+{ $values { "url" url } { "url'" url } }
+{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
+
+HELP: client-state
+{ $values { "key" string } { "value/f" { $maybe string } } }
+{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
+{ $notes "This word is used by session management, conversation scope and asides." } ;
+
+HELP: each-responder
+{ $values { "quot" { $quotation "( responder -- )" } } }
+{ $description "Applies the quotation to each responder involved in processing the current request." } ;
+
+HELP: hidden-form-field
+{ $values { "value" string } { "name" string } }
+{ $description "Renders an HTML hidden form field tag." }
+{ $notes "This word is used by session management, conversation scope and asides." }
+{ $examples
+    { $example
+        "USING: furnace.utilities io ;"
+        "\"bar\" \"foo\" hidden-form-field nl"
+        "<input type='hidden' name='foo' value='bar'/>"
+    }
+} ;
+
+HELP: link-attr
+{ $values { "tag" tag } { "responder" "a responder" } }
+{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
+{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
+{ $examples "Conversation scope adds attributes to link tags." } ;
+
+HELP: modify-form
+{ $values { "responder" "a responder" } }
+{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
+{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
+{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
+
+HELP: modify-query
+{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
+{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
+{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
+{ $examples "Asides add query parameters to URLs." } ;
+
+HELP: modify-redirect-query
+{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
+{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
+{ $notes "This word is called by " { $link "furnace.redirection" } "." }
+{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
+
+HELP: nested-responders
+{ $values { "seq" "a sequence of responders" } }
+{ $description "" } ;
+
+HELP: referrer
+{ $values { "referrer/f" { $maybe string } } }
+{ $description "Outputs the current request's referrer URL." } ;
+
+HELP: request-params
+{ $values { "request" request } { "assoc" assoc } }
+{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
+
+HELP: resolve-base-path
+{ $values { "string" string } { "string'" string } }
+{ $description "" } ;
+
+HELP: resolve-template-path
+{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
+{ $description "" } ;
+
+HELP: same-host?
+{ $values { "url" url } { "?" "a boolean" } }
+{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
+
+HELP: user-agent
+{ $values { "user-agent" { $maybe string } } }
+{ $description "Outputs the user agent reported by the client for the current request." } ;
+
+HELP: vocab-path
+{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
+{ $description "" } ;
+
+HELP: exit-with
+{ $values { "value" object } }
+{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
+
+HELP: with-exit-continuation
+{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
+{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
+{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
+
+ARTICLE: "furnace.extension-points" "Furnace extension points"
+"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
+$nl
+"Responders can implement methods on the following generic words:"
+{ $subsection modify-query }
+{ $subsection modify-redirect-query }
+{ $subsection link-attr }
+{ $subsection modify-form }
+"Presentation-level code can call the following words:"
+{ $subsection adjust-url }
+{ $subsection adjust-redirect-url } ;
+
+ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
+"Inspecting the chain of responders handling the current request:"
+{ $subsection nested-responders }
+{ $subsection each-responder }
+{ $subsection resolve-base-path }
+"Vocabulary root-relative resources:"
+{ $subsection vocab-path }
+{ $subsection resolve-template-path }
+"Early return from a responder:"
+{ $subsection with-exit-continuation }
+{ $subsection exit-with }
+"Other useful words:"
+{ $subsection hidden-form-field }
+{ $subsection request-params }
+{ $subsection client-state }
+{ $subsection user-agent } ;

basis/furnace/utilities/utilities.factor

@@ -1,6 +1,9 @@
-! Copyright (c) 2008 Slava Pestov
+! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors words kernel sequences splitting ;
+USING: namespaces make assocs sequences kernel classes splitting
+words vocabs.loader accessors strings combinators arrays
+continuations present fry urls html.elements http http.server
+http.server.redirection http.server.remapping ;
 IN: furnace.utilities
 
 : word>string ( word -- string )
@@ -17,3 +20,124 @@ ERROR: no-such-word name vocab ;
 
 : strings>words ( seq -- seq' )
     [ string>word ] map ;
+
+: nested-responders ( -- seq )
+    responder-nesting get values ;
+
+: each-responder ( quot -- )
+   nested-responders swap each ; inline
+
+: base-path ( string -- pair )
+    dup responder-nesting get
+    [ second class superclasses [ name>> = ] with contains? ] with find nip
+    [ first ] [ "No such responder: " swap append throw ] ?if ;
+
+: resolve-base-path ( string -- string' )
+    "$" ?head [
+        [
+            "/" split1 [ base-path [  "/" % % ] each "/" % ] dip %
+        ] "" make
+    ] when ;
+
+: vocab-path ( vocab -- path )
+    dup vocab-dir vocab-append-path ;
+
+: resolve-template-path ( pair -- path )
+    [
+        first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
+    ] "" make ;
+
+GENERIC: modify-query ( query responder -- query' )
+
+M: object modify-query drop ;
+
+GENERIC: modify-redirect-query ( query responder -- query' )
+
+M: object modify-redirect-query drop ;
+
+GENERIC: adjust-url ( url -- url' )
+
+M: url adjust-url
+    clone
+        [ [ modify-query ] each-responder ] change-query
+        [ resolve-base-path ] change-path
+    relative-to-request ;
+
+M: string adjust-url ;
+
+GENERIC: adjust-redirect-url ( url -- url' )
+
+M: url adjust-redirect-url
+    adjust-url
+    [ [ modify-redirect-query ] each-responder ] change-query ;
+
+M: string adjust-redirect-url ;
+
+GENERIC: link-attr ( tag responder -- )
+
+M: object link-attr 2drop ;
+
+GENERIC: modify-form ( responder -- )
+
+M: object modify-form drop ;
+
+: hidden-form-field ( value name -- )
+    over [
+        <input
+            "hidden" =type
+            =name
+            present =value
+        input/>
+    ] [ 2drop ] if ;
+
+: nested-forms-key "__n" ;
+
+: request-params ( request -- assoc )
+    dup method>> {
+        { "GET" [ url>> query>> ] }
+        { "HEAD" [ url>> query>> ] }
+        { "POST" [
+            post-data>>
+            dup content-type>> "application/x-www-form-urlencoded" =
+            [ content>> ] [ drop f ] if
+        ] }
+    } case ;
+
+: referrer ( -- referrer/f )
+    #! Typo is intentional, it's in the HTTP spec!
+    "referer" request get header>> at
+    dup [ >url ensure-port [ remap-port ] change-port ] when ;
+
+: user-agent ( -- user-agent )
+    "user-agent" request get header>> at "" or ;
+
+: same-host? ( url -- ? )
+    dup [
+        url get [
+            [ protocol>> ]
+            [ host>> ]
+            [ port>> remap-port ]
+            tri 3array
+        ] bi@ =
+    ] when ;
+
+: cookie-client-state ( key request -- value/f )
+    swap get-cookie dup [ value>> ] when ;
+
+: post-client-state ( key request -- value/f )
+    request-params at ;
+
+: client-state ( key -- value/f )
+    request get dup method>> {
+        { "GET" [ cookie-client-state ] }
+        { "HEAD" [ cookie-client-state ] }
+        { "POST" [ post-client-state ] }
+    } case ;
+
+SYMBOL: exit-continuation
+
+: exit-with ( value -- )
+    exit-continuation get continue-with ;
+
+: with-exit-continuation ( quot -- value )
+    '[ exit-continuation set @ ] callcc1 exit-continuation off ;

basis/generalizations/generalizations.factor

@@ -1,10 +1,18 @@
 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
 ! Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences sequences.private namespaces math
+USING: kernel sequences sequences.private math math.ranges
-math.ranges combinators macros quotations fry arrays ;
+combinators macros quotations fry ;
 IN: generalizations
 
+<<
+
+: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
+
+: repeat ( n obj quot -- ) swapd times ; inline
+
+>>
+
 MACRO: nsequence ( n seq -- quot )
     [
         [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
@@ -22,39 +30,38 @@ MACRO: firstn ( n -- )
         bi prefix '[ _ cleave ]
     ] if ;
 
-MACRO: npick ( n -- )
+MACRO: npick ( n -- quot )
-    1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
+    1- [ dup ] [ '[ _ dip swap ] ] repeat ;
 
 MACRO: ndup ( n -- )
     dup '[ _ npick ] n*quot ;
 
 MACRO: nrot ( n -- )
-    1- dup saver swap [ r> swap ] n*quot append ;
+    1- [ ] [ '[ _ dip swap ] ] repeat ;
 
 MACRO: -nrot ( n -- )
-    1- dup [ swap >r ] n*quot swap restorer append ;
+    1- [ ] [ '[ swap _ dip ] ] repeat ;
 
 MACRO: ndrop ( n -- )
     [ drop ] n*quot ;
 
-: nnip ( n -- )
+MACRO: nnip ( n -- )
-    swap >r ndrop r> ; inline
+    '[ [ _ ndrop ] dip ] ;
 
 MACRO: ntuck ( n -- )
-    2 + [ dupd -nrot ] curry ;
+    2 + '[ dup _ -nrot ] ;
 
 MACRO: nrev ( n -- quot )
     1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
 
 MACRO: ndip ( quot n -- )
-    dup saver -rot restorer 3append ;
+    [ '[ _ dip ] ] times ;
 
 MACRO: nslip ( n -- )
-    dup saver [ call ] rot restorer 3append ;
+    '[ [ call ] _ ndip ] ;
 
-MACRO: nkeep ( n -- )
+MACRO: nkeep ( quot n -- )
-    [ ] [ 1+ ] [ ] tri
+    tuck '[ _ ndup _ _ ndip ] ;
-    '[ [ _ ndup ] dip _ -nrot _ nslip ] ;
 
 MACRO: ncurry ( n -- )
     [ curry ] n*quot ;
@@ -64,5 +71,5 @@ MACRO: nwith ( n -- )
 
 MACRO: napply ( n -- )
     2 [a,b]
-    [ [ 1- ] keep '[ _ ntuck _ nslip ] ]
+    [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
     map concat >quotation [ call ] append ;

basis/http/http-tests.factor

@@ -2,7 +2,7 @@ USING: http http.server http.client tools.test multiline
 io.streams.string io.encodings.utf8 io.encodings.8-bit
 io.encodings.binary io.encodings.string kernel arrays splitting
 sequences assocs io.sockets db db.sqlite continuations urls
-hashtables accessors ;
+hashtables accessors namespaces ;
 IN: http.tests
 
 [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
@@ -11,6 +11,12 @@ IN: http.tests
 
 [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
 
+[ { } ] [ "" parse-cookie ] unit-test
+[ { } ] [ "" parse-set-cookie ] unit-test
+
+! Make sure that totally invalid cookies don't confuse us
+[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
+
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
@@ -126,6 +132,7 @@ content-type: text/html; charset=UTF-8
 ;
 
 read-response-test-1' 1array [
+    URL" http://localhost/" url set
     read-response-test-1 lf>crlf
     [ read-response ] with-string-reader
     [ write-response ] with-string-writer

basis/http/parsers/parsers.factor

@@ -142,16 +142,15 @@ PEG: parse-header-line ( string -- pair )
         'space' ,
         'attr' ,
         'space' ,
-            [ "=" token , 'space' , 'value' , ] seq* [ peek ] action
+        [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional ,
-            epsilon [ drop f ] action
-        2choice ,
         'space' ,
     ] seq* ;
 
 : 'av-pairs' ( -- parser )
     'av-pair' ";" token list-of optional ;
 
-PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
+PEG: (parse-set-cookie) ( string -- alist )
+    'av-pairs' just [ sift ] action ;
 
 : 'cookie-value' ( -- parser )
     [
@@ -162,7 +161,10 @@ PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
         'space' ,
         'value' ,
         'space' ,
-    ] seq* ;
+    ] seq*
+    [ ";,=" member? not ] satisfy repeat1 [ drop f ] action
+    2choice ;
 
 PEG: (parse-cookie) ( string -- alist )
-    'cookie-value' [ ";," member? ] satisfy list-of optional just ;
+    'cookie-value' [ ";," member? ] satisfy list-of
+    optional just [ sift ] action ;

basis/locals/locals-tests.factor

@@ -418,6 +418,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
 [ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
 
+[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
+[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
+
+:: FAILdog-1 ( -- b ) { [| c | c ] } ;
+
+\ FAILdog-1 must-infer
+
+:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
+
+\ FAILdog-2 must-infer
+
+[ 3 ] [ 3 [| a | \ a ] call ] unit-test
+
 ! :: wlet-&&-test ( a -- ? )
 !     [wlet | is-integer? [ a integer? ]
 !             is-even? [ a even? ]

basis/locals/locals.factor

@@ -206,6 +206,8 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
 
 M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
 
+M: wrapper rewrite-literal? drop t ;
+
 M: hashtable rewrite-literal? drop t ;
 
 M: vector rewrite-literal? drop t ;
@@ -235,12 +237,17 @@ M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
 M: tuple rewrite-element
     [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
 
+M: lambda rewrite-element local-rewrite* ;
+
 M: local rewrite-element , ;
 
 M: local-reader rewrite-element , ;
 
 M: word rewrite-element literalize , ;
 
+M: wrapper rewrite-element
+    dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
+
 M: object rewrite-element , ;
 
 M: array local-rewrite* rewrite-element ;
@@ -251,8 +258,10 @@ M: tuple local-rewrite* rewrite-element ;
 
 M: hashtable local-rewrite* rewrite-element ;
 
+M: wrapper local-rewrite* rewrite-element ;
+
 M: word local-rewrite*
-    dup { >r r> } memq?
+    dup { >r r> load-locals get-local drop-locals } memq?
     [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
 
 M: object lambda-rewrite* , ;
@@ -350,10 +359,15 @@ M: wlet local-rewrite*
     word [ over "declared-effect" set-word-prop ] when*
     in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
 
+ERROR: bad-lambda-rewrite output ;
+
+M: bad-lambda-rewrite summary
+    drop "You have found a bug in locals. Please report." ;
+
 : parse-locals-definition ( word -- word quot )
     "(" expect parse-locals \ ; (parse-lambda) <lambda>
     2dup "lambda" set-word-prop
-    lambda-rewrite first ;
+    lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
 
 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
 

basis/macros/macros.factor

@@ -22,9 +22,3 @@ M: macro definition "macro" word-prop ;
 
 M: macro reset-word
     [ call-next-method ] [ f "macro" set-word-prop ] bi ;
-
-: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
-
-: saver ( n -- quot ) \ >r <repetition> >quotation ;
-
-: restorer ( n -- quot ) \ r> <repetition> >quotation ;

basis/math/bitwise/bitwise.factor

@@ -23,17 +23,12 @@ IN: math.bitwise
 
 : bitroll ( x s w -- y )
     [ wrap ] keep
-    [ shift-mod ]
+    [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
-    [ [ - ] keep shift-mod ] 3bi bitor ; inline
 
 : bitroll-32 ( n s -- n' ) 32 bitroll ; inline
 
-HINTS: bitroll-32 bignum fixnum ;
-
 : bitroll-64 ( n s -- n' ) 64 bitroll ; inline
 
-HINTS: bitroll-64 bignum fixnum ;
-
 ! 32-bit arithmetic
 : w+ ( int int -- int ) + 32 bits ; inline
 : w- ( int int -- int ) - 32 bits ; inline

basis/opengl/opengl.factor

@@ -71,18 +71,22 @@ MACRO: all-enabled-client-state ( seq quot -- )
     line-vertices GL_LINES 0 2 glDrawArrays ;
 
 : (rect-vertices) ( dim -- vertices )
+    #! We use GL_LINE_STRIP with a duplicated first vertex
+    #! instead of GL_LINE_LOOP to work around a bug in Apple's
+    #! X3100 driver.
     {
         [ drop 0.5 0.5 ]
         [ first 0.3 - 0.5 ]
         [ [ first 0.3 - ] [ second 0.3 - ] bi ]
         [ second 0.3 - 0.5 swap ]
-    } cleave 8 narray >c-float-array ;
+        [ drop 0.5 0.5 ]
+    } cleave 10 narray >c-float-array ;
 
 : rect-vertices ( dim -- )
     (rect-vertices) gl-vertex-pointer ;
 
 : (gl-rect) ( -- )
-    GL_LINE_LOOP 0 4 glDrawArrays ;
+    GL_LINE_STRIP 0 5 glDrawArrays ;
 
 : gl-rect ( dim -- )
     rect-vertices (gl-rect) ;
@@ -119,7 +123,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : circle-points ( loc dim steps -- points )
     circle-steps unit-circle adjust-points scale-points ;
 
+: close-path ( points -- points' )
+    dup first suffix ;
+
 : circle-vertices ( loc dim steps -- vertices )
+    #! We use GL_LINE_STRIP with a duplicated first vertex
+    #! instead of GL_LINE_LOOP to work around a bug in Apple's
+    #! X3100 driver.
+    circle-points close-path concat >c-float-array ;
+
+: fill-circle-vertices ( loc dim steps -- vertices )
     circle-points concat >c-float-array ;
 
 : (gen-gl-object) ( quot -- id )

basis/ui/gadgets/buttons/buttons.factor

@@ -177,7 +177,7 @@ PRIVATE>
 
 M: radio-paint recompute-pen
     swap dim>>
-    [ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
+    [ { 4 4 } swap { 9 9 } v- circle-steps fill-circle-vertices >>interior-vertices ]
     [ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
     drop ;
 
@@ -194,7 +194,7 @@ M: radio-paint draw-interior
 
 M: radio-paint draw-boundary
     [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
-    GL_LINE_LOOP 0 circle-steps glDrawArrays ;
+    GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
 
 :: radio-knob-theme ( gadget -- gadget )
     [let | radio-paint [ black <radio-paint> ] |

basis/ui/gadgets/canvas/canvas.factor

@@ -12,8 +12,7 @@ TUPLE: canvas < gadget dlist ;
 
 : delete-canvas-dlist ( canvas -- )
     [ find-gl-context ]
-    [ dlist>> [ delete-dlist ] when* ]
+    [ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ;
-    [ f >>dlist drop ] tri ;
 
 : make-canvas-dlist ( canvas quot -- dlist )
     [ drop ] [ GL_COMPILE swap make-dlist ] 2bi

basis/ui/gadgets/editors/editors.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays documents io kernel math models
-namespaces make opengl opengl.gl sequences strings io.styles
+namespaces locals fry make opengl opengl.gl sequences strings
-math.vectors sorting colors combinators assocs math.order fry
+io.styles math.vectors sorting colors combinators assocs
-calendar alarms ui.clipboards ui.commands ui.gadgets
+math.order fry calendar alarms ui.clipboards ui.commands
-ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
+ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
-ui.render ui.gestures math.geometry.rect ;
+ui.gadgets.wrappers ui.render ui.gestures math.geometry.rect ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
@@ -104,14 +104,20 @@ M: editor ungraft*
     editor-font* "" string-height ;
 
 : y>line ( y editor -- line# )
-    [ line-height / >fixnum ] keep model>> validate-line ;
+    line-height / >fixnum ;
 
-: point>loc ( point editor -- loc )
+:: point>loc ( point editor -- loc )
-    [
+    point second editor y>line {
-        [ first2 ] dip tuck y>line dup ,
+        { [ dup 0 < ] [ drop { 0 0 } ] }
-        [ dup editor-font* ] dip
+        { [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
-        rot editor-line x>offset ,
+        [| n |
-    ] { } make ;
+            n
+            point first
+            editor editor-font*
+            n editor editor-line
+            x>offset 2array
+        ]
+    } cond ;
 
 : clicked-loc ( editor -- loc )
     [ hand-rel ] keep point>loc ;
@@ -141,8 +147,8 @@ M: editor ungraft*
     line-height * ;
 
 : caret-loc ( editor -- loc )
-    [ editor-caret* ] keep 2dup loc>x
+    [ editor-caret* ] keep
-    rot first rot line>y 2array ;
+    [ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
 
 : caret-dim ( editor -- dim )
     line-height 0 swap 2array ;
@@ -175,12 +181,16 @@ M: editor ungraft*
     [ font>> ] dip { 0 0 } draw-string ;
 
 : first-visible-line ( editor -- n )
-    clip get rect-loc second origin get second -
+    [
-    swap y>line ;
+        [ clip get rect-loc second origin get second - ] dip
+        y>line
+    ] keep model>> validate-line ;
 
 : last-visible-line ( editor -- n )
-    clip get rect-extent nip second origin get second -
+    [
-    swap y>line 1+ ;
+        [ clip get rect-extent nip second origin get second - ] dip
+        y>line
+    ] keep model>> validate-line 1+ ;
 
 : with-editor ( editor quot -- )
     [
@@ -193,9 +203,8 @@ M: editor ungraft*
     ] with-scope ; inline
 
 : visible-lines ( editor -- seq )
-    \ first-visible-line get
+    [ \ first-visible-line get \ last-visible-line get ] dip
-    \ last-visible-line get
+    control-value <slice> ;
-    rot control-value <slice> ;
 
 : with-editor-translation ( n quot -- )
     [ line-translation origin get v+ ] dip with-translation ;
@@ -313,9 +322,9 @@ M: editor gadget-text* editor-string % ;
 : editor-cut ( editor clipboard -- )
     dupd gadget-copy remove-selection ;
 
-: delete/backspace ( elt editor quot -- )
+: delete/backspace ( editor quot -- )
     over gadget-selection? [
-        drop nip remove-selection
+        drop remove-selection
     ] [
         [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
         [ drop model>> ]
@@ -323,19 +332,19 @@ M: editor gadget-text* editor-string % ;
     ] if ; inline
 
 : editor-delete ( editor elt -- )
-    swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
+    '[ dupd _ next-elt ] delete/backspace ;
 
 : editor-backspace ( editor elt -- )
-    swap [ over [ rot prev-elt ] dip ] delete/backspace ;
+    '[ over [ _ prev-elt ] dip ] delete/backspace ;
 
 : editor-select-prev ( editor elt -- )
-    swap [ rot prev-elt ] change-caret ;
+    '[ _ prev-elt ] change-caret ;
 
 : editor-prev ( editor elt -- )
     dupd editor-select-prev mark>caret ;
 
 : editor-select-next ( editor elt -- )
-    swap [ rot next-elt ] change-caret ;
+    '[ _ next-elt ] change-caret ;
 
 : editor-next ( editor elt -- )
     dupd editor-select-next mark>caret ;

basis/ui/gadgets/frames/frames-tests.factor

@@ -1,4 +1,17 @@
+USING: accessors kernel namespaces tools.test ui.gadgets
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ;
 IN: ui.gadgets.frames.tests
-USING: ui.gadgets.frames ui.gadgets tools.test ;
 
 [ ] [ <frame> layout ] unit-test
+
+[ t ] [
+    <frame>
+        "Hello world" <label> @top grid-add
+        "Hello world" <label> @center grid-add
+        dup pref-dim "dim1" set
+        { 1000 1000 } >>dim
+        dup layout*
+        dup pref-dim "dim2" set
+        drop
+    "dim1" get "dim2" get =
+] unit-test

basis/ui/gadgets/frames/frames.factor

@@ -1,15 +1,17 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel math namespaces sequences words
+USING: accessors arrays generic kernel math namespaces sequences
-splitting grouping math.vectors ui.gadgets.grids ui.gadgets
+words splitting grouping math.vectors ui.gadgets.grids
-math.geometry.rect ;
+ui.gadgets math.geometry.rect ;
 IN: ui.gadgets.frames
 
-! A frame arranges gadgets in a 3x3 grid, where the center
+TUPLE: glue < gadget ;
-! gadgets gets left-over space.
-TUPLE: frame < grid ;
 
-: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
+M: glue pref-dim* drop { 0 0 } ;
+
+: <glue> ( -- glue ) glue new-gadget ;
+
+: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
 
 : @center 1 1 ; inline
 : @left 0 1 ; inline
@@ -22,13 +24,15 @@ TUPLE: frame < grid ;
 : @bottom-left 0 2 ; inline
 : @bottom-right 2 2 ; inline
 
+TUPLE: frame < grid ;
+
 : new-frame ( class -- frame )
     <frame-grid> swap new-grid ; inline
 
 : <frame> ( -- frame )
     frame new-frame ;
 
-: (fill-center) ( n vec -- )
+: (fill-center) ( dim vec -- )
     [ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
 
 : fill-center ( dim horiz vert -- )
@@ -36,4 +40,4 @@ TUPLE: frame < grid ;
 
 M: frame layout*
     dup compute-grid
-    [ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
+    [ [ dim>> ] 2dip fill-center ] [ grid-layout ] 3bi ;

basis/ui/gadgets/menus/menus.factor

@@ -46,7 +46,6 @@ M: menu-glass layout* gadget-child prefer ;
     faint-boundary ;
 
 : <commands-menu> ( hook target commands -- gadget )
-    <filled-pile>
+    [ <filled-pile> ] 3dip
-        -roll
         [ <menu-item> add-gadget ] with with each
     5 <border> menu-theme ;

basis/ui/render/render.factor

@@ -168,24 +168,29 @@ M: gradient draw-interior
     } cleave ;
 
 ! Polygon pen
-TUPLE: polygon color vertex-array count ;
+TUPLE: polygon color
+interior-vertices
+interior-count
+boundary-vertices
+boundary-count ;
 
 : <polygon> ( color points -- polygon )
-    [ concat >c-float-array ] [ length ] bi polygon boa ;
+    dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@
-
+    polygon boa ;
-: draw-polygon ( polygon mode -- )
-    swap
-    [ color>> gl-color ]
-    [ vertex-array>> gl-vertex-pointer ]
-    [ 0 swap count>> glDrawArrays ]
-    tri ;
 
 M: polygon draw-boundary
-    GL_LINE_LOOP draw-polygon drop ;
+    nip
+    [ color>> gl-color ]
+    [ boundary-vertices>> gl-vertex-pointer ]
+    [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
+    tri ;
 
 M: polygon draw-interior
-    dup count>> 2 > GL_POLYGON GL_LINES ?
+    nip
-    draw-polygon drop ;
+    [ color>> gl-color ]
+    [ interior-vertices>> gl-vertex-pointer ]
+    [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
+    tri ;
 
 : arrow-up    { { 3 0 } { 6 6 } { 0 6 } } ;
 : arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;

basis/ui/tools/listener/listener.factor

@@ -6,9 +6,9 @@ listener debugger threads boxes concurrency.flags math arrays
 generic accessors combinators assocs fry ui.commands ui.gadgets
 ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
 ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
-ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
+ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
-ui.tools.browser ui.tools.interactor ui.tools.inspector
+ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
-ui.tools.workspace ;
+ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
 IN: ui.tools.listener
 
 TUPLE: listener-gadget < track input output ;
@@ -153,9 +153,9 @@ M: engine-word word-completion-string
     dup <listener-input> >>input ;
 
 : <listener-scroller> ( listener -- scroller )
-    <filled-pile>
+    <frame>
-        over output>> add-gadget
+        over output>> @top grid-add
-        swap input>> add-gadget
+        swap input>> @center grid-add
     <scroller> ;
 
 : <listener-gadget> ( -- gadget )

basis/ui/traverse/traverse.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces make sequences kernel math arrays io
 ui.gadgets generic combinators ;
@@ -7,7 +7,7 @@ IN: ui.traverse
 TUPLE: node value children ;
 
 : traverse-step ( path gadget -- path' gadget' )
-    >r unclip r> children>> ?nth ;
+    [ unclip ] dip children>> ?nth ;
 
 : make-node ( quot -- ) { } make node boa , ; inline
 
@@ -43,7 +43,7 @@ TUPLE: node value children ;
     traverse-step traverse-from-path ;
 
 : (traverse-middle) ( frompath topath gadget -- )
-    >r >r first 1+ r> first r> children>> <slice> % ;
+    [ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
 
 : traverse-post ( topath gadget -- )
     traverse-step traverse-to-path ;
@@ -59,8 +59,8 @@ TUPLE: node value children ;
 DEFER: (gadget-subtree)
 
 : traverse-child ( frompath topath gadget -- )
-    dup -roll [
+    [ -rot ] keep [
-        >r >r rest-slice r> r> traverse-step (gadget-subtree)
+        [ rest-slice ] 2dip traverse-step (gadget-subtree)
     ] make-node ;
 
 : (gadget-subtree) ( frompath topath gadget -- )

basis/ui/windows/windows.factor

@@ -9,7 +9,7 @@ windows.user32 windows.opengl32 windows.messages windows.types
 windows.nt windows threads libc combinators
 combinators.short-circuit continuations command-line shuffle
 opengl ui.render ascii math.bitwise locals symbols accessors
-math.geometry.rect math.order ascii ;
+math.geometry.rect math.order ascii calendar ;
 IN: ui.windows
 
 SINGLETON: windows-ui-backend
@@ -472,7 +472,7 @@ M: windows-ui-backend do-events
     "MSG" malloc-object msg-obj set-global
     "Factor-window" utf16n malloc-string class-name-ptr set-global
     register-wndclassex drop
-    GetDoubleClickTime double-click-timeout set-global ;
+    GetDoubleClickTime milliseconds double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
     class-name-ptr get-global [ dup f UnregisterClass drop free ] when*

core/combinators/combinators.factor

@@ -45,7 +45,7 @@ ERROR: no-cond ;
     [ rot \ if 3array append [ ] like ] assoc-each ;
 
 : cond>quot ( assoc -- quot )
-    [ dup callable? [ [ t ] swap 2array ] when ] map
+    [ dup pair? [ [ t ] swap 2array ] unless ] map
     reverse [ no-cond ] swap alist>quot ;
 
 ! case

core/generic/parser/parser.factor

@@ -16,7 +16,7 @@ ERROR: not-in-a-method-error ;
 SYMBOL: current-method
 
 : with-method-definition ( method quot -- )
-    [ dup current-method ] dip with-variable ; inline
+    over current-method set call current-method off ; inline
 
 : (M:) ( method def -- )
     CREATE-METHOD [ parse-definition ] with-method-definition ;

extra/mason/common/common.factor

@@ -15,9 +15,11 @@ IN: mason.common
 
 :: upload-safely ( local username host remote -- )
     [let* | temp [ remote ".incomplete" append ]
-            scp-remote [ { username "@" host ":" temp } concat ] |
+            scp-remote [ { username "@" host ":" temp } concat ]
-        { "scp" local scp-remote } short-running-process
+            scp [ scp-command get ]
-        { "ssh" host "-l" username "mv" temp remote } short-running-process
+            ssh [ ssh-command get ] |
+        { scp local scp-remote } short-running-process
+        { ssh host "-l" username "mv" temp remote } short-running-process
     ] ;
 
 : eval-file ( file -- obj )

extra/mason/config/config.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system io.files namespaces kernel accessors ;
+USING: system io.files namespaces kernel accessors assocs ;
 IN: mason.config
 
 ! (Optional) Location for build directories
@@ -77,3 +77,10 @@ SYMBOL: upload-username
 
 ! Directory with binary packages.
 SYMBOL: upload-directory
+
+! Optional: override ssh and scp command names
+SYMBOL: scp-command
+scp-command global [ "scp" or ] change-at
+
+SYMBOL: ssh-command
+ssh-command global [ "ssh" or ] change-at

extra/mason/release/branch/branch-tests.factor

@@ -14,6 +14,7 @@ USING: mason.release.branch mason.config tools.test namespaces ;
 
 [ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
     [
+        "scp" scp-command set
         "joe" image-username set
         "blah.com" image-host set
         "/stuff/clean" image-directory set

extra/mason/release/branch/branch.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces sequences prettyprint io.files
-io.launcher make
+io.launcher make mason.common mason.platform mason.config ;
-mason.common mason.platform mason.config ;
 IN: mason.release.branch
 
 : branch-name ( -- string ) "clean-" platform append ;
@@ -25,7 +24,7 @@ IN: mason.release.branch
 
 : upload-clean-image-cmd ( -- args )
     [
-        "scp" ,
+        scp-command get ,
         boot-image-name ,
         [
             image-username get % "@" %

extra/webapps/wee-url/wee-url.factor

@@ -4,7 +4,8 @@
 USING: math.ranges sequences random accessors combinators.lib
 kernel namespaces fry db.types db.tuples urls validators
 html.components html.forms http http.server.dispatchers furnace
-furnace.actions furnace.boilerplate furnace.redirection ;
+furnace.actions furnace.boilerplate furnace.redirection 
+furnace.utilities ;
 IN: webapps.wee-url
 
 TUPLE: wee-url < dispatcher ;

extra/webapps/wiki/wiki.factor

@@ -7,8 +7,8 @@ syndication farkup
 html.components html.forms
 http.server
 http.server.dispatchers
-furnace
 furnace.actions
+furnace.utilities
 furnace.redirection
 furnace.auth
 furnace.auth.login

misc/factor.el

@@ -109,49 +109,47 @@ buffer."
   :group 'factor
   :group 'faces)
 
-(defsubst factor--face (face) `((t ,(face-attr-construct face))))
+(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
-
-(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
   "Face for parsing words."
   :group 'factor-faces)
 
-(defface factor-font-lock-comment (factor--face font-lock-comment-face)
+(defface factor-font-lock-comment (face-default-spec font-lock-comment-face)
   "Face for comments."
   :group 'factor-faces)
 
-(defface factor-font-lock-string (factor--face font-lock-string-face)
+(defface factor-font-lock-string (face-default-spec font-lock-string-face)
   "Face for strings."
   :group 'factor-faces)
 
-(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face)
+(defface factor-font-lock-stack-effect (face-default-spec font-lock-comment-face)
   "Face for stack effect specifications."
   :group 'factor-faces)
 
-(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face)
+(defface factor-font-lock-word-definition (face-default-spec font-lock-function-name-face)
   "Face for word, generic or method being defined."
   :group 'factor-faces)
 
-(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face)
+(defface factor-font-lock-symbol-definition (face-default-spec font-lock-variable-name-face)
   "Face for name of symbol being defined."
   :group 'factor-faces)
 
-(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face)
+(defface factor-font-lock-vocabulary-name (face-default-spec font-lock-constant-face)
   "Face for names of vocabularies in USE or USING."
   :group 'factor-faces)
 
-(defface factor-font-lock-type-definition (factor--face font-lock-type-face)
+(defface factor-font-lock-type-definition (face-default-spec font-lock-type-face)
   "Face for type (tuple) names."
   :group 'factor-faces)
 
-(defface factor-font-lock-constructor (factor--face font-lock-type-face)
+(defface factor-font-lock-constructor (face-default-spec font-lock-type-face)
   "Face for constructors (<foo>)."
   :group 'factor-faces)
 
-(defface factor-font-lock-setter-word (factor--face font-lock-function-name-face)
+(defface factor-font-lock-setter-word (face-default-spec font-lock-function-name-face)
   "Face for setter words (>>foo)."
   :group 'factor-faces)
 
-(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
+(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
   "Face for parsing words."
   :group 'factor-faces)
 
@@ -162,10 +160,6 @@ buffer."
 
 ;;; Factor mode font lock:
 
-(defconst factor--regexp-word-start
-  (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
-    (format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|"))))
-
 (defconst factor--parsing-words
   '("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
     "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
@@ -204,7 +198,7 @@ buffer."
 (defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
 (defconst factor--regex-use-line "^USE: +\\(.*\\)$")
 
-(defconst factor-font-lock-keywords
+(defconst factor--font-lock-keywords
   `(("( .* )" . 'factor-font-lock-stack-effect)
     ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
     ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
@@ -224,6 +218,10 @@ buffer."
 
 ;;; Factor mode syntax:
 
+(defconst factor--regexp-word-start
+  (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
+    (format "^\\(%s\\)\\(:\\) " (regexp-opt sws))))
+
 (defconst factor--font-lock-syntactic-keywords
   `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;"))
     (,factor--regexp-word-start (2 "(;"))
@@ -323,7 +321,7 @@ buffer."
                               "PRIVATE>" "<PRIVATE" "SYMBOL:" "USE:"))))
 
 (defsubst factor--at-begin-of-def ()
-  (looking-at "\\([^ ]\\|^\\)+:"))
+  (looking-at factor--regexp-word-start))
 
 (defsubst factor--looking-at-emptiness ()
   (looking-at "^[ \t]*$"))
@@ -502,17 +500,25 @@ buffer."
   (use-local-map factor-mode-map)
   (setq major-mode 'factor-mode)
   (setq mode-name "Factor")
+  ;; Font locking
   (set (make-local-variable 'comment-start) "! ")
+  (set (make-local-variable 'parse-sexp-lookup-properties) t)
   (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
   (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
   (set (make-local-variable 'font-lock-defaults)
-       `(factor-font-lock-keywords
+       `(factor--font-lock-keywords
          nil nil nil nil
          (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
+
   (set-syntax-table factor-mode-syntax-table)
+  ;; Defun navigation
+  (setq defun-prompt-regexp "[^ :]+")
+  (set (make-local-variable 'open-paren-in-column-0-is-defun-start) t)
+  ;; Indentation
   (set (make-local-variable 'indent-line-function) 'factor--indent-line)
   (setq factor-indent-width (factor--guess-indent-width))
   (setq indent-tabs-mode nil)
+
   (run-hooks 'factor-mode-hook))
 
 (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
@@ -568,6 +574,7 @@ buffer."
                 "Generic word contract"
                 "Inputs and outputs"
                 "Parent topics:"
+                "See also"
                 "Syntax"
                 "Vocabulary"
                 "Warning"
@@ -578,7 +585,7 @@ buffer."
 
 (defconst factor--help-font-lock-keywords
   `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
-    ,@factor-font-lock-keywords))
+    ,@factor--font-lock-keywords))
 
 (defun factor-help-mode ()
   "Major mode for displaying Factor help messages.
@@ -591,6 +598,7 @@ buffer."
   (set (make-local-variable 'font-lock-defaults)
        '(factor--help-font-lock-keywords t nil nil nil))
   (set (make-local-variable 'comint-redirect-subvert-readonly) t)
+  (set (make-local-variable 'comint-redirect-echo-input) nil)
   (set (make-local-variable 'view-no-disable-on-exit) t)
   (view-mode)
   (setq view-exit-action
@@ -602,11 +610,11 @@ buffer."
   (run-mode-hooks 'factor-help-mode-hook))
 
 (defun factor--listener-help-buffer ()
-  (set-buffer (get-buffer-create "*factor-help*"))
+  (with-current-buffer (get-buffer-create "*factor-help*")
     (let ((inhibit-read-only t))
       (delete-region (point-min) (point-max)))
     (factor-help-mode)
-  (current-buffer))
+    (current-buffer)))
 
 (defvar factor--help-history nil)
 
@@ -622,7 +630,8 @@ buffer."
          (hb (factor--listener-help-buffer))
          (proc (factor--listener-process)))
     (comint-redirect-send-command-to-process cmd hb proc nil)
-    (pop-to-buffer hb)))
+    (pop-to-buffer hb)
+    (beginning-of-buffer hb)))
 
 (defun factor-see ()
   (interactive)
@@ -643,13 +652,12 @@ vocabularies which have been modified on disk."
 
 ;;; Key bindings:
 
-(defmacro factor--define-key (key cmd &optional both)
+(defun factor--define-key (key cmd &optional both)
-  (let ((m (gensym))
+  (let ((ms (list factor-mode-map)))
-        (ms '(factor-mode-map)))
+    (when both (push factor-help-mode-map ms))
-    (when both (push 'factor-help-mode-map ms))
+    (dolist (m ms)
-    `(dolist (,m (list ,@ms))
+      (define-key m (vector '(control ?c) key) cmd)
-       (define-key ,m [(control ?c) ,key] ,cmd)
+      (define-key m (vector '(control ?c) `(control ,key)) cmd))))
-       (define-key ,m [(control ?c) (control ,key)] ,cmd))))
 
 (factor--define-key ?f 'factor-run-file)
 (factor--define-key ?r 'factor-send-region)
@@ -662,7 +670,6 @@ vocabularies which have been modified on disk."
 (define-key factor-mode-map "\C-ch" 'factor-help)
 (define-key factor-help-mode-map "\C-ch" 'factor-help)
 (define-key factor-mode-map "\C-m" 'newline-and-indent)
-(define-key factor-mode-map [tab] 'indent-for-tab-command)
 
 (define-key factor-listener-mode-map [f8] 'factor-refresh-all)
 

vm/data_gc.c

@@ -885,12 +885,13 @@ void garbage_collection(CELL gen,
 	/* collect objects referenced from older generations */
 	collect_cards();
 
-	if(collecting_gen != TENURED)
-	{
 	/* don't scan code heap unless it has pointers to this
 	generation or younger */
 	if(collecting_gen >= last_code_heap_scan)
 	{
+		if(collecting_gen != TENURED)
+		{
+		
 			/* if we are doing code GC, then we will copy over
 			literals from any code block which gets marked as live.
 			if we are not doing code GC, just consider all literals
@@ -898,13 +899,13 @@ void garbage_collection(CELL gen,
 			code_heap_scans++;
 
 			collect_literals();
+		}
 
 		if(collecting_accumulation_gen_p())
 			last_code_heap_scan = collecting_gen;
 		else
 			last_code_heap_scan = collecting_gen + 1;
 	}
-	}
 
 	collect_next_loop(scan,&newspace->here);
 

vm/os-macosx.m

@@ -25,6 +25,14 @@ NS_ENDHANDLER
 
 void early_init(void)
 {
+	SInt32 version;
+	Gestalt(gestaltSystemVersion,&version);
+	if(version <= 0x1050)
+	{
+		printf("Factor requires Mac OS X 10.5 or later.\n");
+		exit(1);
+	}
+
 	[[NSAutoreleasePool alloc] init];
 }