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

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

db4
Aaron Schaefer 2008-11-26 17:48:47 -05:00
parent 6333710f7d c7d86ebd55
commit db20629a0f
55 changed files with 618 additions and 517 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/alien/c-types/c-types-tests.factor
View File

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

2
basis/checksums/common/common.factor
View File

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

2
basis/checksums/md5/md5.factor
View File

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

21
basis/combinators/short-circuit/short-circuit.factor
View File

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

4
basis/cpu/x86/64/winnt/winnt.factor
View File

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

12
basis/delegate/delegate.factor
View File

@ -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
[
over second saver %
%
dup second restorer %
first ,
] [ ] make
] 3bi
[ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi
define ;
: change-word-prop ( word prop quot -- )

2
basis/furnace/actions/actions.factor
View File

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

2
basis/furnace/asides/asides.factor
View File

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

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

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

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

@ -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
http http.server.responses http.server.redirection
http.server.dispatchers
furnace furnace.actions furnace.auth furnace.auth.providers
furnace.redirection ;
threads fry urls smtp validators html.forms present http
http.server.responses http.server.redirection
http.server.dispatchers furnace.actions furnace.auth
furnace.auth.providers furnace.redirection furnace.utilities ;
IN: furnace.auth.features.recover-password
SYMBOL: lost-password-from

2
basis/furnace/auth/features/registration/registration.factor
View File

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

1
basis/furnace/auth/login/login.factor
View File

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

5
basis/furnace/boilerplate/boilerplate.factor
View File

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

2
basis/furnace/chloe-tags/chloe-tags.factor
View File

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

2
basis/furnace/conversations/conversations.factor
View File

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

123
basis/furnace/furnace-docs.factor
View File

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

4
basis/furnace/furnace-tests.factor
View File

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

126
basis/furnace/furnace.factor
View File

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

2
basis/furnace/redirection/redirection.factor
View File

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

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

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

2
basis/furnace/referrer/referrer.factor
View File

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

3
basis/furnace/sessions/sessions-tests.factor
View File

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

10
basis/furnace/sessions/sessions.factor
View File

@ -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
fry calendar combinators combinators.short-circuit destructors alarms
io.servers.connection
db db.tuples db.types
strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
destructors alarms io.servers.connection db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
furnace furnace.cache furnace.scopes ;
html.elements furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions
TUPLE: session < scope user-agent client ;

7
basis/furnace/syndication/syndication.factor
View File

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

126
basis/furnace/utilities/utilities-docs.factor Normal file
View File

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

128
basis/furnace/utilities/utilities.factor
View File

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

37
basis/generalizations/generalizations.factor
View File

@ -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
math.ranges combinators macros quotations fry arrays ;
USING: kernel sequences sequences.private math math.ranges
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 -- )
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
MACRO: npick ( n -- quot )
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 -- )
swap >r ndrop r> ; inline
MACRO: nnip ( n -- )
'[ [ _ 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 -- )
[ ] [ 1+ ] [ ] tri
'[ [ _ ndup ] dip _ -nrot _ nslip ] ;
MACRO: nkeep ( quot n -- )
tuck '[ _ ndup _ _ ndip ] ;
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 ;

9
basis/http/http-tests.factor
View File

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

14
basis/http/parsers/parsers.factor
View File

@ -142,16 +142,15 @@ PEG: parse-header-line ( string -- pair )
'space' ,
'attr' ,
'space' ,
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action
epsilon [ drop f ] action
2choice ,
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional ,
'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 ;

13
basis/locals/locals-tests.factor
View File

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

18
basis/locals/locals.factor
View File

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

6
basis/macros/macros.factor
View File

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

7
basis/math/bitwise/bitwise.factor
View File

@ -23,17 +23,12 @@ IN: math.bitwise
: bitroll ( x s w -- y )
[ wrap ] keep
[ shift-mod ]
[ [ - ] keep shift-mod ] 3bi bitor ; inline
[ shift-mod ] [ [ - ] 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

17
basis/opengl/opengl.factor
View File

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

4
basis/ui/gadgets/buttons/buttons.factor
View File

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

3
basis/ui/gadgets/canvas/canvas.factor
View File

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

65
basis/ui/gadgets/editors/editors.factor
View File

@ -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
math.vectors sorting colors combinators assocs math.order fry
calendar alarms ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
ui.render ui.gestures math.geometry.rect ;
namespaces locals fry make opengl opengl.gl sequences strings
io.styles math.vectors sorting colors combinators assocs
math.order fry calendar alarms ui.clipboards ui.commands
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
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 )
[
[ first2 ] dip tuck y>line dup ,
[ dup editor-font* ] dip
rot editor-line x>offset ,
] { } make ;
:: point>loc ( point editor -- loc )
point second editor y>line {
{ [ dup 0 < ] [ drop { 0 0 } ] }
{ [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
[| n |
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
rot first rot line>y 2array ;
[ editor-caret* ] keep
[ 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
\ last-visible-line get
rot control-value <slice> ;
[ \ first-visible-line get \ last-visible-line get ] dip
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 ;

15
basis/ui/gadgets/frames/frames-tests.factor
View File

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

22
basis/ui/gadgets/frames/frames.factor
View File

@ -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
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
math.geometry.rect ;
USING: accessors arrays generic kernel math namespaces sequences
words splitting grouping math.vectors ui.gadgets.grids
ui.gadgets math.geometry.rect ;
IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center
! gadgets gets left-over space.
TUPLE: frame < grid ;
TUPLE: glue < gadget ;
: <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 ;

3
basis/ui/gadgets/menus/menus.factor
View File

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

29
basis/ui/render/render.factor
View File

@ -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 ;
: draw-polygon ( polygon mode -- )
swap
[ color>> gl-color ]
[ vertex-array>> gl-vertex-pointer ]
[ 0 swap count>> glDrawArrays ]
tri ;
dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@
polygon boa ;
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 ?
draw-polygon drop ;
nip
[ 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 } } ;

12
basis/ui/tools/listener/listener.factor
View File

@ -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.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ;
ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
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>
over output>> add-gadget
swap input>> add-gadget
<frame>
over output>> @top grid-add
swap input>> @center grid-add
<scroller> ;
: <listener-gadget> ( -- gadget )

10
basis/ui/traverse/traverse.factor
View File

@ -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 [
>r >r rest-slice r> r> traverse-step (gadget-subtree)
[ -rot ] keep [
[ rest-slice ] 2dip traverse-step (gadget-subtree)
] make-node ;
: (gadget-subtree) ( frompath topath gadget -- )

4
basis/ui/windows/windows.factor
View File

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

2
core/combinators/combinators.factor
View File

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

2
core/generic/parser/parser.factor
View File

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

8
extra/mason/common/common.factor
View File

@ -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" local scp-remote } short-running-process
{ "ssh" host "-l" username "mv" temp remote } short-running-process
scp-remote [ { username "@" host ":" temp } concat ]
scp [ scp-command get ]
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 )

9
extra/mason/config/config.factor
View File

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

1
extra/mason/release/branch/branch-tests.factor
View File

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

5
extra/mason/release/branch/branch.factor
View File

@ -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
mason.common mason.platform mason.config ;
io.launcher make 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 % "@" %

3
extra/webapps/wee-url/wee-url.factor
View File

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

2
extra/webapps/wiki/wiki.factor
View File

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

71
misc/factor.el
View File

@ -109,49 +109,47 @@ buffer."
:group 'factor
:group 'faces)
(defsubst factor--face (face) `((t ,(face-attr-construct face))))
(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)
(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)
(let ((m (gensym))
(ms '(factor-mode-map)))
(when both (push 'factor-help-mode-map ms))
`(dolist (,m (list ,@ms))
(define-key ,m [(control ?c) ,key] ,cmd)
(define-key ,m [(control ?c) (control ,key)] ,cmd))))
(defun factor--define-key (key cmd &optional both)
(let ((ms (list factor-mode-map)))
(when both (push factor-help-mode-map ms))
(dolist (m ms)
(define-key m (vector '(control ?c) key) cmd)
(define-key m (vector '(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)

7
vm/data_gc.c
View File

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

8
vm/os-macosx.m
View File

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