diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor
index dac8b72dd5..2d494afca3 100644
--- a/basis/alarms/alarms-docs.factor
+++ b/basis/alarms/alarms-docs.factor
@@ -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
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
index 03208de63a..739b45486f 100644
--- a/basis/alien/c-types/c-types-docs.factor
+++ b/basis/alien/c-types/c-types-docs.factor
@@ -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." } ;
diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor
index caabbd7419..cf7915159a 100644
--- a/basis/binary-search/binary-search-docs.factor
+++ b/basis/binary-search/binary-search-docs.factor
@@ -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+ } "."
diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor
index 9b5e3fdfd9..400599383f 100644
--- a/basis/cocoa/messages/messages-docs.factor
+++ b/basis/cocoa/messages/messages-docs.factor
@@ -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
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index b01a835b4a..a6afc4b243 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -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
diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor
index 08bfde55b2..44b71935c8 100644
--- a/basis/compiler/tree/dead-code/liveness/liveness.factor
+++ b/basis/compiler/tree/dead-code/liveness/liveness.factor
@@ -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
diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor
index 9be9f13043..705f44eeb6 100644
--- a/basis/compiler/tree/def-use/def-use.factor
+++ b/basis/compiler/tree/def-use/def-use.factor
@@ -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 ;
diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
index d257cd6600..2e40693e69 100644
--- a/basis/compiler/tree/recursive/recursive.factor
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -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
diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor
index a23301c1e2..cb07e5a8d6 100644
--- a/basis/concurrency/combinators/combinators-docs.factor
+++ b/basis/concurrency/combinators/combinators-docs.factor
@@ -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." } ;
diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor
index 99b4bb6e81..22549c1720 100644
--- a/basis/concurrency/futures/futures-docs.factor
+++ b/basis/concurrency/futures/futures-docs.factor
@@ -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 } "." } ;
diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor
index a3cf2fc782..b74dcec384 100644
--- a/basis/concurrency/locks/locks-docs.factor
+++ b/basis/concurrency/locks/locks-docs.factor
@@ -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." } ;
diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor
index a9b86e3bcd..234fb27d60 100644
--- a/basis/concurrency/mailboxes/mailboxes-docs.factor
+++ b/basis/concurrency/mailboxes/mailboxes-docs.factor
@@ -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:"
diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor
index 6a4a2bf8d6..be7a8cf65b 100644
--- a/basis/concurrency/promises/promises-docs.factor
+++ b/basis/concurrency/promises/promises-docs.factor
@@ -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." } ;
diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor
index 379fd6a3a0..c86623f86f 100644
--- a/basis/concurrency/semaphores/semaphores-docs.factor
+++ b/basis/concurrency/semaphores/semaphores-docs.factor
@@ -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
diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor
index 58f077ed1e..e747bd9316 100644
--- a/basis/deques/deques-docs.factor
+++ b/basis/deques/deques-docs.factor
@@ -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 }
diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor
index 1d86a3f1db..f4e68c214b 100644
--- a/basis/deques/deques.factor
+++ b/basis/deques/deques.factor
@@ -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 ;
diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor
index 557010cf7c..ef6087f852 100644
--- a/basis/dlists/dlists-docs.factor
+++ b/basis/dlists/dlists-docs.factor
@@ -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." }
diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index 92b141dca8..6df3e306dd 100644
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -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
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index 5072c3edfd..549dbf947d 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -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 -- )
diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor
index 61fab306a2..974645b284 100644
--- a/basis/documents/documents-docs.factor
+++ b/basis/documents/documents-docs.factor
@@ -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." } ;
diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor
new file mode 100644
index 0000000000..e7e722344a
--- /dev/null
+++ b/basis/furnace/auth/auth-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/basic/basic-docs.factor b/basis/furnace/auth/basic/basic-docs.factor
new file mode 100644
index 0000000000..c0d3184c78
--- /dev/null
+++ b/basis/furnace/auth/basic/basic-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor
new file mode 100644
index 0000000000..ef4f2e1075
--- /dev/null
+++ b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor
new file mode 100644
index 0000000000..6f3c9d151b
--- /dev/null
+++ b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor
@@ -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>"
+} ;
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor
index 243ea7bfff..cefb472b22 100644
--- a/basis/furnace/auth/features/edit-profile/edit-profile.factor
+++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor
@@ -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? ( -- ? )
diff --git a/basis/furnace/auth/features/recover-password/recover-password-docs.factor b/basis/furnace/auth/features/recover-password/recover-password-docs.factor
new file mode 100644
index 0000000000..1dc7e99eff
--- /dev/null
+++ b/basis/furnace/auth/features/recover-password/recover-password-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor
index 49e692d5a6..5885aaef61 100644
--- a/basis/furnace/auth/features/recover-password/recover-password.factor
+++ b/basis/furnace/auth/features/recover-password/recover-password.factor
@@ -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>
diff --git a/basis/furnace/auth/features/registration/registration-docs.factor b/basis/furnace/auth/features/registration/registration-docs.factor
new file mode 100644
index 0000000000..1f12570173
--- /dev/null
+++ b/basis/furnace/auth/features/registration/registration-docs.factor
@@ -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>"
+} ;
diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor
index ef8923c98b..0484c11727 100644
--- a/basis/furnace/auth/features/registration/registration.factor
+++ b/basis/furnace/auth/features/registration/registration.factor
@@ -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? ( -- ? )
diff --git a/basis/furnace/auth/login/login-docs.factor b/basis/furnace/auth/login/login-docs.factor
new file mode 100644
index 0000000000..08b7d933e6
--- /dev/null
+++ b/basis/furnace/auth/login/login-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor
index 2c98672490..4fc4e7e8be 100644
--- a/basis/furnace/auth/login/login.factor
+++ b/basis/furnace/auth/login/login.factor
@@ -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
diff --git a/basis/furnace/auth/providers/assoc/assoc-docs.factor b/basis/furnace/auth/providers/assoc/assoc-docs.factor
new file mode 100644
index 0000000000..61c2ac4eed
--- /dev/null
+++ b/basis/furnace/auth/providers/assoc/assoc-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/providers/db/db-docs.factor b/basis/furnace/auth/providers/db/db-docs.factor
new file mode 100644
index 0000000000..219edf9490
--- /dev/null
+++ b/basis/furnace/auth/providers/db/db-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/providers/null/null-docs.factor b/basis/furnace/auth/providers/null/null-docs.factor
new file mode 100644
index 0000000000..100b16c7d3
--- /dev/null
+++ b/basis/furnace/auth/providers/null/null-docs.factor
@@ -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"
diff --git a/basis/furnace/auth/providers/providers-docs.factor b/basis/furnace/auth/providers/providers-docs.factor
new file mode 100644
index 0000000000..5d15bf4f65
--- /dev/null
+++ b/basis/furnace/auth/providers/providers-docs.factor
@@ -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"
diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor
index 60844fadae..4ad2c8a249 100644
--- a/basis/furnace/conversations/conversations-docs.factor
+++ b/basis/furnace/conversations/conversations-docs.factor
@@ -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"
diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor
index 57181ff0e9..b86d4c3295 100644
--- a/basis/furnace/furnace-docs.factor
+++ b/basis/furnace/furnace-docs.factor
@@ -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" }
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
index a77b0d28c7..29eb00a8f4 100644
--- a/basis/furnace/furnace.factor
+++ b/basis/furnace/furnace.factor
@@ -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
diff --git a/basis/furnace/referrer/referrer-docs.factor b/basis/furnace/referrer/referrer-docs.factor
index 5deebbe9a7..599461c37c 100644
--- a/basis/furnace/referrer/referrer-docs.factor
+++ b/basis/furnace/referrer/referrer-docs.factor
@@ -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"
diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor
index 778452edc2..959d6b69b8 100644
--- a/basis/furnace/sessions/sessions-docs.factor
+++ b/basis/furnace/sessions/sessions-docs.factor
@@ -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
diff --git a/basis/furnace/summary.txt b/basis/furnace/summary.txt
new file mode 100644
index 0000000000..afbc1b9b2c
--- /dev/null
+++ b/basis/furnace/summary.txt
@@ -0,0 +1 @@
+Furnace web framework
diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor
index 2fe4edfe7f..277d965e39 100644
--- a/basis/help/help-docs.factor
+++ b/basis/help/help-docs.factor
@@ -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" } }
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index 386dca9576..4100a34d72 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -5,7 +5,7 @@ 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 -- )
@@ -22,6 +22,7 @@ IN: help.html
{ CHAR: / "__slash__" }
{ CHAR: \\ "__backslash__" }
{ CHAR: , "__comma__" }
+ { CHAR: @ "__at__" }
} at [ % ] [ , ] ?if ;
: escape-filename ( string -- filename )
@@ -88,19 +89,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 +117,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 ;
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index 1eae56cfcc..a307833338 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -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
diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor
index 402b6e68a9..1f2975bce1 100644
--- a/basis/html/templates/chloe/chloe-docs.factor
+++ b/basis/html/templates/chloe/chloe-docs.factor
@@ -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." } ;
diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor
index d4f277a7c3..7a35ba812b 100644
--- a/basis/http/client/client-docs.factor
+++ b/basis/http/client/client-docs.factor
@@ -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." } ;
diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor
index 4db04f04aa..6fb5b73fad 100644
--- a/basis/http/http-docs.factor
+++ b/basis/http/http-docs.factor
@@ -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
diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor
index bca72a6126..fbe20b5fcd 100644
--- a/basis/http/server/static/static-docs.factor
+++ b/basis/http/server/static/static-docs.factor
@@ -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>
diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor
index c774103fca..09922fc929 100644
--- a/basis/io/mmap/mmap-docs.factor
+++ b/basis/io/mmap/mmap-docs.factor
@@ -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." } ;
diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor
index ce59e23b45..3242b276e6 100644
--- a/basis/io/monitors/monitors-docs.factor
+++ b/basis/io/monitors/monitors-docs.factor
@@ -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." } ;
diff --git a/basis/io/pools/pools-docs.factor b/basis/io/pools/pools-docs.factor
index aae1698349..36f437dd09 100644
--- a/basis/io/pools/pools-docs.factor
+++ b/basis/io/pools/pools-docs.factor
@@ -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
diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor
index 22c40da3d7..b093840987 100644
--- a/basis/io/servers/connection/connection-docs.factor
+++ b/basis/io/servers/connection/connection-docs.factor
@@ -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." } ;
diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor
index 3454f3384e..25401293f5 100644
--- a/basis/io/sockets/sockets-docs.factor
+++ b/basis/io/sockets/sockets-docs.factor
@@ -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"
diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor
index b2927af362..5d72bde0f5 100644
--- a/basis/io/timeouts/timeouts-docs.factor
+++ b/basis/io/timeouts/timeouts-docs.factor
@@ -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"
diff --git a/basis/libc/libc-docs.factor b/basis/libc/libc-docs.factor
index 5e285bf26d..37a3b7068f 100644
--- a/basis/libc/libc-docs.factor
+++ b/basis/libc/libc-docs.factor
@@ -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
diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor
index f9bb8e9897..ea3da55082 100644
--- a/basis/math/functions/functions-docs.factor
+++ b/basis/math/functions/functions-docs.factor
@@ -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 }" }
diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor
index c5e5a6e7b8..5a96c7aceb 100644
--- a/basis/math/intervals/intervals-docs.factor
+++ b/basis/math/intervals/intervals-docs.factor
@@ -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" } }
diff --git a/basis/models/filter/filter-docs.factor b/basis/models/filter/filter-docs.factor
index 8c50aac65b..c3f4df3250 100644
--- a/basis/models/filter/filter-docs.factor
+++ b/basis/models/filter/filter-docs.factor
@@ -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 } "." } ;
diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor
index 97e4557ada..5295420ee3 100644
--- a/basis/models/models-docs.factor
+++ b/basis/models/models-docs.factor
@@ -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." } ;
diff --git a/basis/peg/peg-docs.factor b/basis/peg/peg-docs.factor
index 00390c1b1e..976c32d102 100644
--- a/basis/peg/peg-docs.factor
+++ b/basis/peg/peg-docs.factor
@@ -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 "
diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor
index cc4f5cedb5..64e1fd45ff 100644
--- a/basis/prettyprint/backend/backend-docs.factor
+++ b/basis/prettyprint/backend/backend-docs.factor
@@ -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 ;
diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor
index 842a36a13b..4f1c073a2d 100644
--- a/basis/prettyprint/sections/sections-docs.factor
+++ b/basis/prettyprint/sections/sections-docs.factor
@@ -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)
diff --git a/basis/search-deques/search-deques-docs.factor b/basis/search-deques/search-deques-docs.factor
index fef770b0f8..fe0ce7c157 100644
--- a/basis/search-deques/search-deques-docs.factor
+++ b/basis/search-deques/search-deques-docs.factor
@@ -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." } ;
diff --git a/basis/search-deques/search-deques-tests.factor b/basis/search-deques/search-deques-tests.factor
index cf2837a84c..7c40c60f7a 100644
--- a/basis/search-deques/search-deques-tests.factor
+++ b/basis/search-deques/search-deques-tests.factor
@@ -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
diff --git a/basis/search-deques/search-deques.factor b/basis/search-deques/search-deques.factor
index 8e5506090c..5546a9766d 100644
--- a/basis/search-deques/search-deques.factor
+++ b/basis/search-deques/search-deques.factor
@@ -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 ;
diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor
index b181ba9d60..fa68cc0a8e 100755
--- a/basis/suffix-arrays/suffix-arrays.factor
+++ b/basis/suffix-arrays/suffix-arrays.factor
@@ -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 ;
diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index 3c4715d3e3..471cd2bd34 100644
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -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." } ;
diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor
index f0a3235e62..c61b4547a9 100644
--- a/basis/tools/annotations/annotations-docs.factor
+++ b/basis/tools/annotations/annotations-docs.factor
@@ -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
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index a7332ea9ea..f8f9680c16 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -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
diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor
index 02c0ad126d..f19ffb83a4 100644
--- a/basis/tools/test/test-docs.factor
+++ b/basis/tools/test/test-docs.factor
@@ -60,7 +60,7 @@ HELP: must-fail
{ $notes "This word is used to test boundary conditions and fail-fast behavior." } ;
HELP: must-fail-with
-{ $values { "quot" "a quotation run with an empty stack" } { "pred" "a quotation with stack effect " { $snippet "( error -- ? )" } } }
+{ $values { "quot" "a quotation run with an empty stack" } { "pred" { $quotation "( error -- ? )" } } }
{ $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." }
{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ;
diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor
index 25312ad868..5f1ff6dabd 100644
--- a/basis/ui/commands/commands-docs.factor
+++ b/basis/ui/commands/commands-docs.factor
@@ -71,7 +71,7 @@ HELP: command-word
{ $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ;
HELP: command-map
-{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
+{ $values { "group" string } { "class" "a class word" } { "command-map" { $maybe command-map } } }
{ $description "Outputs a named command map defined on a class." }
{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
$nl
@@ -82,7 +82,7 @@ HELP: commands
{ $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ;
HELP: define-command-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } }
+{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "pairs" "a sequence of gesture/word pairs" } }
{ $description
"Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "."
}
diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor
index c4edaac144..4a428404c1 100644
--- a/basis/ui/gadgets/buttons/buttons-docs.factor
+++ b/basis/ui/gadgets/buttons/buttons-docs.factor
@@ -10,19 +10,19 @@ $nl
"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
HELP: <button>
-{ $values { "label" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
+{ $values { "label" gadget } { "quot" { $quotation "( button -- )" } } { "button" "a new " { $link button } } }
{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
HELP: <roll-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $values { "label" "a label specifier" } { "quot" { $quotation "( button -- )" } } { "button" button } }
{ $description "Creates a new " { $link button } " which is displayed with a solid border when it is under the mouse, informing the user that the gadget is clickable." } ;
HELP: <bevel-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $values { "label" "a label specifier" } { "quot" { $quotation "( button -- )" } } { "button" button } }
{ $description "Creates a new " { $link button } " with a shaded border which is always visible. The button appearance changes in response to mouse gestures using a " { $link button-paint } "." } ;
HELP: <repeat-button>
-{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" repeat-button } }
+{ $values { "label" object } { "quot" { $quotation "( button -- )" } } { "button" repeat-button } }
{ $description "Creates a new " { $link button } " derived from a " { $link <bevel-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
HELP: button-paint
diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor
index b691668206..0cf60ff5e8 100644
--- a/basis/ui/gadgets/editors/editors-docs.factor
+++ b/basis/ui/gadgets/editors/editors-docs.factor
@@ -41,7 +41,7 @@ HELP: editor-mark*
{ $description "Outputs the current mark location as a line/column number pair." } ;
HELP: change-caret
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $values { "editor" editor } { "quot" { $quotation "( loc -- newloc )" } } }
{ $description "Applies a quotation to the current caret location and moves the caret to the location output by the quotation." } ;
{ change-caret change-caret&mark mark>caret } related-words
@@ -51,7 +51,7 @@ HELP: mark>caret
{ $description "Moves the mark to the caret location, effectively deselecting any selected text." } ;
HELP: change-caret&mark
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $values { "editor" editor } { "quot" { $quotation "( loc -- newloc )" } } }
{ $description "Applies a quotation to the current caret location and moves the caret and the mark to the location output by the quotation." } ;
HELP: point>loc
diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor
index 394841c599..169f97f0b9 100644
--- a/basis/ui/gadgets/gadgets-docs.factor
+++ b/basis/ui/gadgets/gadgets-docs.factor
@@ -34,7 +34,7 @@ HELP: children-on
{ $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
HELP: pick-up
-{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
+{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" { $maybe gadget } } }
{ $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ;
HELP: max-dim
@@ -44,7 +44,7 @@ HELP: max-dim
{ pref-dims max-dim dim-sum } related-words
HELP: each-child
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
+{ $values { "gadget" gadget } { "quot" { $quotation "( child -- )" } } }
{ $description "Applies the quotation to each child of the gadget." } ;
HELP: gadget-selection?
@@ -52,7 +52,7 @@ HELP: gadget-selection?
{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
HELP: gadget-selection
-{ $values { "gadget" gadget } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $values { "gadget" gadget } { "string/f" { $maybe string } } }
{ $contract "Outputs the gadget's text selection, or " { $link f } " if nothing is selected." } ;
HELP: relayout
@@ -146,11 +146,11 @@ HELP: parents
{ $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ;
HELP: each-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "?" "a boolean" } }
+{ $values { "gadget" gadget } { "quot" { $quotation "( gadget -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ;
HELP: find-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "parent" gadget } }
+{ $values { "gadget" gadget } { "quot" { $quotation "( gadget -- ? )" } } { "parent" gadget } }
{ $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ;
HELP: screen-loc
diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor
index 877d4ad145..01d695c281 100644
--- a/basis/ui/gadgets/gadgets-tests.factor
+++ b/basis/ui/gadgets/gadgets-tests.factor
@@ -138,7 +138,7 @@ M: mock-gadget ungraft*
[ V{ { f t } } ] [ status-flags ] unit-test
dup [ [ ] [ notify-queued ] unit-test ] when
[ ] [ "g" get clear-gadget ] unit-test
- [ [ 1 ] [ graft-queue length>> ] unit-test ] unless
+ [ [ t ] [ graft-queue [ front>> ] [ back>> ] bi eq? ] unit-test ] unless
[ [ ] [ notify-queued ] unit-test ] when
[ ] [ add-some-children ] unit-test
[ { f t } ] [ "1" get graft-state>> ] unit-test
diff --git a/basis/ui/gadgets/labelled/labelled-docs.factor b/basis/ui/gadgets/labelled/labelled-docs.factor
index f09bcaa825..4ad14abfd1 100644
--- a/basis/ui/gadgets/labelled/labelled-docs.factor
+++ b/basis/ui/gadgets/labelled/labelled-docs.factor
@@ -13,12 +13,12 @@ HELP: closable-gadget
{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
HELP: <closable-gadget>
-{ $values { "gadget" gadget } { "title" string } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
+{ $values { "gadget" gadget } { "title" string } { "quot" { $quotation "( button -- )" } } }
{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
HELP: <labelled-pane>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
+{ $values { "model" model } { "quot" { $quotation "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
{ <labelled-pane> <pane-control> } related-words
diff --git a/basis/ui/gadgets/lists/lists-docs.factor b/basis/ui/gadgets/lists/lists-docs.factor
index b698d558ad..6341e09505 100644
--- a/basis/ui/gadgets/lists/lists-docs.factor
+++ b/basis/ui/gadgets/lists/lists-docs.factor
@@ -14,7 +14,7 @@ HELP: list
} ;
HELP: <list>
-{ $values { "hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "presenter" "a quotation with stack effect " { $snippet "( object -- label )" } } { "model" model } { "gadget" list } }
+{ $values { "hook" { $quotation "( list -- )" } } { "presenter" { $quotation "( object -- label )" } } { "model" model } { "gadget" list } }
{ $description "Creates a new " { $link list } "."
$nl
"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor
index 505eb2231f..303eb0a13e 100644
--- a/basis/ui/gadgets/menus/menus-docs.factor
+++ b/basis/ui/gadgets/menus/menus-docs.factor
@@ -3,7 +3,7 @@ kernel ;
IN: ui.gadgets.menus
HELP: <commands-menu>
-{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
+{ $values { "hook" { $quotation "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
HELP: show-menu
diff --git a/basis/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor
index 99f8b2e82a..d53cba5f76 100644
--- a/basis/ui/gadgets/panes/panes-docs.factor
+++ b/basis/ui/gadgets/panes/panes-docs.factor
@@ -43,7 +43,7 @@ HELP: <scrolling-pane>
{ $description "Creates a new " { $link pane } " gadget which scrolls any scroll pane containing it to the bottom on output. behaving much like a terminal or logger." } ;
HELP: <pane-control>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
+{ $values { "model" model } { "quot" { $quotation "( value -- )" } } { "pane" "a new " { $link pane } } }
{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
HELP: pane-stream
diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor
index 3554c735a7..b248527c37 100644
--- a/basis/ui/gadgets/scrollers/scrollers-docs.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor
@@ -8,7 +8,7 @@ $nl
"Scroller gadgets are created by calling " { $link <scroller> } "." } ;
HELP: find-scroller
-{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } }
+{ $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
HELP: scroller-value
diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor
index 63284f135d..c130c724d0 100644
--- a/basis/ui/gadgets/sliders/sliders-docs.factor
+++ b/basis/ui/gadgets/sliders/sliders-docs.factor
@@ -5,7 +5,7 @@ HELP: elevator
{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
HELP: find-elevator
-{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } }
+{ $values { "gadget" gadget } { "elevator/f" { $maybe elevator } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
HELP: slider
@@ -14,7 +14,7 @@ $nl
"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
HELP: find-slider
-{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } }
+{ $values { "gadget" gadget } { "slider/f" { $maybe slider } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ;
HELP: thumb
diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor
index 122d14eed7..9dd152885e 100644
--- a/basis/ui/gadgets/worlds/worlds-docs.factor
+++ b/basis/ui/gadgets/worlds/worlds-docs.factor
@@ -46,7 +46,7 @@ HELP: <world>
{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
HELP: find-world
-{ $values { "gadget" gadget } { "world/f" "a " { $link world } " or " { $link f } } }
+{ $values { "gadget" gadget } { "world/f" { $maybe world } } }
{ $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ;
HELP: draw-world
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 0575ff17f0..3471bd2cdb 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -189,7 +189,7 @@ HELP: under-hand
{ $description "Outputs a sequence where the first element is the " { $link hand-world } " and the last is the " { $link hand-gadget } ", with all parents in between." } ;
HELP: gesture>string
-{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $values { "gesture" "a gesture" } { "string/f" { $maybe string } } }
{ $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." }
{ $examples
{ $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor
index ebdf3eee1f..d05519f46a 100644
--- a/basis/ui/operations/operations-docs.factor
+++ b/basis/ui/operations/operations-docs.factor
@@ -41,15 +41,15 @@ HELP: object-operations
{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $snippet "predicate" } " quotation in turn." } ;
HELP: primary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $values { "obj" object } { "operation" { $maybe operation } } }
{ $description "Outputs the operation which should be invoked when a presentation of " { $snippet "obj" } " is clicked." } ;
HELP: secondary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $values { "obj" object } { "operation" { $maybe operation } } }
{ $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ;
HELP: define-operation
-{ $values { "pred" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
+{ $values { "pred" { $quotation "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
{ $description "Defines an operation on objects matching the predicate. The hashtable can contain the following keys:"
{ $list
{ { $link +listener+ } " - if set to a true value, the operation will run in the listener" }
@@ -61,7 +61,7 @@ HELP: define-operation
} ;
HELP: define-operation-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } }
+{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "hook" { $quotation "( obj -- newobj )" } ", or " { $link f } } { "translator" { $quotation "( obj -- newobj )" } ", or " { $link f } } }
{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ;
HELP: $operations
diff --git a/basis/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor
index b57dafaf49..12a2e0d806 100644
--- a/basis/ui/tools/debugger/debugger-docs.factor
+++ b/basis/ui/tools/debugger/debugger-docs.factor
@@ -3,7 +3,7 @@ continuations debugger ui ;
IN: ui.tools.debugger
HELP: <debugger>
-{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "gadget" "a new " { $link gadget } } }
+{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" { $quotation "( list -- )" } } { "gadget" "a new " { $link gadget } } }
{ $description
"Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
} ;
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index d8c816d717..58509fc2df 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -23,7 +23,7 @@ HELP: fullscreen?
{ fullscreen? set-fullscreen? } related-words
HELP: find-window
-{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
+{ $values { "quot" { $quotation "( world -- ? )" } } { "world" { $maybe world } } }
{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
diff --git a/basis/unrolled-lists/unrolled-lists-docs.factor b/basis/unrolled-lists/unrolled-lists-docs.factor
new file mode 100644
index 0000000000..387bb3dc7b
--- /dev/null
+++ b/basis/unrolled-lists/unrolled-lists-docs.factor
@@ -0,0 +1,22 @@
+IN: unrolled-lists
+USING: help.markup help.syntax hashtables search-deques dlists
+deques ;
+
+HELP: unrolled-list
+{ $class-description "The class of unrolled lists." } ;
+
+HELP: <unrolled-list>
+{ $values { "list" unrolled-list } }
+{ $description "Creates a new unrolled list." } ;
+
+HELP: <hashed-unrolled-list>
+{ $values { "search-deque" search-deque } }
+{ $description "Creates a new " { $link search-deque } " backed by an " { $link unrolled-list } ", with a " { $link hashtable } " for fast membership tests." } ;
+
+ARTICLE: "unrolled-lists" "Unrolled lists"
+"The " { $vocab-link "unrolled-lists" } " vocabulary provides an implementation of the " { $link deque } " protocol with constant time insertion and removal at both ends, and lower memory overhead than a " { $link dlist } " due to packing 32 elements per every node. The one tradeoff is that unlike dlists, " { $link delete-node } " is not supported for unrolled lists."
+{ $subsection unrolled-list }
+{ $subsection <unrolled-list> }
+{ $subsection <hashed-unrolled-list> } ;
+
+ABOUT: "unrolled-lists"
diff --git a/basis/unrolled-lists/unrolled-lists-tests.factor b/basis/unrolled-lists/unrolled-lists-tests.factor
new file mode 100644
index 0000000000..89eb1cdebd
--- /dev/null
+++ b/basis/unrolled-lists/unrolled-lists-tests.factor
@@ -0,0 +1,130 @@
+USING: unrolled-lists tools.test deques kernel sequences
+random prettyprint grouping ;
+IN: unrolled-lists.tests
+
+[ 1 ] [ <unrolled-list> 1 over push-front pop-front ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-front pop-back ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-back pop-front ] unit-test
+[ 1 ] [ <unrolled-list> 1 over push-back pop-back ] unit-test
+
+[ 1 2 ] [
+ <unrolled-list> 1 over push-back 2 over push-back
+ [ pop-front ] [ pop-front ] bi
+] unit-test
+
+[ 2 1 ] [
+ <unrolled-list> 1 over push-back 2 over push-back
+ [ pop-back ] [ pop-back ] bi
+] unit-test
+
+[ 1 2 3 ] [
+ <unrolled-list>
+ 1 over push-back
+ 2 over push-back
+ 3 over push-back
+ [ pop-front ] [ pop-front ] [ pop-front ] tri
+] unit-test
+
+[ 3 2 1 ] [
+ <unrolled-list>
+ 1 over push-back
+ 2 over push-back
+ 3 over push-back
+ [ pop-back ] [ pop-back ] [ pop-back ] tri
+] unit-test
+
+[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
+ <unrolled-list>
+ 32 [ over push-front ] each
+ 32 [ dup pop-back ] replicate
+ nip
+] unit-test
+
+[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
+ <unrolled-list>
+ 32 [ over push-front ] each
+ 32 [ dup pop-front ] replicate reverse
+ nip
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1000 [ 1000 random ] replicate
+ [ [ over push-front ] each ]
+ [ [ dup pop-back ] replicate ]
+ [ ]
+ tri
+ =
+ nip
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1000 [ 1000 random ] replicate
+ [
+ 10 group [
+ [ [ over push-front ] each ]
+ [ [ dup pop-back ] replicate ]
+ bi
+ ] map concat
+ ] keep
+ =
+ nip
+] unit-test
+
+[ t ] [ <unrolled-list> deque-empty? ] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-front
+ dup pop-front*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-back
+ dup pop-front*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-front
+ dup pop-back*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 1 over push-back
+ dup pop-back*
+ deque-empty?
+] unit-test
+
+[ t ] [
+ <unrolled-list>
+ 21 over push-front
+ 22 over push-front
+ 25 over push-front
+ 26 over push-front
+ dup pop-back 21 assert=
+ 28 over push-front
+ dup pop-back 22 assert=
+ 29 over push-front
+ dup pop-back 25 assert=
+ 24 over push-front
+ dup pop-back 26 assert=
+ 23 over push-front
+ dup pop-back 28 assert=
+ dup pop-back 29 assert=
+ dup pop-back 24 assert=
+ 17 over push-front
+ dup pop-back 23 assert=
+ 27 over push-front
+ dup pop-back 17 assert=
+ 30 over push-front
+ dup pop-back 27 assert=
+ dup pop-back 30 assert=
+ deque-empty?
+] unit-test
diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor
new file mode 100644
index 0000000000..d434632abd
--- /dev/null
+++ b/basis/unrolled-lists/unrolled-lists.factor
@@ -0,0 +1,140 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays math kernel accessors sequences sequences.private
+deques search-deques hashtables ;
+IN: unrolled-lists
+
+: unroll-factor 32 ; inline
+
+<PRIVATE
+
+MIXIN: ?node
+INSTANCE: f ?node
+TUPLE: node { data array } { prev ?node } { next ?node } ;
+INSTANCE: node ?node
+
+PRIVATE>
+
+TUPLE: unrolled-list
+{ front ?node } { front-pos fixnum }
+{ back ?node } { back-pos fixnum } ;
+
+: <unrolled-list> ( -- list )
+ unrolled-list new
+ unroll-factor >>back-pos ; inline
+
+: <hashed-unrolled-list> ( -- search-deque )
+ 20 <hashtable> <unrolled-list> <search-deque> ;
+
+ERROR: empty-unrolled-list list ;
+
+<PRIVATE
+
+M: unrolled-list deque-empty?
+ dup [ front>> ] [ back>> ] bi dup [
+ eq? [ [ front-pos>> ] [ back-pos>> ] bi eq? ] [ drop f ] if
+ ] [ 3drop t ] if ;
+
+M: unrolled-list clear-deque
+ f >>front
+ 0 >>front-pos
+ f >>back
+ unroll-factor >>back-pos
+ drop ;
+
+: <front-node> ( elt front -- node )
+ [
+ unroll-factor 0 <array>
+ [ unroll-factor 1- swap set-nth ] keep f
+ ] dip [ node boa dup ] keep
+ dup [ (>>prev) ] [ 2drop ] if ; inline
+
+: normalize-back ( list -- )
+ dup back>> [
+ dup prev>> [ drop ] [ swap front>> >>prev ] if
+ ] [ dup front>> >>back ] if* drop ; inline
+
+: push-front/new ( elt list -- )
+ unroll-factor 1- >>front-pos
+ [ <front-node> ] change-front
+ normalize-back ; inline
+
+: push-front/existing ( elt list front -- )
+ [ [ 1- ] change-front-pos ] dip
+ [ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline
+
+M: unrolled-list push-front*
+ dup [ front>> ] [ front-pos>> 0 eq? not ] bi
+ [ drop ] [ and ] 2bi
+ [ push-front/existing ] [ drop push-front/new ] if f ;
+
+M: unrolled-list peek-front
+ dup front>>
+ [ [ front-pos>> ] dip data>> nth-unsafe ]
+ [ empty-unrolled-list ]
+ if* ;
+
+: pop-front/new ( list front -- )
+ [ 0 >>front-pos ] dip
+ [ f ] change-next drop dup [ f >>prev ] when >>front
+ dup front>> [ normalize-back ] [ f >>back drop ] if ; inline
+
+: pop-front/existing ( list front -- )
+ [ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
+ [ 1+ ] change-front-pos
+ drop ; inline
+
+M: unrolled-list pop-front*
+ dup front>> [ empty-unrolled-list ] unless*
+ over front-pos>> unroll-factor 1- eq?
+ [ pop-front/new ] [ pop-front/existing ] if ;
+
+: <back-node> ( elt back -- node )
+ [
+ unroll-factor 0 <array> [ set-first ] keep
+ ] dip [ f node boa dup ] keep
+ dup [ (>>next) ] [ 2drop ] if ; inline
+
+: normalize-front ( list -- )
+ dup front>> [
+ dup next>> [ drop ] [ swap back>> >>next ] if
+ ] [ dup back>> >>front ] if* drop ; inline
+
+: push-back/new ( elt list -- )
+ 1 >>back-pos
+ [ <back-node> ] change-back
+ normalize-front ; inline
+
+: push-back/existing ( elt list back -- )
+ [ [ 1+ ] change-back-pos ] dip
+ [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline
+
+M: unrolled-list push-back*
+ dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
+ [ drop ] [ and ] 2bi
+ [ push-back/existing ] [ drop push-back/new ] if f ;
+
+M: unrolled-list peek-back
+ dup back>>
+ [ [ back-pos>> 1- ] dip data>> nth-unsafe ]
+ [ empty-unrolled-list ]
+ if* ;
+
+: pop-back/new ( list back -- )
+ [ unroll-factor >>back-pos ] dip
+ [ f ] change-prev drop dup [ f >>next ] when >>back
+ dup back>> [ normalize-front ] [ f >>front drop ] if ; inline
+
+: pop-back/existing ( list back -- )
+ [ [ 1- ] change-back-pos ] dip
+ [ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
+ drop ; inline
+
+M: unrolled-list pop-back*
+ dup back>> [ empty-unrolled-list ] unless*
+ over back-pos>> 1 eq?
+ [ pop-back/new ] [ pop-back/existing ] if ;
+
+PRIVATE>
+
+INSTANCE: unrolled-list deque
diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index b423e6b751..ce8a7be88c 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -77,7 +77,7 @@ HELP: ensure-port
} ;
HELP: parse-host
-{ $values { "string" string } { "host" string } { "port" "an " { $link integer } " or " { $link f } } }
+{ $values { "string" string } { "host" string } { "port" { $maybe integer } } }
{ $description "Splits a string of the form " { $snippet "host:port" } " into a host and a port number. If the port number is not specified, outputs " { $link f } "." }
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
{ $examples
@@ -89,13 +89,13 @@ HELP: parse-host
} ;
HELP: protocol-port
-{ $values { "protocol" "a protocol string" } { "port" "an " { $link integer } " or " { $link f } } }
+{ $values { "protocol" "a protocol string" } { "port" { $maybe integer } } }
{ $description "Outputs the port number associated with a protocol, or " { $link f } " if the protocol is unknown." } ;
HELP: query-param
{ $values
{ "url" url } { "key" string }
- { "value" "a " { $link string } " or " { $link f } } }
+ { "value" { $maybe string } } }
{ $description "Outputs the URL-decoded value of a URL query parameter." }
{ $examples
{ $example
diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor
index c96ea0f8cf..69e2801110 100644
--- a/basis/values/values-docs.factor
+++ b/basis/values/values-docs.factor
@@ -35,5 +35,5 @@ HELP: to:
} ;
HELP: change-value
-{ $values { "word" "a value word" } { "quot" "a quotation with stack effect " { $snippet "( oldvalue -- newvalue )" } } }
+{ $values { "word" "a value word" } { "quot" { $quotation "( oldvalue -- newvalue )" } } }
{ $description "Changes the value using the given quotation." } ;
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index f969b208eb..b02e0189b2 100644
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -161,7 +161,7 @@ HELP: new-assoc
{ $contract "Creates a new assoc of the same size as " { $snippet "exemplar" } " which can hold " { $snippet "capacity" } " entries before growing." } ;
HELP: assoc-find
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
{ $description "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } ;
HELP: clear-assoc
@@ -197,7 +197,7 @@ HELP: at
{ $description "Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to " { $link f } "; if the difference is important, use " { $link at* } "." } ;
HELP: assoc-each
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- )" } } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- )" } } }
{ $description "Applies a quotation to each entry in the assoc." }
{ $examples
{ $example
@@ -209,7 +209,7 @@ HELP: assoc-each
} ;
HELP: assoc-map
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- newkey newvalue )" } } { "newassoc" "a new assoc" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- newkey newvalue )" } } { "newassoc" "a new assoc" } }
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the same type as the input." }
{ $examples
{ $unchecked-example
@@ -224,19 +224,19 @@ HELP: assoc-map
{ assoc-map assoc-map-as } related-words
HELP: assoc-push-if
-{ $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
+{ $values { "accum" "a resizable mutable sequence" } { "quot" { $quotation "( key value -- ? )" } } { "key" object } { "value" object } }
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
HELP: assoc-filter
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
HELP: assoc-contains?
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
HELP: assoc-all?
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: assoc-subset?
@@ -325,20 +325,20 @@ HELP: substitute
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
HELP: cache
-{ $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }
{ $side-effects "assoc" } ;
HELP: map>assoc
-{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- key value )" } } { "exemplar" assoc } { "assoc" "a new assoc" } }
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- key value )" } } { "exemplar" assoc } { "assoc" "a new assoc" } }
{ $description "Applies the quotation to each element of the sequence, and collects the keys and values into a new assoc having the same type as " { $snippet "exemplar" } "." } ;
HELP: assoc>map
-{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- elt )" } } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- elt )" } } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
{ $description "Applies the quotation to each entry of the assoc and collects the results into a new sequence of the same type as the exemplar." } ;
HELP: change-at
-{ $values { "key" object } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } }
+{ $values { "key" object } { "assoc" assoc } { "quot" { $quotation "( value -- newvalue )" } } }
{ $description "Applies the quotation to the value associated with " { $snippet "key" } ", storing the new value back in the assoc." }
{ $side-effects "assoc" } ;
diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor
index d03d97cd4c..3ea0a24674 100644
--- a/core/classes/predicate/predicate-docs.factor
+++ b/core/classes/predicate/predicate-docs.factor
@@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes"
ABOUT: "predicates"
HELP: define-predicate-class
-{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
+{ $values { "class" class } { "superclass" class } { "definition" { $quotation "( superclass -- ? )" } } }
{ $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index a494c09b05..0caabf2fad 100644
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -137,7 +137,7 @@ HELP: no-case
{ $error-description "Thrown by " { $link case } " if the object at the top of the stack does not match any case, and no default case is given." } ;
HELP: recursive-hashcode
-{ $values { "n" integer } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( n obj -- code )" } } { "code" integer } }
+{ $values { "n" integer } { "obj" object } { "quot" { $quotation "( n obj -- code )" } } { "code" integer } }
{ $description "A combinator used to implement methods for the " { $link hashcode* } " generic word. If " { $snippet "n" } " is less than or equal to zero, outputs 0, otherwise calls the quotation." } ;
HELP: cond>quot
@@ -159,7 +159,7 @@ $nl
} } ;
HELP: distribute-buckets
-{ $values { "alist" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
+{ $values { "alist" "an alist" } { "initial" object } { "quot" { $quotation "( obj -- assoc )" } } { "buckets" "a new array" } }
{ $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor
index d86587662b..cb896dbf53 100644
--- a/core/compiler/errors/errors-docs.factor
+++ b/core/compiler/errors/errors-docs.factor
@@ -1,6 +1,6 @@
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
-quotations compiler.errors.private ;
+quotations ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves various notifications in a global variable:"
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
index 7a28c1fb99..c2452f719d 100644
--- a/core/compiler/errors/errors.factor
+++ b/core/compiler/errors/errors.factor
@@ -14,8 +14,6 @@ M: object compiler-error-type drop +error+ ;
GENERIC# compiler-error. 1 ( error word -- )
-<PRIVATE
-
SYMBOL: compiler-errors
SYMBOL: with-compiler-errors?
@@ -47,8 +45,6 @@ SYMBOL: with-compiler-errors?
"semantic warnings" +warning+ "warnings" (compiler-report)
"linkage errors" +linkage+ "linkage" (compiler-report) ;
-PRIVATE>
-
: :errors ( -- ) +error+ compiler-errors. ;
: :warnings ( -- ) +warning+ compiler-errors. ;
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index f5ebc2a338..7a22306c50 100644
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -108,17 +108,17 @@ HELP: >continuation<
{ $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc
-{ $values { "capture" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "restore" quotation } }
+{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
{ callcc0 continue callcc1 continue-with ifcc } related-words
HELP: callcc0
-{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } }
+{ $values { "quot" { $quotation "( continuation -- )" } } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;
HELP: callcc1
-{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
+{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
HELP: continue
@@ -160,7 +160,7 @@ HELP: cleanup
{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
HELP: recover
-{ $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } }
+{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
HELP: ignore-errors
diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor
index c82f92dc10..0b6ca15f31 100644
--- a/core/destructors/destructors-docs.factor
+++ b/core/destructors/destructors-docs.factor
@@ -21,7 +21,7 @@ HELP: dispose*
} ;
HELP: with-disposal
-{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
+{ $values { "object" "a disposable object" } { "quot" { $quotation "( object -- )" } } }
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
HELP: with-destructors
diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor
index f9c18e410d..b209dcf259 100644
--- a/core/effects/effects-docs.factor
+++ b/core/effects/effects-docs.factor
@@ -68,5 +68,5 @@ HELP: effect>string
} ;
HELP: stack-effect
-{ $values { "word" word } { "effect/f" "an " { $link effect } " or " { $link f } } }
+{ $values { "word" word } { "effect/f" { $maybe effect } } }
{ $description "Outputs the stack effect of a word; either a stack effect declared with " { $link POSTPONE: ( } ", or an inferred stack effect (see " { $link "inference" } "." } ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 396b3e8f9a..b5f22ec120 100644
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -127,7 +127,7 @@ HELP: method-body
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
HELP: method
-{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
+{ $values { "class" class } { "generic" generic } { "method/f" { $maybe method-body } } }
{ $description "Looks up a method definition." } ;
{ method create-method POSTPONE: M: } related-words
@@ -146,7 +146,7 @@ HELP: check-method
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
-{ $values { "class" class } { "generic" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
+{ $values { "class" class } { "generic" generic } { "quot" { $quotation "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor
index b0201f3248..da5d4f9eed 100644
--- a/core/generic/math/math-docs.factor
+++ b/core/generic/math/math-docs.factor
@@ -3,7 +3,7 @@ sequences quotations ;
IN: generic.math
HELP: math-upgrade
-{ $values { "class1" class } { "class2" class } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
+{ $values { "class1" class } { "class2" class } { "quot" { $quotation "( n n -- n n )" } } }
{ $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
{ $examples { $example "USING: generic.math math kernel prettyprint ;" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
index b2b75509e9..10d8f7d947 100644
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -5,6 +5,33 @@ strings generic splitting continuations destructors
io.streams.plain io.encodings math.order growable ;
IN: io.streams.string
+<PRIVATE
+
+: harden-as ( seq growble-exemplar -- newseq )
+ underlying>> like ;
+
+: growable-read-until ( growable n -- str )
+ >fixnum dupd tail-slice swap harden-as dup reverse-here ;
+
+SINGLETON: null-encoding
+
+M: null-encoding decode-char drop stream-read1 ;
+
+: format-column ( seq ? -- seq )
+ [
+ [ 0 [ length max ] reduce ] keep
+ swap [ CHAR: \s pad-right ] curry map
+ ] unless ;
+
+: map-last ( seq quot -- seq )
+ >r dup length <reversed> [ zero? ] r> compose 2map ; inline
+
+PRIVATE>
+
+: format-table ( table -- seq )
+ flip [ format-column ] map-last
+ flip [ " " join ] map ;
+
M: growable dispose drop ;
M: growable stream-write1 push ;
@@ -20,12 +47,6 @@ M: growable stream-flush drop ;
M: growable stream-read1 [ f ] [ pop ] if-empty ;
-: harden-as ( seq growble-exemplar -- newseq )
- underlying>> like ;
-
-: growable-read-until ( growable n -- str )
- >fixnum dupd tail-slice swap harden-as dup reverse-here ;
-
: find-last-sep ( seq seps -- n )
swap [ memq? ] curry find-last drop ;
@@ -50,30 +71,14 @@ M: growable stream-read
M: growable stream-read-partial
stream-read ;
-SINGLETON: null
-M: null decode-char drop stream-read1 ;
-
: <string-reader> ( str -- stream )
- >sbuf dup reverse-here null <decoder> ;
+ >sbuf dup reverse-here null-encoding <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-input-stream ; inline
INSTANCE: growable plain-writer
-: format-column ( seq ? -- seq )
- [
- [ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-right ] curry map
- ] unless ;
-
-: map-last ( seq quot -- seq )
- >r dup length <reversed> [ zero? ] r> compose 2map ; inline
-
-: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
-
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 71f3980a6c..289d39868c 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -170,7 +170,7 @@ HELP: xor
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
@@ -178,7 +178,7 @@ HELP: both?
} ;
HELP: either?
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
@@ -211,19 +211,19 @@ HELP: 3slip
{ $description "Calls a quotation while hiding the top three stack elements." } ;
HELP: keep
-{ $values { "quot" "a quotation with stack effect " { $snippet "( x -- )" } } { "x" object } }
+{ $values { "quot" { $quotation "( x -- )" } } { "x" object } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } ;
HELP: 2keep
-{ $values { "quot" "a quotation with stack effect " { $snippet "( x y -- )" } } { "x" object } { "y" object } }
+{ $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
-{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
+{ $values { "quot" { $quotation "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
-{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
+{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
@@ -245,7 +245,7 @@ HELP: bi
} ;
HELP: 2bi
-{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
+{ $values { "x" object } { "y" object } { "p" { $quotation "( x y -- ... )" } } { "q" { $quotation "( x y -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
@@ -266,7 +266,7 @@ HELP: 2bi
} ;
HELP: 3bi
-{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x y z -- ... )" } } { "q" { $quotation "( x y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
@@ -287,7 +287,7 @@ HELP: 3bi
} ;
HELP: tri
-{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
+{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } { "r" { $quotation "( x -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." }
{ $examples
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
@@ -308,7 +308,7 @@ HELP: tri
} ;
HELP: 2tri
-{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
+{ $values { "x" object } { "y" object } { "p" { $quotation "( x y -- ... )" } } { "q" { $quotation "( x y -- ... )" } } { "r" { $quotation "( x y -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values, and finally applies " { $snippet "r" } " to the two input values." }
{ $examples
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
@@ -324,7 +324,7 @@ HELP: 2tri
} ;
HELP: 3tri
-{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x y z -- ... )" } } { "q" { $quotation "( x y z -- ... )" } } { "r" { $quotation "( x y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." }
{ $examples
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
@@ -341,7 +341,7 @@ HELP: 3tri
HELP: bi*
-{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } }
+{ $values { "x" object } { "y" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -352,7 +352,7 @@ HELP: bi*
} ;
HELP: 2bi*
-{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( w x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y z -- ... )" } } }
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "p" { $quotation "( w x -- ... )" } } { "q" { $quotation "( y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "w" } " and " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } " and " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -363,7 +363,7 @@ HELP: 2bi*
} ;
HELP: tri*
-{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( z -- ... )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } { "r" { $quotation "( z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -374,7 +374,7 @@ HELP: tri*
} ;
HELP: bi@
-{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -390,7 +390,7 @@ HELP: bi@
} ;
HELP: 2bi@
-{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- )" } } }
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- )" } } }
{ $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -406,7 +406,7 @@ HELP: 2bi@
} ;
HELP: tri@
-{ $values { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@@ -440,7 +440,7 @@ $nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if*
-{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" quotation } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
@@ -449,7 +449,7 @@ $nl
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
HELP: when*
-{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } }
{ $description "Variant of " { $link if* } " with no false quotation."
$nl
"The following two lines are equivalent:"
@@ -463,7 +463,7 @@ HELP: unless*
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
-{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
+{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" { $quotation "( default -- )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
@@ -520,7 +520,7 @@ HELP: null
} ;
HELP: most
-{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
HELP: curry
@@ -550,7 +550,7 @@ HELP: 3curry
{ $notes "This operation is efficient and does not copy the quotation." } ;
HELP: with
-{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
+{ $values { "param" object } { "obj" object } { "quot" { $quotation "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
{ $description "Partial application on the left. The following two lines are equivalent:"
{ $code "swap [ swap A ] curry B" }
{ $code "[ A ] with B" }
@@ -630,7 +630,7 @@ HELP: 3dip
} ;
HELP: while
-{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
$nl
diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor
index 67948cc8f9..31f5a3f72e 100644
--- a/core/lexer/lexer-docs.factor
+++ b/core/lexer/lexer-docs.factor
@@ -32,7 +32,7 @@ HELP: skip
{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
HELP: change-lexer-column
-{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
+{ $values { "lexer" lexer } { "quot" { $quotation "( col line -- newcol )" } } }
{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
HELP: skip-blank
@@ -54,11 +54,11 @@ HELP: still-parsing-line?
{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ;
HELP: parse-token
-{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } }
+{ $values { "lexer" lexer } { "str/f" { $maybe string } } }
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ;
HELP: scan
-{ $values { "str/f" "a " { $link string } " or " { $link f } } }
+{ $values { "str/f" { $maybe string } } }
{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
$parsing-note ;
@@ -73,7 +73,7 @@ HELP: parse-tokens
$parsing-note ;
HELP: unexpected
-{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
+{ $values { "want" { $maybe word } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." }
{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." }
{ $examples
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index a863715d33..20b4e0bbbe 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -284,22 +284,22 @@ HELP: power-of-2?
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: each-integer
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }
{ $notes "This word is used to implement " { $link each } "." } ;
HELP: all-integers?
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "?" "a boolean" } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
{ $notes "This word is used to implement " { $link all? } "." } ;
HELP: find-integer
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs a true value or the end is reached. If the quotation yields a true value for some integer, this word outputs that integer. Otherwise, this word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find } "." } ;
HELP: find-last-integer
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
+{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find-last } "." } ;
diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor
index 65edbdaaae..c8d3095ce6 100644
--- a/core/math/order/order-docs.factor
+++ b/core/math/order/order-docs.factor
@@ -32,7 +32,7 @@ HELP: invert-comparison
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
HELP: compare
-{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "<=>" "an ordering specifier" } }
+{ $values { "obj1" object } { "obj2" object } { "quot" { $quotation "( obj -- newobj )" } } { "<=>" "an ordering specifier" } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
} ;
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index fb1d4a336f..8f49d882ee 100644
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -19,12 +19,12 @@ HELP: end-scan ( -- )
{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
HELP: each-object
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $values { "quot" { $quotation "( obj -- )" } } }
{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." }
{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ;
HELP: instances
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "seq" "a fresh sequence" } }
+{ $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } }
{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor
index c84699539d..4716a8fe99 100644
--- a/core/namespaces/namespaces-docs.factor
+++ b/core/namespaces/namespaces-docs.factor
@@ -69,7 +69,7 @@ HELP: on
{ $side-effects "variable" } ;
HELP: change
-{ $values { "variable" "a variable, by convention a symbol" } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." }
{ $side-effects "variable" } ;
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index d33f5cd6d9..d3c2cff19d 100644
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -294,7 +294,7 @@ HELP: parse-base
$parsing-note ;
HELP: parse-literal
-{ $values { "accum" vector } { "end" word } { "quot" "a quotation with stack effect " { $snippet "( seq -- obj )" } } }
+{ $values { "accum" vector } { "end" word } { "quot" { $quotation "( seq -- obj )" } } }
{ $description "Parses objects from parser input until " { $snippet "end" } ", applies the quotation to the resulting sequence, and adds the output value to the accumulator." }
{ $examples "This word is used to implement " { $link POSTPONE: [ } "." }
$parsing-note ;
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 8cb7f1c088..cc8daba8c0 100644
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -247,15 +247,15 @@ HELP: set-array-nth
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ;
HELP: collect
-{ $values { "n" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( n -- value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
+{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( n -- value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. User code should use " { $link map } " instead." } ;
HELP: each
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence in order." } ;
HELP: reduce
-{ $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." }
{ $examples
{ $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
@@ -271,7 +271,7 @@ HELP: reduce-index
} } ;
HELP: accumulate
-{ $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
+{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
$nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
@@ -280,11 +280,11 @@ $nl
} ;
HELP: map
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: map-as
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
+{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
@@ -311,13 +311,13 @@ HELP: map-index
} } ;
HELP: change-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
+{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( elt -- newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
{ $errors "Throws an error if the sequence is immutable, if the index is out of bounds, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
HELP: change-each
-{ $values { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } }
+{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence." }
{ $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
@@ -331,79 +331,76 @@ HELP: max-length
{ $description "Outputs the maximum of the lengths of the two sequences." } ;
HELP: 2each
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: 2reduce
{ $values { "seq1" sequence }
{ "seq2" sequence }
{ "identity" object }
- { "quot" "a quotation with stack effect "
- { $snippet "( prev elt1 elt2 -- next )" } }
+ { "quot" { $quotation "( prev elt1 elt2 -- next )" } }
{ "result" "the final result" } }
{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
HELP: 2map
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 2map-as
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all?
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: find
{ $values { "seq" sequence }
- { "quot" "a quotation with stack effect "
- { $snippet "( elt -- ? )" } }
- { "i" "the index of the first match, or f" }
+ { "quot" { $quotation "( elt -- ? )" } }
+ { "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ;
HELP: find-from
{ $values { "n" "a starting index" }
{ "seq" sequence }
- { "quot" "a quotation with stack effect "
- { $snippet "( elt -- ? )" } }
- { "i" "the index of the first match, or f" }
+ { "quot" { $quotation "( elt -- ? )" } }
+ { "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in turn, until it outputs a true value or the end of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: find-last
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ;
HELP: find-last-from
-{ $values { "n" "a starting index" } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
+{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: contains?
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ;
HELP: all?
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
-{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
+{ $values { "elt" object } { "quot" { $quotation "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
{ $notes "This word is a factor of " { $link filter } "." } ;
HELP: filter
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter-here
-{ $values { "seq" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } }
+{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
HELP: monotonic?
-{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
{ $examples
"Testing if a sequence is non-decreasing:"
@@ -415,12 +412,12 @@ HELP: monotonic?
{ monotonic? all-eq? all-equal? } related-words
HELP: interleave
-{ $values { "seq" sequence } { "between" "a quotation" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
HELP: cache-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( i -- elt )" } } { "elt" object } }
+{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
{ $side-effects "seq" } ;
@@ -584,7 +581,7 @@ HELP: reverse-here
{ $side-effects "seq" } ;
HELP: padding
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
HELP: pad-left
@@ -874,7 +871,7 @@ HELP: supremum
{ $errors "Throws an error if the sequence is empty." } ;
HELP: produce
-{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index d2d7dc1102..c9ce334388 100644
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -166,5 +166,5 @@ HELP: set-slot ( value obj n -- )
{ $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
HELP: slot-named
-{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
+{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" { $maybe slot-spec } } }
{ $description "Outputs the " { $link slot-spec } " with the given name." } ;
diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor
index 036ff2f759..6ea1485425 100644
--- a/core/sorting/sorting-docs.factor
+++ b/core/sorting/sorting-docs.factor
@@ -19,7 +19,7 @@ $nl
ABOUT: "sequences-sorting"
HELP: sort
-{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts the elements into a new array." } ;
HELP: sort-keys
diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor
index 328dce9b03..64a5a589dc 100644
--- a/core/vocabs/vocabs-docs.factor
+++ b/core/vocabs/vocabs-docs.factor
@@ -75,7 +75,7 @@ HELP: forget-vocab
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: load-vocab-hook
-{ $var-description "a quotation with stack effect " { $snippet "( name -- vocab )" } " which loads a vocabulary. This quotation is called by " { $link load-vocab } ". The default value should not need to be changed; this functinality is implemented via a hook stored in a variable to break a circular dependency which would otherwise exist from " { $vocab-link "vocabs" } " to " { $vocab-link "vocabs.loader" } " to " { $vocab-link "parser" } " back to " { $vocab-link "vocabs" } "." } ;
+{ $var-description { $quotation "( name -- vocab )" } " which loads a vocabulary. This quotation is called by " { $link load-vocab } ". The default value should not need to be changed; this functinality is implemented via a hook stored in a variable to break a circular dependency which would otherwise exist from " { $vocab-link "vocabs" } " to " { $vocab-link "vocabs.loader" } " to " { $vocab-link "parser" } " back to " { $vocab-link "vocabs" } "." } ;
HELP: words-named
{ $values { "str" string } { "seq" "a sequence of words" } }
diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor
index 6a9359027d..c402cdf15b 100644
--- a/extra/lists/lazy/lazy-docs.factor
+++ b/extra/lists/lazy/lazy-docs.factor
@@ -5,22 +5,22 @@ USING: help.markup help.syntax sequences strings lists ;
IN: lists.lazy
HELP: lazy-cons
-{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
+{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } }
{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
{ $see-also cons car cdr nil nil? } ;
{ 1lazy-list 2lazy-list 3lazy-list } related-words
HELP: 1lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $values { "a" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
HELP: 2lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
HELP: 3lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "c" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
HELP: <memoized-cons>
@@ -31,11 +31,11 @@ HELP: <memoized-cons>
{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
HELP: lazy-map
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } }
{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lazy-map-with
-{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
+{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } }
{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
HELP: ltake
@@ -43,15 +43,15 @@ HELP: ltake
{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lfilter
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( -- X )" } } { "result" "resulting cons object" } }
{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lwhile
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: luntil
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: list>vector
@@ -69,7 +69,7 @@ HELP: lappend
{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
+{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "list" "a lazy list of integers" } }
{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
HELP: lfrom
@@ -101,11 +101,11 @@ HELP: lcartesian-product*
{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
HELP: lcomp
-{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
+{ $values { "list" "a list of lists" } { "quot" { $quotation "( seq -- X )" } } { "result" "the resulting list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "list" "the resulting list" } { "result" "a list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
{ $examples
{ $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor
index cd2e6f7081..8807c8cf8a 100644
--- a/extra/lists/lists-docs.factor
+++ b/extra/lists/lists-docs.factor
@@ -61,19 +61,19 @@ HELP: uncons
{ leach foldl lmap>array } related-words
HELP: leach
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- )" } } }
{ $description "Call the quotation for each item in the list." } ;
HELP: foldl
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
HELP: foldr
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
HELP: lmap
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } }
+{ $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } }
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
HELP: lreverse
@@ -97,8 +97,8 @@ HELP: seq>cons
{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
HELP: traverse
-{ $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" }
- { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } }
+{ $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } }
+ { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } }
{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
" returns true for with the result of applying quot to." } ;
diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor
index 8b8befce34..35070d8902 100644
--- a/extra/mason/build/build.factor
+++ b/extra/mason/build/build.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.encodings.utf8 prettyprint arrays
calendar namespaces mason.common mason.child
-mason.release mason.report mason.email mason.cleanup ;
+mason.release mason.report mason.email mason.cleanup
+mason.help ;
IN: mason.build
: create-build-dir ( -- )
@@ -23,6 +24,7 @@ IN: mason.build
clone-builds-factor
record-id
build-child
+ upload-help
release
email-report
cleanup ;
diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor
index 02085a89b3..2bc6b191c4 100644
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@@ -61,6 +61,7 @@ IN: mason.child
[ load-everything-vocabs-file eval-file empty? ]
[ test-all-vocabs-file eval-file empty? ]
[ help-lint-vocabs-file eval-file empty? ]
+ [ compiler-errors-file eval-file empty? ]
} 0&& ;
: build-child ( -- )
diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
index dfda85e4d7..fc7149e181 100644
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -3,7 +3,7 @@
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.launcher io.encodings.utf8
prettyprint combinators.short-circuit parser combinators
-calendar calendar.format arrays mason.config ;
+calendar calendar.format arrays mason.config locals ;
IN: mason.common
: short-running-process ( command -- )
@@ -13,6 +13,13 @@ IN: mason.common
15 minutes >>timeout
try-process ;
+:: upload-safely ( local username host remote -- )
+ [let* | temp [ remote ".incomplete" append ]
+ scp-remote [ { username "@" host ":" temp } concat ] |
+ { "scp" local scp-remote } short-running-process
+ { "ssh" host "-l" username "mv" temp remote } short-running-process
+ ] ;
+
: eval-file ( file -- obj )
dup utf8 file-lines parse-fresh
[ "Empty file: " swap append throw ] [ nip first ] if-empty ;
@@ -68,9 +75,11 @@ SYMBOL: stamp
: boot-time-file "boot-time" ;
: load-time-file "load-time" ;
+: compiler-errors-file "compiler-errors" ;
: test-time-file "test-time" ;
: help-lint-time-file "help-lint-time" ;
: benchmark-time-file "benchmark-time" ;
+: html-help-time-file "html-help-time" ;
: benchmarks-file "benchmarks" ;
diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor
index 0ce059c995..e4ef127413 100644
--- a/extra/mason/config/config.factor
+++ b/extra/mason/config/config.factor
@@ -33,10 +33,23 @@ target-os get-global [
! Keep test-log around?
SYMBOL: builder-debug
-! Boolean. Do we release binaries and update the clean branch?
-SYMBOL: upload-to-factorcode
+SYMBOL: upload-help?
-! The below are only needed if upload-to-factorcode is true.
+! The below are only needed if upload-help is true.
+
+! Host with HTML help
+SYMBOL: help-host
+
+! Username to log in.
+SYMBOL: help-username
+
+! Directory to upload docs to.
+SYMBOL: help-directory
+
+! Boolean. Do we release binaries and update the clean branch?
+SYMBOL: upload-to-factorcode?
+
+! The below are only needed if upload-to-factorcode? is true.
! Host with clean git repo.
SYMBOL: branch-host
diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor
new file mode 100644
index 0000000000..1e3e1509c9
--- /dev/null
+++ b/extra/mason/help/help.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.html sequences io.files io.launcher make namespaces
+kernel arrays mason.common mason.config ;
+IN: mason.help
+
+: make-help-archive ( -- )
+ "factor/temp" [
+ { "tar" "cfz" "docs.tar.gz" "docs" } try-process
+ ] with-directory ;
+
+: upload-help-archive ( -- )
+ "factor/temp/docs.tar.gz"
+ help-username get
+ help-host get
+ help-directory get "/docs.tar.gz" append
+ upload-safely ;
+
+: upload-help ( -- )
+ upload-help? get [
+ make-help-archive
+ upload-help-archive
+ ] when ;
diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor
index 8872cda5b5..ff2632a9b3 100644
--- a/extra/mason/release/branch/branch.factor
+++ b/extra/mason/release/branch/branch.factor
@@ -45,4 +45,4 @@ IN: mason.release.branch
] with-directory ;
: update-clean-branch ( -- )
- upload-to-factorcode get [ (update-clean-branch) ] when ;
+ upload-to-factorcode? get [ (update-clean-branch) ] when ;
diff --git a/extra/mason/release/upload/upload-tests.factor b/extra/mason/release/upload/upload-tests.factor
index 9f5300b129..73fc311399 100644
--- a/extra/mason/release/upload/upload-tests.factor
+++ b/extra/mason/release/upload/upload-tests.factor
@@ -1,38 +1,4 @@
IN: mason.release.upload.tests
-USING: mason.release.upload mason.common mason.config
-mason.common namespaces calendar tools.test ;
-
-[
- {
- "scp"
- "factor-linux-ppc-2008-09-11-23-12.tar.gz"
- "slava@www.apple.com:/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
- }
- {
- "ssh"
- "www.apple.com"
- "-l" "slava"
- "mv"
- "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
- "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz"
- }
-] [
- [
- "slava" upload-username set
- "www.apple.com" upload-host set
- "/uploads" upload-directory set
- "linux" target-os set
- "ppc" target-cpu set
- T{ timestamp
- { year 2008 }
- { month 09 }
- { day 11 }
- { hour 23 }
- { minute 12 }
- } datestamp stamp set
- upload-command
- rename-command
- ] with-scope
-] unit-test
+USING: mason.release.upload tools.test ;
\ upload must-infer
diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor
index 2bf18f1126..68f2ffcdb5 100644
--- a/extra/mason/release/upload/upload.factor
+++ b/extra/mason/release/upload/upload.factor
@@ -11,37 +11,11 @@ IN: mason.release.upload
: remote-archive-name ( -- dest )
remote-location "/" archive-name 3append ;
-: temp-archive-name ( -- dest )
- remote-archive-name ".incomplete" append ;
-
-: upload-command ( -- args )
- "scp"
- archive-name
- [
- upload-username get % "@" %
- upload-host get % ":" %
- temp-archive-name %
- ] "" make
- 3array ;
-
-: rename-command ( -- args )
- [
- "ssh" ,
- upload-host get ,
- "-l" ,
- upload-username get ,
- "mv" ,
- temp-archive-name ,
- remote-archive-name ,
- ] { } make ;
-
-: upload-temp-file ( -- )
- upload-command short-running-process ;
-
-: rename-temp-file ( -- )
- rename-command short-running-process ;
-
: upload ( -- )
- upload-to-factorcode get
- [ upload-temp-file rename-temp-file ]
- when ;
+ upload-to-factorcode? get [
+ archive-name
+ upload-username get
+ upload-host get
+ remote-archive-name
+ upload-safely
+ ] when ;
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
index 145686d621..1b2697a5d1 100644
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces debugger fry io io.files io.sockets
io.encodings.utf8 prettyprint benchmark mason.common
-mason.platform mason.config ;
+mason.platform mason.config sequences ;
IN: mason.report
: time. ( file -- )
@@ -46,21 +46,29 @@ IN: mason.report
test-time-file time.
help-lint-time-file time.
benchmark-time-file time.
+ html-help-time-file time.
nl
- "Did not pass load-everything:" print
- load-everything-vocabs-file cat
- load-everything-errors-file cat
+ load-everything-vocabs-file eval-file [
+ "== Did not pass load-everything:" print .
+ load-everything-errors-file cat
+ ] unless-empty
- "Did not pass test-all:" print
- test-all-vocabs-file cat
- test-all-errors-file cat
+ compiler-errors-file eval-file [
+ "== Vocabularies with compiler errors:" print .
+ ] unless-empty
- "Did not pass help-lint:" print
- help-lint-vocabs-file cat
- help-lint-errors-file cat
+ test-all-vocabs-file eval-file [
+ "== Did not pass test-all:" print .
+ test-all-errors-file cat
+ ] unless-empty
- "Benchmarks:" print
+ help-lint-vocabs-file eval-file [
+ "== Did not pass help-lint:" print .
+ help-lint-errors-file cat
+ ] unless-empty
+
+ "== Benchmarks:" print
benchmarks-file eval-file benchmarks.
] with-report ;
\ No newline at end of file
diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor
index 58884175a3..0206df7db9 100644
--- a/extra/mason/test/test.factor
+++ b/extra/mason/test/test.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs io.files io.encodings.utf8
prettyprint help.lint benchmark tools.time bootstrap.stage2
-tools.test tools.vocabs mason.common ;
+tools.test tools.vocabs help.html mason.common words generic
+accessors compiler.errors sequences sets sorting ;
IN: mason.test
: do-load ( -- )
@@ -11,6 +12,19 @@ IN: mason.test
[ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ]
bi ;
+GENERIC: word-vocabulary ( word -- vocabulary )
+
+M: word word-vocabulary vocabulary>> ;
+
+M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
+
+: do-compile-errors ( -- )
+ compiler-errors-file utf8 [
+ +error+ errors-of-type keys
+ [ word-vocabulary ] map
+ prune natural-sort .
+ ] with-file-writer ;
+
: do-tests ( -- )
run-all-tests
[ keys test-all-vocabs-file to-file ]
@@ -29,7 +43,8 @@ IN: mason.test
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
- [ do-load ] benchmark load-time-file to-file
+ [ do-load do-compile-errors ] benchmark load-time-file to-file
+ [ generate-help ] benchmark html-help-time-file to-file
[ do-tests ] benchmark test-time-file to-file
[ do-help-lint ] benchmark help-lint-time-file to-file
[ do-benchmarks ] benchmark benchmark-time-file to-file
diff --git a/extra/partial-continuations/partial-continuations-docs.factor b/extra/partial-continuations/partial-continuations-docs.factor
index 93e68eac4a..a70109347b 100644
--- a/extra/partial-continuations/partial-continuations-docs.factor
+++ b/extra/partial-continuations/partial-continuations-docs.factor
@@ -2,12 +2,12 @@ IN: partial-continuations
USING: help.markup help.syntax kernel ;
HELP: breset
-{ $values { "quot" "a quotation with stack effect " { $snippet "( r -- v )" } } }
+{ $values { "quot" { $quotation "( r -- v )" } } }
{ $description "Marks the boundary of the partial continuation. The quotation has stack effect " { $snippet "( r -- v )" } ", where " { $snippet "r" } " identifies the " { $link breset } " in scope and should be passed to "{ $link bshift } " to mark the boundary of the continuation." }
{ $notes "It is important to note that even if the quotation discards items on the stack, the stack will be restored to the way it was before it is called (which is true of continuation usage in general)." } ;
HELP: bshift
-{ $values { "r" "the " { $link breset } " in scope" } { "quot" "a quotation with stack effect " { $snippet "( pcc -- v )" } } }
+{ $values { "r" "the " { $link breset } " in scope" } { "quot" { $quotation "( pcc -- v )" } } }
{ $description "Calls the quotation with the partial continuation on the stack. The quotation should have stack effect " { $snippet "( pcc -- v )" } ". The partial continuation can be called with " { $link call } " and has stack effect " { $snippet "( a -- b )" } "." }
{ $notes "It is important to note that even if the quotation discards items on the stack, the stack will be restored to the way it was before it is called (which is true of continuation usage in general)." } ;
diff --git a/extra/promises/promises-docs.factor b/extra/promises/promises-docs.factor
index c482df0d15..4e8dc9a9a2 100755
--- a/extra/promises/promises-docs.factor
+++ b/extra/promises/promises-docs.factor
@@ -5,17 +5,17 @@ USING: help.markup help.syntax ;
IN: promises
HELP: promise
-{ $values { "quot" "a quotation with stack effect ( -- X )" } { "promise" "a promise object" } }
+{ $values { "quot" { $quotation "( -- X )" } } { "promise" "a promise object" } }
{ $description "Creates a promise to return a value. When forced this quotation is called and the value returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
{ $see-also force promise-with promise-with2 } ;
HELP: promise-with
-{ $values { "value" "an object" } { "quot" "a quotation with stack effect ( value -- X )" } { "promise" "a promise object" } }
+{ $values { "value" "an object" } { "quot" { $quotation "( value -- X )" } } { "promise" "a promise object" } }
{ $description "Creates a promise to return a value. When forced this quotation is called with the given value on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
{ $see-also force promise promise-with2 } ;
HELP: promise-with2
-{ $values { "value1" "an object" } { "value2" "an object" } { "quot" "a quotation with stack effect ( value1 value2 -- X )" } { "promise" "a promise object" } }
+{ $values { "value1" "an object" } { "value2" "an object" } { "quot" { $quotation "( value1 value2 -- X )" } } { "promise" "a promise object" } }
{ $description "Creates a promise to return a value. When forced this quotation is called with the given values on the stack and the result returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." }
{ $see-also force promise promise-with2 } ;
diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor
index 07865f38e0..21e97a1827 100644
--- a/extra/springies/ui/ui.factor
+++ b/extra/springies/ui/ui.factor
@@ -7,7 +7,7 @@ IN: springies.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
+: draw-node ( node -- ) pos>> { -5 -5 } v+ [ { 10 10 } gl-rect ] with-translation ;
: draw-spring ( spring -- )
[ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
diff --git a/extra/webapps/user-admin/user-admin-docs.factor b/extra/webapps/user-admin/user-admin-docs.factor
new file mode 100644
index 0000000000..3551210664
--- /dev/null
+++ b/extra/webapps/user-admin/user-admin-docs.factor
@@ -0,0 +1,22 @@
+USING: help.markup help.syntax db strings ;
+IN: webapps.user-admin
+
+HELP: <user-admin>
+{ $values { "responder" "a new responder" } }
+{ $description "Creates a new instance of the user admin tool. This tool must be added to an authentication realm, and access is restricted to users having the " { $link can-administer-users? } " capability." } ;
+
+HELP: can-administer-users?
+{ $description "A user capability. Users having this capability may use the " { $link user-admin } " tool." }
+{ $notes "See " { $link "furnace.auth.capabilities" } " for information about capabilities." } ;
+
+HELP: make-admin
+{ $values { "username" string } }
+{ $description "Makes an existing user into an administrator by giving them the " { $link can-administer-users? } " capability, thus allowing them to use the user admin tool." } ;
+
+ARTICLE: "furnace.auth.user-admin" "Furnace user administration tool"
+"The " { $vocab-link "webapps.user-admin" } " vocabulary implements a web application for adding, removing and editing users in authentication realms that use " { $link "furnace.auth.providers.db" } "."
+{ $subsection <user-admin> }
+"Access to the web app itself is protected, and only users having an administrative capability can access it:"
+{ $subsection can-administer-users? }
+"To make an existing user an administrator, call the following word in a " { $link with-db } " scope:"
+{ $subsection make-admin } ;
diff --git a/misc/factor.el b/misc/factor.el
index 5d937c14ca..2d222187e4 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -17,20 +17,42 @@
;; M-x run-factor === Start a Factor listener inside Emacs
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Customization
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgroup factor nil
"Factor mode"
:group 'languages)
-(defvar factor-mode-syntax-table nil
- "Syntax table used while in Factor mode.")
+(defcustom factor-default-indent-width 4
+ "Default indentantion width for factor-mode.
+
+This value will be used for the local variable
+`factor-indent-width' in new factor buffers. For existing code,
+we first check if `factor-indent-width' is set explicitly in a
+local variable section or line (e.g. '! -*- factor-indent-witdth: 2 -*-').
+If that's not the case, `factor-mode' tries to infer its correct
+value from the existing code in the buffer."
+ :type 'integer
+ :group 'factor)
(defcustom factor-display-compilation-output t
"Display the REPL buffer before compiling files."
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'factor)
+(defcustom factor-mode-hook nil
+ "Hook run when entering Factor mode."
+ :type 'hook
+ :group 'factor)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode syntax
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar factor-mode-syntax-table nil
+ "Syntax table used while in Factor mode.")
(if factor-mode-syntax-table
()
@@ -72,17 +94,59 @@
(modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
(modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
-(defvar factor-mode-map (make-sparse-keymap))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode font lock
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defcustom factor-mode-hook nil
- "Hook run when entering Factor mode."
- :type 'hook
- :group 'factor)
+(require 'font-lock)
+
+(defgroup factor-faces nil
+ "Faces used in Factor mode"
+ :group 'factor
+ :group 'faces)
+
+(defsubst factor--face (face) `((t ,(face-attr-construct face))))
+
+(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
+ "Face for parsing words."
+ :group 'factor-faces)
+
+(defface factor-font-lock-comment (factor--face font-lock-comment-face)
+ "Face for comments."
+ :group 'factor-faces)
+
+(defface factor-font-lock-string (factor--face font-lock-string-face)
+ "Face for strings."
+ :group 'factor-faces)
+
+(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face)
+ "Face for stack effect specifications."
+ :group 'factor-faces)
+
+(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face)
+ "Face for word, generic or method being defined."
+ :group 'factor-faces)
+
+(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face)
+ "Face for name of symbol being defined."
+ :group 'factor-faces)
+
+(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face)
+ "Face for names of vocabularies in USE or USING."
+ :group 'factor-faces)
+
+(defface factor-font-lock-type-definition (factor--face font-lock-type-face)
+ "Face for type (tuple) names."
+ :group 'factor-faces)
+
+(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
+ "Face for parsing words."
+ :group 'factor-faces)
(defconst factor--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
- "DEFER:" "ERROR:" "FORGET:"
+ "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
"IN:" "INSTANCE:" "INTERSECTION:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
@@ -96,8 +160,8 @@
"initial:" "inline" "parsing" "read-only" "recursive")
'words))
-(defun factor--regex-second-word (prefixes)
- (format "^%s +\\([^ ]+\\)" (regexp-opt prefixes t)))
+(defsubst factor--regex-second-word (prefixes)
+ (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(defconst factor--regex-word-definition
(factor--regex-second-word '(":" "::" "M:" "GENERIC:")))
@@ -105,52 +169,33 @@
(defconst factor--regex-type-definition
(factor--regex-second-word '("TUPLE:")))
-(defconst factor--regex-const-definition
+(defconst factor--regex-symbol-definition
(factor--regex-second-word '("SYMBOL:")))
+(defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
+(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
+
(defconst factor-font-lock-keywords
- `(("#!.*$" . font-lock-comment-face)
- ("!( .* )" . font-lock-comment-face)
- ("^!.*$" . font-lock-comment-face)
- (" !.*$" . font-lock-comment-face)
- ("( .* )" . font-lock-comment-face)
- ("\"[^ ][^\"]*\"" . font-lock-string-face)
- ("\"\"" . font-lock-string-face)
- ("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face)
+ `(("#!.*$" . 'factor-font-lock-comment)
+ ("!( .* )" . 'factor-font-lock-comment)
+ ("^!.*$" . 'factor-font-lock-comment)
+ (" !.*$" . 'factor-font-lock-comment)
+ ("( .* )" . 'factor-font-lock-stack-effect)
+ ("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string)
+ ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
- '(2 font-lock-keyword-face)))
+ '(2 'factor-font-lock-parsing-word)))
factor--parsing-words)
- (,factor--regex-parsing-words-ext . font-lock-keyword-face)
- (,factor--regex-word-definition 2 font-lock-function-name-face)
- (,factor--regex-type-definition 2 font-lock-type-face)
- (,factor--regex-const-definition 2 font-lock-constant-face)))
-
-(defun factor-indent-line ()
- "Indent current line as Factor code"
- (indent-line-to (+ (current-indentation) 4)))
-
-(defun factor-mode ()
- "A mode for editing programs written in the Factor programming language.
-\\{factor-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map factor-mode-map)
- (setq major-mode 'factor-mode)
- (setq mode-name "Factor")
- (set (make-local-variable 'indent-line-function) #'factor-indent-line)
- (make-local-variable 'comment-start)
- (setq comment-start "! ")
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '(factor-font-lock-keywords t nil nil nil))
- (set-syntax-table factor-mode-syntax-table)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'factor-indent-line)
- (run-hooks 'factor-mode-hook))
-
-(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
+ (,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word)
+ (,factor--regex-word-definition 2 'factor-font-lock-word-definition)
+ (,factor--regex-type-definition 2 'factor-font-lock-type-definition)
+ (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
+ (,factor--regex-using-line 1 'factor-font-lock-vocabulary-name)
+ (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'comint)
@@ -243,6 +288,8 @@
(beginning-of-line)
(insert "! "))
+(defvar factor-mode-map (make-sparse-keymap))
+
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
@@ -254,7 +301,7 @@
(define-key factor-mode-map [tab] 'indent-for-tab-command)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; indentation
+;; factor-mode indentation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst factor-word-starting-keywords
@@ -265,6 +312,26 @@
"^\\(%s\\): "
(mapconcat 'identity ,keywords "\\|")))
+(defvar factor-indent-width factor-default-indent-width
+ "Indentation width in factor buffers. A local variable.")
+
+(make-variable-buffer-local 'factor-indent-width)
+
+(defun factor--guess-indent-width ()
+ "Chooses an indentation value from existing code."
+ (let ((word-def (factor-word-start-re factor-word-starting-keywords))
+ (word-cont "^ +[^ ]")
+ (iw))
+ (save-excursion
+ (beginning-of-buffer)
+ (while (not iw)
+ (if (not (re-search-forward word-def nil t))
+ (setq iw factor-default-indent-width)
+ (forward-line)
+ (when (looking-at word-cont)
+ (setq iw (current-indentation))))))
+ iw))
+
(defun factor-calculate-indentation ()
"Calculate Factor indentation for line at point."
(let ((not-indented t)
@@ -280,21 +347,21 @@
(let ((cur-depth (factor-brackets-depth)))
(forward-line -1)
(setq cur-indent (+ (current-indentation)
- (* default-tab-width
+ (* factor-indent-width
(- cur-depth (factor-brackets-depth)))))
(setq not-indented nil)))
(forward-line -1)
;; Check that we are after the end of previous word
(if (looking-at ".*;[ \t]*$")
(progn
- (setq cur-indent (- (current-indentation) default-tab-width))
+ (setq cur-indent (- (current-indentation) factor-indent-width))
(setq not-indented nil))
;; Check that we are after the start of word
(if (looking-at (factor-word-start-re factor-word-starting-keywords))
; (if (looking-at "^[A-Z:]*: ")
(progn
(message "inword")
- (setq cur-indent (+ (current-indentation) default-tab-width))
+ (setq cur-indent (+ (current-indentation) factor-indent-width))
(setq not-indented nil))
(if (bobp)
(setq not-indented nil))))))))
@@ -319,6 +386,30 @@
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-mode
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun factor-mode ()
+ "A mode for editing programs written in the Factor programming language.
+\\{factor-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map factor-mode-map)
+ (setq major-mode 'factor-mode)
+ (setq mode-name "Factor")
+ (set (make-local-variable 'indent-line-function) #'factor-indent-line)
+ (set (make-local-variable 'comment-start) "! ")
+ (set (make-local-variable 'font-lock-defaults)
+ '(factor-font-lock-keywords t nil nil nil))
+ (set-syntax-table factor-mode-syntax-table)
+ (set (make-local-variable 'indent-line-function) 'factor-indent-line)
+ (setq factor-indent-width (factor--guess-indent-width))
+ (setq indent-tabs-mode nil)
+ (run-hooks 'factor-mode-hook))
+
+(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; factor-listener-mode
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/vm/layouts.h b/vm/layouts.h
index 6dc29efdae..e55a5e9fd3 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -201,14 +201,6 @@ typedef struct {
void *dll;
} F_DLL;
-typedef struct {
- CELL header;
- /* tagged */
- CELL obj;
- /* tagged */
- CELL quot;
-} F_CURRY;
-
typedef struct {
CELL header;
/* tagged */