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

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

db4
Bruno Deferrari 2008-09-08 14:39:28 -03:00
parent 198e35fac2 24b42d4008
commit d6daf688ad
127 changed files with 1013 additions and 685 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/base64/base64.factor
View File

@ -36,7 +36,7 @@ PRIVATE>
#! pad string with = when not enough bits
dup length dup 3 mod - cut
[ 3 <groups> [ encode3 ] map concat ]
[ dup empty? [ drop "" ] [ >base64-rem ] if ]
[ [ "" ] [ >base64-rem ] if-empty ]
bi* append ;
: base64> ( base64 -- str )

2
basis/bootstrap/stage2.factor
View File

@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
default-image-name "output-image" set-global
"threads math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
"math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line

4
basis/channels/channels.factor
View File

@ -33,10 +33,10 @@ PRIVATE>
M: channel to ( value channel -- )
dup receivers>>
dup empty? [ drop dup wait to ] [ nip (to) ] if ;
[ dup wait to ] [ nip (to) ] if-empty ;
M: channel from ( channel -- value )
[
notify senders>>
dup empty? [ drop ] [ (from) ] if
[ (from) ] unless-empty
] curry "channel receive" suspend ;

2
basis/checksums/sha1/sha1.factor
View File

@ -120,7 +120,7 @@ M: sha1 checksum-stream ( stream -- sha1 )
: seq>2seq ( seq -- seq1 seq2 )
#! { abcdefgh } -> { aceg } { bdfh }
2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
2 group flip [ { } { } ] [ first2 ] if-empty ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }

8
basis/compiler/generator/iterator/iterator.factor
View File

@ -28,18 +28,18 @@ DEFER: (tail-call?)
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
dup empty? [ drop t ] [
[ t ] [
[ first [ #return? ] [ #terminate? ] bi or ]
[ tail-phi? ]
bi or
] if ;
] if-empty ;
: tail-call? ( -- ? )
node-stack get [
rest-slice
dup empty? [ drop t ] [
[ t ] [
[ (tail-call?) ]
[ first #terminate? not ]
bi and
] if
] if-empty
] all? ;

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

@ -32,7 +32,7 @@ M: #shuffle check-node*
M: #copy check-node* inputs/outputs 2array check-lengths ;
: check->r/r> ( node -- )
inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ;
inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
M: #>r check-node* check->r/r> ;

4
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -37,8 +37,8 @@ GENERIC: cleanup* ( node -- node/nodes )
[ cleanup* ] map flatten ;
: cleanup-folding? ( #call -- ? )
node-output-infos dup empty?
[ drop f ] [ [ literal?>> ] all? ] if ;
node-output-infos
[ f ] [ [ literal?>> ] all? ] if-empty ;
: cleanup-folding ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its

4
basis/compiler/tree/escape-analysis/branches/branches.factor
View File

@ -15,7 +15,7 @@ M: #branch escape-analysis*
: (merge-allocations) ( values -- allocation )
[
dup [ allocation ] map sift dup empty? [ 2drop f ] [
dup [ allocation ] map sift [ drop f ] [
dup [ t eq? not ] all? [
dup [ length ] map all-equal? [
nip flip
@ -23,7 +23,7 @@ M: #branch escape-analysis*
[ record-allocations ] keep
] [ drop add-escaping-values t ] if
] [ drop add-escaping-values t ] if
] if
] if-empty
] map ;
: merge-allocations ( in-values out-values -- )

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

@ -205,5 +205,5 @@ M: node normalize* ;
dup [ collect-label-info ] each-node
dup count-introductions make-values
[ (normalize) ] [ nip ] 2bi
dup empty? [ drop ] [ #introduce prefix ] if
[ #introduce prefix ] unless-empty
rename-node-values ;

5
basis/compiler/tree/propagation/info/info.factor
View File

@ -237,9 +237,8 @@ DEFER: (value-info-union)
} cond ;
: value-infos-union ( infos -- info )
dup empty?
[ drop null-info ]
[ dup first [ value-info-union ] reduce ] if ;
[ null-info ]
[ dup first [ value-info-union ] reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{

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

@ -185,7 +185,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
: ends-with-terminate? ( nodes -- ? )
dup empty? [ drop f ] [ peek #terminate? ] if ;
[ f ] [ peek #terminate? ] if-empty ;
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;

6
basis/db/postgresql/lib/lib.factor
View File

@ -87,11 +87,11 @@ M: postgresql-result-null summary ( obj -- str )
{ URL [ dup [ present ] when default-param-value ] }
[ drop default-param-value ]
} case 2array
] 2map flip dup empty? [
drop f f
] 2map flip [
f f
] [
first2 [ >c-void*-array ] [ >c-uint-array ] bi*
] if ;
] if-empty ;
: param-formats ( statement -- seq )
in-params>> [ type>> type>param-format ] map >c-uint-array ;

2
basis/db/types/types.factor
View File

@ -136,7 +136,7 @@ ERROR: no-sql-type ;
: modifiers ( spec -- string )
modifiers>> [ lookup-modifier ] map " " join
dup empty? [ " " prepend ] unless ;
[ "" ] [ " " prepend ] if-empty ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )

6
basis/debugger/debugger.factor
View File

@ -48,14 +48,12 @@ M: string error. print ;
] "" make print ;
: restarts. ( -- )
restarts get dup empty? [
drop
] [
restarts get [
nl
"The following restarts are available:" print
nl
[ restart. ] each-index
] if ;
] unless-empty ;
: print-error ( error -- )
[ error. flush ] curry

51
basis/farkup/farkup-docs.factor
View File

@ -1,6 +1,51 @@
USING: help.markup help.syntax ;
USING: help.markup help.syntax strings io ;
IN: farkup
HELP: convert-farkup
{ $values { "string" "a string" } { "string'" "a string" } }
{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ;
{ $values { "string" string } { "string'" string } }
{ $description "Parse a Farkup string and convert it to an HTML string." } ;
HELP: write-farkup
{ $values { "string" string } }
{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
HELP: farkup ( string -- farkup )
{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
HELP: (write-farkup)
{ $values { "farkup" "a Farkup syntax tree node" } }
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
{ $subsection heading1 }
{ $subsection heading2 }
{ $subsection heading3 }
{ $subsection heading4 }
{ $subsection strong }
{ $subsection emphasis }
{ $subsection superscript }
{ $subsection subscript }
{ $subsection inline-code }
{ $subsection paragraph }
{ $subsection list-item }
{ $subsection list }
{ $subsection table }
{ $subsection table-row }
{ $subsection link }
{ $subsection image }
{ $subsection code } ;
ARTICLE: "farkup" "Farkup"
"The " { $vocab-link "farkup" } " vocabulary implements Farkup (Factor mARKUP), a simple markup language. Farkup was loosely based on the markup languages employed by MediaWiki and " { $url "http://reddit.com" } "."
$nl
"The main entry points for converting Farkup to HTML:"
{ $subsection convert-farkup }
{ $subsection write-farkup }
"The syntax tree of a piece of Farkup can also be inspected and modified:"
{ $subsection farkup }
{ $subsection (write-farkup) }
{ $subsection "farkup-ast" } ;
ABOUT: "farkup"

18
basis/farkup/farkup-tests.factor
View File

@ -1,8 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test ;
USING: farkup kernel peg peg.ebnf tools.test namespaces ;
IN: farkup.tests
[ "Baz" ] [ "Foo/Bar/Baz" simple-link-title ] unit-test
[ "Baz" ] [ "Baz" simple-link-title ] unit-test
[ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23"
"paragraph" \ farkup rule parse drop
@ -81,10 +84,15 @@ IN: farkup.tests
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
[ "<p><img src='lol.jpg'/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src='lol.jpg' alt='teh lol'/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [
[ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
] with-variable
[ ] [ "[{}]" convert-farkup drop ] unit-test

87
basis/farkup/farkup.factor
View File

@ -28,6 +28,12 @@ TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
: absolute-url? ( string -- ? )
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" last-split1 swap or ] unless ;
EBNF: farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
@ -67,7 +73,7 @@ image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ second >string f image boa ]]
simple-link = "[[" (!("|]" | "]]") .)+ "]]"
=> [[ second >string dup link boa ]]
=> [[ second >string dup simple-link-title link boa ]]
labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
@ -102,7 +108,12 @@ list = ((list-item nl)+ list-item? | list-item)
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
stand-alone = (code | heading | list | table | paragraph | nl)*
simple-code
= "[{" (!("}]").)+ "}]"
=> [[ second f swap code boa ]]
stand-alone
= (code | simple-code | heading | list | table | paragraph | nl)*
;EBNF
@ -114,31 +125,26 @@ stand-alone = (code | heading | list | table | paragraph | nl)*
{ [ dup empty? ] [ drop invalid-url ] }
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop invalid-url ] unless
] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend ]
} cond ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
: write-link ( text href -- )
: write-link ( href text -- )
escape-link
"<a" write
" href=\"" write write "\"" write
link-no-follow? get [ " nofollow=\"true\"" write ] when
">" write write "</a>" write ;
[ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ]
bi* ;
: write-image-link ( href text -- )
disable-images? get [
2drop "<strong>Images are not allowed</strong>" write
2drop
<strong> "Images are not allowed" write </strong>
] [
escape-link
>r "<img src=\"" write write "\"" write r>
dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
"/>" write
[ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
] if ;
: render-code ( string mode -- string' )
@ -149,32 +155,35 @@ stand-alone = (code | heading | list | table | paragraph | nl)*
</pre>
] with-string-writer write ;
GENERIC: write-farkup ( obj -- )
GENERIC: (write-farkup) ( farkup -- )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
M: table-row write-farkup ( obj -- )
obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
M: fixnum write-farkup ( obj -- ) write1 ;
M: string write-farkup ( obj -- ) write ;
M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
M: f write-farkup ( obj -- ) drop ;
M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
M: table-row (write-farkup) ( obj -- )
obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
M: fixnum (write-farkup) ( obj -- ) write1 ;
M: string (write-farkup) ( obj -- ) write ;
M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
M: f (write-farkup) ( obj -- ) drop ;
: write-farkup ( string -- )
farkup (write-farkup) ;
: convert-farkup ( string -- string' )
farkup [ write-farkup ] with-string-writer ;
farkup [ (write-farkup) ] with-string-writer ;

10
basis/fry/fry.factor
View File

@ -14,13 +14,13 @@ DEFER: shallow-fry
: ((shallow-fry)) ( accum quot adder -- result )
>r shallow-fry r>
append swap dup empty? [ drop ] [
append swap [
[ prepose ] curry append
] if ; inline
] unless-empty ; inline
: (shallow-fry) ( accum quot -- result )
dup empty? [
drop 1quotation
[
1quotation
] [
unclip {
{ \ , [ [ curry ] ((shallow-fry)) ] }
@ -31,7 +31,7 @@ DEFER: shallow-fry
[ swap >r suffix r> (shallow-fry) ]
} case
] if ;
] if-empty ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;

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

@ -23,11 +23,11 @@ SYMBOL: rest
: render-validation-messages ( -- )
form get errors>>
dup empty? [ drop ] [
[
<ul "errors" =class ul>
[ <li> escape-string write </li> ] each
</ul>
] if ;
] unless-empty ;
CHLOE: validation-messages drop render-validation-messages ;
@ -47,11 +47,11 @@ TUPLE: action rest authorize init display validate submit ;
2tri ;
: set-nested-form ( form name -- )
dup empty? [
drop merge-forms
[
merge-forms
] [
unclip [ set-nested-form ] nest-form
] if ;
] if-empty ;
: restore-validation-errors ( -- )
form cget [

27
basis/furnace/auth/auth.factor
View File

@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ;
swap >>responder ;
: have-capabilities? ( capabilities -- ? )
logged-in-user get {
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ capabilities>> subset? ]
} cond ;
realm get secure>> secure-connection? not and [ drop f ] [
logged-in-user get {
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ capabilities>> subset? ]
} cond
] if ;
M: protected call-responder* ( path responder -- response )
'[
, ,
dup protected set
dup capabilities>> have-capabilities?
[ call-next-method ] [
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
realm get login-required*
] if
] if-secure-realm ;
dup protected set
dup capabilities>> have-capabilities?
[ call-next-method ] [
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
realm get login-required*
] if ;
: <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ;

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

@ -42,8 +42,8 @@ IN: furnace.auth.features.edit-profile
[
logged-in-user get
"new-password" value dup empty?
[ drop ] [ >>encoded-password ] if
"new-password" value
[ >>encoded-password ] unless-empty
"realname" value >>realname
"email" value >>email

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

@ -36,7 +36,8 @@ IN: furnace.auth.features.registration
URL" $realm" <redirect>
] >>submit
<auth-boilerplate> ;
<auth-boilerplate>
<secure-realm-only> ;
: allow-registration ( login -- login )
<register-action> "register" add-responder ;

19
basis/furnace/chloe-tags/chloe-tags-tests.factor Normal file
View File

@ -0,0 +1,19 @@
USING: html.forms furnace.chloe-tags tools.test ;
IN: furnace.chloe-tags.tests
[ f ] [ f parse-query-attr ] unit-test
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
begin-form
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
begin-form
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
] unit-test

126
basis/furnace/chloe-tags/chloe-tags.factor Normal file
View File

@ -0,0 +1,126 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
namespaces sequences splitting words
fry urls multiline present qualified
xml
xml.data
xml.entities
xml.writer
xml.utilities
html.components
html.elements
html.forms
html.templates
html.templates.chloe
html.templates.chloe.compiler
html.templates.chloe.syntax
http
http.server
http.server.redirection
http.server.responses
furnace ;
QUALIFIED-WITH: assocs a
IN: furnace.chloe-tags
! Chloe tags
: parse-query-attr ( string -- assoc )
[ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
: a-url-path ( href rest -- string )
dup [ value ] when
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( href rest query value-name -- url )
dup [ >r 3drop r> value ] [
drop
<url>
swap parse-query-attr >>query
-rot a-url-path >>path
adjust-url relative-to-request
] if ;
: compile-a-url ( tag -- )
{
[ "href" required-attr compile-attr ]
[ "rest" optional-attr compile-attr ]
[ "query" optional-attr compile-attr ]
[ "value" optional-attr compile-attr ]
} cleave [ a-url ] [code] ;
CHLOE: atom
[ compile-children>string ] [ compile-a-url ] bi
[ add-atom-feed ] [code] ;
CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
: compile-link-attrs ( tag -- )
#! Side-effects current namespace.
attrs>> '[ [ , _ link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
[ compile-link-attrs ] [ compile-a-url ] bi
[ <a =href a> ] [code] ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
CHLOE: a
[
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
] compile-with-scope ;
: compile-hidden-form-fields ( for -- )
'[
, [ "," split [ hidden render ] each ] when*
nested-forms get " " join f like nested-forms-key hidden-form-field
[ modify-form ] each-responder
] [code] ;
: compile-form-attrs ( method action attrs -- )
[ <form ] [code]
[ compile-attr [ =method ] [code] ]
[ compile-attr [ resolve-base-path =action ] [code] ]
[ compile-attrs ]
tri*
[ form> ] [code] ;
: form-start-tag ( tag -- )
[
[ "method" optional-attr "post" or ]
[ "action" required-attr ]
[ attrs>> non-chloe-attrs-only ] tri
compile-form-attrs
]
[ "for" optional-attr compile-hidden-form-fields ] bi ;
: form-end-tag ( tag -- )
drop [ </form> ] [code] ;
CHLOE: form
[
{
[ compile-link-attrs ]
[ form-start-tag ]
[ compile-children ]
[ form-end-tag ]
} cleave
] compile-with-scope ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
button-tag-markup string>xml body>>
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>> ] dip "button" tag-named (>>children) ]
[ nip ]
} 2cleave compile-chloe-tag ;

3
basis/furnace/conversations/conversations.factor
View File

@ -130,7 +130,8 @@ M: conversations call-responder*
over post-data>> >>post-data
over url>> >>url
] change
url>> path>> split-path
[ url>> url set ]
[ url>> path>> split-path ] bi
conversations get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging

142
basis/furnace/furnace.factor
View File

@ -1,30 +1,14 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
continuations namespaces sequences splitting words
vocabs.loader classes strings
fry urls multiline present
xml
xml.data
xml.entities
xml.writer
html.components
html.elements
html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
http
http.server
http.server.redirection
http.server.responses
qualified ;
QUALIFIED-WITH: assocs a
EXCLUDE: xml.utilities => children>string ;
USING: namespaces assocs sequences kernel classes splitting
vocabs.loader accessors strings combinators arrays
continuations present fry
urls html.elements
http http.server http.server.redirection ;
IN: furnace
: nested-responders ( -- seq )
responder-nesting get a:values ;
responder-nesting get values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
@ -63,10 +47,25 @@ M: url adjust-url
M: string adjust-url ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
@ -110,99 +109,4 @@ SYMBOL: exit-continuation
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
! Chloe tags
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
: a-url-path ( tag -- string )
[ "href" required-attr ]
[ "rest" optional-attr dup [ value ] when ] bi
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( tag -- url )
dup "value" optional-attr
[ value ] [
<url>
swap
[ a-url-path >>path ]
[ "query" optional-attr parse-query-attr >>query ]
bi
adjust-url relative-to-request
] ?if ;
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
: link-attrs ( tag -- )
#! Side-effects current namespace.
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
CHLOE: a
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: form-magic ( tag -- )
[ modify-form ] each-responder
nested-forms get " " join f like nested-forms-key hidden-form-field
"for" optional-attr [ "," split [ hidden render ] each ] when* ;
: form-start-tag ( tag -- )
[
[
<form
{
[ link-attrs ]
[ "method" optional-attr "post" or =method ]
[ "action" required-attr resolve-base-path =action ]
[ attrs>> non-chloe-attrs-only print-attrs ]
} cleave
form>
]
[ form-magic ] bi
] with-scope ;
CHLOE: form
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
button-tag-markup string>xml body>>
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>string 1array ] dip "button" tag-named (>>children) ]
[ nip ]
} 2cleave process-chloe-tag ;
"furnace.chloe-tags" require

18
basis/furnace/redirection/redirection.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry
io.servers.connection urls
http http.server http.server.redirection http.server.filters
furnace ;
io.servers.connection urls http http.server
http.server.redirection http.server.responses
http.server.filters furnace ;
IN: furnace.redirection
: <redirect> ( url -- response )
@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ;
C: <secure-only> secure-only
: if-secure ( quot -- )
>r url get protocol>> "http" =
[ url get <secure-redirect> ]
r> if ; inline
: secure-connection? ( -- ? ) url get protocol>> "https" = ;
: if-secure ( quot -- response )
{
{ [ secure-connection? ] [ call ] }
{ [ request get method>> "POST" = ] [ drop <400> ] }
[ drop url get <secure-redirect> ]
} cond ; inline
M: secure-only call-responder*
'[ , , call-next-method ] if-secure ;

19
basis/generalizations/generalizations-docs.factor
View File

@ -2,6 +2,16 @@ USING: help.syntax help.markup kernel sequences quotations
math arrays ;
IN: generalizations
HELP: nsequence
{ $values { "n" integer } { "seq" "an exemplar" } }
{ $description "A generalization of " { $link 2sequence } ", "
{ $link 3sequence } ", and " { $link 4sequence } " "
"that constructs a sequence from the top " { $snippet "n" } " elements of the stack."
}
{ $examples
{ $example "USING: generalizations prettyprint ;" "CHAR: f CHAR: i CHAR: s CHAR: h 4 \"\" nsequence ." "\"fish\"" }
} ;
HELP: narray
{ $values { "n" integer } }
{ $description "A generalization of " { $link 1array } ", "
@ -9,6 +19,8 @@ HELP: narray
"that constructs an array from the top " { $snippet "n" } " elements of the stack."
} ;
{ nsequence narray } related-words
HELP: firstn
{ $values { "n" integer } }
{ $description "A generalization of " { $link first } ", "
@ -127,11 +139,15 @@ HELP: nkeep
{ $see-also keep nslip } ;
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"A number of stack shuffling words and combinators for use in "
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
"macros where the arity of the input quotations depends on an "
"input parameter."
$nl
"Generalized sequence operations:"
{ $subsection narray }
{ $subsection nsequence }
{ $subsection firstn }
"Generated stack shuffle operations:"
{ $subsection ndup }
{ $subsection npick }
{ $subsection nrot }
@ -139,6 +155,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators"
{ $subsection nnip }
{ $subsection ndrop }
{ $subsection nrev }
"Generalized combinators:"
{ $subsection ndip }
{ $subsection nslip }
{ $subsection nkeep }

7
basis/generalizations/generalizations.factor
View File

@ -5,10 +5,13 @@ USING: kernel sequences sequences.private namespaces math
math.ranges combinators macros quotations fry arrays ;
IN: generalizations
MACRO: narray ( n -- quot )
[ <reversed> ] [ '[ , f <array> ] ] bi
MACRO: nsequence ( n seq -- quot )
[ drop <reversed> ] [ '[ , , new-sequence ] ] 2bi
[ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;
MACRO: narray ( n -- quot )
'[ , { } nsequence ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ , _ nth-unsafe ] ] map ]

9
basis/help/help.factor
View File

@ -72,15 +72,13 @@ M: word article-parent "help-parent" word-prop ;
M: word set-article-parent swap "help-parent" set-word-prop ;
: $doc-path ( article -- )
help-path dup empty? [
drop
] [
help-path [
[
help-path-style get [
"Parent topics: " write $links
] with-style
] ($block)
] if ;
] unless-empty ;
: $title ( topic -- )
title-style get [
@ -112,8 +110,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
sort-articles [ \ $subsection swap 2array ] map print-element ;
: $index ( element -- )
first call dup empty?
[ drop ] [ ($index) ] if ;
first call [ ($index) ] unless-empty ;
: $about ( element -- )
first vocab-help [ 1array $subsection ] when* ;

5
basis/help/lint/lint.factor
View File

@ -136,15 +136,14 @@ M: help-error error.
] with-scope ;
: typos. ( assoc -- )
dup empty? [
drop
[
"==== ALL CHECKS PASSED" print
] [
[
swap vocab-heading.
[ error. nl ] each
] assoc-each
] if ;
] if-empty ;
: help-lint ( prefix -- ) run-help-lint typos. ;

6
basis/help/markup/markup.factor
View File

@ -15,7 +15,7 @@ IN: help.markup
! Element types are words whose name begins with $.
PREDICATE: simple-element < array
dup empty? [ drop t ] [ first word? not ] if ;
[ t ] [ first word? not ] if-empty ;
SYMBOL: last-element
SYMBOL: span
@ -201,8 +201,8 @@ ALIAS: $slot $snippet
dup [ "related" set-word-prop ] curry each ;
: $related ( element -- )
first dup "related" word-prop remove dup empty?
[ drop ] [ $see-also ] if ;
first dup "related" word-prop remove
[ $see-also ] unless-empty ;
: ($grid) ( style quot -- )
[

4
basis/hints/hints.factor
View File

@ -13,10 +13,10 @@ IN: hints
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
] if-empty ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [

2
basis/html/components/components.factor
View File

@ -156,7 +156,7 @@ M: farkup render*
[
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
[ disable-images>> [ string>boolean disable-images? set ] when* ] bi
drop string-lines "\n" join convert-farkup write
drop string-lines "\n" join write-farkup
] with-scope ;
! Inspector component

3
basis/html/elements/elements.factor
View File

@ -142,6 +142,7 @@ SYMBOL: html
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "input"
"strong"
] [ define-closed-html-word ] each
! Define some open HTML tags
@ -160,6 +161,8 @@ SYMBOL: html
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked"
"summary" "cellspacing" "align" "scope" "abbr"
"nofollow" "alt"
] [ define-attribute-word ] each
>>

12
basis/html/streams/streams.factor
View File

@ -88,11 +88,11 @@ TUPLE: html-sub-stream < html-stream style parent ;
] make-css ;
: span-tag ( style quot -- )
over span-css-style dup empty? [
drop call
over span-css-style [
call
] [
<span =style span> call </span>
] if ; inline
] if-empty ; inline
: format-html-span ( string style stream -- )
stream>> [
@ -121,11 +121,11 @@ M: html-span-stream dispose
] make-css ;
: div-tag ( style quot -- )
swap div-css-style dup empty? [
drop call
swap div-css-style [
call
] [
<div =style div> call </div>
] if ; inline
] if-empty ; inline
: format-html-div ( string style stream -- )
stream>> [

17
basis/html/templates/chloe/chloe-tests.factor
View File

@ -4,22 +4,7 @@ namespaces xml html.components html.forms
splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
begin-form
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
begin-form
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
] unit-test
reset-templates
: run-template
with-string-writer [ "\r\n\t" member? not ] filter

136
basis/html/templates/chloe/chloe.factor
View File

@ -1,78 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
USING: accessors kernel sequences combinators kernel fry
namespaces classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string unicode.case
mirrors math urls present multiline quotations xml xml.data
html.forms
html.elements
html.components
html.templates
html.templates.chloe.compiler
html.templates.chloe.components
html.templates.chloe.syntax ;
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
SYMBOL: tag-stack
TUPLE: chloe path ;
C: <chloe> chloe
DEFER: process-template
CHLOE: chloe compile-children ;
: chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = ] assoc-filter ;
: non-chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
{ [ dup url>> chloe-ns = not ] [ f ] }
[ t ]
} cond nip ;
: process-tag-children ( tag -- )
[ process-template ] each ;
CHLOE: chloe process-tag-children ;
: children>string ( tag -- string )
[ process-tag-children ] with-string-writer ;
CHLOE: title children>string set-title ;
CHLOE: title compile-children>string [ set-title ] [code] ;
CHLOE: write-title
drop
"head" tag-stack get member?
"title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
[ <title> write-title </title> ] [ write-title ] ? [code] ;
CHLOE: style
dup "include" optional-attr dup [
swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw
] unless
utf8 file-contents
dup "include" optional-attr [
utf8 file-contents [ add-style ] [code-with]
] [
drop children>string
] if add-style ;
compile-children>string [ add-style ] [code]
] ?if ;
CHLOE: write-style
drop <style> write-style </style> ;
drop [ <style> write-style </style> ] [code] ;
CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
CHLOE: even
[ "index" value even? swap when ] process-children ;
CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
CHLOE: odd
[ "index" value odd? swap when ] process-children ;
: (bind-tag) ( tag quot -- )
[
[ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
[ "name" required-attr compile-attr ] keep
] dip process-children ; inline
CHLOE: each [ with-each-value ] (bind-tag) ;
@ -80,22 +55,23 @@ CHLOE: bind-each [ with-each-object ] (bind-tag) ;
CHLOE: bind [ with-form ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
CHLOE: comment drop ;
CHLOE: call-next-template drop call-next-template ;
CHLOE: call-next-template
drop reset-buffer \ call-next-template , ;
: attr>word ( value -- word/f )
":" split1 swap lookup ;
: if-satisfied? ( tag -- ? )
[ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
[ "value" optional-attr [ value ] [ t ] if* ]
bi and ;
: if>quot ( tag -- quot )
[
[ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
[ "value" optional-attr [ , \ value , ] [ t , ] if* ]
bi
\ and ,
] [ ] make ;
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
CHLOE: if dup if>quot [ swap when ] append process-children ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
@ -112,51 +88,21 @@ CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
dup main>> dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: read-template ( chloe -- xml )
path>> ".xml" append utf8 <file-reader> read-xml ;
: process-tag ( tag -- )
{
[ main>> >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
[ drop tag-stack get pop* ]
} cleave ;
MEMO: template-quot ( chloe -- quot )
read-template compile-template ;
: expand-attrs ( tag -- tag )
dup [ tag? ] [ xml? ] bi or [
clone [
[ "@" ?head [ value present ] when ] assoc-map
] change-attrs
] when ;
MEMO: nested-template-quot ( chloe -- quot )
read-template compile-nested-template ;
: process-template ( xml -- )
expand-attrs
{
{ [ dup chloe-tag? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
{ [ t ] [ write-item ] }
} cond ;
: process-chloe ( xml -- )
[
V{ } clone tag-stack set
nested-template? get [
process-template
] [
{
[ prolog>> write-prolog ]
[ before>> write-chunk ]
[ process-template ]
[ after>> write-chunk ]
} cleave
] if
] with-scope ;
: reset-templates ( -- )
{ template-quot nested-template-quot } [ reset-memoized ] each ;
M: chloe call-template*
path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
nested-template? get
[ nested-template-quot ] [ template-quot ] if
assert-depth ;
INSTANCE: chloe template

131
basis/html/templates/chloe/compiler/compiler.factor Normal file
View File

@ -0,0 +1,131 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces kernel sequences accessors combinators
strings splitting io io.streams.string present xml.writer
xml.data xml.entities html.forms html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = ] assoc-filter ;
: non-chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
{ [ dup url>> chloe-ns = not ] [ f ] }
[ t ]
} cond nip ;
SYMBOL: string-buffer
SYMBOL: tag-stack
DEFER: compile-element
: compile-children ( tag -- )
[ compile-element ] each ;
: [write] ( string -- ) string-buffer get push-all ;
: reset-buffer ( -- )
string-buffer get [
[ >string , \ write , ] [ delete-all ] bi
] unless-empty ;
: [code] ( quot -- )
reset-buffer % ;
: [code-with] ( obj quot -- )
reset-buffer [ , ] [ % ] bi* ;
: expand-attr ( value -- )
[ value present write ] [code-with] ;
: compile-attr ( value -- )
reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
: compile-attrs ( assoc -- )
[
" " [write]
swap name>string [write]
"=\"" [write]
"@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
"\"" [write]
] assoc-each ;
: compile-start-tag ( tag -- )
"<" [write]
[ name>string [write] ] [ compile-attrs ] bi
">" [write] ;
: compile-end-tag ( tag -- )
"</" [write]
name>string [write]
">" [write] ;
: compile-tag ( tag -- )
{
[ main>> tag-stack get push ]
[ compile-start-tag ]
[ compile-children ]
[ compile-end-tag ]
[ drop tag-stack get pop* ]
} cleave ;
: compile-chloe-tag ( tag -- )
! "Unknown chloe tag: " prepend throw
dup main>> dup tags get at
[ curry assert-depth ] [ 2drop ] ?if ;
: compile-element ( element -- )
{
{ [ dup chloe-tag? ] [ compile-chloe-tag ] }
{ [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
{ [ dup string? ] [ escape-string [write] ] }
{ [ dup comment? ] [ drop ] }
[ [ write-item ] [code-with] ]
} cond ;
: with-compiler ( quot -- quot' )
[
SBUF" " string-buffer set
V{ } clone tag-stack set
call
reset-buffer
] [ ] make ; inline
: compile-nested-template ( xml -- quot )
[ compile-element ] with-compiler ;
: compile-chunk ( seq -- )
[ compile-element ] each ;
: compile-quot ( quot -- )
reset-buffer
[
SBUF" " string-buffer set
call
reset-buffer
] [ ] make , ; inline
: process-children ( tag quot -- )
[ [ compile-children ] compile-quot ] [ % ] bi* ; inline
: compile-children>string ( tag -- )
[ with-string-writer ] process-children ;
: compile-with-scope ( quot -- )
compile-quot [ with-scope ] [code] ; inline
: compile-template ( xml -- quot )
[
{
[ prolog>> [ write-prolog ] [code-with] ]
[ before>> compile-chunk ]
[ compile-element ]
[ after>> compile-chunk ]
} cleave
] with-compiler ;

35
basis/html/templates/chloe/components/components.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel parser fry quotations
classes.tuple
html.components
html.templates.chloe.compiler
html.templates.chloe.syntax ;
IN: html.templates.chloe.components
: singleton-component-tag ( tag class -- )
[ "name" required-attr compile-attr ]
[ literalize [ render ] [code-with] ]
bi* ;
: CHLOE-SINGLETON:
scan-word
[ name>> ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> , at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ render ] [code] ;
: CHLOE-TUPLE:
scan-word
[ name>> ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

29
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -21,7 +21,7 @@ tags global [ H{ } clone or ] change-at
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
MEMO: chloe-name ( string -- name )
: chloe-name ( string -- name )
name new
swap >>main
chloe-ns >>url ;
@ -32,30 +32,3 @@ MEMO: chloe-name ( string -- name )
: optional-attr ( tag name -- value )
chloe-name swap at ;
: singleton-component-tag ( tag class -- )
[ "name" required-attr ] dip render ;
: CHLOE-SINGLETON:
scan-word
[ name>> ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
swap main>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr ]
[ new [ attrs>slots ] keep ]
2bi render ;
: CHLOE-TUPLE:
scan-word
[ name>> ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

2
basis/http/http.factor
View File

@ -113,7 +113,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
{ [ dup real? ] [ number>string ] }
[ ]
} cond
check-cookie-string "=" swap check-cookie-string 3append ,
[ check-cookie-string ] bi@ "=" swap 3append ,
]
} case ;

6
basis/inspector/inspector.factor
View File

@ -50,14 +50,14 @@ SYMBOL: +editable+
: describe* ( obj mirror keys -- )
rot summary.
dup empty? [
2drop
[
drop
] [
dup enum? [ +sequence+ on ] when
standard-table-style [
swap [ -rot describe-row ] curry each-index
] tabular-output
] if ;
] if-empty ;
: describe ( obj -- )
dup make-mirror dup sorted-keys describe* ;

2
basis/io/servers/connection/connection.factor
View File

@ -73,7 +73,7 @@ M: threaded-server handle-client* handler>> call ;
] with-stream ;
: thread-name ( server-name addrspec -- string )
unparse " connection from " swap 3append ;
unparse-short " connection from " swap 3append ;
: accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi

4
basis/io/sockets/sockets.factor
View File

@ -95,11 +95,11 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
<PRIVATE
: parse-inet6 ( string -- seq )
dup empty? [ drop f ] [
[ f ] [
":" split [
hex> [ "Component not a number" throw ] unless*
] B{ } map-as
] if ;
] if-empty ;
: pad-inet6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap -

2
basis/io/unix/sockets/sockets.factor
View File

@ -67,7 +67,7 @@ M: object ((client)) ( addrspec -- fd )
M: object (server) ( addrspec -- handle )
[
SOCK_STREAM server-socket-fd
dup handle-fd 10 listen io-error
dup handle-fd 128 listen io-error
] with-destructors ;
: do-accept ( server addrspec -- fd sockaddr )

4
basis/lcs/diff2html/diff2html.factor
View File

@ -3,14 +3,14 @@
USING: lcs html.elements kernel qualified ;
FROM: accessors => item>> ;
FROM: io => write ;
FROM: sequences => each empty? ;
FROM: sequences => each if-empty ;
FROM: xml.entities => escape-string ;
IN: lcs.diff2html
GENERIC: diff-line ( obj -- )
: write-item ( item -- )
item>> dup empty? [ drop "&nbsp;" ] [ escape-string ] if write ;
item>> [ "&nbsp;" ] [ escape-string ] if-empty write ;
M: retain diff-line
<tr>

14
basis/locals/locals-tests.factor
View File

@ -316,3 +316,17 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test
[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
[ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
[ T{ slice f 0 3 "abc" } ]
[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test

86
basis/locals/locals.factor
View File

@ -1,12 +1,14 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences sequences.private assocs math
parser words quotations debugger macros arrays macros splitting
combinators prettyprint.backend definitions prettyprint
hashtables prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
locals.backend memoize macros.expander lexer
stack-checker.known-words ;
vectors strings classes.tuple generalizations
parser words quotations debugger macros arrays macros splitting
combinators prettyprint.backend definitions prettyprint
hashtables prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
locals.backend memoize macros.expander lexer
stack-checker.known-words ;
IN: locals
! Inspired by
@ -98,8 +100,8 @@ C: <quote> quote
UNION: special local quote local-word local-reader local-writer ;
: load-locals-quot ( args -- quot )
dup empty? [
drop [ ]
[
[ ]
] [
dup [ local-reader? ] contains? [
<reversed> [
@ -108,14 +110,10 @@ UNION: special local quote local-word local-reader local-writer ;
] [
length [ load-locals ] curry >quotation
] if
] if ;
] if-empty ;
: drop-locals-quot ( args -- quot )
dup empty? [
drop [ ]
] [
length [ drop-locals ] curry
] if ;
[ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
: point-free-body ( quot args -- newquot )
>r but-last-slice r> [ localize ] curry map concat ;
@ -202,6 +200,66 @@ M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Broil is used to support locals in literals
DEFER: [broil]
DEFER: [broil-hashtable]
DEFER: [broil-tuple]
: broil-element ( obj -- quot )
{
{ [ dup number? ] [ 1quotation ] }
{ [ dup string? ] [ 1quotation ] }
{ [ dup sequence? ] [ [broil] ] }
{ [ dup hashtable? ] [ [broil-hashtable] ] }
{ [ dup tuple? ] [ [broil-tuple] ] }
{ [ dup local? ] [ 1quotation ] }
{ [ dup word? ] [ literalize 1quotation ] }
{ [ t ] [ 1quotation ] }
}
cond ;
: [broil] ( seq -- quot )
[ [ broil-element ] map concat >quotation ]
[ length ]
[ ]
tri
[ nsequence ] curry curry compose ;
MACRO: broil ( seq -- quot ) [broil] ;
: [broil-hashtable] ( hashtable -- quot )
>alist
[ [ broil-element ] map concat >quotation ]
[ length ]
[ ]
tri
[ nsequence >hashtable ] curry curry compose ;
MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ;
: [broil-tuple] ( tuple -- quot )
tuple>array
[ [ broil-element ] map concat >quotation ]
[ length ]
[ ]
tri
[ nsequence >tuple ] curry curry compose ;
MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ;
! Engage broil on arrays and vectors. Can't do it on 'sequence'
! because that will pick up strings and integers. What do do...
M: array local-rewrite* ( array -- ) [broil] % ;
M: vector local-rewrite* ( vector -- ) [broil] % ;
M: tuple local-rewrite* ( tuple -- ) [broil-tuple] % ;
M: hashtable local-rewrite* ( hashtable -- ) [broil-hashtable] % ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-local ( name -- word )
"!" ?tail [
<local-reader>

4
basis/logging/insomniac/insomniac.factor
View File

@ -18,14 +18,14 @@ SYMBOL: insomniac-recipients
] "" make ;
: (email-log-report) ( service word-names -- )
dupd ?analyze-log dup empty? [ 2drop ] [
dupd ?analyze-log [ drop ] [
<email>
swap >>body
insomniac-recipients get >>to
insomniac-sender get >>from
swap email-subject >>subject
send-email
] if ;
] if-empty ;
\ (email-log-report) NOTICE add-error-logging

1
basis/logging/logging.factor
View File

@ -46,6 +46,7 @@ SYMBOL: log-service
dup array? [ dup length 1 = [ first ] when ] when
dup string? [
[
boa-tuples? on
string-limit? off
1 line-limit set
3 nesting-limit set

5
basis/models/history/history.factor
View File

@ -17,9 +17,8 @@ TUPLE: history < model back forward ;
swap value>> dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
dup empty?
[ 3drop ]
[ >r dupd (add-history) r> pop swap set-model ] if ;
[ 2drop ]
[ >r dupd (add-history) r> pop swap set-model ] if-empty ;
: go-back ( history -- )
dup [ forward>> ] [ back>> ] bi go-back/forward ;

5
basis/multiline/multiline.factor
View File

@ -37,9 +37,8 @@ PRIVATE>
: parse-multiline-string ( end-text -- str )
[
lexer get column>> swap (parse-multiline-string)
lexer get (>>column)
] "" make rest but-last ;
lexer get [ swap (parse-multiline-string) ] change-column drop
] "" make rest-slice but-last ;
: <"
"\">" parse-multiline-string parsed ; parsing

11
basis/persistent/heaps/heaps.factor
View File

@ -1,4 +1,4 @@
USING: kernel accessors multi-methods locals combinators math arrays
USING: kernel accessors locals combinators math arrays
assocs namespaces sequences ;
IN: persistent.heaps
! These are minheaps
@ -36,14 +36,15 @@ PRIVATE>
GENERIC: sift-down ( value prio left right -- heap )
METHOD: sift-down { empty-heap empty-heap } <branch> ;
METHOD: sift-down { singleton-heap empty-heap }
: singleton-sift-down ( value prio singleton empty -- heap )
3dup drop prio>> <= [ <branch> ] [
drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
<singleton-heap> <persistent-heap> <branch>
] if ;
M: empty-heap sift-down
over singleton-heap? [ singleton-sift-down ] [ <branch> ] if ;
:: reroot-left ( value prio left right -- heap )
left value>> left prio>>
value prio left left>> left right>> sift-down
@ -54,7 +55,7 @@ METHOD: sift-down { singleton-heap empty-heap }
value prio right left>> right right>> sift-down
<branch> ;
METHOD: sift-down { branch branch }
M: branch sift-down ! both arguments are branches
3dup [ prio>> <= ] both-with? [ <branch> ] [
2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
] if ;

6
basis/prettyprint/prettyprint.factor
View File

@ -38,13 +38,13 @@ IN: prettyprint
[ write-in nl ] when* ;
: use. ( seq -- )
dup empty? [ drop ] [
[
natural-sort [
\ USING: pprint-word
[ pprint-vocab ] each
\ ; pprint-word
] with-pprint nl
] if ;
] unless-empty ;
: vocabs. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
@ -98,7 +98,7 @@ SYMBOL: ->
"word-style" set-word-prop
: remove-step-into ( word -- )
building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ;
building get [ nip pop wrapped>> ] unless-empty , ;
: (remove-breakpoints) ( quot -- newquot )
[

6
basis/random/random.factor
View File

@ -34,14 +34,12 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
] keep head ;
: random ( seq -- elt )
dup empty? [
drop f
] [
[ f ] [
[
length dup log2 7 + 8 /i
random-bytes byte-array>bignum swap mod
] keep nth
] if ;
] if-empty ;
: delete-random ( seq -- elt )
[ length random ] keep [ nth ] 2keep delete-nth ;

15
basis/stack-checker/backend/backend.factor
View File

@ -11,9 +11,9 @@ IN: stack-checker.backend
: push-d ( obj -- ) meta-d get push ;
: pop-d ( -- obj )
meta-d get dup empty? [
drop <value> dup 1array #introduce, d-in inc
] [ pop ] if ;
meta-d get [
<value> dup 1array #introduce, d-in inc
] [ pop ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
@ -40,7 +40,9 @@ IN: stack-checker.backend
: output-r ( seq -- ) meta-r get push-all ;
: pop-literal ( -- rstate obj )
pop-d [ 1array #drop, ] [ literal [ recursion>> ] [ value>> ] bi ] bi ;
pop-d
[ 1array #drop, ]
[ literal [ recursion>> ] [ value>> ] bi ] bi ;
GENERIC: apply-object ( obj -- )
@ -142,8 +144,11 @@ M: object apply-object push-literal ;
[ "inferred-effect" set-word-prop ]
2tri ;
: cannot-infer-effect ( word -- * )
"cannot-infer" word-prop throw ;
: maybe-cannot-infer ( word quot -- )
[ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline
[ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
: infer-word ( word -- effect )
[

8
basis/stack-checker/branches/branches.factor
View File

@ -31,10 +31,10 @@ SYMBOL: +bottom+
: unify-values ( values -- phi-out )
remove-bottom
dup empty? [ drop <value> ] [
[ <value> ] [
[ known ] map dup all-eq?
[ first make-known ] [ drop <value> ] if
] if ;
] if-empty ;
: phi-outputs ( phi-in -- stack )
flip [ unify-values ] map ;
@ -42,12 +42,12 @@ SYMBOL: +bottom+
SYMBOL: quotations
: unify-branches ( ins stacks -- in phi-in phi-out )
zip dup empty? [ drop 0 { } { } ] [
zip [ 0 { } { } ] [
[ keys supremum ] [ ] [ balanced? ] tri
[ dupd phi-inputs dup phi-outputs ]
[ quotations get unbalanced-branches-error ]
if
] if ;
] if-empty ;
: branch-variable ( seq symbol -- seq )
'[ , _ at ] map ;

6
basis/stack-checker/errors/errors-docs.factor
View File

@ -45,11 +45,6 @@ HELP: too-many-r>
}
} ;
HELP: cannot-infer-effect
{ $values { "word" word } }
{ $description "Throws a " { $link cannot-infer-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: missing-effect
{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." }
{ $examples
@ -108,7 +103,6 @@ ARTICLE: "inference-errors" "Inference warnings and errors"
{ $subsection inference-error }
"Inference warnings:"
{ $subsection literal-expected }
{ $subsection cannot-infer-effect }
"Inference errors:"
{ $subsection recursive-quotation-error }
{ $subsection unbalanced-branches-error }

12
basis/stack-checker/errors/errors.factor
View File

@ -26,8 +26,8 @@ M: inference-error error-help error>> error-help ;
M: inference-error error.
[
rstate>> dup empty?
[ drop ] [ "Nesting:" print stack. ] if
rstate>>
[ "Nesting:" print stack. ] unless-empty
] [ error>> error. ] bi ;
TUPLE: literal-expected ;
@ -57,14 +57,6 @@ M: too-many-r> summary
drop
"Quotation pops retain stack elements which it did not push" ;
TUPLE: cannot-infer-effect word ;
: cannot-infer-effect ( word -- * )
\ cannot-infer-effect inference-warning ;
M: cannot-infer-effect error.
"Unable to infer stack effect of " write word>> . ;
TUPLE: missing-effect word ;
M: missing-effect error.

6
basis/stack-checker/transforms/transforms.factor
View File

@ -69,15 +69,15 @@ IN: stack-checker.transforms
\ cond [ cond>quot ] 1 define-transform
\ case [
dup empty? [
drop [ no-case ]
[
[ no-case ]
] [
dup peek quotation? [
dup peek swap but-last
] [
[ no-case ] swap
] if case>quot
] if
] if-empty
] 1 define-transform
\ cleave [ cleave>quot ] 1 define-transform

2
basis/tools/deploy/backend/backend.factor
View File

@ -42,9 +42,9 @@ IN: tools.deploy.backend
: bootstrap-profile ( -- profile )
{
{ "threads" deploy-threads? }
{ "math" deploy-math? }
{ "compiler" deploy-compiler? }
{ "threads" deploy-threads? }
{ "ui" deploy-ui? }
{ "random" deploy-random? }
} [ nip get ] assoc-filter keys

2
basis/tools/deploy/config/config.factor
View File

@ -73,7 +73,7 @@ SYMBOL: deploy-image
: deploy-config ( vocab -- assoc )
dup default-config swap
dup deploy-config-path vocab-file-contents
parse-fresh dup empty? [ drop ] [ first assoc-union ] if ;
parse-fresh [ first assoc-union ] unless-empty ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>

8
basis/tools/deploy/deploy-tests.factor
View File

@ -26,7 +26,7 @@ namespaces continuations layouts accessors ;
[ t ] [ 1300000 small-enough? ] unit-test
[ "staging.threads-math-compiler-ui-strip.image" ] [
[ "staging.math-compiler-threads-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
@ -39,9 +39,9 @@ namespaces continuations layouts accessors ;
!
! [ t ] [ 1500000 small-enough? ] unit-test
!
! [ ] [ "bunny" shake-and-bake ] unit-test
!
! [ t ] [ 2500000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"

16
basis/tools/deploy/test/1/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.1" }
{ deploy-io 2 }
{ deploy-random? f }
{ deploy-math? t }
{ deploy-compiler? t }
{ deploy-reflection 2 }
{ "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.1" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}

14
basis/tools/deploy/test/2/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.2" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/3/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 3 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.3" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/4/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.4" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/5/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 3 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.5" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

6
basis/tools/scaffold/scaffold.factor
View File

@ -175,7 +175,11 @@ ERROR: no-vocab vocab ;
{
[ "IN: " write print nl ]
[ interesting-words. ]
[ "ARTICLE: " write unparse dup write bl print ";" print nl ]
[
[ "ARTICLE: " write unparse dup write bl print ]
[ "{ $vocab-link " write pprint " }" print ] bi
";" print nl
]
[ "ABOUT: " write unparse print ]
} cleave
] with-string-writer ;

9
basis/tools/test/test.factor
View File

@ -67,8 +67,7 @@ SYMBOL: this-test
: test-failures. ( assoc -- )
[
nl
dup empty? [
drop
[
"==== ALL TESTS PASSED" print
] [
"==== FAILING TESTS:" print
@ -76,16 +75,16 @@ SYMBOL: this-test
swap vocab-heading.
[ failure. nl ] each
] assoc-each
] if
] if-empty
] [
"==== NOTHING TO TEST" print
] if* ;
: run-tests ( prefix -- failures )
child-vocabs dup empty? [ drop f ] [
child-vocabs [ f ] [
[ dup run-test ] { } map>assoc
[ second empty? not ] filter
] if ;
] if-empty ;
: test ( prefix -- )
run-tests test-failures. ;

24
basis/tools/vocabs/browser/browser.factor
View File

@ -36,14 +36,14 @@ IN: tools.vocabs.browser
: vocabs. ( assoc -- )
[
dup empty? [
2drop
[
drop
] [
swap root-heading.
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
] if
] if-empty
] assoc-each ;
: describe-summary ( vocab -- )
@ -98,10 +98,10 @@ C: <vocab-author> vocab-author
] when* ;
: describe-words ( vocab -- )
words dup empty? [
words [
"Words" $heading
dup natural-sort $links
] unless drop ;
natural-sort $links
] unless-empty ;
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words [ generic? not ] filter r> map
@ -113,16 +113,16 @@ C: <vocab-author> vocab-author
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: describe-uses ( vocab -- )
vocab-uses dup empty? [
vocab-uses [
"Uses" $heading
dup $vocab-links
] unless drop ;
$vocab-links
] unless-empty ;
: describe-usage ( vocab -- )
vocab-usage dup empty? [
vocab-usage [
"Used by" $heading
dup $vocab-links
] unless drop ;
$vocab-links
] unless-empty ;
: $describe-vocab ( element -- )
first

12
basis/tools/vocabs/vocabs.factor
View File

@ -165,11 +165,11 @@ MEMO: vocab-file-contents ( vocab name -- seq )
: vocab-summary ( vocab -- summary )
dup dup vocab-summary-path vocab-file-contents
dup empty? [
drop vocab-name " vocabulary" append
[
vocab-name " vocabulary" append
] [
nip first
] if ;
] if-empty ;
M: vocab summary
[
@ -212,11 +212,9 @@ M: vocab-link summary vocab-summary ;
: (all-child-vocabs) ( root name -- vocabs )
[ vocab-dir append-path subdirs ] keep
dup empty? [
drop
] [
[
swap [ "." swap 3append ] with map
] if ;
] unless-empty ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [

2
basis/tools/walker/walker.factor
View File

@ -197,7 +197,7 @@ SYMBOL: +stopped+
: step-back-msg ( continuation -- continuation' )
walker-history tget
[ pop* ]
[ dup empty? [ drop ] [ nip pop ] if ] bi ;
[ [ nip pop ] unless-empty ] bi ;
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status

4
basis/ui/gestures/gestures.factor
View File

@ -108,7 +108,7 @@ SYMBOL: double-click-timeout
: drag-gesture ( -- )
hand-buttons get-global
dup empty? [ drop ] [ first <drag> button-gesture ] if ;
[ first <drag> button-gesture ] unless-empty ;
SYMBOL: drag-timer
@ -170,7 +170,7 @@ SYMBOL: drag-timer
: modifier ( mod modifiers -- seq )
[ second swap bitand 0 > ] with filter
0 <column> prune dup empty? [ drop f ] [ >array ] if ;
0 <column> prune [ f ] [ >array ] if-empty ;
: drag-loc ( -- loc )
hand-loc get-global hand-click-loc get-global v- ;

6
basis/ui/tools/listener/listener.factor
View File

@ -72,11 +72,9 @@ M: listener-operation invoke-command ( target command -- )
evaluate-input ;
: listener-run-files ( seq -- )
dup empty? [
drop
] [
[
[ [ run-file ] each ] curry call-listener
] if ;
] unless-empty ;
: com-end ( listener -- )
input>> interactor-eof ;

4
basis/unicode/breaks/breaks.factor
View File

@ -80,10 +80,10 @@ VALUE: grapheme-table
nip swap length or 1+ ;
: (>graphemes) ( str -- )
dup empty? [ drop ] [
[
dup first-grapheme cut-slice
swap , (>graphemes)
] if ;
] unless-empty ;
: >graphemes ( str -- graphemes )
[ (>graphemes) ] { } make ;

2
basis/windows/com/wrapper/wrapper.factor
View File

@ -100,7 +100,7 @@ unless
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
[ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
[ [ drop [ ] ] [ swap 1- '[ , , ndip ] ] if-empty ]
dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )

4
basis/xml/generator/generator-tests.factor
View File

@ -1,3 +1,3 @@
USING: tools.test io.streams.string xml.generator xml.writer ;
USING: tools.test io.streams.string xml.generator xml.writer accessors ;
[ "<html><body><a href=\"blah\"/></body></html>" ]
[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] with-string-writer ] unit-test
[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test

2
basis/xml/tokenize/tokenize.factor
View File

@ -164,7 +164,7 @@ SYMBOL: ns-stack
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
} diff
dup empty? [ drop ] [ <extra-attrs> throw ] if ;
[ <extra-attrs> throw ] unless-empty ;
: good-version ( version -- version )
dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;

5
basis/xml/writer/writer-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: xml.writer.tests
USING: xml.data xml.writer tools.test ;
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test

9
basis/xml/writer/writer.factor
View File

@ -34,13 +34,14 @@ SYMBOL: indenter
: ?filter-children ( children -- no-whitespace )
xml-pprint? get [
[ dup string? [ trim-whitespace ] when ] map
[ dup empty? swap string? and not ] filter
[ [ empty? ] [ string? ] bi and not ] filter
] when ;
: name>string ( name -- string )
[ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
: print-name ( name -- )
dup space>> f like
[ write CHAR: : write1 ] when*
main>> write ;
name>string write ;
: print-attrs ( assoc -- )
[

4
core/classes/algebra/algebra.factor
View File

@ -208,9 +208,9 @@ M: anonymous-complement (classes-intersect?)
: min-class ( class seq -- class/f )
over [ classes-intersect? ] curry filter
dup empty? [ 2drop f ] [
[ drop f ] [
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
] if-empty ;
GENERIC: (flatten-class) ( class -- )

6
core/classes/builtin/builtin.factor
View File

@ -44,11 +44,11 @@ M: builtin-class (classes-intersect?)
M: anonymous-intersection (flatten-class)
participants>> [ flatten-builtin-class ] map
dup empty? [
drop builtins get sift [ (flatten-class) ] each
[
builtins get sift [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
] if-empty ;
M: anonymous-complement (flatten-class)
drop builtins get sift [ (flatten-class) ] each ;

6
core/classes/intersection/intersection.factor
View File

@ -8,14 +8,14 @@ PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
: intersection-predicate-quot ( members -- quot )
dup empty? [
drop [ drop t ]
[
[ drop t ]
] [
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] swap [ not ] 3append
[ drop f ]
] { } map>assoc alist>quot
] if ;
] if-empty ;
: define-intersection-predicate ( class -- )
dup participants intersection-predicate-quot define-predicate ;

2
core/classes/tuple/parser/parser.factor
View File

@ -26,7 +26,7 @@ ERROR: duplicate-slot-names names ;
: check-duplicate-slots ( slots -- )
slot-names duplicates
dup empty? [ drop ] [ duplicate-slot-names ] if ;
[ duplicate-slot-names ] unless-empty ;
ERROR: invalid-slot-name name ;

6
core/classes/union/union.factor
View File

@ -8,14 +8,14 @@ PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
[
[ drop f ]
] [
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] prepend
[ drop t ]
] { } map>assoc alist>quot
] if ;
] if-empty ;
: define-union-predicate ( class -- )
dup members union-predicate-quot define-predicate ;

2
core/destructors/destructors.factor
View File

@ -21,7 +21,7 @@ M: object dispose
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
] { } make dup empty? [ drop ] [ peek rethrow ] if ;
] { } make [ peek rethrow ] unless-empty ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline

4
core/io/files/files.factor
View File

@ -59,7 +59,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? )
dup empty? [ drop f ] [ [ path-separator? ] all? ] if ;
[ f ] [ [ path-separator? ] all? ] if-empty ;
ERROR: no-parent-directory path ;
@ -80,7 +80,7 @@ ERROR: no-parent-directory path ;
: head-path-separator? ( path1 ? -- ?' )
[
dup empty? [ drop t ] [ first path-separator? ] if
[ t ] [ first path-separator? ] if-empty
] [
drop f
] if ;

8
core/io/streams/string/string.factor
View File

@ -18,7 +18,7 @@ M: growable stream-flush drop ;
<string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
M: growable stream-read1 [ f ] [ pop ] if-empty ;
: harden-as ( seq growble-exemplar -- newseq )
underlying>> like ;
@ -39,13 +39,13 @@ M: growable stream-read-until
] if ;
M: growable stream-read
dup empty? [
2drop f
[
drop f
] [
[ length swap - 0 max ] keep
[ swap growable-read-until ] 2keep
set-length
] if ;
] if-empty ;
M: growable stream-read-partial
stream-read ;

2
core/memory/memory-tests.factor
View File

@ -3,6 +3,8 @@ sequences tools.test words namespaces layouts classes
classes.builtin arrays quotations ;
IN: memory.tests
[ [ ] instances ] must-infer
! Code GC wasn't kicking in when needed
: leak-step 800000 f <array> 1quotation call drop ;

11
core/memory/memory.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences arrays system ;
USING: kernel continuations sequences vectors arrays system math ;
IN: memory
: (each-object) ( quot: ( obj -- ) -- )
@ -9,7 +9,14 @@ IN: memory
: each-object ( quot -- )
begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
: count-instances ( quot -- n )
0 swap [ 1 0 ? + ] compose each-object ; inline
: instances ( quot -- seq )
pusher [ each-object ] dip >array ; inline
#! To ensure we don't need to grow the vector while scanning
#! the heap, we do two scans, the first one just counts the
#! number of objects that satisfy the predicate.
[ count-instances 100 + <vector> ] keep swap
[ [ push-if ] 2curry each-object ] keep >array ; inline
: save ( -- ) image save-image ;

1
core/parser/parser.factor
View File

@ -182,6 +182,7 @@ SYMBOL: interactive-vocabs
"sequences"
"slicing"
"sorting"
"stack-checker"
"strings"
"syntax"
"tools.annotations"

36
core/sequences/sequences-docs.factor
View File

@ -335,6 +335,42 @@ HELP: if-empty
"6"
} ;
HELP: when-empty
{ $values
{ "seq" sequence } { "quot" "the first quotation of an " { $link if-empty } } }
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and the " { $snippet "quot1" } " is called." }
{ $examples "This word is equivalent to " { $link if-empty } " with an empty second quotation:"
{ $example
"USING: sequences prettyprint ;"
"{ } [ { 4 5 6 } ] [ ] if-empty ."
"{ 4 5 6 }"
}
{ $example
"USING: sequences prettyprint ;"
"{ } [ { 4 5 6 } ] when-empty ."
"{ 4 5 6 }"
}
} ;
HELP: unless-empty
{ $values
{ "seq" sequence } { "quot" "the second quotation of an " { $link if-empty } } }
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped. Otherwise, the " { $snippet "quot2" } " is called on the sequence." }
{ $examples "This word is equivalent to " { $link if-empty } " with an empty first quotation:"
{ $example
"USING: sequences prettyprint ;"
"{ 4 5 6 } [ ] [ sum ] if-empty ."
"15"
}
{ $example
"USING: sequences prettyprint ;"
"{ 4 5 6 } [ sum ] unless-empty ."
"15"
}
} ;
{ if-empty when-empty unless-empty } related-words
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }

12
core/sequences/sequences.factor
View File

@ -32,9 +32,9 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
: if-empty ( seq quot1 quot2 -- )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline
: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
: unless-empty ( seq quot -- ) [ ] swap if-empty ; inline
: delete-all ( seq -- ) 0 swap set-length ;
@ -91,7 +91,7 @@ M: sequence set-nth-unsafe set-nth ;
! The f object supports the sequence protocol trivially
M: f length drop 0 ;
M: f nth-unsafe nip ;
M: f like drop dup empty? [ drop f ] when ;
M: f like drop [ f ] when-empty ;
INSTANCE: f immutable-sequence
@ -630,14 +630,14 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
0 [ length + ] reduce ;
: concat ( seq -- newseq )
dup empty? [
drop { }
[
{ }
] [
[ sum-lengths ] keep
[ first new-resizable ] keep
[ [ over push-all ] each ] keep
first like
] if ;
] if-empty ;
: joined-length ( seq glue -- n )
>r dup sum-lengths swap length 1 [-] r> length * + ;

5
extra/backtrack/backtrack.factor
View File

@ -50,9 +50,8 @@ PRIVATE>
[ amb-integer ] [ nth ] bi ;
: amb ( seq -- elt )
dup empty?
[ drop fail f ]
[ unsafe-amb ] if ; inline
[ fail f ]
[ unsafe-amb ] if-empty ; inline
MACRO: amb-execute ( seq -- quot )
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi

25
extra/benchmark/sockets/sockets.factor
View File

@ -6,7 +6,7 @@ IN: benchmark.sockets
SYMBOL: counter
: number-of-requests 1 ;
: number-of-requests 1000 ;
: server-addr ( -- addr ) "127.0.0.1" 7777 <inet4> ;
@ -31,12 +31,14 @@ SYMBOL: counter
] ignore-errors ;
: simple-client ( -- )
server-addr ascii [
CHAR: b write1 flush
number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times
counter get count-down
] with-client ;
[
server-addr ascii [
CHAR: b write1 flush
number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times
] with-client
] try
counter get count-down ;
: stop-server ( -- )
server-addr ascii [
@ -52,8 +54,13 @@ SYMBOL: counter
counter get await
stop-server
yield yield
] time ;
] benchmark . flush ;
: socket-benchmarks ;
: socket-benchmarks ( -- )
1 clients
10 clients
20 clients
40 clients
100 clients ;
MAIN: socket-benchmarks

50
extra/builder/release/upload/upload.factor
View File

@ -1,5 +1,5 @@
USING: kernel namespaces io io.files
USING: kernel namespaces sequences arrays io io.files
builder.util
builder.common
builder.release.archive ;
@ -8,17 +8,47 @@ IN: builder.release.upload
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remote-location ( -- dest )
"factorcode.org:/var/www/factorcode.org/newsite/downloads"
platform
append-path ;
SYMBOL: upload-host
: (upload) ( -- )
{ "scp" archive-name remote-location } to-strings
[ "Error uploading binary to factorcode" print ]
run-or-bail ;
SYMBOL: upload-username
SYMBOL: upload-directory
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remote-location ( -- dest )
upload-directory get platform append ;
: 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 [ "Error uploading binary to factorcode" print ] run-or-bail ;
: rename-temp-file ( -- )
rename-command [ "Error renaming binary on factorcode" print ] run-or-bail ;
: upload ( -- )
upload-to-factorcode get
[ (upload) ]
[ upload-temp-file rename-temp-file ]
when ;

2
extra/cords/cords.factor
View File

@ -27,7 +27,7 @@ M: multi-cord virtual@
[ first - ] [ second ] bi ;
M: multi-cord virtual-seq
seqs>> dup empty? [ drop f ] [ first second ] if ;
seqs>> [ f ] [ first second ] if-empty ;
: <cord> ( seqs -- cord )
dup length 2 = [

2
extra/game-input/backend/iokit/iokit.factor
View File

@ -58,7 +58,7 @@ SINGLETON: iokit-game-input-backend
buttons-matching-hash device-elements-matching length ;
: ?axis ( device hash -- axis/f )
device-elements-matching dup empty? [ drop f ] [ first ] if ;
device-elements-matching [ f ] [ first ] if-empty ;
: ?x-axis ( device -- ? )
x-axis-matching-hash ?axis ;

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