Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
abf4700af8
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -164,7 +164,7 @@ GENERIC: stack-size ( type -- size ) foldable
|
|||
|
||||
M: string stack-size c-type stack-size ;
|
||||
|
||||
M: c-type stack-size size>> ;
|
||||
M: c-type stack-size size>> cell align ;
|
||||
|
||||
GENERIC: byte-length ( seq -- n ) flushable
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc
|
||||
math namespaces parser sequences strings words libc fry
|
||||
alien.c-types alien.structs.fields cpu.architecture ;
|
||||
IN: alien.structs
|
||||
|
||||
: if-value-structs? ( ctype true false -- )
|
||||
value-structs?
|
||||
[ drop call ] [ >r 2drop "void*" r> call ] if ; inline
|
||||
|
||||
TUPLE: struct-type size align fields ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
|
@ -17,20 +13,26 @@ M: struct-type c-type-align align>> ;
|
|||
|
||||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
||||
M: struct-type unbox-parameter
|
||||
[ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
|
||||
|
||||
M: struct-type unbox-return
|
||||
f swap %unbox-struct ;
|
||||
M: struct-type unbox-parameter
|
||||
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
|
||||
|
||||
M: struct-type box-parameter
|
||||
[ %box-struct ] [ box-parameter ] if-value-structs? ;
|
||||
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
|
||||
|
||||
: if-small-struct ( c-type true false -- ? )
|
||||
[ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
|
||||
|
||||
M: struct-type unbox-return
|
||||
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
|
||||
|
||||
M: struct-type box-return
|
||||
f swap %box-struct ;
|
||||
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
|
||||
|
||||
M: struct-type stack-size
|
||||
[ heap-size ] [ stack-size ] if-value-structs? ;
|
||||
[ heap-size ] [ stack-size ] if-value-struct ;
|
||||
|
||||
: c-struct? ( type -- ? ) (c-type) struct-type? ;
|
||||
|
||||
|
|
@ -40,7 +42,7 @@ M: struct-type stack-size
|
|||
-rot define-c-type ;
|
||||
|
||||
: define-struct-early ( name vocab fields -- fields )
|
||||
-rot [ rot first2 <field-spec> ] 2curry map ;
|
||||
[ first2 <field-spec> ] with with map ;
|
||||
|
||||
: compute-struct-align ( types -- n )
|
||||
[ c-type-align ] map supremum ;
|
||||
|
|
|
|||
|
|
@ -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+ } "."
|
||||
|
|
|
|||
|
|
@ -1,2 +1 @@
|
|||
unportable
|
||||
windows
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } "."
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -235,7 +235,7 @@ M: float-regs reg-class-variable drop float-regs ;
|
|||
GENERIC: inc-reg-class ( register-class -- )
|
||||
|
||||
: ?dummy-stack-params ( reg-class -- )
|
||||
dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
|
||||
dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
|
||||
|
||||
: ?dummy-int-params ( reg-class -- )
|
||||
dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
|
||||
|
|
@ -264,7 +264,7 @@ M: object reg-class-full?
|
|||
|
||||
: spill-param ( reg-class -- n reg-class )
|
||||
stack-params get
|
||||
>r reg-size stack-params +@ r>
|
||||
>r reg-size cell align stack-params +@ r>
|
||||
stack-params ;
|
||||
|
||||
: fastcall-param ( reg-class -- n reg-class )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -146,13 +146,21 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
|||
|
||||
! Make sure XT doesn't get clobbered in stack frame
|
||||
|
||||
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
|
||||
"void"
|
||||
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
|
||||
"int"
|
||||
f "ffi_test_31"
|
||||
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
|
||||
alien-invoke gc 3 ;
|
||||
|
||||
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
|
||||
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
|
||||
|
||||
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
|
||||
"float"
|
||||
f "ffi_test_31_point_5"
|
||||
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
|
||||
alien-invoke ;
|
||||
|
||||
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
|
||||
|
||||
FUNCTION: longlong ffi_test_21 long x long y ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,14 +34,10 @@ IN: compiler.tree.builder
|
|||
if ;
|
||||
|
||||
: (build-tree-from-word) ( word -- )
|
||||
dup
|
||||
[ "inline" word-prop ]
|
||||
[ "recursive" word-prop ] bi and [
|
||||
1quotation f initial-recursive-state infer-quot
|
||||
] [
|
||||
[ specialized-def ] [ initial-recursive-state ] 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 } "." } ;
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -141,10 +141,10 @@ HOOK: %loop-entry cpu ( -- )
|
|||
HOOK: small-enough? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( heap-size -- ? )
|
||||
HOOK: struct-small-enough? cpu ( c-type -- ? )
|
||||
|
||||
! Do we pass value structs by value or hidden reference?
|
||||
HOOK: value-structs? cpu ( -- ? )
|
||||
! Do we pass this struct by value or hidden reference?
|
||||
HOOK: value-struct? cpu ( c-type -- ? )
|
||||
|
||||
! If t, all parameters are shadowed by dummy stack parameters
|
||||
HOOK: dummy-stack-params? cpu ( -- ? )
|
||||
|
|
@ -207,14 +207,3 @@ M: object %callback-return drop %return ;
|
|||
M: stack-params param-reg drop ;
|
||||
|
||||
M: stack-params param-regs drop f ;
|
||||
|
||||
: if-small-struct ( n size true false -- ? )
|
||||
[ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
|
||||
[ '[ nip @ ] ] dip if ;
|
||||
inline
|
||||
|
||||
: %unbox-struct ( n c-type -- )
|
||||
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
|
||||
|
||||
: %box-struct ( n c-type -- )
|
||||
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ M: linux lr-save 1 cells ;
|
|||
|
||||
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
|
||||
|
||||
M: ppc value-structs? f ;
|
||||
M: ppc value-struct? drop f ;
|
||||
|
||||
M: ppc dummy-stack-params? f ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ M: macosx lr-save 2 cells ;
|
|||
|
||||
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
|
||||
|
||||
M: ppc value-structs? t ;
|
||||
M: ppc value-struct? drop t ;
|
||||
|
||||
M: ppc dummy-stack-params? t ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,8 +10,9 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
|||
|
||||
M: x86.64 reserved-area-size 4 cells ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
heap-size cell <= ;
|
||||
M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ;
|
||||
|
||||
M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
|
||||
|
||||
M: x86.64 dummy-stack-params? f ;
|
||||
|
||||
|
|
|
|||
|
|
@ -507,7 +507,7 @@ M: x86 %prepare-alien-invoke
|
|||
temp-reg-1 2 cells [+] ds-reg MOV
|
||||
temp-reg-1 3 cells [+] rs-reg MOV ;
|
||||
|
||||
M: x86 value-structs? t ;
|
||||
M: x86 value-struct? drop t ;
|
||||
|
||||
M: x86 small-enough? ( n -- ? )
|
||||
HEX: -80000000 HEX: 7fffffff between? ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 get "emacsclient" or ,
|
||||
"--no-wait" ,
|
||||
os windows? [ "--no-wait" , ] unless
|
||||
"+" swap number>string append ,
|
||||
,
|
||||
] { } make try-process ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
'[
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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"
|
||||
|
|
@ -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"
|
||||
|
|
@ -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>"
|
||||
} ;
|
||||
|
|
@ -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? ( -- ? )
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@
|
|||
</table>
|
||||
|
||||
<p>
|
||||
<button>Update</button>
|
||||
<button type="submit">Update</button>
|
||||
<t:validation-errors />
|
||||
</p>
|
||||
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
|
||||
</table>
|
||||
|
||||
<button>Recover password</button>
|
||||
<button type="submit">Recover password</button>
|
||||
|
||||
</t:form>
|
||||
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@
|
|||
</table>
|
||||
|
||||
<p>
|
||||
<button>Set password</button>
|
||||
<button type="submit">Set password</button>
|
||||
<t:validation-errors />
|
||||
</p>
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@
|
|||
|
||||
<p>
|
||||
|
||||
<button>Register</button>
|
||||
<button type="submit">Register</button>
|
||||
<t:validation-errors />
|
||||
|
||||
</p>
|
||||
|
|
|
|||
|
|
@ -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>"
|
||||
} ;
|
||||
|
|
@ -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? ( -- ? )
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
|
||||
<p>
|
||||
|
||||
<button>Log in</button>
|
||||
<button type="submit">Log in</button>
|
||||
<t:validation-errors />
|
||||
|
||||
</p>
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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"
|
||||
|
|
@ -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"
|
||||
|
|
@ -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"
|
||||
|
|
@ -28,7 +28,7 @@ HELP: cset
|
|||
{ $description "Sets the value of a conversation variable." } ;
|
||||
|
||||
HELP: cchange
|
||||
{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
|
||||
{ $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"
|
||||
|
|
|
|||
|
|
@ -1,159 +1,129 @@
|
|||
USING: assocs help.markup help.syntax io.streams.string quotations sequences strings urls ;
|
||||
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 "" } ;
|
||||
{ $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 "" } ;
|
||||
|
||||
HELP: base-path
|
||||
{ $values
|
||||
{ "string" string }
|
||||
{ "pair" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" null }
|
||||
{ "value/f" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: cookie-client-state
|
||||
{ $values
|
||||
{ "key" null } { "request" null }
|
||||
{ "value/f" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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 }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: exit-continuation
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: exit-with
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $values { "quot" { $quotation "( responder -- )" } } }
|
||||
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
|
||||
|
||||
HELP: hidden-form-field
|
||||
{ $values
|
||||
{ "value" null } { "name" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" null } { "responder" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" null } { "responder" null }
|
||||
{ "query'" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" null } { "responder" null }
|
||||
{ "query'" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: nested-forms-key
|
||||
{ $description "" } ;
|
||||
{ $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" sequence }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: post-client-state
|
||||
{ $values
|
||||
{ "key" null } { "request" null }
|
||||
{ "value/f" null }
|
||||
}
|
||||
{ $values { "seq" "a sequence of responders" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: referrer
|
||||
{ $values
|
||||
|
||||
{ "referrer/f" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $values { "referrer/f" { $maybe string } } }
|
||||
{ $description "Outputs the current request's referrer URL." } ;
|
||||
|
||||
HELP: request-params
|
||||
{ $values
|
||||
{ "request" null }
|
||||
{ "assoc" assoc }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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 }
|
||||
}
|
||||
{ $values { "string" string } { "string'" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: resolve-template-path
|
||||
{ $values
|
||||
{ "pair" null }
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: same-host?
|
||||
{ $values
|
||||
{ "url" url }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" }
|
||||
}
|
||||
{ $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 }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $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" }
|
||||
|
|
@ -193,10 +163,13 @@ ARTICLE: "furnace" "Furnace framework"
|
|||
{ $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" }
|
||||
|
|
|
|||
|
|
@ -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,7 @@ 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
|
||||
|
|
@ -152,3 +152,4 @@ USE: vocabs.loader
|
|||
"furnace.scopes" require
|
||||
"furnace.sessions" require
|
||||
"furnace.syndication" require
|
||||
"webapps.user-admin" require
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: help.markup help.syntax io.streams.string ;
|
||||
USING: help.markup help.syntax io.streams.string
|
||||
furnace ;
|
||||
IN: furnace.referrer
|
||||
|
||||
HELP: <check-form-submissions>
|
||||
|
|
@ -10,6 +11,9 @@ HELP: <check-form-submissions>
|
|||
|
||||
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> } ;
|
||||
{ $subsection <check-form-submissions> }
|
||||
"Explicit referrer checking:"
|
||||
{ $subsection referrer }
|
||||
{ $subsection same-host? } ;
|
||||
|
||||
ABOUT: "furnace.referrer"
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ HELP: <sessions>
|
|||
{ $description "Wraps a responder in a session manager responder." } ;
|
||||
|
||||
HELP: schange
|
||||
{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
|
||||
{ $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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Furnace web framework
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.crossref help.stylesheet help.topics
|
||||
help.syntax definitions io prettyprint summary arrays math
|
||||
sequences vocabs ;
|
||||
sequences vocabs strings ;
|
||||
IN: help
|
||||
|
||||
ARTICLE: "printing-elements" "Printing markup elements"
|
||||
|
|
@ -33,6 +33,10 @@ ARTICLE: "block-elements" "Block elements"
|
|||
{ $subsection $side-effects }
|
||||
{ $subsection $errors }
|
||||
{ $subsection $see-also }
|
||||
"Elements used in " { $link $values } " forms:"
|
||||
{ $subsection $instance }
|
||||
{ $subsection $maybe }
|
||||
{ $subsection $quotation }
|
||||
"Boilerplate paragraphs:"
|
||||
{ $subsection $low-level-note }
|
||||
{ $subsection $io-error }
|
||||
|
|
@ -281,7 +285,7 @@ HELP: $link
|
|||
} ;
|
||||
|
||||
HELP: textual-list
|
||||
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
|
||||
{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- )" } } }
|
||||
{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
|
||||
{ $examples
|
||||
{ $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
|
||||
|
|
@ -318,7 +322,37 @@ HELP: $table
|
|||
|
||||
HELP: $values
|
||||
{ $values { "element" "an array of pairs of markup elements" } }
|
||||
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder can be an element of any form." } ;
|
||||
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
|
||||
{ $see-also $maybe $instance $quotation } ;
|
||||
|
||||
HELP: $instance
|
||||
{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
|
||||
{ $description
|
||||
"Produces the text ``a " { $emphasis "class" } "'' or ``an " { $emphasis "class" } "'', depending on the first letter of " { $emphasis "class" } "."
|
||||
}
|
||||
{ $examples
|
||||
{ $markup-example { $instance string } }
|
||||
{ $markup-example { $instance integer } }
|
||||
{ $markup-example { $instance f } }
|
||||
} ;
|
||||
|
||||
HELP: $maybe
|
||||
{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
|
||||
{ $description
|
||||
"Produces the text ``a " { $emphasis "class" } " or f'' or ``an " { $emphasis "class" } " or f'', depending on the first letter of " { $emphasis "class" } "."
|
||||
}
|
||||
{ $examples
|
||||
{ $markup-example { $maybe string } }
|
||||
} ;
|
||||
|
||||
HELP: $quotation
|
||||
{ $values { "element" "an array with shape " { $snippet "{ effect }" } } }
|
||||
{ $description
|
||||
"Produces the text ``a quotation with stack effect " { $emphasis "effect" } "''."
|
||||
}
|
||||
{ $examples
|
||||
{ $markup-example { $quotation "( obj -- )" } }
|
||||
} ;
|
||||
|
||||
HELP: $list
|
||||
{ $values { "element" "an array of markup elements" } }
|
||||
|
|
|
|||
|
|
@ -5,23 +5,22 @@ io.files html.streams html.elements html.components help kernel
|
|||
assocs sequences make words accessors arrays help.topics vocabs
|
||||
tools.vocabs tools.vocabs.browser namespaces prettyprint io
|
||||
vocabs.loader serialize fry memoize unicode.case math.order
|
||||
sorting ;
|
||||
sorting debugger ;
|
||||
IN: help.html
|
||||
|
||||
: escape-char ( ch -- )
|
||||
dup H{
|
||||
{ CHAR: " "__quote__" }
|
||||
{ CHAR: " "__quo__" }
|
||||
{ CHAR: * "__star__" }
|
||||
{ CHAR: : "__colon__" }
|
||||
{ CHAR: < "__lt__" }
|
||||
{ CHAR: > "__gt__" }
|
||||
{ CHAR: ? "__question__" }
|
||||
{ CHAR: \\ "__backslash__" }
|
||||
{ CHAR: ? "__que__" }
|
||||
{ CHAR: \\ "__back__" }
|
||||
{ CHAR: | "__pipe__" }
|
||||
{ CHAR: _ "__underscore__" }
|
||||
{ CHAR: / "__slash__" }
|
||||
{ CHAR: \\ "__backslash__" }
|
||||
{ CHAR: , "__comma__" }
|
||||
{ CHAR: @ "__at__" }
|
||||
} at [ % ] [ , ] ?if ;
|
||||
|
||||
: escape-filename ( string -- filename )
|
||||
|
|
@ -88,19 +87,17 @@ M: topic browser-link-href topic>filename ;
|
|||
all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
|
||||
|
||||
: generate-help-files ( -- )
|
||||
all-topics [ help>html ] each ;
|
||||
all-topics [ '[ _ help>html ] try ] each ;
|
||||
|
||||
: generate-help ( -- )
|
||||
{ "resource:core" "resource:basis" "resource:extra" } vocab-roots [
|
||||
load-everything
|
||||
|
||||
"/tmp/docs/" make-directory
|
||||
|
||||
"/tmp/docs/" [
|
||||
"docs" temp-file
|
||||
[ make-directories ]
|
||||
[
|
||||
[
|
||||
generate-indices
|
||||
generate-help-files
|
||||
] with-directory
|
||||
] with-variable ;
|
||||
] bi ;
|
||||
|
||||
MEMO: load-index ( name -- index )
|
||||
binary file-contents bytes>object ;
|
||||
|
|
@ -118,10 +115,10 @@ M: result link-href href>> ;
|
|||
[ [ title>> ] compare ] sort ;
|
||||
|
||||
: article-apropos ( string -- results )
|
||||
"articles.idx" offline-apropos ;
|
||||
"articles.idx" temp-file offline-apropos ;
|
||||
|
||||
: word-apropos ( string -- results )
|
||||
"words.idx" offline-apropos ;
|
||||
"words.idx" temp-file offline-apropos ;
|
||||
|
||||
: vocab-apropos ( string -- results )
|
||||
"vocabs.idx" offline-apropos ;
|
||||
"vocabs.idx" temp-file offline-apropos ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: accessors arrays definitions generic io kernel assocs
|
||||
hashtables namespaces make parser prettyprint sequences strings
|
||||
io.styles vectors words math sorting splitting classes slots
|
||||
vocabs help.stylesheet help.topics vocabs.loader alias ;
|
||||
vocabs help.stylesheet help.topics vocabs.loader alias
|
||||
quotations ;
|
||||
IN: help.markup
|
||||
|
||||
! Simple markup language.
|
||||
|
|
@ -234,7 +235,8 @@ ALIAS: $slot $snippet
|
|||
] ($grid) ;
|
||||
|
||||
: a/an ( str -- str )
|
||||
first "aeiou" member? "an" "a" ? ;
|
||||
[ first ] [ length ] bi 1 =
|
||||
"afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
|
||||
|
||||
GENERIC: ($instance) ( element -- )
|
||||
|
||||
|
|
@ -244,7 +246,17 @@ M: word ($instance)
|
|||
M: string ($instance)
|
||||
dup a/an write bl $snippet ;
|
||||
|
||||
: $instance ( children -- ) first ($instance) ;
|
||||
M: f ($instance)
|
||||
drop { f } $link ;
|
||||
|
||||
: $instance ( element -- ) first ($instance) ;
|
||||
|
||||
: $maybe ( element -- )
|
||||
$instance " or " print-element { f } $instance ;
|
||||
|
||||
: $quotation ( element -- )
|
||||
{ "a " { $link quotation } " with stack effect " } print-element
|
||||
$snippet ;
|
||||
|
||||
: values-row ( seq -- seq )
|
||||
unclip \ $snippet swap ?word-name 2array
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ HELP: required-attr
|
|||
{ $errors "Throws an error if the attribute is not specified." } ;
|
||||
|
||||
HELP: optional-attr
|
||||
{ $values { "tag" tag } { "name" string } { "value" "a " { $link string } " or " { $link f } } }
|
||||
{ $values { "tag" tag } { "name" string } { "value" { $maybe string } } }
|
||||
{ $description "Extracts an attribute from a tag." }
|
||||
{ $notes "Outputs " { $link f } " if the attribute is not specified." } ;
|
||||
|
||||
|
|
@ -24,7 +24,7 @@ HELP: compile-attr
|
|||
|
||||
HELP: CHLOE:
|
||||
{ $syntax "name definition... ;" }
|
||||
{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } }
|
||||
{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } }
|
||||
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
|
||||
|
||||
HELP: COMPONENT:
|
||||
|
|
@ -46,7 +46,7 @@ HELP: [code]
|
|||
{ $description "Compiles the quotation. It will be called when the template is called." } ;
|
||||
|
||||
HELP: process-children
|
||||
{ $values { "tag" tag } { "quot" "a quotation with stack effect " { $snippet "( compiled-tag -- )" } } }
|
||||
{ $values { "tag" tag } { "quot" { $quotation "( compiled-tag -- )" } } }
|
||||
{ $description "Compiles the tag. The quotation will be applied to the resulting quotation when the template is called." }
|
||||
{ $examples "See " { $link "html.templates.chloe.extend.tags.example" } " for an example which uses this word to implement a custom control flow tag." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ HELP: http-post
|
|||
{ $errors "Throws an error if the HTTP request fails." } ;
|
||||
|
||||
HELP: with-http-get
|
||||
{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
|
||||
{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
|
||||
{ $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." }
|
||||
{ $errors "Throws an error if the HTTP request fails." } ;
|
||||
|
||||
|
|
@ -50,7 +50,7 @@ HELP: http-request
|
|||
{ $errors "Throws an error if the HTTP request fails." } ;
|
||||
|
||||
HELP: with-http-request
|
||||
{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
|
||||
{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
|
||||
{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
|
||||
{ $errors "Throws an error if the HTTP request fails." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ HELP: delete-cookie
|
|||
{ $side-effects "request/response" } ;
|
||||
|
||||
HELP: get-cookie
|
||||
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" "a " { $link cookie } " or " { $link f } } }
|
||||
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" { $maybe cookie } } }
|
||||
{ $description "Gets a named cookie from a request or response." } ;
|
||||
|
||||
HELP: put-cookie
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: help.markup help.syntax io.streams.string ;
|
|||
IN: http.server.static
|
||||
|
||||
HELP: <file-responder>
|
||||
{ $values { "root" "a pathname string" } { "hook" "a quotation with stack effect " { $snippet "( path mime-type -- response )" } } { "responder" file-responder } }
|
||||
{ $values { "root" "a pathname string" } { "hook" { $quotation "( path mime-type -- response )" } } { "responder" file-responder } }
|
||||
{ $description "Creates a file responder which serves content from " { $snippet "path" } " by using the hook to generate a response." } ;
|
||||
|
||||
HELP: <static>
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ HELP: <mapped-file>
|
|||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: with-mapped-file
|
||||
{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } }
|
||||
{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } }
|
||||
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ HELP: next-change
|
|||
{ $errors "Throws an error if the monitor is closed from another thread." } ;
|
||||
|
||||
HELP: with-monitor
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" { $quotation "( monitor -- )" } } }
|
||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ HELP: return-connection
|
|||
{ $description "Returns a connection to the pool." } ;
|
||||
|
||||
HELP: with-pooled-connection
|
||||
{ $values { "pool" pool } { "quot" "a quotation with stack effect " { $snippet "( conn -- )" } } }
|
||||
{ $values { "pool" pool } { "quot" { $quotation "( conn -- )" } } }
|
||||
{ $description "Calls a quotation with a pooled connection on the stack. If the quotation returns successfully, the connection is returned to the pool; if the quotation throws an error, the connection is disposed of with " { $link dispose } "." } ;
|
||||
|
||||
HELP: make-connection
|
||||
|
|
|
|||
|
|
@ -114,11 +114,11 @@ HELP: stop-this-server
|
|||
{ $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
|
||||
|
||||
HELP: secure-port
|
||||
{ $values { "n" "an " { $link integer } " or " { $link f } } }
|
||||
{ $values { "n" { $maybe integer } } }
|
||||
{ $description "Outputs the port number on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
|
||||
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||
|
||||
HELP: insecure-port
|
||||
{ $values { "n" "an " { $link integer } " or " { $link f } } }
|
||||
{ $values { "n" { $maybe integer } } }
|
||||
{ $description "Outputs the port number on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
|
||||
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ ARTICLE: "network-streams" "Networking"
|
|||
{ $subsection "network-addressing" }
|
||||
{ $subsection "network-connection" }
|
||||
{ $subsection "network-packet" }
|
||||
{ $subsection "io.sockets.secure" }
|
||||
{ $vocab-subsection "Secure sockets (SSL, TLS)" "io.sockets.secure" }
|
||||
{ $see-also "io.pipes" } ;
|
||||
|
||||
ABOUT: "network-streams"
|
||||
|
|
|
|||
|
|
@ -2,11 +2,11 @@ IN: io.timeouts
|
|||
USING: help.markup help.syntax math kernel calendar ;
|
||||
|
||||
HELP: timeout
|
||||
{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } }
|
||||
{ $values { "obj" object } { "dt/f" { $maybe duration } } }
|
||||
{ $contract "Outputs an object's timeout." } ;
|
||||
|
||||
HELP: set-timeout
|
||||
{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } }
|
||||
{ $values { "dt/f" { $maybe duration } } { "obj" object } }
|
||||
{ $contract "Sets an object's timeout." } ;
|
||||
|
||||
HELP: cancel-operation
|
||||
|
|
@ -14,7 +14,7 @@ HELP: cancel-operation
|
|||
{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
|
||||
|
||||
HELP: with-timeout
|
||||
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $values { "obj" object } { "quot" { $quotation "( obj -- )" } } }
|
||||
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ;
|
||||
|
||||
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
||||
|
|
|
|||
|
|
@ -1,2 +1 @@
|
|||
unportable
|
||||
windows
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ HELP: free
|
|||
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
|
||||
|
||||
HELP: with-malloc
|
||||
{ $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } }
|
||||
{ $values { "size" "a positive integer" } { "quot" { $quotation "( c-ptr -- )" } } }
|
||||
{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ;
|
||||
|
||||
HELP: &free
|
||||
|
|
|
|||
|
|
@ -279,7 +279,7 @@ HELP: mod-inv
|
|||
} ;
|
||||
|
||||
HELP: each-bit
|
||||
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } }
|
||||
{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } }
|
||||
{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
|
||||
{ $examples
|
||||
{ $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
|
||||
|
|
|
|||
|
|
@ -156,8 +156,8 @@ HELP: interval*
|
|||
{ $description "Multiplies two intervals." } ;
|
||||
|
||||
HELP: interval-shift
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ;
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ;
|
||||
|
||||
HELP: interval-max
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
|
|
@ -253,8 +253,8 @@ HELP: points>interval
|
|||
;
|
||||
|
||||
HELP: interval-shift-safe
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ;
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ;
|
||||
|
||||
HELP: incomparable
|
||||
{ $description "Output value from " { $link interval<= } ", " { $link interval< } ", " { $link interval>= } " and " { $link interval> } " in the case where the result of the comparison is ambiguous." } ;
|
||||
|
|
@ -304,20 +304,20 @@ HELP: interval>points
|
|||
{ $description "Outputs both endpoints of the interval." } ;
|
||||
|
||||
HELP: assume<
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: assume<=
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: assume>
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
|
||||
|
||||
HELP: assume>=
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
|
||||
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ;
|
||||
{ $values { "i1" interval } { "i2" interval } { "i3" interval } }
|
||||
{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } "." } ;
|
||||
|
||||
HELP: integral-closure
|
||||
{ $values { "i1" "an " { $link interval } " with integer end-points" } { "i2" "a closed " { $link interval } " with integer end-points" } }
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ HELP: filter
|
|||
} ;
|
||||
|
||||
HELP: <filter>
|
||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
|
||||
{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
|
||||
{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }
|
||||
{ $examples "See the example in the documentation for " { $link filter } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -66,11 +66,11 @@ HELP: set-model
|
|||
{ set-model change-model (change-model) } related-words
|
||||
|
||||
HELP: change-model
|
||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }
|
||||
{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
|
||||
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
|
||||
|
||||
HELP: (change-model)
|
||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }
|
||||
{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
|
||||
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
|
||||
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,2 +1 @@
|
|||
unportable
|
||||
windows
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ IN: opengl
|
|||
over glEnableClientState dip glDisableClientState ; inline
|
||||
|
||||
: words>values ( word/value-seq -- value-seq )
|
||||
[ dup word? [ execute ] [ ] if ] map ;
|
||||
[ dup word? [ execute ] when ] map ;
|
||||
|
||||
: (all-enabled) ( seq quot -- )
|
||||
over [ glEnable ] each dip [ glDisable ] each ; inline
|
||||
|
|
@ -71,10 +71,10 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
|
||||
: (rect-vertices) ( dim -- vertices )
|
||||
{
|
||||
[ drop 0 1 ]
|
||||
[ first 1- 1 ]
|
||||
[ [ first 1- ] [ second ] bi ]
|
||||
[ second 0 swap ]
|
||||
[ drop 0.5 0.5 ]
|
||||
[ first 0.5 - 0.5 ]
|
||||
[ [ first 0.5 - ] [ second 0.5 - ] bi ]
|
||||
[ second 0.5 - 0.5 swap ]
|
||||
} cleave 8 narray >c-float-array ;
|
||||
|
||||
: rect-vertices ( dim -- )
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ HELP: optional
|
|||
HELP: semantic
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
{ "quot" "a quotation with stack effect ( object -- bool )" }
|
||||
{ "quot" { $quotation "( object -- ? )" } }
|
||||
}
|
||||
{ $description
|
||||
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
|
||||
|
|
@ -130,7 +130,7 @@ HELP: ensure-not
|
|||
HELP: action
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
{ "quot" "a quotation with stack effect ( ast -- ast )" }
|
||||
{ "quot" { $quotation "( ast -- ast )" } }
|
||||
}
|
||||
{ $description
|
||||
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ HELP: nesting-limit?
|
|||
$prettyprinting-note ;
|
||||
|
||||
HELP: check-recursion
|
||||
{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $values { "obj" "an object" } { "quot" { $quotation "( obj -- )" } } }
|
||||
{ $description "If the object is already being printed, that is, if the prettyprinter has encountered a cycle in the object graph, or if the maximum nesting depth has been reached, outputs a dummy string. Otherwise applies the quotation to the object." }
|
||||
$prettyprinting-note ;
|
||||
|
||||
|
|
|
|||
|
|
@ -355,3 +355,13 @@ INTERSECTION: intersection-see-test sequence number ;
|
|||
[ ] [ \ curry see ] unit-test
|
||||
|
||||
[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
|
||||
|
||||
TUPLE: started-out-hustlin' ;
|
||||
|
||||
GENERIC: ended-up-ballin'
|
||||
|
||||
M: started-out-hustlin' ended-up-ballin' ; inline
|
||||
|
||||
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
|
||||
[ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -253,6 +253,9 @@ M: object see
|
|||
block>
|
||||
] with-use nl ;
|
||||
|
||||
M: method-spec see
|
||||
first2 method see ;
|
||||
|
||||
GENERIC: see-class* ( word -- )
|
||||
|
||||
M: union-class see-class*
|
||||
|
|
|
|||
|
|
@ -145,7 +145,7 @@ HELP: save-end-position
|
|||
{ $description "Save the current position as the end position of the block." } ;
|
||||
|
||||
HELP: pprint-sections
|
||||
{ $values { "block" block } { "advancer" "a quotation with stack effect " { $snippet "( block -- )" } } }
|
||||
{ $values { "block" block } { "advancer" { $quotation "( block -- )" } } }
|
||||
{ $description "Prints child sections of a block, ignoring any " { $link line-break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ;
|
||||
|
||||
HELP: do-break
|
||||
|
|
@ -157,7 +157,7 @@ HELP: empty-block?
|
|||
{ $description "Tests if the block has no child sections." } ;
|
||||
|
||||
HELP: if-nonempty
|
||||
{ $values { "block" block } { "quot" "a quotation with stack effect " { $snippet "( block -- )" } } }
|
||||
{ $values { "block" block } { "quot" { $quotation "( block -- )" } } }
|
||||
{ $description "If the block has child sections, calls the quotation, otherwise does nothing." } ;
|
||||
|
||||
HELP: (<block)
|
||||
|
|
|
|||
|
|
@ -1,2 +1 @@
|
|||
unportable
|
||||
windows
|
||||
|
|
|
|||
|
|
@ -1,21 +1,15 @@
|
|||
IN: search-deques
|
||||
USING: help.markup help.syntax kernel dlists hashtables
|
||||
USING: help.markup help.syntax kernel hashtables
|
||||
deques assocs ;
|
||||
|
||||
ARTICLE: "search-deques" "Search deques"
|
||||
"A search deque is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search deques implement all deque operations in terms of an underlying deque, and membership testing with " { $link deque-member? } " is implemented with an underlying assoc. Search deques are defined in the " { $vocab-link "search-deques" } " vocabulary."
|
||||
$nl
|
||||
"Creating a search deque:"
|
||||
{ $subsection <search-deque> }
|
||||
"Default implementation:"
|
||||
{ $subsection <hashed-dlist> } ;
|
||||
{ $subsection <search-deque> } ;
|
||||
|
||||
ABOUT: "search-deques"
|
||||
|
||||
HELP: <search-deque> ( assoc deque -- search-deque )
|
||||
{ $values { "assoc" assoc } { "deque" deque } { "search-deque" search-deque } }
|
||||
{ $description "Creates a new " { $link search-deque } "." } ;
|
||||
|
||||
HELP: <hashed-dlist> ( -- search-deque )
|
||||
{ $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." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: search-deques.tests
|
||||
USING: search-deques tools.test namespaces
|
||||
kernel sequences words deques vocabs ;
|
||||
kernel sequences words deques vocabs dlists ;
|
||||
|
||||
<hashed-dlist> "h" set
|
||||
|
||||
|
|
@ -15,13 +15,11 @@ kernel sequences words deques vocabs ;
|
|||
[ t ] [ "1" get "2" get eq? ] unit-test
|
||||
[ t ] [ "2" get "3" get eq? ] unit-test
|
||||
|
||||
[ 3 ] [ "h" get deque-length ] unit-test
|
||||
[ t ] [ 7 "h" get deque-member? ] unit-test
|
||||
|
||||
[ 3 ] [ "1" get node-value ] unit-test
|
||||
[ ] [ "1" get "h" get delete-node ] unit-test
|
||||
|
||||
[ 2 ] [ "h" get deque-length ] unit-test
|
||||
[ 1 ] [ "h" get pop-back ] unit-test
|
||||
[ 7 ] [ "h" get pop-back ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,16 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel assocs deques dlists hashtables ;
|
||||
USING: accessors kernel assocs deques ;
|
||||
IN: search-deques
|
||||
|
||||
TUPLE: search-deque assoc deque ;
|
||||
|
||||
C: <search-deque> search-deque
|
||||
|
||||
: <hashed-dlist> ( -- search-deque )
|
||||
0 <hashtable> <dlist> <search-deque> ;
|
||||
|
||||
M: search-deque deque-length deque>> deque-length ;
|
||||
M: search-deque deque-empty? deque>> deque-empty? ;
|
||||
|
||||
M: search-deque peek-front deque>> peek-front ;
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: inference-error error-help error>> error-help ;
|
|||
+warning+ (inference-error) ; inline
|
||||
|
||||
M: inference-error error.
|
||||
[ "In word: " write word>> . ] [ error>> error. ] bi ;
|
||||
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
|
||||
|
||||
TUPLE: literal-expected ;
|
||||
|
||||
|
|
@ -108,3 +108,9 @@ M: inconsistent-recursive-call-error error.
|
|||
"The recursive word " write
|
||||
word>> pprint
|
||||
" calls itself with a different set of quotation parameters than were input" print ;
|
||||
|
||||
TUPLE: unknown-primitive-error ;
|
||||
|
||||
M: unknown-primitive-error error.
|
||||
drop
|
||||
"Cannot determine stack effect statically" print ;
|
||||
|
|
|
|||
|
|
@ -162,7 +162,7 @@ M: object infer-call*
|
|||
{ \ load-locals [ infer-load-locals ] }
|
||||
{ \ get-local [ infer-get-local ] }
|
||||
{ \ drop-locals [ infer-drop-locals ] }
|
||||
{ \ do-primitive [ \ do-primitive cannot-infer-effect ] }
|
||||
{ \ do-primitive [ unknown-primitive-error inference-warning ] }
|
||||
{ \ alien-invoke [ infer-alien-invoke ] }
|
||||
{ \ alien-indirect [ infer-alien-indirect ] }
|
||||
{ \ alien-callback [ infer-alien-callback ] }
|
||||
|
|
|
|||
|
|
@ -4,9 +4,7 @@ USING: accessors arrays sequences kernel sequences assocs
|
|||
namespaces stack-checker.recursive-state.tree ;
|
||||
IN: stack-checker.recursive-state
|
||||
|
||||
TUPLE: recursive-state words word quotations inline-words ;
|
||||
|
||||
C: <recursive-state> recursive-state
|
||||
TUPLE: recursive-state word words quotations inline-words ;
|
||||
|
||||
: prepare-recursive-state ( word rstate -- rstate )
|
||||
swap >>word
|
||||
|
|
|
|||
|
|
@ -580,3 +580,5 @@ DEFER: eee'
|
|||
dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
|
||||
|
||||
[ bogus-error ] must-infer
|
||||
|
||||
[ [ clear ] infer. ] [ inference-error? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ math.vectors math.order sorting binary-search sets assocs fry ;
|
|||
IN: suffix-arrays
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: suffixes ( string -- suffixes-seq )
|
||||
dup length [ tail-slice ] with map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax kernel kernel.private io
|
||||
threads.private continuations dlists init quotations strings
|
||||
threads.private continuations init quotations strings
|
||||
assocs heaps boxes namespaces deques ;
|
||||
IN: threads
|
||||
|
||||
|
|
@ -82,7 +82,7 @@ $nl
|
|||
{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
|
||||
|
||||
HELP: run-queue
|
||||
{ $values { "queue" dlist } }
|
||||
{ $values { "queue" deque } }
|
||||
{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time."
|
||||
$nl
|
||||
"By convention, threads are queued with " { $link push-front }
|
||||
|
|
@ -129,7 +129,7 @@ HELP: interrupt
|
|||
{ $description "Interrupts a sleeping thread." } ;
|
||||
|
||||
HELP: suspend
|
||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "state" string } { "obj" object } }
|
||||
{ $values { "quot" { $quotation "( thread -- )" } } { "state" string } { "obj" object } }
|
||||
{ $description "Suspends the current thread and passes it to the quotation."
|
||||
$nl
|
||||
"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "."
|
||||
|
|
@ -149,7 +149,7 @@ $nl
|
|||
} ;
|
||||
|
||||
HELP: spawn-server
|
||||
{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } { "thread" thread } }
|
||||
{ $values { "quot" { $quotation "( -- ? )" } } { "name" string } { "thread" thread } }
|
||||
{ $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." }
|
||||
{ $examples
|
||||
"A thread that runs forever:"
|
||||
|
|
@ -172,5 +172,5 @@ HELP: tset
|
|||
{ $description "Sets the value of a thread-local variable." } ;
|
||||
|
||||
HELP: tchange
|
||||
{ $values { "key" object } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } }
|
||||
{ $values { "key" object } { "quot" { $quotation "( value -- newvalue )" } } }
|
||||
{ $description "Applies the quotation to the current value of a thread-local variable, storing the result back to the same variable." } ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ ARTICLE: "tools.annotations" "Word annotations"
|
|||
ABOUT: "tools.annotations"
|
||||
|
||||
HELP: annotate
|
||||
{ $values { "word" "a word" } { "quot" "a quotation with stack effect " { $snippet "( word def -- def )" } } }
|
||||
{ $values { "word" "a word" } { "quot" { $quotation "( word def -- def )" } } }
|
||||
{ $description "Changes a word definition to the result of applying a quotation to the old definition." }
|
||||
{ $notes "This word is used to implement " { $link watch } "." } ;
|
||||
|
||||
|
|
@ -28,7 +28,7 @@ HELP: breakpoint
|
|||
{ $description "Annotates a word definition to enter the single stepper when executed." } ;
|
||||
|
||||
HELP: breakpoint-if
|
||||
{ $values { "quot" "a quotation with stack effect" { $snippet "( -- ? )" } } { "word" word } }
|
||||
{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
|
||||
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
|
||||
|
||||
HELP: annotate-methods
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ sorting compiler.units definitions ;
|
|||
QUALIFIED: bootstrap.stage2
|
||||
QUALIFIED: classes
|
||||
QUALIFIED: command-line
|
||||
QUALIFIED: compiler.errors.private
|
||||
QUALIFIED: compiler.errors
|
||||
QUALIFIED: continuations
|
||||
QUALIFIED: definitions
|
||||
QUALIFIED: init
|
||||
|
|
@ -291,7 +291,7 @@ IN: tools.deploy.shaker
|
|||
|
||||
strip-debugger? [
|
||||
{
|
||||
compiler.errors.private:compiler-errors
|
||||
compiler.errors:compiler-errors
|
||||
continuations:thread-error-hook
|
||||
} %
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -1,3 +1,2 @@
|
|||
unportable
|
||||
windows
|
||||
tools
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue