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

basis/db/db.factor

@@ -149,4 +149,4 @@ M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
     t in-transaction [
         begin-transaction
         [ ] [ rollback-transaction ] cleanup commit-transaction
-    ] with-variable ;
+    ] with-variable ; inline

basis/furnace/actions/actions-docs.factor

@@ -1,6 +1,6 @@
 USING: assocs classes help.markup help.syntax io.streams.string
 http http.server.dispatchers http.server.responses
-furnace.redirection strings multiline ;
+furnace.redirection strings multiline html.forms ;
 IN: furnace.actions
 
 HELP: <action>
@@ -74,6 +74,8 @@ HELP: validate-params
     }
 } ;
 
+{ validate-params validate-values } related-words
+      
 HELP: validation-failed
 { $description "Stops processing the current request and takes action depending on the type of the current request:"
     { $list

basis/furnace/actions/actions.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors sequences kernel assocs combinators
 validators http hashtables namespaces fry continuations locals
-io arrays math boxes splitting urls
+io arrays math boxes splitting urls call
 xml.entities
 http.server
 http.server.responses
@@ -52,10 +52,10 @@ TUPLE: action rest init authorize display validate submit ;
     '[
         _ dup display>> [
             {
-                [ init>> call ]
+                [ init>> call( -- ) ]
-                [ authorize>> call ]
+                [ authorize>> call( -- ) ]
                 [ drop restore-validation-errors ]
-                [ display>> call ]
+                [ display>> call( -- response ) ]
             } cleave
         ] [ drop <400> ] if
     ] with-exit-continuation ;
@@ -81,9 +81,9 @@ CONSTANT: revalidate-url-key "__u"
 : handle-post ( action -- response )
     '[
         _ dup submit>> [
-            [ validate>> call ]
+            [ validate>> call( -- ) ]
-            [ authorize>> call ]
+            [ authorize>> call( -- ) ]
-            [ submit>> call ]
+            [ submit>> call( -- response ) ]
             tri
         ] [ drop <400> ] if
     ] with-exit-continuation ;

basis/furnace/auth/login/login.factor

@@ -53,7 +53,7 @@ M: login-realm modify-form ( responder -- )
 
 \ successful-login DEBUG add-input-logging
 
-: logout ( -- )
+: logout ( -- response )
     permit-id get [ delete-permit ] when*
     URL" $realm" end-aside ;
 

basis/furnace/boilerplate/boilerplate.factor

@@ -1,6 +1,6 @@
-! Copyright (c) 2008 Slava Pestov
+! Copyright (c) 2008, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.order namespaces combinators.short-circuit
+USING: accessors kernel math.order namespaces combinators.short-circuit call
 html.forms
 html.templates
 html.templates.chloe
@@ -23,7 +23,7 @@ TUPLE: boilerplate < filter-responder template init ;
 M:: boilerplate call-responder* ( path responder -- )
     begin-form
     path responder call-next-method
-    responder init>> call
+    responder init>> call( -- )
     dup wrap-boilerplate? [
         clone [| body |
             [

basis/furnace/referrer/referrer.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel http.server http.server.filters
-http.server.responses furnace.utilities ;
+http.server.responses furnace.utilities call ;
 IN: furnace.referrer
 
 TUPLE: referrer-check < filter-responder quot ;
@@ -9,7 +9,7 @@ TUPLE: referrer-check < filter-responder quot ;
 C: <referrer-check> referrer-check
 
 M: referrer-check call-responder*
-    referrer over quot>> call
+    referrer over quot>> call( referrer -- ? )
     [ call-next-method ]
     [ 2drop 403 "Bad referrer" <trivial-response> ] if ;
 

basis/furnace/utilities/utilities.factor

@@ -135,4 +135,4 @@ SYMBOL: exit-continuation
     exit-continuation get continue-with ;
 
 : with-exit-continuation ( quot -- value )
-    '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+    '[ exit-continuation set @ ] callcc1 exit-continuation off ; inline

basis/html/forms/forms.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors strings namespaces assocs hashtables io
+USING: kernel accessors strings namespaces assocs hashtables io call
 mirrors math fry sequences words continuations
 xml.entities xml.writer xml.syntax ;
 IN: html.forms
@@ -96,7 +96,7 @@ C: <validation-error> validation-error
     >hashtable "validators" set-word-prop ;
 
 : validate ( value quot -- result )
-    [ <validation-error> ] recover ; inline
+    '[ _ call( value -- validated ) ] [ <validation-error> ] recover ;
 
 : validate-value ( name value quot -- )
     validate

basis/html/templates/templates.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel fry io io.encodings.utf8 io.files
 debugger prettyprint continuations namespaces boxes sequences
-arrays strings html io.streams.string assocs
+arrays strings html io.streams.string assocs call
 quotations xml.data xml.writer xml.syntax ;
 IN: html.templates
 
@@ -12,7 +12,7 @@ GENERIC: call-template* ( template -- )
 
 M: string call-template* write ;
 
-M: callable call-template* call ;
+M: callable call-template* call( -- ) ;
 
 M: xml call-template* write-xml ;
 

basis/http/server/server.factor

@@ -132,15 +132,15 @@ M: response write-full-response ( request response -- )
         [ content-charset>> encode-output ]
         [ write-response-body ]
         bi
-    ] unless ;
+    ] unless drop ;
 
 M: raw-response write-response ( respose -- )
     write-response-line
     write-response-body
     drop ;
 
-M: raw-response write-full-response ( response -- )
+M: raw-response write-full-response ( request response -- )
-    write-response ;
+    nip write-response ;
 
 : post-request? ( -- ? ) request get method>> "POST" = ;
 
@@ -182,7 +182,7 @@ main-responder [ <404> <trivial-responder> ] initialize
     swap development? get [ make-http-error >>body ] [ drop ] if ;
 
 : do-response ( response -- )
-    [ request get swap write-full-response ]
+    '[ request get _ write-full-response ]
     [
         [ \ do-response log-error ]
         [

basis/http/server/static/static-docs.factor

@@ -20,7 +20,7 @@ HELP: enable-fhtml
 { $side-effects "responder" } ;
 
 ARTICLE: "http.server.static.extend" "Hooks for dynamic content"
-"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
+"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- response )" } "."
 $nl
 "A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
 { $subsection enable-fhtml }

basis/http/server/static/static.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: calendar kernel math math.order math.parser namespaces
 parser sequences strings assocs hashtables debugger mime.types
@@ -6,7 +6,7 @@ sorting logging calendar.format accessors splitting io io.files
 io.files.info io.directories io.pathnames io.encodings.binary
 fry xml.entities destructors urls html xml.syntax
 html.templates.fhtml http http.server http.server.responses
-http.server.redirection xml.writer ;
+http.server.redirection xml.writer call ;
 IN: http.server.static
 
 TUPLE: file-responder root hook special allow-listings ;
@@ -42,7 +42,9 @@ TUPLE: file-responder root hook special allow-listings ;
 
 : serve-static ( filename mime-type -- response )
     over modified-since?
-    [ file-responder get hook>> call ] [ 2drop <304> ] if ;
+    [ file-responder get hook>> call( filename mime-type -- response ) ]
+    [ 2drop <304> ]
+    if ;
 
 : serving-path ( filename -- filename )
     [ file-responder get root>> trim-tail-separators "/" ] dip
@@ -51,7 +53,7 @@ TUPLE: file-responder root hook special allow-listings ;
 : serve-file ( filename -- response )
     dup mime-type
     dup file-responder get special>> at
-    [ call ] [ serve-static ] ?if ;
+    [ call( filename -- response ) ] [ serve-static ] ?if ;
 
 \ serve-file NOTICE add-input-logging
 

basis/inverse/inverse.factor

@@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
 continuations debugger classes.tuple namespaces make vectors
 bit-arrays byte-arrays strings sbufs math.functions macros
 sequences.private combinators mirrors splitting
-combinators.short-circuit fry words.symbol generalizations ;
+combinators.short-circuit fry words.symbol generalizations call ;
 RENAME: _ fry => __
 IN: inverse
 
@@ -122,7 +122,7 @@ M: math-inverse inverse
 
 M: pop-inverse inverse
     [ "pop-length" word-prop cut-slice swap >quotation ]
-    [ "pop-inverse" word-prop ] bi compose call ;
+    [ "pop-inverse" word-prop ] bi compose call( -- quot ) ;
 
 : (undo) ( revquot -- )
     [ unclip-slice inverse % (undo) ] unless-empty ;

basis/io/servers/connection/connection.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations destructors kernel math math.parser
 namespaces parser sequences strings prettyprint
@@ -7,7 +7,7 @@ fry accessors arrays io io.sockets io.encodings.ascii
 io.sockets.secure io.files io.streams.duplex io.timeouts
 io.encodings threads make concurrency.combinators
 concurrency.semaphores concurrency.flags
-combinators.short-circuit ;
+combinators.short-circuit call ;
 IN: io.servers.connection
 
 TUPLE: threaded-server
@@ -69,7 +69,7 @@ GENERIC: handle-client* ( threaded-server -- )
     [ [ remote-address set ] [ local-address set ] bi* ]
     2bi ;
 
-M: threaded-server handle-client* handler>> call ;
+M: threaded-server handle-client* handler>> call( -- ) ;
 
 : handle-client ( client remote local -- )
     '[

basis/logging/analysis/analysis.factor

@@ -41,7 +41,7 @@ SYMBOL: message-histogram
         [ >alist sort-values <reversed> ] dip [
             [ swapd with-cell pprint-cell ] with-row
         ] curry assoc-each
-    ] tabular-output ;
+    ] tabular-output ; inline
 
 : log-entry. ( entry -- )
     "====== " write

basis/logging/logging.factor

@@ -80,7 +80,7 @@ ERROR: bad-log-message-parameters msg word level ;
 PRIVATE>
 
 : (define-logging) ( word level quot -- )
-    [ dup ] 2dip 2curry annotate ;
+    [ dup ] 2dip 2curry annotate ; inline
 
 : call-logging-quot ( quot word level -- quot' )
     [ "called" ] 2dip [ log-message ] 3curry prepose ;

core/bootstrap/primitives.factor

@@ -25,7 +25,8 @@ H{ } clone sub-primitives set
     { "linux-ppc" "ppc/linux" }
     { "macosx-ppc" "ppc/macosx" }
     { "arm" "arm" }
-} at "/bootstrap.factor" 3append parse-file
+} ?at [ "Bad architecture: " prepend throw ] unless
+"/bootstrap.factor" 3append parse-file
 
 "vocab:bootstrap/layouts/layouts.factor" parse-file
 
@@ -45,10 +46,6 @@ init-caches
 ! Vocabulary for slot accessors
 "accessors" create-vocab drop
 
-! Trivial recompile hook. We don't want to touch the code heap
-! during stage1 bootstrap, it would just waste time.
-SINGLETON: dummy-compiler
-M: dummy-compiler recompile drop { } ;
 dummy-compiler compiler-impl set
 
 call

core/classes/mixin/mixin-tests.factor

@@ -109,3 +109,13 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 MIXIN: empty-mixin
 
 [ f ] [ "hi" empty-mixin? ] unit-test
+
+MIXIN: move-instance-declaration-mixin
+
+[ ] [ "IN: classes.mixin.tests.a USE: strings USE: classes.mixin.tests INSTANCE: string move-instance-declaration-mixin" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
+
+[ ] [ "IN: classes.mixin.tests.b USE: strings USE: classes.mixin.tests INSTANCE: string move-instance-declaration-mixin" <string-reader> "move-mixin-test-2" parse-stream drop ] unit-test
+
+[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
+
+[ { string } ] [ move-instance-declaration-mixin members ] unit-test

core/compiler/units/units.factor

@@ -40,8 +40,15 @@ SYMBOL: compiler-impl
 
 HOOK: recompile compiler-impl ( words -- alist )
 
+! Non-optimizing compiler
 M: f recompile [ f ] { } map>assoc ;
 
+! Trivial compiler. We don't want to touch the code heap
+! during stage1 bootstrap, it would just waste time.
+SINGLETON: dummy-compiler
+
+M: dummy-compiler recompile drop { } ;
+
 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
 
 SYMBOL: definition-observers

core/generic/generic-tests.factor

@@ -2,7 +2,8 @@ USING: accessors alien arrays definitions generic generic.standard
 generic.math assocs hashtables io kernel math namespaces parser
 prettyprint sequences strings tools.test vectors words
 quotations classes classes.algebra classes.tuple continuations
-layouts classes.union sorting compiler.units eval multiline ;
+layouts classes.union sorting compiler.units eval multiline
+io.streams.string ;
 IN: generic.tests
 
 GENERIC: foobar ( x -- y )
@@ -236,3 +237,14 @@ M: number c-n-m-cache ;
 [ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
 
 [ 2 ] [ 2 c-n-m-cache ] unit-test
+
+! Moving a method from one vocab to another doesn't always work
+GENERIC: move-method-generic ( a -- b )
+
+[ ] [ "IN: generic.tests.a USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
+
+[ ] [ "IN: generic.tests.b USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
+
+[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
+
+[ { string } ] [ move-method-generic order ] unit-test

extra/webapps/pastebin/pastebin.factor

@@ -83,8 +83,7 @@ annotation "ANNOTATIONS"
 ! LINKS, ETC
 ! ! !
 
-: pastebin-url ( -- url )
+CONSTANT: pastebin-url URL" $pastebin/"
-    URL" $pastebin/list" ;
 
 : paste-url ( id -- url )
     "$pastebin/paste" >url swap "id" set-query-param ;
@@ -187,7 +186,7 @@ M: annotation entity-url
                 "id" value <paste> delete-tuples
                 "id" value f <annotation> delete-tuples
             ] with-transaction
-            URL" $pastebin/list" <redirect>
+            pastebin-url <redirect>
         ] >>submit
 
         <protected>

extra/webapps/site-watcher/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/webapps/site-watcher/site-list.xml

@@ -0,0 +1,41 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html>
+  <head>
+    <title>SiteWatcher</title>
+  </head>
+  <body>
+    <h1>SiteWatcher</h1>
+    <h2>It tells you if your web site goes down.</h2>
+    <table>
+      <t:bind-each t:name="sites">
+	<tr>
+	  <td> <t:label t:name="url" /> </td>
+	  <td> <t:button t:action="$site-watcher-app/remove" t:for="url">Remove</t:button> </td>
+	</tr>
+      </t:bind-each>
+    </table>
+    <p>
+      <t:button t:action="$site-watcher-app/check">Check now</t:button>
+    </p>
+    <hr />
+    <h3>Add a new site</h3>
+    <t:form t:action="$site-watcher-app/add">
+      <table>
+	<tr>
+	  <th>URL:</th>
+	  <td> <t:field t:name="url" t:size="80" /> </td>
+	</tr>
+	<tr>
+	  <th>E-mail:</th>
+	  <td> <t:field t:name="email" t:size="80" /> </td>
+	</tr>
+      </table>
+      <p> <button type="submit">Done</button> </p>
+    </t:form>
+  </body>
+</html>
+
+</t:chloe>

extra/webapps/site-watcher/site-watcher.factor

@@ -0,0 +1,54 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.alloy furnace.redirection
+html.forms http.server http.server.dispatchers namespaces site-watcher
+site-watcher.private kernel urls validators db.sqlite assocs ;
+IN: webapps.site-watcher
+
+TUPLE: site-watcher-app < dispatcher ;
+
+CONSTANT: site-list-url URL" $site-watcher-app/"
+
+: <site-list-action> ( -- action )
+    <page-action>
+        { site-watcher-app "site-list" } >>template
+        [
+            begin-form
+            sites get values "sites" set-value
+        ] >>init ;
+
+: <add-site-action> ( -- action )
+    <action>
+        [
+            { { "url" [ v-url ] } { "email" [ v-email ] } } validate-params
+        ] >>validate
+        [
+            "email" value "url" value watch-site
+            site-list-url <redirect>
+        ] >>submit ;
+
+: <remove-site-action> ( -- action )
+    <action>
+        [
+            { { "url" [ v-url ] } } validate-params
+        ] >>validate
+        [
+            "url" value delete-site
+            site-list-url <redirect>
+        ] >>submit ;
+
+: <check-sites-action> ( -- action )
+    <action>
+        [
+            sites get [ check-sites ] [ report-sites ] bi
+            site-list-url <redirect>
+        ] >>submit ;
+
+: <site-watcher-app> ( -- dispatcher )
+    site-watcher-app new-dispatcher
+        <site-list-action> "" add-responder
+        <add-site-action> "add" add-responder
+        <remove-site-action> "remove" add-responder
+        <check-sites-action> "check" add-responder ;
+
+<site-watcher-app> "resource:test.db" <sqlite-db> <alloy> main-responder set-global