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

extra/alarms/alarms-docs.factor

@@ -10,7 +10,7 @@ HELP: add-alarm
 
 HELP: later
 { $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
 
 HELP: cancel-alarm
 { $values { "alarm" alarm } }

extra/alarms/alarms.factor

@@ -82,10 +82,10 @@ PRIVATE>
     <alarm> [ register-alarm ] keep ;
 
 : later ( quot dt -- alarm )
-    from-now f add-alarm ;
+    hence f add-alarm ;
 
 : every ( quot dt -- alarm )
-    [ from-now ] keep add-alarm ;
+    [ hence ] keep add-alarm ;
 
 : cancel-alarm ( alarm -- )
     alarm-entry [ alarms get-global heap-delete ] if-box? ;

extra/bake/bake.factor

@@ -1,7 +1,7 @@
 
 USING: kernel parser namespaces sequences quotations arrays vectors splitting
-       words math
+       strings words math generalizations
-       macros generalizations combinators.lib combinators.conditional newfx ;
+       macros combinators.lib combinators.conditional newfx ;
 
 IN: bake
 
@@ -20,7 +20,9 @@ DEFER: [bake]
 : broil-element ( obj -- quot )
     {
       { [ comma?    ] [ drop [ >r ]          ] }
+      { [ f =       ] [ [ >r ] prefix-on     ] }
       { [ integer?  ] [ [ >r ] prefix-on     ] }
+      { [ string?   ] [ [ >r ] prefix-on     ] }
       { [ sequence? ] [ [bake] [ >r ] append ] }
       { [ word?     ] [ literalize [ >r ] prefix-on ] }
       { [ drop t    ] [ [ >r ] prefix-on     ] }
@@ -92,3 +94,4 @@ MACRO: bake ( seq -- quot ) [bake] ;
 
 :  `{ \ } [ >array     ] parse-literal \ bake parsed ; parsing
 : `V{ \ } [ >vector    ] parse-literal \ bake parsed ; parsing
+:  `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing

extra/bake/fry/fry-tests.factor

@@ -13,74 +13,74 @@ IN: bake.fry.tests
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-[ [ 3 + ] ] [ 3 `[ , + ] ] unit-test
+[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
 
-[ [ 1 3 + ] ] [ 1 3 `[ , , + ] ] unit-test
+[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
 
-[ [ 1 + ] ] [ 1 [ + ] `[ , @ ] ] unit-test
+[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
 
-[ [ 1 + . ] ] [ 1 [ + ] `[ , @ . ] ] unit-test
+[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
 
-[ [ + - ] ] [ [ + ] [ - ] `[ @ @ ] ] unit-test
+[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
 
 [ [ "a" write "b" print ] ]
-[ "a" "b" `[ , write , print ] ] unit-test
+[ "a" "b" '[ , write , print ] ] unit-test
 
 [ [ 1 2 + 3 4 - ] ]
-[ [ + ] [ - ] `[ 1 2 @ 3 4 @ ] ] unit-test
+[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
 
 [ 1/2 ] [
-    1 `[ , _ / ] 2 swap call
+    1 '[ , _ / ] 2 swap call
 ] unit-test
 
 [ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
-    1 `[ , _ _ 3array ]
+    1 '[ , _ _ 3array ]
     { "a" "b" "c" } { "A" "B" "C" } rot 2map
 ] unit-test
 
 [ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
-    `[ 1 _ 2array ]
+    '[ 1 _ 2array ]
     { "a" "b" "c" } swap map
 ] unit-test
 
 [ 1 2 ] [
-    1 2 `[ _ , ] call
+    1 2 '[ _ , ] call
 ] unit-test
 
 [ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
-    1 2 `[ , _ , 3array ]
+    1 2 '[ , _ , 3array ]
     { "a" "b" "c" } swap map
 ] unit-test
 
-: funny-dip `[ @ _ ] call ; inline
+: funny-dip '[ @ _ ] call ; inline
 
 [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
 
 [ { 1 2 3 } ] [
-    3 1 `[ , [ , + ] map ] call
+    3 1 '[ , [ , + ] map ] call
 ] unit-test
 
 [ { 1 { 2 { 3 } } } ] [
-    1 2 3 `[ , [ , [ , 1array ] call 2array ] call 2array ] call
+    1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
 ] unit-test
 
-{ 1 1 } [ `[ [ [ , ] ] ] ] must-infer-as
+{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
 
 [ { { { 3 } } } ] [
-    3 `[ [ [ , 1array ] call 1array ] call 1array ] call
+    3 '[ [ [ , 1array ] call 1array ] call 1array ] call
 ] unit-test
 
 [ { { { 3 } } } ] [
-    3 `[ [ [ , 1array ] call 1array ] call 1array ] call
+    3 '[ [ [ , 1array ] call 1array ] call 1array ] call
 ] unit-test
 
-! [ 10 20 30 40 `[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
+! [ 10 20 30 40 '[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
 
-[ 10 20 30 40 `[ , V{ , { , } } , ] ]
+[ 10 20 30 40 '[ , V{ , { , } } , ] ]
 [ [ 10 20 30 >r r> 1 narray >r >r r> r> 2 narray >vector 40 ] ]
 unit-test*
 
-[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `[ , { V{ @ } { , } } ] call ]
+[ { 1 2 3 } { 4 5 6 } { 7 8 9 } '[ , { V{ @ } { , } } ] call ]
 [
   { 1 2 3 }
   { V{ 4 5 6 } { { 7 8 9 } } }

extra/bake/fry/fry.factor

@@ -77,4 +77,4 @@ DEFER: shallow-fry
 
 MACRO: fry ( seq -- quot ) [fry] ;
 
-: `[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
+: '[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing

extra/calendar/calendar.factor

@@ -284,7 +284,7 @@ MEMO: unix-1970 ( -- timestamp )
 
 : now ( -- timestamp ) gmt >local-time ;
 
-: from-now ( dt -- timestamp ) now swap time+ ;
+: hence ( dt -- timestamp ) now swap time+ ;
 : ago ( dt -- timestamp ) now swap time- ;
 
 : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
@@ -357,7 +357,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 
 M: timestamp sleep-until timestamp>millis sleep-until ;
 
-M: duration sleep from-now sleep-until ;
+M: duration sleep hence sleep-until ;
 
 {
     { [ os unix? ] [ "calendar.unix" ] }

extra/ctags/ctags-docs.factor

@@ -12,9 +12,9 @@ HELP: ctags ( path -- )
 { $values { "path" "a pathname string" } }
 { $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." }
 { $examples
-  { $example
+  { $unchecked-example
     "USING: ctags ;"
-    "\"tags\" ctags-write"
+    "\"tags\" ctags"
     ""
   }
 } ;
@@ -24,7 +24,7 @@ HELP: ctags-write ( seq path -- )
           { "path" "a pathname string" } }
 { $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
 { $examples
-  { $example
+  { $unchecked-example
     "USING: kernel ctags ;"
     "{ { if  { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write"
     ""
@@ -38,9 +38,9 @@ HELP: ctag-strings ( alist -- seq )
           { "seq" sequence } }
 { $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." }
 { $examples
-  { $example
+  { $unchecked-example
-    "USING: kernel ctags ;"
+    "USING: kernel ctags prettyprint ;"
-    "{ { if  { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings"
+    "{ { if  { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings ."
     "{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }"
   }
 } ;
@@ -50,8 +50,8 @@ HELP: ctag ( seq -- str )
           { "str" string } }
 { $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" }
 { $examples
-  { $example
+  { $unchecked-example
-    "USING: kernel ctags ;"
+    "USING: kernel ctags prettyprint ;"
     "{ if  { \"resource:extra/unix/unix.factor\" 91 } } ctag ."
     "\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\""
   }

extra/ctags/ctags.factor

@@ -22,7 +22,7 @@ IN: ctags
   { } swap [ ctag suffix ] each ;
 
 : ctags-write ( seq path -- )
-  >r ctag-strings r> ascii set-file-lines ;
+  [ ctag-strings ] dip ascii set-file-lines ;
 
 : (ctags) ( -- seq )
   { } all-words [

extra/db/pools/pools-tests.factor

@@ -1,8 +1,22 @@
 IN: db.pools.tests
-USING: db.pools tools.test ;
+USING: db.pools tools.test continuations io.files namespaces
+accessors kernel math destructors ;
 
 \ <db-pool> must-infer
 
 { 2 0 } [ [ ] with-db-pool ] must-infer-as
 
 { 1 0 } [ [ ] with-pooled-db ] must-infer-as
+
+! Test behavior after image save/load
+USE: db.sqlite
+
+[ "pool-test.db" temp-file delete-file ] ignore-errors
+
+[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
+
+[ ] [ "pool" get expired>> t >>expired drop ] unit-test
+
+[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
+
+[ ] [ "pool" get dispose ] unit-test

extra/documents/documents.factor

@@ -15,11 +15,11 @@ IN: documents
 
 : lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
 
-TUPLE: document locs ;
+TUPLE: document < model locs ;
 
 : <document> ( -- document )
-    V{ "" } clone <model> V{ } clone
+    V{ "" } clone document new-model
-    { set-delegate set-document-locs } document construct ;
+    V{ } clone >>locs ;
 
 : add-loc ( loc document -- ) locs>> push ;
 

extra/furnace/auth/login/login.factor

@@ -40,10 +40,9 @@ M: login-realm modify-form ( responder -- )
     permit-id get realm get name>> permit-id-key <cookie>
         "$login-realm" resolve-base-path >>path
         realm get
-        [ timeout>> from-now >>expires ]
         [ domain>> >>domain ]
         [ secure>> >>secure ]
-        tri ;
+        bi ;
 
 : put-permit-cookie ( response -- response' )
     <permit-cookie> put-cookie ;

extra/furnace/cache/cache.factor

@@ -33,4 +33,4 @@ TUPLE: server-state-manager < filter-responder timeout ;
         20 minutes >>timeout ; inline
 
 : touch-state ( state manager -- )
-    timeout>> from-now >>expires drop ;
+    timeout>> hence >>expires drop ;

extra/furnace/sessions/sessions.factor

@@ -116,7 +116,6 @@ M: session-saver dispose
 : <session-cookie> ( -- cookie )
     session get id>> session-id-key <cookie>
         "$sessions" resolve-base-path >>path
-        sessions get timeout>> from-now >>expires
         sessions get domain>> >>domain ;
 
 : put-session-cookie ( response -- response' )

extra/io/pools/pools.factor

@@ -9,7 +9,7 @@ TUPLE: pool connections disposed expired ;
 : check-pool ( pool -- )
     dup check-disposed
     dup expired>> expired? [
-        ALIEN: 31337 >>expired
+        31337 <alien> >>expired
         connections>> delete-all
     ] [ drop ] if ;
 

extra/io/unix/backend/backend.factor

@@ -125,7 +125,8 @@ M: fd refill
     } cond ;
 
 M: unix (wait-to-read) ( port -- )
-    dup dup handle>> refill dup
+    dup
+    dup handle>> dup check-disposed refill dup
     [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
 
 ! Writers
@@ -144,7 +145,9 @@ M: fd drain
     } cond ;
 
 M: unix (wait-to-write) ( port -- )
-    dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
+    dup
+    dup handle>> dup check-disposed drain
+    dup [ wait-for-port ] [ 2drop ] if ;
 
 M: unix io-multiplex ( ms/f -- )
     mx get-global wait-for-events ;

extra/io/windows/files/files.factor

@@ -61,6 +61,7 @@ C: <FileArgs> FileArgs
 
 : make-FileArgs ( port -- <FileArgs> )
     {
+        [ handle>> check-disposed ]
         [ handle>> handle>> ]
         [ buffer>> ]
         [ buffer>> buffer-length ]

extra/io/windows/nt/backend/backend.factor

@@ -74,7 +74,7 @@ M: winnt add-completion ( win32-handle -- )
     ] if ;
 
 M: win32-handle cancel-operation
-    handle>> CancelIo drop ;
+    [ check-disposed ] [ handle>> CancelIo drop ] bi ;
 
 M: winnt io-multiplex ( ms -- )
     handle-overlapped [ 0 io-multiplex ] when ;

extra/tetris/tetris.factor

@@ -45,7 +45,7 @@ tetris-gadget H{
     dup tetris-gadget-tetris maybe-update relayout-1 ;
 
 M: tetris-gadget graft* ( gadget -- )
-    dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm
+    dup [ tick ] curry 100 milliseconds every
     swap set-tetris-gadget-alarm ;
 
 M: tetris-gadget ungraft* ( gadget -- )

extra/ui/gestures/gestures.factor

@@ -121,7 +121,7 @@ SYMBOL: drag-timer
 : start-drag-timer ( -- )
     hand-buttons get-global empty? [
         [ drag-gesture ]
-        300 milliseconds from-now
+        300 milliseconds hence
         100 milliseconds
         add-alarm drag-timer get-global >box
     ] when ;

extra/webapps/planet/mini-planet.xml

@@ -1,14 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-	<t:bind-each t:name="postings">
-
-		<p class="news">
-			<strong><t:label t:name="title" /></strong> <br/>
-			<t:a value="link" class="more">Read More...</t:a>
-		</p>
-
-	</t:bind-each>
-
-</t:chloe>

extra/webapps/wiki/initial-content/Farkup.txt

@@ -0,0 +1,63 @@
+Look at the source to this page by clicking *Edit* to compare the farkup language with resulting output.
+
+= level 1 heading =
+
+== level 2 heading ==
+
+=== level 3 heading ===
+
+==== level 4 heading ====
+
+Here is a paragraph of text, with _emphasized_ and *strong* text, together with an inline %code snippet%. Did you know that E=mc^2^, and L~2~ spaces are cool? Of course, if you want to include \_ special \* characters \^ you \~ can \% do that, too.
+
+You can make [[Wiki Links]] just like that, as well as links to external sites: [[http://sbcl.sourceforge.net]]. [[Factor|Custom link text]] can be used [[http://www.apple.com|with both types of links]].
+
+Images can be embedded in the text:
+
+[[image:http://factorcode.org/graphics/logo.png]]
+
+- a list
+- with three
+- items
+
+|a table|with|four|columns|
+|and|two|rows|...|
+
+Here is some code:
+
+[{HAI
+CAN HAS STDIO?
+VISIBLE "HAI WORLD!"
+KTHXBYE}]
+
+There is syntax highlighting various languages, too:
+
+[factor{PEG: parse-request-line ( string -- triple )
+    #! Triple is { method url version }
+    [ 
+        'space' ,
+        'http-method' ,
+        'space' ,
+        'url' ,
+        'space' ,
+        'http-version' ,
+        'space' ,
+    ] seq* just ;}]
+
+Some Java:
+
+[java{/**
+ * Returns the extension of the specified filename, or an empty
+ * string if there is none.
+ * @param path The path
+ */
+public static String getFileExtension(String path)
+{
+    int fsIndex = getLastSeparatorIndex(path);
+    int index = path.lastIndexOf('.');
+    // there could be a dot in the path and no file extension
+    if(index == -1 || index < fsIndex )
+        return "";
+    else
+        return path.substring(index);
+}}]

extra/webapps/wiki/initial-content/Front Page.txt

@@ -0,0 +1,5 @@
+Congratulations, you are now running your very own Wiki.
+
+You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text.
+
+Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.

extra/webapps/wiki/wiki-common.xml

@@ -13,6 +13,7 @@
 		<t:a t:href="$wiki">Front Page</t:a>
 		| <t:a t:href="$wiki/articles">All Articles</t:a>
 		| <t:a t:href="$wiki/changes">Recent Changes</t:a>
+		| <t:a t:href="$wiki/random">Random Article</t:a>
 
 		<t:if t:code="furnace.auth:logged-in?">
 
@@ -45,6 +46,16 @@
 				</td>
 			</t:if>
 		</tr>
+
+		<tr>
+			<td>
+				<t:bind t:name="footer">
+					<small>
+						<t:farkup t:name="content" />
+					</small>
+				</t:bind>
+			</td>
+		</tr>
 	</table>
 
 </t:chloe>

extra/webapps/wiki/wiki.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel hashtables calendar
+USING: accessors kernel hashtables calendar random assocs
 namespaces splitting sequences sorting math.order present
+io.files io.encodings.ascii
 syndication
 html.components html.forms
 http.server
@@ -115,6 +116,14 @@ M: revision feed-entry-url id>> revision-url ;
 
         { wiki "view" } >>template ;
 
+: <random-article-action> ( -- action )
+    <action>
+        [
+            article new select-tuples random
+            [ title>> ] [ "Front Page" ] if*
+            view-url <redirect>
+        ] >>display ;
+
 : amend-article ( revision article -- )
     swap id>> >>revision update-tuple ;
 
@@ -286,15 +295,15 @@ M: revision feed-entry-url id>> revision-url ;
         { wiki "page-common" } >>template ;
 
 : init-sidebar ( -- )
-    "Sidebar" latest-revision [
+    "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
-        "sidebar" [ from-object ] nest-form
+    "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
-    ] when* ;
 
 : <wiki> ( -- dispatcher )
     wiki new-dispatcher
         <main-article-action> <article-boilerplate> "" add-responder
         <view-article-action> <article-boilerplate> "view" add-responder
         <view-revision-action> <article-boilerplate> "revision" add-responder
+        <random-article-action> "random" add-responder
         <list-revisions-action> <article-boilerplate> "revisions" add-responder
         <list-revisions-feed-action> "revisions.atom" add-responder
         <diff-action> <article-boilerplate> "diff" add-responder
@@ -309,3 +318,15 @@ M: revision feed-entry-url id>> revision-url ;
     <boilerplate>
         [ init-sidebar ] >>init
         { wiki "wiki-common" } >>template ;
+
+: init-wiki ( -- )
+    "resource:extra/webapps/wiki/initial-content" directory* keys
+    [
+        [ ascii file-contents ] [ file-name "." split1 drop ] bi
+        f <revision>
+            swap >>title
+            swap >>content
+            "slava" >>author
+            now >>date
+        add-revision
+    ] each ;

extra/websites/concatenative/concatenative.factor

@@ -25,7 +25,7 @@ webapps.wee-url
 webapps.user-admin ;
 IN: websites.concatenative
 
-: test-db ( -- db params ) "resource:test.db" sqlite-db ;
+: test-db ( -- params db ) "resource:test.db" sqlite-db ;
 
 : init-factor-db ( -- )
     test-db [

extra/windows/user32/user32.factor

@@ -1285,10 +1285,10 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
 ! FUNCTION: SetWindowPlacement
 FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
 
-: HWND_BOTTOM ALIEN: 1 ;
+: HWND_BOTTOM ( -- alien ) 1 <alien> ;
-: HWND_NOTOPMOST ALIEN: -2 ;
+: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
-: HWND_TOP ALIEN: 0 ;
+: HWND_TOP ( -- alien ) 0 <alien> ;
-: HWND_TOPMOST ALIEN: -1 ;
+: HWND_TOPMOST ( -- alien ) -1 <alien> ;
 
 ! FUNCTION: SetWindowRgn
 ! FUNCTION: SetWindowsHookA