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

db4
Doug Coleman 2008-07-09 19:12:08 -05:00
commit 7fea8f6381
26 changed files with 182 additions and 77 deletions

View File

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

View File

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

9
extra/bake/bake.factor Executable file → Normal file
View File

@ -1,7 +1,7 @@
USING: kernel parser namespaces sequences quotations arrays vectors splitting
words math
macros generalizations combinators.lib combinators.conditional newfx ;
strings words math generalizations
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 ] }
@ -90,5 +92,6 @@ MACRO: bake ( seq -- quot ) [bake] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
: `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing

View File

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

View File

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

View File

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

View File

@ -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
"USING: kernel ctags ;"
"{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings"
{ $unchecked-example
"USING: kernel ctags prettyprint ;"
"{ { 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
"USING: kernel ctags ;"
{ $unchecked-example
"USING: kernel ctags prettyprint ;"
"{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag ."
"\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\""
}

View File

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

View File

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

View File

@ -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
{ set-delegate set-document-locs } document construct ;
V{ "" } clone document new-model
V{ } clone >>locs ;
: add-loc ( loc document -- ) locs>> push ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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" [ from-object ] nest-form
] when* ;
"Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
"Footer" latest-revision [ "footer" [ from-object ] nest-form ] 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 ;

View File

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

View File

@ -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_NOTOPMOST ALIEN: -2 ;
: HWND_TOP ALIEN: 0 ;
: HWND_TOPMOST ALIEN: -1 ;
: HWND_BOTTOM ( -- alien ) 1 <alien> ;
: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
: HWND_TOP ( -- alien ) 0 <alien> ;
: HWND_TOPMOST ( -- alien ) -1 <alien> ;
! FUNCTION: SetWindowRgn
! FUNCTION: SetWindowsHookA