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

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

db4
Doug Coleman 2008-11-17 06:57:22 -06:00
parent 6ced106bee 369831cd39
commit 91f0d85a41
436 changed files with 4239 additions and 1861 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,7 @@ HELP: alarm
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
HELP: add-alarm
{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }
{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
HELP: later

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

@ -16,7 +16,7 @@ HELP: ALIAS:
}
} ;
ARTICLE: "alias" "Alias"
ARTICLE: "alias" "Word aliasing"
"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
"Make a new word that aliases another word:"
{ $subsection define-alias }

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

@ -39,12 +39,12 @@ HELP: byte-length
{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
HELP: c-getter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } }
{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;

2
basis/binary-search/binary-search-docs.factor
View File

@ -2,7 +2,7 @@ IN: binary-search
USING: help.markup help.syntax sequences kernel math.order ;
HELP: search
{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $values { "seq" "a sorted sequence" } { "quot" { $quotation "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
$nl
"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."

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

@ -134,6 +134,7 @@ SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-declare-word
SYMBOL: jit-save-stack
! Default definition for undefined words
SYMBOL: undefined-quot
@ -158,6 +159,7 @@ SYMBOL: undefined-quot
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
{ jit-save-stack 43 }
{ undefined-quot 60 }
} at header-size + ;
@ -459,6 +461,7 @@ M: quotation '
jit-return
jit-profiling
jit-declare-word
jit-save-stack
undefined-quot
} [ emit-userenv ] each ;

1
basis/calendar/windows/tags.txt Normal file → Executable file
View File

@ -1,2 +1 @@
unportable
windows

2
basis/cocoa/messages/messages-docs.factor
View File

@ -31,7 +31,7 @@ HELP: alien>objc-types
{ objc>alien-types alien>objc-types } related-words
HELP: import-objc-class
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } }
{ $values { "name" string } { "quot" { $quotation "( -- )" } } }
{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
HELP: root-class

48
basis/command-line/command-line-docs.factor
View File

@ -2,10 +2,10 @@ USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
HELP: run-bootstrap-init
{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
{ $description "Runs the bootstrap initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } " on Unix and " { $snippet "factor-boot-rc" } " on Windows." } ;
HELP: run-user-init
{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
HELP: cli-param
{ $values { "param" string } }
@ -57,7 +57,7 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"
{ $table
{ { $snippet "-output-image=" { $emphasis "image" } } { "Save the result to " { $snippet "image" } ". The default is " { $snippet "factor.image" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-boot-rc" } " file in the user's home directory." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-include=" { $emphasis "components..." } } "A list of components to include (see below)." }
{ { $snippet "-exclude=" { $emphasis "components..." } } "A list of components to exclude." }
{ { $snippet "-ui-backend=" { $emphasis "backend" } } { "One of " { $snippet "x11" } ", " { $snippet "windows" } ", or " { $snippet "cocoa" } ". The default is platform-specific." } }
@ -74,9 +74,9 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"By default, all optional components are loaded. To load all optional components except for a given list, use the " { $snippet "-exclude=" } " switch; to only load specified optional components, use the " { $snippet "-include=" } "."
$nl
"For example, to build an image with the compiler but no other components, you could do:"
{ $code "./factor -i=boot.ppc.image -include=compiler" }
{ $code "./factor -i=boot.macosx-ppc.image -include=compiler" }
"To build an image with everything except for the user interface and graphical tools,"
{ $code "./factor -i=boot.ppc.image -exclude=\"ui ui.tools\"" }
{ $code "./factor -i=boot.macosx-ppc.image -exclude=\"ui ui.tools\"" }
"To generate a bootstrap image in the first place, see " { $link "bootstrap.image" } "." ;
ARTICLE: "standard-cli-args" "Command line switches for general usage"
@ -84,17 +84,43 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ $table
{ { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } }
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-rc" } " file in the user's home directory on startup." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ;
ARTICLE: "rc-files" "Running code on startup"
"Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment."
ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts."
$nl
"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
{ $subsection run-user-init }
{ $subsection run-bootstrap-init } ;
"A word to run this file from an existing Factor session:"
{ $subsection run-bootstrap-init }
"For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ;
ARTICLE: "factor-rc" "Startup initialization file"
"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts."
$nl
"A word to run this file from an existing Factor session:"
{ $subsection run-user-init } ;
ARTICLE: "rc-files" "Running code on startup"
"Factor looks for two files in your home directory."
{ $subsection "factor-boot-rc" }
{ $subsection "factor-rc" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
$nl
"If you are unsure where the files should be located, evaluate the following code:"
{ $code
"USE: command-line"
"\"factor-rc\" rc-path print"
"\"factor-boot-rc\" rc-path print"
}
"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:"
{ $code
"USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;"
"\"/opt/local/bin\" \\ gvim-path set-global"
"\"/home/jane/src/\" vocab-roots get push"
"100 dpi set-global"
} ;
ARTICLE: "cli" "Command line usage"
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."

8
basis/command-line/command-line.factor
View File

@ -5,14 +5,18 @@ kernel.private namespaces parser sequences strings system
splitting io.files eval ;
IN: command-line
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
home prepend-path ;
: run-bootstrap-init ( -- )
"user-init" get [
home ".factor-boot-rc" append-path ?run-file
"factor-boot-rc" rc-path ?run-file
] when ;
: run-user-init ( -- )
"user-init" get [
home ".factor-rc" append-path ?run-file
"factor-rc" rc-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;

23
basis/compiler/cfg/builder/builder.factor
View File

@ -190,7 +190,7 @@ M: #if emit-node
: emit-dispatch ( node -- )
##epilogue
ds-pop ^^offset>slot i ##dispatch
ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
@ -221,21 +221,14 @@ M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ;
! #shuffle
: emit-shuffle ( effect -- )
[ out>> ] [ in>> dup length ds-load zip ] bi
'[ _ at ] map ds-store ;
M: #shuffle emit-node
shuffle-effect emit-shuffle iterate-next ;
M: #>r emit-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ neg ##inc-d ] [ ds-load rs-store ] if
iterate-next ;
M: #r> emit-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ neg ##inc-r ] [ rs-load ds-store ] if
dup
H{ } clone
[ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
iterate-next ;
! #return

2
basis/compiler/cfg/instructions/instructions.factor
View File

@ -62,7 +62,7 @@ INSN: ##jump word ;
INSN: ##return ;
! Jump tables
INSN: ##dispatch src temp ;
INSN: ##dispatch src temp offset ;
INSN: ##dispatch-label label ;
! Slot access

4
basis/compiler/cfg/linearization/linearization.factor
View File

@ -43,8 +43,8 @@ M: ##branch linearize-insn
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> first useless-branch? ] 2bi
[ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
[ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;

5
basis/compiler/cfg/rpo/rpo.factor
View File

@ -9,7 +9,10 @@ SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
[ successors>> [ post-order-traversal ] each ] [ , ] bi
[
successors>> <reversed>
[ post-order-traversal ] each
] [ , ] bi
] if ;
: post-order ( bb -- blocks )

20
basis/compiler/cfg/stacks/stacks.factor
View File

@ -15,16 +15,28 @@ IN: compiler.cfg.stacks
1 ##inc-d D 0 ##replace ;
: ds-load ( n -- vregs )
[ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
dup 0 =
[ drop f ]
[ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
: ds-store ( vregs -- )
<reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
[
<reversed>
[ length ##inc-d ]
[ [ <ds-loc> ##replace ] each-index ] bi
] unless-empty ;
: rs-load ( n -- vregs )
[ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
dup 0 =
[ drop f ]
[ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
: rs-store ( vregs -- )
<reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
[
<reversed>
[ length ##inc-r ]
[ [ <rs-loc> ##replace ] each-index ] bi
] unless-empty ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;

16
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math
math fry
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
@ -113,4 +113,18 @@ M: ##compare-imm rewrite
] when
] when ;
: dispatch-offset ( expr -- n )
[ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
\ ##sub-imm eq? [ neg ] when ;
: add-dispatch-offset? ( insn -- expr ? )
src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
M: ##dispatch rewrite
dup add-dispatch-offset? [
[ clone ] dip
[ in1>> vn>vreg >>src ]
[ dispatch-offset '[ _ + ] change-offset ] bi
] [ drop ] if ;
M: insn rewrite ;

2
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -34,7 +34,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##dispatch f V int-regs 1 V int-regs 2 }
T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
} dup value-numbering =
] unit-test

2
basis/compiler/codegen/codegen.factor
View File

@ -93,7 +93,7 @@ M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
: >slot<
{

4
basis/compiler/codegen/fixup/fixup.factor
View File

@ -72,8 +72,8 @@ SYMBOL: literal-table
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: rel-here ( offset class -- )
rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set

4
basis/compiler/compiler.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques
words fry continuations vocabs assocs dlists definitions
math threads graphs generic combinators deques search-deques
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer

17
basis/compiler/constants/constants.factor
View File

@ -37,14 +37,15 @@ IN: compiler.constants
: rc-indirect-arm-pc 8 ; inline
! Relocation types
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rt-stack-chain 8 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

11
basis/compiler/tests/templates.factor → basis/compiler/tests/codegen.factor
View File

@ -230,3 +230,14 @@ TUPLE: id obj ;
10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
[ ] [ gc-check-bug ] unit-test
! New optimization
: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
[ "a" ] [ 8 test-1 ] unit-test
[ "b" ] [ 9 test-1 ] unit-test
: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
[ "a" ] [ 1 test-2 ] unit-test
[ "b" ] [ 2 test-2 ] unit-test

27
basis/compiler/tree/builder/builder.factor
View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators stack-checker
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree ;
assocs words arrays vectors hints combinators compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
stack-checker.visitor
stack-checker.backend
stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
@ -12,12 +16,13 @@ IN: compiler.tree.builder
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
[ f infer-quot ] with-tree-builder nip ;
[ f initial-recursive-state infer-quot ] with-tree-builder nip ;
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
[ >vector meta-d set ] [ f infer-quot ] bi*
[ >vector meta-d set ]
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
@ -29,14 +34,10 @@ IN: compiler.tree.builder
if ;
: (build-tree-from-word) ( word -- )
dup
[ "inline" word-prop ]
[ "recursive" word-prop ] bi and [
1quotation f infer-quot
] [
[ specialized-def ]
[ dup 2array 1array ] bi infer-quot
] if ;
dup initial-recursive-state recursive-state set
dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
[ 1quotation ] [ specialized-def ] if
infer-quot-here ;
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;

18
basis/compiler/tree/checker/checker.factor
View File

@ -22,8 +22,8 @@ ERROR: check-use-error value message ;
GENERIC: check-node* ( node -- )
M: #shuffle check-node*
[ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
[ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ]
bi ;
: check-lengths ( seq -- )
@ -31,13 +31,6 @@ M: #shuffle check-node*
M: #copy check-node* inputs/outputs 2array check-lengths ;
: check->r/r> ( node -- )
inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
M: #>r check-node* check->r/r> ;
M: #r> check-node* check->r/r> ;
M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
M: #phi check-node*
@ -113,11 +106,8 @@ M: #push check-stack-flow* check-out-d ;
M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
M: #shuffle check-stack-flow*
{ [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ;
: assert-datastack-empty ( -- )
datastack get empty? [ "Data stack not empty" throw ] unless ;

2
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -39,7 +39,7 @@ M: #branch remove-dead-code*
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;
#data-shuffle ;
: insert-drops ( nodes values indices -- nodes' )
'[

5
basis/compiler/tree/dead-code/liveness/liveness.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs deques search-deques
kernel sequences sequences.deep words sets stack-checker.branches
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
dlists kernel sequences sequences.deep words sets
stack-checker.branches compiler.tree compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.dead-code.liveness
SYMBOL: work-list

26
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -39,12 +39,6 @@ M: #copy compute-live-values*
M: #call compute-live-values* nip look-at-inputs ;
M: #>r compute-live-values*
[ out-r>> ] [ in-d>> ] bi look-at-mapping ;
M: #r> compute-live-values*
[ out-d>> ] [ in-r>> ] bi look-at-mapping ;
M: #shuffle compute-live-values*
mapping>> at look-at-value ;
@ -61,7 +55,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
zip filter-mapping values ;
: filter-live ( values -- values' )
[ live-value? ] filter ;
dup empty? [ [ live-value? ] filter ] unless ;
:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
inputs
@ -69,7 +63,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
outputs
mapping-keys
mapping-values
filter-corresponding zip #shuffle ; inline
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
[let* | new-outputs [ outputs make-values ]
@ -95,16 +89,6 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
M: #introduce remove-dead-code* ( #introduce -- nodes )
maybe-drop-dead-outputs ;
M: #>r remove-dead-code*
[ filter-live ] change-out-r
[ filter-live ] change-in-d
dup in-d>> empty? [ drop f ] when ;
M: #r> remove-dead-code*
[ filter-live ] change-out-d
[ filter-live ] change-in-r
dup in-r>> empty? [ drop f ] when ;
M: #push remove-dead-code*
dup out-d>> first live-value? [ drop f ] unless ;
@ -125,12 +109,14 @@ M: #call remove-dead-code*
M: #shuffle remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
[ filter-live ] change-in-r
[ filter-live ] change-out-r
[ filter-mapping ] change-mapping
dup in-d>> empty? [ drop f ] when ;
dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
M: #copy remove-dead-code*
[ in-d>> ] [ out-d>> ] bi
2dup swap zip #shuffle
2dup swap zip #data-shuffle
remove-dead-code* ;
M: #terminate remove-dead-code*

48
basis/compiler/tree/debugger/debugger.factor
View File

@ -3,7 +3,7 @@
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting hints qualified
combinators combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
@ -57,9 +57,41 @@ TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
: (shuffle-effect) ( in out #shuffle -- effect )
mapping>> '[ _ at ] map <effect> ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
: #>r? ( #shuffle -- ? )
{
[ in-d>> length 1 = ]
[ out-r>> length 1 = ]
[ in-r>> empty? ]
[ out-d>> empty? ]
} 1&& ;
: #r>? ( #shuffle -- ? )
{
[ in-d>> empty? ]
[ out-r>> empty? ]
[ in-r>> length 1 = ]
[ out-d>> length 1 = ]
} 1&& ;
M: #shuffle node>quot
shuffle-effect dup pretty-shuffle
[ % ] [ shuffle-node boa , ] ?if ;
{
{ [ dup #>r? ] [ drop \ >r , ] }
{ [ dup #r>? ] [ drop \ r> , ] }
{
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
[
shuffle-effect dup pretty-shuffle
[ % ] [ shuffle-node boa , ] ?if
]
}
[ drop "COMPLEX SHUFFLE" , ]
} cond ;
M: #push node>quot literal>> , ;
@ -82,16 +114,6 @@ M: #if node>quot
M: #dispatch node>quot
children>> [ nodes>quot ] map , \ dispatch , ;
M: #>r node>quot
[ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
<repetition> % ;
DEFER: rdrop
M: #r> node>quot
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
<repetition> % ;
M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;

12
basis/compiler/tree/def-use/def-use.factor
View File

@ -18,12 +18,16 @@ TUPLE: definition value node uses ;
swap >>node
V{ } clone >>uses ;
ERROR: no-def-error value ;
: def-of ( value -- definition )
def-use get at* [ "No def" throw ] unless ;
dup def-use get at* [ nip ] [ no-def-error ] if ;
ERROR: multiple-defs-error ;
: def-value ( node value -- )
def-use get 2dup key? [
"Multiple defs" throw
multiple-defs-error
] [
[ [ <definition> ] keep ] dip set-at
] if ;
@ -38,16 +42,16 @@ GENERIC: node-uses-values ( node -- values )
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #alien-callback node-uses-values drop f ;
M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values )
M: #>r node-defs-values out-r>> ;
M: #shuffle node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
M: #branch node-defs-values drop f ;
M: #declare node-defs-values drop f ;
M: #return node-defs-values drop f ;

2
basis/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.state ;
combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:

8
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize classes.builtin
fry assocs
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -27,9 +28,10 @@ GENERIC: finalize* ( node -- nodes )
M: #copy finalize* drop f ;
M: #shuffle finalize*
dup shuffle-effect
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
dup
[ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
bi and [ drop f ] when ;
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;

2
basis/compiler/tree/identities/identities.factor
View File

@ -79,7 +79,7 @@ GENERIC: apply-identities* ( node -- node )
: select-input ( node n -- #shuffle )
[ [ in-d>> ] [ out-d>> ] bi ] dip
pick nth over first associate #shuffle ;
pick nth over first associate #data-shuffle ;
M: #call apply-identities*
dup word>> "identities" word-prop [

6
basis/compiler/tree/normalization/renaming/renaming.factor
View File

@ -10,7 +10,7 @@ SYMBOL: rename-map
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
rename-map get '[ [ _ at ] keep or ] map ;
dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ;
: add-renamings ( old new -- )
[ rename-values ] dip
@ -22,13 +22,11 @@ M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
M: #r> rename-node-values*
[ rename-values ] change-in-r ;
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;

2
basis/compiler/tree/recursive/recursive.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs arrays namespaces accessors sequences deques
search-deques compiler.tree compiler.tree.combinators ;
search-deques dlists compiler.tree compiler.tree.combinators ;
IN: compiler.tree.recursive
! Collect label info

38
basis/compiler/tree/tree.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
sequences words vectors math.intervals classes
accessors combinators stack-checker.state stack-checker.visitor
stack-checker.inlining ;
IN: compiler.tree
@ -42,30 +42,21 @@ TUPLE: #push < node literal out-d ;
TUPLE: #renaming < node ;
TUPLE: #shuffle < #renaming mapping in-d out-d ;
TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ;
: #shuffle ( inputs outputs mapping -- node )
: #shuffle ( in-d out-d in-r out-r mapping -- node )
\ #shuffle new
swap >>mapping
swap >>out-r
swap >>in-r
swap >>out-d
swap >>in-d ;
: #data-shuffle ( in-d out-d mapping -- node )
[ f f ] dip #shuffle ; inline
: #drop ( inputs -- node )
{ } { } #shuffle ;
TUPLE: #>r < #renaming in-d out-r ;
: #>r ( inputs outputs -- node )
\ #>r new
swap >>out-r
swap >>in-d ;
TUPLE: #r> < #renaming in-r out-d ;
: #r> ( inputs outputs -- node )
\ #r> new
swap >>out-d
swap >>in-r ;
{ } { } #data-shuffle ;
TUPLE: #terminate < node in-d in-r ;
@ -171,16 +162,9 @@ TUPLE: #alien-callback < #alien-node ;
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
M: #shuffle inputs/outputs mapping>> unzip swap ;
M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
'[ _ at ] map
<effect> ;
: recursive-phi-in ( #enter-recursive -- seq )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
@ -193,8 +177,8 @@ M: vector #call, #call node, ;
M: vector #push, #push node, ;
M: vector #shuffle, #shuffle node, ;
M: vector #drop, #drop node, ;
M: vector #>r, #>r node, ;
M: vector #r>, #r> node, ;
M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ;
M: vector #return, #return node, ;
M: vector #enter-recursive, #enter-recursive node, ;
M: vector #return-recursive, #return-recursive node, ;

14
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -42,7 +42,7 @@ M: #push unbox-tuples* ( #push -- nodes )
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
: flatten-values ( values -- values' )
(flatten-values) flatten ;
dup empty? [ (flatten-values) flatten ] unless ;
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> flatten-values ]
@ -54,7 +54,7 @@ M: #push unbox-tuples* ( #push -- nodes )
] tri ;
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
[ drop ] [ zip ] 2bi #shuffle ;
[ drop ] [ zip ] 2bi #data-shuffle ;
: unbox-slot-access ( #call -- nodes )
dup out-d>> first unboxed-slot-access? [
@ -77,17 +77,11 @@ M: #copy unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
M: #>r unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-r ;
M: #r> unbox-tuples*
[ flatten-values ] change-in-r
[ flatten-values ] change-out-d ;
M: #shuffle unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d
[ flatten-values ] change-in-r
[ flatten-values ] change-out-r
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terminate unbox-tuples*

10
basis/concurrency/combinators/combinators-docs.factor
View File

@ -2,27 +2,27 @@ USING: help.markup help.syntax sequences ;
IN: concurrency.combinators
HELP: parallel-map
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-each
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
{ $errors "Throws an error if one of the iterations throws an error." } ;

2
basis/concurrency/futures/futures-docs.factor
View File

@ -5,7 +5,7 @@ continuations help.markup help.syntax quotations ;
IN: concurrency.futures
HELP: future
{ $values { "quot" "a quotation with stack effect " { $snippet "( -- value )" } } { "future" future } }
{ $values { "quot" { $quotation "( -- value )" } } { "future" future } }
{ $description "Creates a deferred computation."
$nl
"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;

6
basis/concurrency/locks/locks-docs.factor
View File

@ -14,7 +14,7 @@ HELP: <reentrant-lock>
{ $description "Creates a reentrant lock." } ;
HELP: with-lock-timeout
{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
@ -36,7 +36,7 @@ HELP: rw-lock
{ $class-description "The class of reader/writer locks." } ;
HELP: with-read-lock-timeout
{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
@ -45,7 +45,7 @@ HELP: with-read-lock
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ;
HELP: with-write-lock-timeout
{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." }
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;

27
basis/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax kernel arrays ;
USING: help.markup help.syntax kernel arrays calendar ;
IN: concurrency.mailboxes
HELP: <mailbox>
@ -18,46 +18,41 @@ HELP: mailbox-put
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
HELP: block-unless-pred
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ "timeout" "a timeout in milliseconds, or " { $link f } }
{ $values { "pred" { $quotation "( obj -- ? )" } }
{ "mailbox" mailbox }
{ "timeout" "a " { $link duration } " or " { $link f } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
HELP: block-if-empty
{ $values { "mailbox" mailbox }
{ "timeout" "a timeout in milliseconds, or " { $link f } }
{ "timeout" "a " { $link duration } " or " { $link f } }
}
{ $description "Block the thread if the mailbox is empty." } ;
HELP: mailbox-get
{ $values { "mailbox" mailbox }
{ "obj" object }
}
{ $values { "mailbox" mailbox } { "obj" object } }
{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
HELP: mailbox-get-all
{ $values { "mailbox" mailbox }
{ "array" array }
}
{ $values { "mailbox" mailbox } { "array" array } }
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
HELP: while-mailbox-empty
{ $values { "mailbox" mailbox }
{ "quot" "a quotation with stack effect " { $snippet "( -- )" } }
{ "quot" { $quotation "( -- )" } }
}
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "mailbox" mailbox }
{ "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "pred" { $quotation "( obj -- ? )" } }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
ARTICLE: "concurrency.mailboxes" "Mailboxes"
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
{ $subsection mailbox }
{ $subsection <mailbox> }
"Removing the first element:"

2
basis/concurrency/promises/promises-docs.factor
View File

@ -12,7 +12,7 @@ HELP: promise-fulfilled?
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
HELP: ?promise-timeout
{ $values { "promise" promise } { "timeout" "a " { $link duration } " or " { $link f } } { "result" object } }
{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." }
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;

4
basis/concurrency/semaphores/semaphores-docs.factor
View File

@ -9,7 +9,7 @@ HELP: <semaphore>
{ $description "Creates a counting semaphore with the specified initial count." } ;
HELP: acquire-timeout
{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } }
{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } }
{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }
{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;
@ -22,7 +22,7 @@ HELP: release
{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
HELP: with-semaphore-timeout
{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } }
{ $description "Calls the quotation with the semaphore held." } ;
HELP: with-semaphore

2
basis/cpu/architecture/architecture.factor
View File

@ -50,7 +50,7 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch cpu ( src temp offset -- )
HOOK: %dispatch-label cpu ( word -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )

7
basis/cpu/ppc/bootstrap.factor
View File

@ -57,7 +57,12 @@ big-endian on
[
0 6 LOAD32
4 1 MR
7 6 0 LWZ
1 7 0 STW
] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
[
0 6 LOAD32
6 MTCTR
BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define

8
basis/cpu/ppc/ppc.factor
View File

@ -111,10 +111,10 @@ M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp -- )
0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
temp temp src ADD
temp temp 5 cells LWZ
M:: ppc %dispatch ( src temp offset -- )
0 temp LOAD32
4 offset + cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX
temp MTCTR
BCTR ;

14
basis/cpu/x86/32/32.factor
View File

@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics ;
compiler.cfg.builder compiler.cfg.intrinsics make ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@ -26,6 +26,18 @@ M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M:: x86.32 %dispatch ( src temp offset -- )
! Load jump table base.
src HEX: ffffffff ADD
offset cells rc-absolute-cell rel-here
! Go
src HEX: 7f [+] JMP
! Fix up the displacement above
cell code-alignment
[ 7 + building get dup pop* push ]
[ align-code ]
bi ;
M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;

11
basis/cpu/x86/32/bootstrap.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ;
cpu.x86.assembler layouts vocabs parser compiler.constants ;
IN: bootstrap.x86
4 \ cell set
@ -19,5 +19,14 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;
[
arg0 0 [] MOV ! load stack_chain
arg0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
[
(JMP) drop
] rc-relative rt-primitive 1 jit-primitive jit-define
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call

15
basis/cpu/x86/64/64.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
slots splitting assocs combinators cpu.x86.assembler
slots splitting assocs combinators make locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
@ -24,6 +24,19 @@ M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M:: x86.64 %dispatch ( src temp offset -- )
! Load jump table base.
temp HEX: ffffffff MOV
offset cells rc-absolute-cell rel-here
! Add jump table base
src temp ADD
src HEX: 7f [+] JMP
! Fix up the displacement above
cell code-alignment
[ 15 + building get dup pop* push ]
[ align-code ]
bi ;
: param-reg-1 int-regs param-regs first ; inline
: param-reg-2 int-regs param-regs second ; inline
: param-reg-3 int-regs param-regs third ; inline

13
basis/cpu/x86/64/bootstrap.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ;
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
IN: bootstrap.x86
8 \ cell set
@ -16,5 +16,16 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;
[
arg0 0 MOV ! load stack_chain
arg0 arg0 [] MOV
arg0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
[
arg1 0 MOV ! load XT
arg1 JMP ! go
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call

6
basis/cpu/x86/bootstrap.factor
View File

@ -44,12 +44,6 @@ big-endian off
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
[
arg0 0 MOV ! load XT
arg1 stack-reg MOV ! pass callstack pointer as arg 2
arg0 JMP ! go
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
[
(JMP) drop
] rc-relative rt-xt 1 jit-word-jump jit-define

13
basis/cpu/x86/x86.factor
View File

@ -60,19 +60,6 @@ M: x86 %return ( -- ) 0 RET ;
: align-code ( n -- )
0 <repetition> % ;
M:: x86 %dispatch ( src temp -- )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Add jump table base
temp HEX: ffffffff MOV rc-absolute-cell rel-here
src temp ADD
src HEX: 7f [+] JMP
! Fix up the displacement above
cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;

25
basis/deques/deques-docs.factor
View File

@ -4,7 +4,7 @@ IN: deques
HELP: deque-empty?
{ $values { "deque" deque } { "?" "a boolean" } }
{ $description "Returns true if a deque is empty." }
{ $contract "Returns true if a deque is empty." }
{ $notes "This operation is O(1)." } ;
HELP: clear-deque
@ -12,12 +12,6 @@ HELP: clear-deque
{ "deque" deque } }
{ $description "Removes all elements from a deque." } ;
HELP: deque-length
{ $values
{ "deque" deque }
{ "n" integer } }
{ $description "Returns the number of elements in a deque." } ;
HELP: deque-member?
{ $values
{ "value" object } { "deque" deque }
@ -31,7 +25,7 @@ HELP: push-front
HELP: push-front*
{ $values { "obj" object } { "deque" deque } { "node" "a node" } }
{ $description "Push the object onto the front of the deque and return the newly created node." }
{ $contract "Push the object onto the front of the deque and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: push-back
@ -41,7 +35,7 @@ HELP: push-back
HELP: push-back*
{ $values { "obj" object } { "deque" deque } { "node" "a node" } }
{ $description "Push the object onto the back of the deque and return the newly created node." }
{ $contract "Push the object onto the back of the deque and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: push-all-back
@ -56,7 +50,7 @@ HELP: push-all-front
HELP: peek-front
{ $values { "deque" deque } { "obj" object } }
{ $description "Returns the object at the front of the deque." } ;
{ $contract "Returns the object at the front of the deque." } ;
HELP: pop-front
{ $values { "deque" deque } { "obj" object } }
@ -65,12 +59,12 @@ HELP: pop-front
HELP: pop-front*
{ $values { "deque" deque } }
{ $description "Pop the object off the front of the deque." }
{ $contract "Pop the object off the front of the deque." }
{ $notes "This operation is O(1)." } ;
HELP: peek-back
{ $values { "deque" deque } { "obj" object } }
{ $description "Returns the object at the back of the deque." } ;
{ $contract "Returns the object at the back of the deque." } ;
HELP: pop-back
{ $values { "deque" deque } { "obj" object } }
@ -79,13 +73,13 @@ HELP: pop-back
HELP: pop-back*
{ $values { "deque" deque } }
{ $description "Pop the object off the back of the deque." }
{ $contract "Pop the object off the back of the deque." }
{ $notes "This operation is O(1)." } ;
HELP: delete-node
{ $values
{ "node" object } { "deque" deque } }
{ $description "Deletes the node from the deque." } ;
{ $contract "Deletes the node from the deque." } ;
HELP: deque
{ $description "A data structure that has constant-time insertion and removal of elements at both ends." } ;
@ -111,7 +105,7 @@ $nl
"Querying the deque:"
{ $subsection peek-front }
{ $subsection peek-back }
{ $subsection deque-length }
{ $subsection deque-empty? }
{ $subsection deque-member? }
"Adding and removing elements:"
{ $subsection push-front* }
@ -123,7 +117,6 @@ $nl
{ $subsection delete-node }
{ $subsection node-value }
"Utility operations built in terms of the above:"
{ $subsection deque-empty? }
{ $subsection push-front }
{ $subsection push-all-front }
{ $subsection push-back }

5
basis/deques/deques.factor
View File

@ -10,13 +10,10 @@ GENERIC: peek-back ( deque -- obj )
GENERIC: pop-front* ( deque -- )
GENERIC: pop-back* ( deque -- )
GENERIC: delete-node ( node deque -- )
GENERIC: deque-length ( deque -- n )
GENERIC: deque-member? ( value deque -- ? )
GENERIC: clear-deque ( deque -- )
GENERIC: node-value ( node -- value )
: deque-empty? ( deque -- ? )
deque-length zero? ;
GENERIC: deque-empty? ( deque -- ? )
: push-front ( obj deque -- )
push-front* drop ;

14
basis/dlists/dlists-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel quotations
deques ;
deques search-deques hashtables ;
IN: dlists
ARTICLE: "dlists" "Double-linked lists"
@ -18,10 +18,20 @@ $nl
{ $subsection dlist-contains? }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
{ $subsection delete-node-if } ;
{ $subsection delete-node-if }
"Search deque implementation:"
{ $subsection <hashed-dlist> } ;
ABOUT: "dlists"
HELP: <dlist>
{ $values { "list" dlist } }
{ $description "Creates a new double-linked list." } ;
HELP: <hashed-dlist>
{ $values { "search-deque" search-deque } }
{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ;
HELP: dlist-find
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }

19
basis/dlists/dlists-tests.factor
View File

@ -5,7 +5,7 @@ IN: dlists.tests
[ t ] [ <dlist> deque-empty? ] unit-test
[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } } ]
[ <dlist> 1 over push-front ] unit-test
! Make sure empty lists are empty
@ -17,10 +17,10 @@ IN: dlists.tests
[ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
[ 1 ] [ <dlist> 1 over push-back pop-front ] unit-test
[ 1 ] [ <dlist> 1 over push-back pop-back ] unit-test
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-front* ] unit-test
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-back* ] unit-test
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-front* ] unit-test
[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-back* ] unit-test
[ T{ dlist f f f } ] [ <dlist> 1 over push-front dup pop-front* ] unit-test
[ T{ dlist f f f } ] [ <dlist> 1 over push-front dup pop-back* ] unit-test
[ T{ dlist f f f } ] [ <dlist> 1 over push-back dup pop-front* ] unit-test
[ T{ dlist f f f } ] [ <dlist> 1 over push-back dup pop-back* ] unit-test
! Test the prev,next links for two nodes
[ f ] [
@ -52,15 +52,6 @@ IN: dlists.tests
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop deque-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop deque-length ] unit-test
[ 0 ] [ <dlist> deque-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front deque-length ] unit-test
[ 0 ] [ <dlist> 1 over push-front dup pop-front* deque-length ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test

75
basis/dlists/dlists.factor
View File

@ -2,51 +2,57 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors deques
summary ;
search-deques summary hashtables ;
IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist new
0 >>length ;
M: dlist deque-length length>> ;
<PRIVATE
TUPLE: dlist-node obj prev next ;
MIXIN: ?dlist-node
INSTANCE: f ?dlist-node
TUPLE: dlist-node obj { prev ?dlist-node } { next ?dlist-node } ;
INSTANCE: dlist-node ?dlist-node
C: <dlist-node> dlist-node
PRIVATE>
TUPLE: dlist
{ front ?dlist-node }
{ back ?dlist-node } ;
: <dlist> ( -- list )
dlist new ; inline
: <hashed-dlist> ( -- search-deque )
20 <hashtable> <dlist> <search-deque> ;
M: dlist deque-empty? front>> not ;
M: dlist-node node-value obj>> ;
: inc-length ( dlist -- )
[ 1+ ] change-length drop ; inline
: dec-length ( dlist -- )
[ 1- ] change-length drop ; inline
: set-prev-when ( dlist-node dlist-node/f -- )
[ (>>prev) ] [ drop ] if* ;
[ (>>prev) ] [ drop ] if* ; inline
: set-next-when ( dlist-node dlist-node/f -- )
[ (>>next) ] [ drop ] if* ;
[ (>>next) ] [ drop ] if* ; inline
: set-next-prev ( dlist-node -- )
dup next>> set-prev-when ;
dup next>> set-prev-when ; inline
: normalize-front ( dlist -- )
dup back>> [ f >>front ] unless drop ;
dup back>> [ f >>front ] unless drop ; inline
: normalize-back ( dlist -- )
dup front>> [ f >>back ] unless drop ;
dup front>> [ f >>back ] unless drop ; inline
: set-back-to-front ( dlist -- )
dup back>> [ dup front>> >>back ] unless drop ;
dup back>> [ dup front>> >>back ] unless drop ; inline
: set-front-to-back ( dlist -- )
dup front>> [ dup back>> >>front ] unless drop ;
dup front>> [ dup back>> >>front ] unless drop ; inline
: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
over [
@ -62,22 +68,20 @@ M: dlist-node node-value obj>> ;
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ;
dup next>> swap prev>> set-next-when ; inline
PRIVATE>
M: dlist push-front* ( obj dlist -- dlist-node )
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep
[ set-back-to-front ] keep
inc-length ;
set-back-to-front ;
M: dlist push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
set-front-to-back ;
ERROR: empty-dlist ;
@ -88,31 +92,27 @@ M: dlist peek-front ( dlist -- obj )
front>> [ obj>> ] [ empty-dlist ] if* ;
M: dlist pop-front* ( dlist -- )
dup front>> [ empty-dlist ] unless
[
dup front>>
dup front>> [ empty-dlist ] unless*
dup next>>
f rot (>>next)
f over set-prev-when
swap (>>front)
] keep
[ normalize-back ] keep
dec-length ;
normalize-back ;
M: dlist peek-back ( dlist -- obj )
back>> [ obj>> ] [ empty-dlist ] if* ;
M: dlist pop-back* ( dlist -- )
dup back>> [ empty-dlist ] unless
[
dup back>>
dup back>> [ empty-dlist ] unless*
dup prev>>
f rot (>>prev)
f over set-next-when
swap (>>back)
] keep
[ normalize-front ] keep
dec-length ;
normalize-front ;
: dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose
@ -128,7 +128,7 @@ M: dlist delete-node ( dlist-node dlist -- )
{
{ [ 2dup front>> eq? ] [ nip pop-front* ] }
{ [ 2dup back>> eq? ] [ nip pop-back* ] }
[ dec-length unlink-node ]
[ drop unlink-node ]
} cond ;
: delete-node-if* ( dlist quot -- obj/f ? )
@ -148,7 +148,6 @@ M: dlist delete-node ( dlist-node dlist -- )
M: dlist clear-deque ( dlist -- )
f >>front
f >>back
0 >>length
drop ;
: dlist-each ( dlist quot -- )

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

@ -42,7 +42,7 @@ HELP: doc-lines
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
HELP: each-line
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( string -- )" } } }
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( string -- )" } } }
{ $description "Applies the quotation to each line in the range." }
{ $notes "The range is created by calling " { $link <slice> } "." }
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;

6
basis/editors/emacs/emacs.factor
View File

@ -1,11 +1,11 @@
USING: definitions io.launcher kernel parser words sequences math
math.parser namespaces editors make ;
math.parser namespaces editors make system ;
IN: editors.emacs
: emacsclient ( file line -- )
[
"emacsclient" ,
"--no-wait" ,
\ emacsclient get "emacsclient" or ,
os windows? [ "--no-wait" , ] unless
"+" swap number>string append ,
,
] { } make try-process ;

1
basis/editors/etexteditor/authors.txt Executable file
View File

@ -0,0 +1 @@
Kibleur Christophe

18
basis/editors/etexteditor/etexteditor.factor Executable file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Kibleur Christophe.
! See http://factorcode.org/license.txt for BSD license.
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 make ;
IN: editors.etexteditor
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
program-files "e\\e.exe" append-path
] unless* ;
: etexteditor ( file line -- )
[
etexteditor-path ,
[ , ] [ "--line" , number>string , ] bi*
] { } make run-detached drop ;
[ etexteditor ] edit-hook set-global

1
basis/editors/etexteditor/summary.txt Executable file
View File

@ -0,0 +1 @@
etexteditor integration

1
basis/editors/etexteditor/tags.txt Executable file
View File

@ -0,0 +1 @@
unportable

170
basis/furnace/actions/actions-docs.factor Normal file
View File

@ -0,0 +1,170 @@
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
furnace.redirection strings multiline ;
IN: furnace.actions
HELP: <action>
{ $values { "action" action } }
{ $description "Creates a new action." } ;
HELP: <chloe-content>
{ $values
{ "path" "a pathname string" }
{ "response" response }
}
{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;
HELP: <page-action>
{ $values { "page" action } }
{ $description "Creates a new action which serves a Chloe template when servicing a GET request." } ;
HELP: action
{ $class-description "The class of Furnace actions. New instances are created with " { $link <action> } ". New instances of subclasses can be created with " { $link new-action } ". The " { $link page-action } " class is a useful subclass."
$nl
"Action slots are documented in " { $link "furnace.actions.config" } "." } ;
HELP: new-action
{ $values
{ "class" class }
{ "action" action }
}
{ $description "Constructs a subclass of " { $link action } "." } ;
HELP: page-action
{ $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
HELP: param
{ $values
{ "name" string }
{ "value" string }
}
{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
HELP: params
{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
HELP: validate-integer-id
{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." }
{ $examples
{ $code
"<action>"
" ["
" validate-integer-id"
" \"id\" value <person> select-tuple from-object"
" ] >>init"
}
} ;
HELP: validate-params
{ $values
{ "validators" "an association list mapping parameter names to validator quotations" }
}
{ $description "Validates query or POST parameters, depending on the request type, and stores them in " { $link "html.forms.values" } ". The validator quotations can execute " { $link "validators" } "." }
{ $examples
"A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:"
{ $code
<" : validate-todo ( -- )
{
{ "summary" [ v-one-line ] }
{ "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
{ "description" [ v-required ] }
} validate-params ;">
}
} ;
HELP: validation-failed
{ $description "Stops processing the current request and takes action depending on the type of the current request:"
{ $list
{ "For GET or HEAD requests, the client receives a " { $link <400> } " response." }
{ "For POST requests, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." }
}
"This word is called by " { $link validate-params } " and can also be called directly. For more details, see " { $link "furnace.actions.lifecycle" } "." } ;
ARTICLE: "furnace.actions.page.example" "Furnace page action example"
"The " { $vocab-link "webapps.counter" } " vocabulary defines a subclass of " { $link dispatcher } ":"
{ $code "TUPLE: counter-app < dispatcher ;" }
"The " { $snippet "<counter-app>" } " constructor word creates a new instance of the " { $snippet "counter-app" } " class, and adds a " { $link page-action } " instance to the dispatcher. This " { $link page-action } " has its " { $slot "template" } " slot set as follows,"
{ $code "{ counter-app \"counter\" } >>template" }
"This means the action will serve the Chloe template located at " { $snippet "resource:extra/webapps/counter/counter.xml" } " upon receiving a GET request." ;
ARTICLE: "furnace.actions.page" "Furnace page actions"
"Page actions implement the common case of an action that simply serves a Chloe template in response to a GET request."
{ $subsection page-action }
{ $subsection <page-action> }
"When using a page action, instead of setting the " { $slot "display" } " slot, the " { $slot "template" } " slot is set instead. The " { $slot "init" } ", " { $slot "authorize" } ", " { $slot "validate" } " and " { $slot "submit" } " slots can still be set as usual."
$nl
"The " { $slot "template" } " slot of a " { $link page-action } " contains a pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file."
{ $subsection "furnace.actions.page.example" } ;
ARTICLE: "furnace.actions.config" "Furnace action configuration"
"Actions have the following slots:"
{ $table
{ { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } }
{ { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } }
{ { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } }
{ { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } }
{ { $slot "validate" } { "A quotation called at the beginning of a POST request to validate POST parameters." } }
{ { $slot "submit" } { "A quotation called after the " { $slot "validate" } " quotation in a POST request. This quotation must return an HTTP " { $link response } "." } }
}
"At least one of the " { $slot "display" } " and " { $slot "submit" } " slots must be set, otherwise the action will be useless." ;
ARTICLE: "furnace.actions.validation" "Form validation with actions"
"The action code is set up so that the " { $slot "init" } " quotation can validate query parameters, and the " { $slot "validate" } " quotation can validate POST parameters."
$nl
"A word to validate parameters and make them available as HTML form values (see " { $link "html.forms.values" } "); typically this word is invoked from the " { $slot "init" } " and " { $slot "validate" } " quotations:"
{ $subsection validate-params }
"The above word expects an association list mapping parameter names to validator quotations; validator quotations can use the words in the "
"Custom validation logic can invoke a word when validation fails; " { $link validate-params } " invokes this word for you:"
{ $subsection validation-failed }
"If validation fails, no more action code is executed, and the client is redirected back to the originating page, where validation errors can be displayed. Note that validation errors are rendered automatically by the " { $link "html.components" } " words, and in particular, " { $link "html.templates.chloe" } " use these words." ;
ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle"
{ $heading "GET request lifecycle" }
"A GET request results in the following sequence of events:"
{ $list
{ "The " { $snippet "init" } " quotation is called." }
{ "The " { $snippet "authorize" } " quotation is called." }
{ "If the GET request was generated as a result of form validation failing during a POST, then the form values entered by the user, along with validation errors, are stored in " { $link "html.forms.values" } "." }
{ "The " { $snippet "display" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack." }
}
"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a GET request, the client receives a " { $link <400> } " error."
{ $heading "HEAD request lifecycle" }
"A HEAD request proceeds exactly like a GET request. The only difference is that the " { $slot "body" } " slot of the " { $link response } " object is never rendered."
{ $heading "POST request lifecycle" }
"A POST request results in the following sequence of events:"
{ $list
{ "The " { $snippet "validate" } " quotation is called." }
{ "The " { $snippet "authorize" } " quotation is called." }
{ "The " { $snippet "submit" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack. By convention, this response should be a " { $link <redirect> } "." }
}
"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ;
ARTICLE: "furnace.actions.impl" "Furnace actions implementation"
"The following words are used by the action implementation and there is rarely any reason to call them directly:"
{ $subsection new-action }
{ $subsection param }
{ $subsection params } ;
ARTICLE: "furnace.actions" "Furnace actions"
"The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle."
$nl
"Other than form validation capability, actions are also often simpler to use than implementing new responders directly, since creating a new class is not required, and the action dispatches on the request type (GET, HEAD, or POST)."
$nl
"The class of actions:"
{ $subsection action }
"Creating a new action:"
{ $subsection <action> }
"Once created, an action needs to be configured; typically the creation and configuration of an action is encapsulated into a single word:"
{ $subsection "furnace.actions.config" }
"Validating forms with actions:"
{ $subsection "furnace.actions.validation" }
"More about the form validation lifecycle:"
{ $subsection "furnace.actions.lifecycle" }
"A convenience class:"
{ $subsection "furnace.actions.page" }
"Low-level features:"
{ $subsection "furnace.actions.impl" } ;
ABOUT: "furnace.actions"

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

@ -22,18 +22,7 @@ SYMBOL: params
SYMBOL: rest
: render-validation-messages ( -- )
form get errors>>
[
<ul "errors" =class ul>
[ <li> escape-string write </li> ] each
</ul>
] unless-empty ;
CHLOE: validation-messages
drop [ render-validation-messages ] [code] ;
TUPLE: action rest authorize init display validate submit ;
TUPLE: action rest init authorize display validate submit ;
: new-action ( class -- action )
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline

42
basis/furnace/alloy/alloy-docs.factor Normal file
View File

@ -0,0 +1,42 @@
IN: furnace.alloy
USING: help.markup help.syntax db multiline ;
HELP: init-furnace-tables
{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
HELP: <alloy>
{ $values { "responder" "a responder" } { "db" db } { "responder'" "an alloy responder" } }
{ $description "Wraps the responder with support for asides, conversations, sessions and database persistence." }
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
{ $code
<" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>
counter-db <alloy>
main-responder set-global
8080 httpd ;">
}
} ;
HELP: start-expiring
{ $values { "db" db } }
{ $description "Starts a timer which expires old session state from the given database." } ;
ARTICLE: "furnace.alloy" "Furnace alloy responder"
"The " { $vocab-link "furnace.alloy" } " vocabulary implements a convenience responder which combines several Furnace features into one easy-to-use wrapper:"
{ $list
{ $link "furnace.asides" }
{ $link "furnace.conversations" }
{ $link "furnace.sessions" }
{ $link "furnace.db" }
}
"A word to wrap a responder in an alloy:"
{ $subsection <alloy> }
"Initializing database tables for asides, conversations and sessions:"
{ $subsection init-furnace-tables }
"Start a timer to expire asides, conversations and sessions:"
{ $subsection start-expiring } ;
ABOUT: "furnace.alloy"

4
basis/furnace/alloy/alloy.factor
View File

@ -4,7 +4,6 @@ USING: kernel sequences db.tuples alarms calendar db fry
furnace.db
furnace.cache
furnace.asides
furnace.referrer
furnace.sessions
furnace.conversations
furnace.auth.providers
@ -24,8 +23,7 @@ IN: furnace.alloy
<conversations>
<sessions>
] dip
<db-persistence>
<check-form-submissions> ;
<db-persistence> ;
: start-expiring ( db -- )
'[

33
basis/furnace/asides/asides-docs.factor Normal file
View File

@ -0,0 +1,33 @@
USING: help.markup help.syntax io.streams.string urls
furnace.redirection http furnace.sessions furnace.db ;
IN: furnace.asides
HELP: <asides>
{ $values
{ "responder" "a responder" }
{ "responder'" "a new responder" }
}
{ $description "Creates a new " { $link asides } " responder wrapping an existing responder." } ;
HELP: begin-aside
{ $values { "url" url } }
{ $description "Begins an aside. When the current action returns a " { $link <redirect> } ", the redirect will have query parameters which reference the current page via an opaque handle." } ;
HELP: end-aside
{ $values { "default" url } { "response" response } }
{ $description "Ends an aside. If an aside is currently active, the response redirects the client " } ;
ARTICLE: "furnace.asides" "Furnace asides"
"The " { $vocab-link "furnace.asides" } " vocabulary provides support for sending a user to a page which can then return to the former location."
$nl
"To use asides, wrap your responder in an aside responder:"
{ $subsection <asides> }
"The asides responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
$nl
"Saving the current page in an aside which propagates through " { $link <redirect> } " responses:"
{ $subsection begin-aside }
"Returning from an aside:"
{ $subsection end-aside }
"Asides are used by " { $vocab-link "furnace.auth.login" } "; when the client requests a protected page, an aside begins and the client is redirected to a login page. Upon a successful login, the aside ends and the client returns to the protected page. If the client directly visits the login page and logs in, there is no current aside, so the client is sent to the default URL passed to " { $link end-aside } ", which in the case of login is the root URL." ;
ABOUT: "furnace.asides"

193
basis/furnace/auth/auth-docs.factor Normal file
View File

@ -0,0 +1,193 @@
USING: assocs classes help.markup help.syntax kernel
quotations strings words furnace.auth.providers.db
checksums.sha2 furnace.auth.providers math byte-arrays
http multiline ;
IN: furnace.auth
HELP: <protected>
{ $values
{ "responder" "a responder" }
{ "protected" "a new responder" }
}
{ $description "Wraps a responder in a protected responder. Access to the wrapped responder will be conditional upon the client authenticating with the current authentication realm." } ;
HELP: >>encoded-password
{ $values { "user" user } { "string" string } }
{ $description "Sets the user's password by combining it with a random salt and encoding it with the current authentication realm's checksum." } ;
HELP: capabilities
{ $var-description "Global variable holding all defined capabilities. New capabilities may be defined with " { $link define-capability } "." } ;
HELP: check-login
{ $values { "password" string } { "username" string } { "user/f" { $maybe user } } }
{ $description "Checks a username/password pair with the current authentication realm. Outputs a user if authentication succeeded, otherwise outputs " { $link f } "." } ;
HELP: define-capability
{ $values { "word" symbol } }
{ $description "Defines a new capability by adding it to the " { $link capabilities } " global variable." } ;
HELP: encode-password
{ $values
{ "string" string } { "salt" integer }
{ "bytes" byte-array }
}
{ $description "Encodes a password with the current authentication realm's checksum." } ;
HELP: have-capabilities?
{ $values
{ "capabilities" "a sequence of capabilities" }
{ "?" "a boolean" }
}
{ $description "Tests if the currently logged-in user possesses the given capabilities." } ;
HELP: logged-in-user
{ $var-description "Holds the currently logged-in user." } ;
HELP: login-required
{ $values
{ "description" string } { "capabilities" "a sequence of capabilities" }
}
{ $description "Redirects the client to a login page." } ;
HELP: login-required*
{ $values
{ "description" string } { "capabilities" "a sequence of capabilities" } { "realm" "an authenticaiton realm" }
{ "response" response }
}
{ $contract "Constructs an HTTP response for redirecting the client to a login page." } ;
HELP: protected
{ $class-description "The class of protected responders. See " { $link "furnace.auth.protected" } " for a description of usage and slots." } ;
HELP: realm
{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ;
HELP: uchange
{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ;
HELP: uget
{ $values { "key" symbol } { "value" object } }
{ $description "Outputs the value of a user profile variable." } ;
HELP: uset
{ $values { "value" object } { "key" symbol } }
{ $description "Sets the value of a user profile variable." } ;
HELP: username
{ $values { "string/f" { $maybe string } }
}
{ $description "Outputs the currently logged-in username, or " { $link f } " if no user is logged in." } ;
HELP: users
{ $values { "provider" "an authentication provider" } }
{ $description "Outputs the current authentication provider." } ;
ARTICLE: "furnace.auth.capabilities" "Authentication capabilities"
"Every user in the authentication framework has a set of associated capabilities."
$nl
"Defining new capabilities:"
{ $subsection define-capability }
"Capabilities are stored in a global variable:"
{ $subsection capabilities }
"Protected resources can be restricted to users possessing certain capabilities only by storing a sequence of capabilities in the " { $slot "capabilities" } " slot of a " { $link protected } " instance." ;
ARTICLE: "furnace.auth.protected" "Protected resources"
"To restrict access to authenticated clients only, wrap a responder in a protected responder."
{ $subsection protected }
{ $subsection <protected> }
"Protected responders have the following two slots which may be set:"
{ $table
{ { $slot "description" } "A string identifying the protected resource for user interface purposes" }
{ { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } }
} ;
ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration"
"Instances of subclasses of " { $link realm } " have the following slots which may be set:"
{ $table
{ { $slot "name" } "A string identifying the realm for user interface purposes" }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } }
{ { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } }
{ { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } }
} ;
ARTICLE: "furnace.auth.providers" "Authentication providers"
"The " { $vocab-link "furnace.auth" } " framework looks up users using an authentication provider. Different authentication providers can be swapped in to implement various authentication strategies."
$nl
"Each authentication realm has a provider stored in the " { $slot "users" } " slot. The default provider is " { $link users-in-db } "."
{ $subsection "furnace.auth.providers.protocol" }
{ $subsection "furnace.auth.providers.null" }
{ $subsection "furnace.auth.providers.assoc" }
{ $subsection "furnace.auth.providers.db" } ;
ARTICLE: "furnace.auth.features" "Optional authentication features"
"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
{ $subsection "furnace.auth.features.deactivate-user" }
{ $subsection "furnace.auth.features.edit-profile" }
{ $subsection "furnace.auth.features.recover-password" }
{ $subsection "furnace.auth.features.registration" } ;
ARTICLE: "furnace.auth.realms" "Authentication realms"
"The superclass of authentication realms:"
{ $subsection realm }
"There are two concrete implementations:"
{ $subsection "furnace.auth.basic" }
{ $subsection "furnace.auth.login" }
"Authentication realms need to be configured after construction."
{ $subsection "furnace.auth.realm-config" } ;
ARTICLE: "furnace.auth.users" "User profiles"
"A responder wrapped in an authentication realm may access the currently logged-in user,"
{ $subsection logged-in-user }
"as well as the logged-in username:"
{ $subsection username }
"Values can also be stored in user profile variables:"
{ $subsection uget }
{ $subsection uset }
{ $subsection uchange }
"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
ARTICLE: "furnace.auth.example" "Furnace authentication example"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':"
{ $code
<" <protected>
"view your todo list" >>description">
}
"The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:"
{ $code
<" <protected>
"delete wiki articles" >>description
{ can-delete-wiki-articles? } >>capabilities">
}
"The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:"
{ $code
<" : <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
allow-deactivation ;">
} ;
ARTICLE: "furnace.auth" "Furnace authentication"
"The " { $vocab-link "furnace.auth" } " vocabulary implements a pluggable authentication framework."
$nl
"Usernames and passwords are verified using an " { $emphasis "authentication provider" } "."
{ $subsection "furnace.auth.providers" }
"Users have capabilities assigned to them."
{ $subsection "furnace.auth.capabilities" }
"An " { $emphasis "authentication realm" } " is a responder which manages access to protected resources."
{ $subsection "furnace.auth.realms" }
"Actions contained inside an authentication realm can be protected by wrapping them with a responder."
{ $subsection "furnace.auth.protected" }
"Actions contained inside an authentication realm can access the currently logged-in user profile."
{ $subsection "furnace.auth.users" }
"Authentication realms can be adorned with additional functionality."
{ $subsection "furnace.auth.features" }
"An administration tool."
{ $subsection "furnace.auth.user-admin" }
"A concrete example."
{ $subsection "furnace.auth.example" } ;
ABOUT: "furnace.auth"

16
basis/furnace/auth/basic/basic-docs.factor Normal file
View File

@ -0,0 +1,16 @@
USING: help.markup help.syntax ;
IN: furnace.auth.basic
HELP: <basic-auth-realm>
{ $values { "responder" "a responder" } { "name" "an authentication realm name" } { "realm" basic-auth-realm } }
{ $description "Wraps a responder in a basic authentication realm. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ;
HELP: basic-auth-realm
{ $class-description "The basic authentication realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ;
ARTICLE: "furnace.auth.basic" "Basic authentication"
"The " { $vocab-link "furnace.auth.basic" } " vocabulary implements HTTP basic authentication."
{ $subsection basic-auth-realm }
{ $subsection <basic-auth-realm> } ;
ABOUT: "furnace.auth.basic"

26
basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor Normal file
View File

@ -0,0 +1,26 @@
USING: help.markup help.syntax kernel ;
IN: furnace.auth.features.deactivate-user
HELP: allow-deactivation
{ $values { "realm" "an authentication realm" } }
{ $description "Adds a " { $snippet "deactivate-user" } " action to an authentication realm." } ;
HELP: allow-deactivation?
{ $values { "?" "a boolean" } }
{ $description "Outputs true if the current authentication realm allows user profile deactivation." } ;
ARTICLE: "furnace.auth.features.deactivate-user" "User profile deactivation"
"The " { $vocab-link "furnace.auth.features.deactivate-user" } " vocabulary implements an authentication feature for user profile deactivation, allowing users to voluntarily deactivate their account."
$nl
"To enable this feature, call the following word on an authentication realm:"
{ $subsection allow-deactivation }
"To check if deactivation is enabled:"
{ $subsection allow-deactivation? }
"This feature adds a " { $snippet "deactivate-user" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
{ $code
"<t:if t:code=\"furnace.auth.features.deactivate-user:allow-deactivation?\">"
" <t:button t:action=\"$realm/deactivate-user\">Deactivate user</t:button>"
"</t:if>"
} ;
ABOUT: "furnace.auth.features.deactivate-user"

24
basis/furnace/auth/features/edit-profile/edit-profile-docs.factor Normal file
View File

@ -0,0 +1,24 @@
USING: help.markup help.syntax kernel ;
IN: furnace.auth.features.edit-profile
HELP: allow-edit-profile
{ $values { "realm" "an authentication realm" } }
{ $description "Adds an " { $snippet "edit-profile" } " action to an authentication realm." } ;
HELP: allow-edit-profile?
{ $values { "?" "a boolean" } }
{ $description "Outputs true if the current authentication realm allows user profile editing." } ;
ARTICLE: "furnace.auth.features.edit-profile" "User profile editing"
"The " { $vocab-link "furnace.auth.features.edit-profile" } " vocabulary implements an authentication feature for user profile editing, allowing users to change some details of their account."
$nl
"To enable this feature, call the following word on an authentication realm:"
{ $subsection allow-edit-profile }
"To check if profile editing is enabled:"
{ $subsection allow-edit-profile? }
"This feature adds an " { $snippet "edit-profile" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
{ $code
"<t:if t:code=\"furnace.auth.features.edit-profile:allow-edit-profile?\">"
" <t:button t:action=\"$realm/edit-profile\">Edit profile</t:button>"
"</t:if>"
} ;

2
basis/furnace/auth/features/edit-profile/edit-profile.factor
View File

@ -58,7 +58,7 @@ IN: furnace.auth.features.edit-profile
<protected>
"edit your profile" >>description ;
: allow-edit-profile ( login -- login )
: allow-edit-profile ( realm -- realm )
<edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
: allow-edit-profile? ( -- ? )

2
basis/furnace/auth/features/edit-profile/edit-profile.xml
View File

@ -62,7 +62,7 @@
<p>
<button>Update</button>
<t:validation-messages />
<t:validation-errors />
</p>
</t:form>

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

@ -32,7 +32,7 @@
<p>
<button>Set password</button>
<t:validation-messages />
<t:validation-errors />
</p>
</t:form>

34
basis/furnace/auth/features/recover-password/recover-password-docs.factor Normal file
View File

@ -0,0 +1,34 @@
USING: help.markup help.syntax kernel strings urls ;
IN: furnace.auth.features.recover-password
HELP: allow-password-recovery
{ $values { "realm" "an authentication realm" } }
{ $description "Adds a " { $snippet "recover-password" } " action to an authentication realm." } ;
HELP: allow-password-recovery?
{ $values { "?" "a boolean" } }
{ $description "Outputs true if the current authentication realm allows user password recovery." } ;
HELP: lost-password-from
{ $var-description "A variable with the source e-mail address of password recovery e-mails." } ;
ARTICLE: "furnace.auth.features.recover-password" "User password recovery"
"The " { $vocab-link "furnace.auth.features.recover-password" }
" vocabulary implements an authentication feature for user password recovery, allowing users to get a new password e-mailed to them in the event they forget their current one."
$nl
"To enable this feature, first call the following word on an authentication realm,"
{ $subsection allow-password-recovery }
"Then set a global configuration variable:"
{ $subsection lost-password-from }
"In addition, the " { $link "smtp" } " may need to be configured as well."
$nl
"To check if password recovery is enabled:"
{ $subsection allow-password-recovery? }
"This feature adds a " { $snippet "recover-password" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
{ $code
"<t:if t:code=\"furnace.auth.features.recover-password:allow-password-recovery?\">"
" <t:button t:action=\"$realm/recover-password\">Recover password</t:button>"
"</t:if>"
} ;
ABOUT: "furnace.auth.features.recover-password"

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

@ -110,7 +110,7 @@ SYMBOL: lost-password-from
<page-action>
{ realm "features/recover-password/recover-4" } >>template ;
: allow-password-recovery ( login -- login )
: allow-password-recovery ( realm -- realm )
<recover-action-1> <auth-boilerplate>
"recover-password" add-responder
<recover-action-2> <auth-boilerplate>

2
basis/furnace/auth/features/registration/register.xml
View File

@ -63,7 +63,7 @@
<p>
<button>Register</button>
<t:validation-messages />
<t:validation-errors />
</p>

24
basis/furnace/auth/features/registration/registration-docs.factor Normal file
View File

@ -0,0 +1,24 @@
USING: help.markup help.syntax kernel ;
IN: furnace.auth.features.registration
HELP: allow-registration
{ $values { "realm" "an authentication realm" } }
{ $description "Adds a " { $snippet "registration" } " action to an authentication realm." } ;
HELP: allow-registration?
{ $values { "?" "a boolean" } }
{ $description "Outputs true if the current authentication realm allows user registration." } ;
ARTICLE: "furnace.auth.features.registration" "User registration"
"The " { $vocab-link "furnace.auth.features.registration" } " vocabulary implements an authentication feature for user registration, allowing new users to create accounts."
$nl
"To enable this feature, call the following word on an authentication realm:"
{ $subsection allow-registration }
"To check if user registration is enabled:"
{ $subsection allow-registration? }
"This feature adds a " { $snippet "register" } " action to the realm. A link to this action is inserted on the login page if the " { $vocab-link "furnace.auth.login" } " authentication realm is used. Links to this action can be inserted from other pages using the following Chloe XML snippet:"
{ $code
"<t:if t:code=\"furnace.auth.features.registration:allow-registration?\">"
" <t:button t:action=\"$realm/register\">Register</t:button>"
"</t:if>"
} ;

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

@ -38,7 +38,7 @@ IN: furnace.auth.features.registration
<auth-boilerplate>
<secure-realm-only> ;
: allow-registration ( login -- login )
: allow-registration ( realm -- realm )
<register-action> "register" add-responder ;
: allow-registration? ( -- ? )

23
basis/furnace/auth/login/login-docs.factor Normal file
View File

@ -0,0 +1,23 @@
USING: help.markup help.syntax kernel strings ;
IN: furnace.auth.login
HELP: <login-realm>
{ $values
{ "responder" "a responder" } { "name" string }
{ "realm" "a new responder" }
}
{ $description "Wraps a responder in a new login realm with the given name. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ;
HELP: login-realm
{ $class-description "The login realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ;
ARTICLE: "furnace.auth.login" "Login authentication"
"The " { $vocab-link "furnace.auth.login" } " vocabulary implements an authentication realm which displays a login page with a username and password field."
{ $subsection login-realm }
{ $subsection <login-realm> }
"The " { $snippet "logout" } " action logs the user out of the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:"
{ $code
"<t:button t:action=\"$login-realm/logout\">Logout</t:button>"
} ;
ABOUT: "furnace.auth.login"

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

@ -58,9 +58,13 @@ M: login-realm modify-form ( responder -- )
permit-id get [ delete-permit ] when*
URL" $realm" end-aside ;
<PRIVATE
SYMBOL: description
SYMBOL: capabilities
PRIVATE>
: flashed-variables { description capabilities } ;
: login-failed ( -- * )
@ -107,7 +111,7 @@ M: login-realm login-required* ( description capabilities login -- response )
M: login-realm user-registered ( user realm -- )
drop successful-login ;
: <login-realm> ( responder name -- auth )
: <login-realm> ( responder name -- realm )
login-realm new-realm
<login-action> "login" add-responder
<logout-action> "logout" add-responder

2
basis/furnace/auth/login/login.xml
View File

@ -36,7 +36,7 @@
<p>
<button>Log in</button>
<t:validation-messages />
<t:validation-errors />
</p>

14
basis/furnace/auth/providers/assoc/assoc-docs.factor Normal file
View File

@ -0,0 +1,14 @@
USING: help.markup help.syntax io.streams.string ;
IN: furnace.auth.providers.assoc
HELP: <users-in-memory>
{ $values { "provider" users-in-memory } }
{ $description "Creates a new authentication provider which stores the usernames and passwords in an associative mapping." } ;
ARTICLE: "furnace.auth.providers.assoc" "In-memory authentication provider"
"The " { $vocab-link "furnace.auth.providers.assoc" } " vocabulary implements an authentication provider which looks up usernames and passwords in an associative mapping."
{ $subsection users-in-memory }
{ $subsection <users-in-memory> }
"The " { $slot "assoc" } " slot of the " { $link users-in-memory } " tuple maps usernames to checksums of passwords." ;
ABOUT: "furnace.auth.providers.assoc"

13
basis/furnace/auth/providers/db/db-docs.factor Normal file
View File

@ -0,0 +1,13 @@
USING: help.markup help.syntax ;
IN: furnace.auth.providers.db
HELP: users-in-db
{ $class-description "Singleton class implementing the database authentication provider." } ;
ARTICLE: "furnace.auth.providers.db" "Database authentication provider"
"The " { $vocab-link "furnace.auth.providers.db" } " vocabulary implements an authentication provider which looks up authentication requests in the " { $snippet "USERS" } " table of the current database. The database schema is Factor-specific, and the table should be initialized by calling"
{ $code "users create-table" }
"The authentication provider class:"
{ $subsection users-in-db } ;
ABOUT: "furnace.auth.providers.db"

10
basis/furnace/auth/providers/null/null-docs.factor Normal file
View File

@ -0,0 +1,10 @@
USING: help.markup help.syntax ;
IN: furnace.auth.providers.null
HELP: no-users
{ $class-description "Singleton class implementing the dummy authentication provider." } ;
ARTICLE: "furnace.auth.providers.null" "Dummy authentication provider"
"The " { $vocab-link "furnace.auth.providers.null" } " vocabulary implements an authentication provider which refuses all authentication requests. It is only useful for testing purposes." ;
ABOUT: "furnace.auth.providers.null"

45
basis/furnace/auth/providers/providers-docs.factor Normal file
View File

@ -0,0 +1,45 @@
USING: help.markup help.syntax strings ;
IN: furnace.auth.providers
HELP: user
{ $class-description "The class of users. Instances have the following slots:"
{ $table
{ { $slot "username" } { "The username, used to identify the user for login purposes" } }
{ { $slot "realname" } { "The user's real name, optional" } }
{ { $slot "password" } { "The user's password, encoded with a checksum" } }
{ { $slot "salt" } { "A random salt prepended to the password to ensure that two users with the same plain-text password still have different checksum output" } }
{ { $slot "email" } { "The user's e-mail address, optional" } }
{ { $slot "ticket" } { "Used for password recovery" } }
{ { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } }
{ { $slot "profile" } { "A hashtable with webapp-specific configuration" } }
{ { $slot "deleted" } { "A boolean indicating whether the user is active or not. This allows a user account to be deactivated without removing the user from the database" } }
{ { $slot "changed?" } { "A boolean indicating whether the user has changed since being retrieved from the database" } }
} } ;
HELP: add-user
{ $values { "provider" "an authentication provider" } { "user" user } }
{ $description "A utility word which calls " { $link new-user } " and throws an error if the user already exists." } ;
HELP: get-user
{ $values { "username" string } { "provider" "an authentication provider" } { "user/f" { $maybe user } } }
{ $contract "Looks up a username in the authentication provider." } ;
HELP: new-user
{ $values { "user" user } { "provider" "an authentication provider" } { "user/f" { $maybe user } } }
{ $contract "Adds a new user to the authentication provider. Outputs " { $link f } " if a user with this username already exists." } ;
HELP: update-user
{ $values { "user" user } { "provider" "an authentication provider" } }
{ $contract "Stores a user back to an authentication provider after being changed. This is a no-op with in-memory providers; providers which use an external store will save the user in this word. " } ;
ARTICLE: "furnace.auth.providers.protocol" "Authentication provider protocol"
"The " { $vocab-link "furnace.auth.providers" } " vocabulary implements a protocol for persistence and authentication of users."
$nl
"The class of users:"
{ $subsection user }
"Generic protocol:"
{ $subsection get-user }
{ $subsection new-user }
{ $subsection update-user } ;
ABOUT: "furnace.auth.providers.protocol"

35
basis/furnace/boilerplate/boilerplate-docs.factor Normal file
View File

@ -0,0 +1,35 @@
USING: help.markup help.syntax io.streams.string
http.server.dispatchers ;
IN: furnace.boilerplate
HELP: <boilerplate>
{ $values
{ "responder" "a responder" }
{ "boilerplate" "a new boilerplate responder" }
}
{ $description "Wraps a responder in a boilerplate responder. The boilerplate responder needs to be configured before use; see " { $link "furnace.boilerplate.config" } "." } ;
HELP: boilerplate
{ $class-description "The class of boilerplate responders. Slots are documented in " { $link "furnace.boilerplate.config" } "." } ;
ARTICLE: "furnace.boilerplate.config" "Boilerplate configuration"
"The " { $link boilerplate } " tuple has two slots which can be set:"
{ $table
{ { $slot "template" } { "A pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file." } }
{ { $slot "init" } { "A quotation run before the boilerplate template is rendered. This quotation can set values which the template can then display." } }
} ;
ARTICLE: "furnace.boilerplate.example" "Boilerplate example"
"The " { $vocab-link "webapps.wiki" } " vocabulary uses boilerplate to add a footer and sidebar to every page. Since the footer and sidebar are themselves dynamic content, it sets the " { $slot "init" } " quotation as well as the " { $slot "template" } " slot:"
{ $code "<boilerplate>"
" [ init-sidebars init-relative-link-prefix ] >>init"
" { wiki \"wiki-common\" } >>template" } ;
ARTICLE: "furnace.boilerplate" "Furnace boilerplate support"
"The " { $vocab-link "furnace.boilerplate" } " vocabulary implements a facility for sharing a common header and footer between different pages on a web site. It builds on top of " { $link "html.templates.boilerplate" } "."
{ $subsection <boilerplate> }
{ $subsection "furnace.boilerplate.config" }
{ $subsection "furnace.boilerplate.example" }
{ $see-also "html.templates.chloe.tags.boilerplate" } ;
ABOUT: "furnace.boilerplate"

53
basis/furnace/conversations/conversations-docs.factor Normal file
View File

@ -0,0 +1,53 @@
USING: help.markup help.syntax urls http words kernel
furnace.sessions furnace.db ;
IN: furnace.conversations
HELP: <conversations>
{ $values
{ "responder" "a responder" }
{ "responder'" "a new responder" }
}
{ $description "Creates a new " { $link conversations } " responder wrapping an existing responder." } ;
HELP: begin-conversation
{ $description "Starts a new conversation scope. Values can be stored in the conversation scope with " { $link cset } ", and the conversation can be continued with " { $link <continue-conversation> } "." } ;
HELP: end-conversation
{ $description "Ends the current conversation scope." } ;
HELP: <continue-conversation>
{ $values { "url" url } { "response" response } }
{ $description "Creates an HTTP response which redirects the client to the specified URL while continuing the conversation. Any values set in the current conversation scope will be visible to the resonder handling the URL." } ;
HELP: cget
{ $values { "key" symbol } { "value" object } }
{ $description "Outputs the value of a conversation variable." } ;
HELP: cset
{ $values { "value" object } { "key" symbol } }
{ $description "Sets the value of a conversation variable." } ;
HELP: cchange
{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the conversation variable, and assigns the resulting value back to the variable." } ;
ARTICLE: "furnace.conversations" "Furnace conversation scope"
"The " { $vocab-link "furnace.conversations" } " vocabulary implements conversation scope, which allows data to be passed between requests on a finer level of granularity than session scope."
$nl
"Conversation scope is used by form validation to pass validation errors between requests."
$nl
"To use conversation scope, wrap your responder in an conversation responder:"
{ $subsection <conversations> }
"The conversations responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
$nl
"Managing conversation scopes:"
{ $subsection begin-conversation }
{ $subsection end-conversation }
{ $subsection <continue-conversation> }
"Reading and writing conversation variables:"
{ $subsection cget }
{ $subsection cset }
{ $subsection cchange }
"Note that conversation scope is serialized as part of the session, which means that only serializable objects can be stored there. See " { $link "furnace.sessions.serialize" } " for details." ;
ABOUT: "furnace.conversations"

16
basis/furnace/db/db-docs.factor Normal file
View File

@ -0,0 +1,16 @@
USING: help.markup help.syntax db http.server ;
IN: furnace.db
HELP: <db-persistence>
{ $values
{ "responder" "a responder" } { "db" db }
{ "responder'" db-persistence }
}
{ $description "Wraps a responder with database persistence support. The responder's " { $link call-responder* } " method will run in a " { $link with-db } " scope." } ;
ARTICLE: "furnace.db" "Furnace database support"
"The " { $vocab-link "furnace.db" } " vocabulary implements a responder which maintains a database connection pool and runs each request in a " { $link with-db } " scope."
{ $subsection <db-persistence> }
"The " { $vocab-link "furnace.alloy" } " vocabulary combines database persistence with several other features." ;
ABOUT: "furnace.db"

180
basis/furnace/furnace-docs.factor Normal file
View File

@ -0,0 +1,180 @@
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 setateless 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:"
{ $subsection "furnace.sessions" }
{ $subsection "furnace.conversations" }
{ $subsection "furnace.asides" }
{ $subsection "furnace.presentation" } ;
ARTICLE: "furnace.presentation" "Furnace presentation layer"
"HTML components:"
{ $subsection "html.components" }
{ $subsection "html.forms" }
"Content templates:"
{ $subsection "html.templates" }
{ $subsection "html.templates.chloe" }
{ $subsection "html.templates.fhtml" }
{ $subsection "furnace.boilerplate" }
"Other types of content:"
{ $subsection "furnace.syndication" }
{ $subsection "furnace.json" } ;
ARTICLE: "furnace.load-balancing" "Load balancing and fail-over with Furnace"
"The Furnace session manager persists sessions to a database. This means that HTTP requests can be transparently distributed between multiple Factor HTTP server instances, running the same web app on top of the same database, as long as the web applications do not use mutable global state, such as global variables. The Furnace framework itself does not use any mutable global state." ;
ARTICLE: "furnace" "Furnace framework"
"The " { $vocab-link "furnace" } " vocabulary implements a full-featured web framework on top of the " { $link "http.server" } ". Some of its features include:"
{ $list
"Session management capable of load-balancing and fail-over"
"Form components and validation"
"Authentication system with basic authentication or login pages, and pluggable authentication backends"
"Easy Atom feed syndication"
"Conversation scope and asides for complex page flow"
}
"Major functionality:"
{ $subsection "furnace.actions" }
{ $subsection "furnace.alloy" }
{ $subsection "furnace.persistence" }
{ $subsection "furnace.presentation" }
{ $subsection "furnace.auth" }
{ $subsection "furnace.load-balancing" }
"Utilities:"
{ $subsection "furnace.referrer" }
{ $subsection "furnace.redirection" }
{ $subsection "furnace.extension-points" }
{ $subsection "furnace.misc" }
"Related frameworks:"
{ $subsection "db" }
{ $subsection "xml" }
{ $subsection "http.server" }
{ $subsection "logging" }
{ $subsection "urls" } ;
ABOUT: "furnace"

28
basis/furnace/furnace.factor
View File

@ -90,7 +90,7 @@ M: object modify-form drop ;
} case ;
: referrer ( -- referrer/f )
#! Typo is intentional, its in the HTTP spec!
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
dup [ >url ensure-port [ remap-port ] change-port ] when ;
@ -125,7 +125,31 @@ SYMBOL: exit-continuation
: exit-with ( value -- )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
USE: vocabs.loader
"furnace.actions" require
"furnace.alloy" require
"furnace.asides" require
"furnace.auth" require
"furnace.auth.basic" require
"furnace.auth.features.deactivate-user" require
"furnace.auth.features.edit-profile" require
"furnace.auth.features.recover-password" require
"furnace.auth.features.registration" require
"furnace.auth.login" require
"furnace.auth.providers.assoc" require
"furnace.auth.providers.db" require
"furnace.auth.providers.null" require
"furnace.boilerplate" require
"furnace.chloe-tags" require
"furnace.conversations" require
"furnace.db" require
"furnace.json" require
"furnace.redirection" require
"furnace.referrer" require
"furnace.scopes" require
"furnace.sessions" require
"furnace.syndication" require
"webapps.user-admin" require

12
basis/furnace/json/json-docs.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel http.server help.markup help.syntax http ;
IN: furnace.json
HELP: <json-content>
{ $values { "body" object } { "response" response } }
{ $description "Creates an HTTP response which serves a serialized JSON object to the client." } ;
ARTICLE: "furnace.json" "Furnace JSON support"
"The " { $vocab-link "furnace.json" } " vocabulary provides a utility word for serving HTTP responses with JSON content."
{ $subsection <json-content> } ;
ABOUT: "furnace.json"

59
basis/furnace/redirection/redirection-docs.factor Normal file
View File

@ -0,0 +1,59 @@
USING: help.markup help.syntax io.streams.string quotations urls
http.server http ;
IN: furnace.redirection
HELP: <redirect-responder>
{ $values { "url" url } { "responder" "a responder" } }
{ $description "Creates a responder which unconditionally redirects the client to the given URL." } ;
HELP: <redirect>
{ $values { "url" url } { "response" response } }
{ $description "Creates a response which redirects the client to the given URL." } ;
HELP: <secure-only> ( responder -- responder' )
{ $values { "responder" "a responder" } { "responder'" "a responder" } }
{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ;
HELP: <secure-redirect>
{ $values
{ "url" url }
{ "response" response }
}
{ $description "Creates a responder which unconditionally redirects the client to the given URL after setting its protocol to HTTPS." }
{ $notes "This word is intended to be used with a relative URL. The client is redirected to the relative URL, but with HTTPS instead of HTTP." } ;
HELP: >secure-url
{ $values
{ "url" url }
{ "url'" url }
}
{ $description "Sets the protocol of a URL to HTTPS." } ;
HELP: if-secure
{ $values
{ "quot" quotation }
{ "response" response }
}
{ $description "Runs a quotation if the current request was made over HTTPS, otherwise returns a redirect to have the client request the current page again via HTTPS." } ;
ARTICLE: "furnace.redirection.secure" "Secure redirection"
"The words in this section help with implementing sites which require SSL/TLS for additional security."
$nl
"Converting a HTTP URL into an HTTPS URL:"
{ $subsection >secure-url }
"Redirecting the client to an HTTPS URL:"
{ $subsection <secure-redirect> }
"Tools for writing responders which require SSL/TLS connections:"
{ $subsection if-secure }
{ $subsection <secure-only> } ;
ARTICLE: "furnace.redirection" "Furnace redirection support"
"The " { $vocab-link "furnace.redirection" } " vocabulary builds additional functionality on top of " { $vocab-link "http.server.redirection" } ", and integrates with various Furnace features such as " { $link "furnace.asides" } " and " { $link "furnace.conversations" } "."
$nl
"A redirection response which takes asides and conversations into account:"
{ $subsection <redirect> }
"A responder which unconditionally redirects the client to another URL:"
{ $subsection <redirect-responder> }
{ $subsection "furnace.redirection.secure" } ;
ABOUT: "furnace.redirection"

19
basis/furnace/referrer/referrer-docs.factor Normal file
View File

@ -0,0 +1,19 @@
USING: help.markup help.syntax io.streams.string
furnace ;
IN: furnace.referrer
HELP: <check-form-submissions>
{ $values
{ "responder" "a responder" }
{ "responder'" "a responder" }
}
{ $description "Wraps the responder in a filter responder which ensures that form submissions originate from a page on the same server. Any submissions which do not are sent back with a 403 error." } ;
ARTICLE: "furnace.referrer" "Form submission referrer checking"
"The " { $vocab-link "furnace.referrer" } " implements a simple security measure which can be used to thwart cross-site scripting attacks."
{ $subsection <check-form-submissions> }
"Explicit referrer checking:"
{ $subsection referrer }
{ $subsection same-host? } ;
ABOUT: "furnace.referrer"

55
basis/furnace/sessions/sessions-docs.factor Normal file
View File

@ -0,0 +1,55 @@
USING: help.markup help.syntax io.streams.string quotations strings calendar serialize kernel furnace.db words kernel ;
IN: furnace.sessions
HELP: <sessions>
{ $values
{ "responder" "a responder" }
{ "responder'" "a new responder" }
}
{ $description "Wraps a responder in a session manager responder." } ;
HELP: schange
{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the session variable, and assigns the resulting value back to the variable." } ;
HELP: sget
{ $values { "key" symbol } { "value" object } }
{ $description "Outputs the value of a session variable." } ;
HELP: sset
{ $values { "value" object } { "key" symbol } }
{ $description "Sets the value of a session variable." } ;
ARTICLE: "furnace.sessions.config" "Session manager configuration"
"The " { $link sessions } " tuple has two slots which contain configuration parameters:"
{ $table
{ { $slot "verify?" } { "If set to a true value, the client IP address and user agent of each session is tracked, and checked every time a client attempts to re-establish a session. While this does not offer any real security, it can thwart unskilled packet-sniffing attacks. On by default." } }
{ { $slot "timeout" } { "A " { $link duration } " storing the maximum time that inactive sessions will be stored on the server. The default timeout is 20 minutes. Note that for sessions to actually expire, you must start a thread to do so; see the " { $vocab-link "furnace.alloy" } " vocabulary for an easy way of doing this." } }
} ;
ARTICLE: "furnace.sessions.serialize" "Session state serialization"
"Session variable values are serialized to the database using the " { $link "serialize" } " library."
$nl
"This means that there are three restrictions on the values stored in the session:"
{ $list
"Continuations cannot be stored at all."
{ "Object identity is not preserved between serialization and deserialization. That is, if an object is stored with " { $link sset } " and later retrieved with " { $link sget } ", the retrieved value will be " { $link = } " to the original, but not necessarily " { $link eq? } "." }
{ "All objects reachable from the value passed to " { $link sset } " are serialized, so large structures should not be stored in the session state, and neither should anything that can reference the global namespace. Large structures should be persisted in the database directly instead, using " { $vocab-link "db.tuples" } "." }
} ;
ARTICLE: "furnace.sessions" "Furnace sessions"
"The " { $vocab-link "furnace.sessions" } " vocabulary implements session management, which allows state to be maintained between HTTP requests. The session state is stored on the server; the client receives an opaque ID which is saved in a cookie (for GET requests) or a hidden form field (for POST requests)."
$nl
"To use session management, wrap your responder in an session manager:"
{ $subsection <sessions> }
"The sessions responder must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
$nl
"Reading and writing session variables from a request:"
{ $subsection sget }
{ $subsection sset }
{ $subsection schange }
"Additional topics:"
{ $subsection "furnace.sessions.config" }
{ $subsection "furnace.sessions.serialize" } ;
ABOUT: "furnace.sessions"

1
basis/furnace/summary.txt Normal file
View File

@ -0,0 +1 @@
Furnace web framework

73
basis/furnace/syndication/syndication-docs.factor Normal file
View File

@ -0,0 +1,73 @@
USING: help.markup help.syntax io.streams.string kernel sequences strings urls syndication calendar ;
IN: furnace.syndication
HELP: <feed-action>
{ $values { "action" feed-action } }
{ $description "Creates a new Atom feed action." } ;
HELP: >entry
{ $values
{ "object" object }
{ "entry" entry }
}
{ $contract "Converts an object into an Atom feed entry. The default implementation constructs an entry by calling "
{ $link feed-entry-title } ", "
{ $link feed-entry-description } ", "
{ $link feed-entry-date } ", and "
{ $link feed-entry-url } "." } ;
HELP: feed-action
{ $class-description "The class of feed actions. Contains several slots, documented in " { $link "furnace.syndication.config" } "." } ;
HELP: feed-entry-date
{ $values
{ "object" object }
{ "timestamp" timestamp }
}
{ $contract "Outputs a feed entry timestmap." } ;
HELP: feed-entry-description
{ $values
{ "object" object }
{ "description" null }
}
{ $contract "Outputs a feed entry description." } ;
HELP: feed-entry-title
{ $values
{ "object" object }
{ "string" string }
}
{ $contract "Outputs a feed entry title." } ;
HELP: feed-entry-url
{ $values
{ "object" object }
{ "url" url }
}
{ $contract "Outputs a feed entry URL." } ;
ARTICLE: "furnace.syndication.config" "Configuring Atom feed actions"
"Instances of " { $link feed-action } " have three slots which need to be set:"
{ $table
{ { $slot "title" } "The title of the feed as a string" }
{ { $slot "url" } { "The feed " { $link url } } }
{ { $slot "entries" } { "A quotation with stack effect " { $snippet "( -- seq )" } ", which produces a sequence of objects responding to the " { $link "furnace.syndication.protocol" } " protocol" } }
} ;
ARTICLE: "furnace.syndication.protocol" "Atom feed entry protocol"
"An Atom feed action takes a sequence of objects and converts them into Atom feed entries. The objects must implement a protocol consisting of either a single generic word:"
{ $subsection >entry }
"Or a series of generic words, called by the default implementation of " { $link >entry } ":"
{ $subsection feed-entry-title }
{ $subsection feed-entry-description }
{ $subsection feed-entry-date }
{ $subsection feed-entry-url } ;
ARTICLE: "furnace.syndication" "Furnace Atom syndication support"
"The " { $vocab-link "furnace.syndication" } " vocabulary builds on the " { $link "syndication" } " library by providing easy support for generating Atom feeds from " { $link "furnace.actions" } "."
{ $subsection <feed-action> }
{ $subsection "furnace.syndication.config" }
{ $subsection "furnace.syndication.protocol" } ;
ABOUT: "furnace.syndication"

0
core/grouping/authors.txt → basis/grouping/authors.txt
View File

0
core/grouping/grouping-docs.factor → basis/grouping/grouping-docs.factor
View File

0
core/grouping/grouping-tests.factor → basis/grouping/grouping-tests.factor
View File

0
core/grouping/grouping.factor → basis/grouping/grouping.factor
View File

Some files were not shown because too many files have changed in this diff Show More